diff options
| author | phk <phk@FreeBSD.org> | 1996-06-26 06:06:43 +0000 |
|---|---|---|
| committer | phk <phk@FreeBSD.org> | 1996-06-26 06:06:43 +0000 |
| commit | 00febf60093a024ccc629fdfc81e02a40c5f6572 (patch) | |
| tree | 4d70f77f44120e6541d1418223baf06562774975 /contrib | |
| download | FreeBSD-src-00febf60093a024ccc629fdfc81e02a40c5f6572.zip FreeBSD-src-00febf60093a024ccc629fdfc81e02a40c5f6572.tar.gz | |
Tcl 7.5, various makefiles will be updated to use these sources as soon
as I get these back down to my machine.
Diffstat (limited to 'contrib')
294 files changed, 100301 insertions, 0 deletions
diff --git a/contrib/tcl/README b/contrib/tcl/README new file mode 100644 index 0000000..ea65409 --- /dev/null +++ b/contrib/tcl/README @@ -0,0 +1,331 @@ +Tcl + +by John Ousterhout (and many others at Sun Microsystems and elsewhere) +john.ousterhout@eng.sun.com + +SCCS: @(#) README 1.29 96/04/19 11:42:58 + +1. Introduction +--------------- + +This directory and its descendants contain the sources and documentation +for Tcl, an embeddable scripting language. The information here corresponds +to release 7.5. The most important new feature in this release is support +for the PC and Mac platforms. In addition, there are major new facilities +for dynamic loading, package and version management, multiple interpreters, +safe execution of untrusted scripts, and a new I/O system that supports +nonblocking I/O and sockets. This release also contains many bug fixes. +Tcl 7.5 should be backwards compatible with Tcl 7.4 scripts (there are two +small incompatibilities described below, but they are relatively insignificant +and shouldn't affect most existing Tcl code and extensions). + +2. Documentation +---------------- + +The best way to get started with Tcl is to read one of the introductory +books on Tcl: + + Tcl and the Tk Toolkit, by John Ousterhout, + Addison-Wesley, 1994, ISBN 0-201-63337-X + + Practical Programming in Tcl and Tk, by Brent Welch, + Prentice-Hall, 1995, ISBN 0-13-182007-9 + + Exploring Expect, by Don Libes, + O'Reilly and Associates, 1995, ISBN 1-56592-090-2 + +The "doc" subdirectory in this release contains a complete set of reference +manual entries for Tcl. Files with extension ".1" are for programs (for +example, tclsh.1); files with extension ".3" are for C library procedures; +and files with extension ".n" describe Tcl commands. The file "doc/Tcl.n" +gives a quick summary of the Tcl language syntax. To print any of the man +pages, cd to the "doc" directory and invoke your favorite variant of +troff using the normal -man macros, for example + + 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 + + man Tcl + +There is also an official home for Tcl and Tk on the Web: + http://www.sunlabs.com/research/tcl +These Web pages include release updates, reports on bug fixes and porting +issues, HTML versions of the manual pages, and pointers to many other +Tcl/Tk Web pages at other sites. Check them out! + +3. Compiling and installing Tcl +------------------------------- + +This release contains everything you should need to compile and run +Tcl under UNIX, Macintoshes, and PCs (either Windows NT, Windows 95, +or Win 3.1 with Win32s). + +Before trying to compile Tcl you should do the following things: + + (a) Check for a binary release. Pre-compiled binary releases are + available now for PCs and Macintoshes, and they may be available + in the future for some flavors of UNIX. Binary releases are much + easier to install than source releases. To find out whether a + binary release is available for your platform, check the home page + for the Sun Tcl/Tk project (http://www.sunlabs.com/research/tcl) + and also check in the FTP directory from which you retrieved the + base distribution. + + (b) Check for patches. Look in the FTP directory from which you + retrieved the base distribution and see if there are files with + names like tcl7.5p1.patch, tcl7.5p2.patch, etc. These files may + also have .gz or .Z extensions to indicate compression. If you find + any patch files, apply them to the source directory in order + from "p1" up. To apply an uncompressed patch file such as + tcl7.5p1.patch, invoke a shell command like the following from + the directory containing this file: + patch -p < tcl7.5p1.patch + If the patch file has a .gz extension, invoke a command like the + following: + gunzip -c tcl7.5p1.patch.gz | patch -p + If the patch file has a .Z extension, it was compressed with + compress. To apply it, invoke a command like the following: + zcat tcl7.5p1.patch.Z | patch -p + If you're applying a patch to a release that has already been + compiled, then before applying the patch you should cd to the + "unix" subdirectory and type "make distclean" to restore the + directory to a pristine state. + +Once you've done this, change to the "unix" subdirectory if you're +compiling under UNIX, "win" if you're compiling under Windows, or +"mac" if you're compiling on a Macintosh. Then follow the instructions +in the README file in that directory for compiling Tcl, installing it, +and running the test suite. + +4. Summary of changes in Tcl 7.5 +-------------------------------- + +The most important change for Tcl 7.5 is that Tcl now runs on Macintosh +and PC platforms as well as UNIX. The PC port runs under Windows 3.1 +(with Win32s), Windows 95, and Windows NT. This required a lot of +reorganization of the sources but it didn't require any changes to +Tcl's externally visible interfaces. + +In addition to the ports, Tcl 7.5 also has many other new features. +The following feature changes have occurred since Tcl 7.4: + + 1. Dynamic loading. There is a new "load" command for loading binary + extensions into Tcl on the fly. This works now on most of the major + UNIX platforms as well as PCs and Macintoshes. Three new "info" + commands, "info loaded", "info sharedlibextension", and + "info nameofexecutable", were also added as part of the dynamic loading + implementation. You can also create Tcl and Tk themselves as shared + libraries with the --enable-shared switch to the configure script. + + 2. Packages and versions. There is a new "package" command for + package and version management. See the manual entries for "package" + and "pkg_mkIndex" for details on how to use it. There are also + C APIs to the package mechanism. See PkgRequire.3. + + 3. Multiple interpreters and Safe-Tcl. There is a new "interp" command + that allows you to create multiple interpreters within a single application + and set up communication between them with "aliases". The mechanism also + supports "safe" interpreters, which provide a generalized version of the + security mechanisms in Borenstein and Rose's Safe-Tcl. There are still + a few missing security features, such as resource control. You can use + "load" to add extensions (including Tk) into slave interpreters. + + 4. The event loop from Tk has been moved to Tcl. Tcl now has commands + "after", "fileevent", "update", and "vwait" (which replaces tkwait). + The "tkerror" command has been renamed to "bgerror". "Tkerror" is + still supported for backwards compatibility, but you should switch ASAP + to using "bgerror" instead. Many C procedures that used to be in Tk + have been moved to Tcl and renamed, such as Tcl_DoOneEvent, Tcl_DoWhenIdle, + Tcl_CreateFileHandler, and Tcl_CreateTimerHandler. + + 5. Tcl has a whole new I/O system. All of the Tcl commands like + "open" and "puts" should continue to operate as before, but there + is a totally new implementation that doesn't use the C stdio library: + - The new I/O system is more portable, and it can be extended + with new kinds of I/O channels; see CrtChannel.3 for details. + - Nonblocking I/O is supported on all platforms and there is a + new command "fconfigure" to enable it and other channel options; + see fconfigure.n for details. There is also a new "fblocked" + command. + - The I/O system automatically translates between different + end-of-line representations (such as CR on Macs and CRLF on + PC's) to the newline form used in UNIX and in all Tcl scripts; + the "fconfigure" command can be used to control this feature. + - There is a set of C APIs for manipulating Tcl_Channel's, which + are analogous to UNIX FILE's. The C procedures have roughly the + same functionality as the stdio procedures. See OpenFileChnl.3, + CrtCloseHdlr.3, and CrtChnlHdlr.3 for details. + - There is a new structure Tcl_File that provides platform- + independent access to file handles such as UNIX fd's. See + GetFile.3 for details. + - There are new procedures Tcl_GetErrno and Tcl_SetErrno for + accessing the "errno" variable in a safe and portable fashion. + See SetErrno.3. + + 6. There are new commands "file split", "file join", and "file pathtype", + which make it possible to handle file names in a way that will work on + all platforms. See the manual entries file.n and filename.n for + details. + + 7. There is a new "socket" command for network communication via + TCP sockets. It works for both the client and server sides. There + is also C-level support for sockets; see OpenTcp.3. + + 8. There is a new "clock" command, which contains the functionality + of the TclX clock-handling commands. + + 9. The "foreach" command has been generalized significantly to support + multiple lists and multiple variables iterating over each list. + + 10. There is a new "notifier" mechanism, which was added as part of + the ports. This allows the basic mechanisms for reporting events + to be implemented in different ways on different platforms. It + may also be useful for other purposes, such as merging the Tk and + Xt event loops so that Tk and Xt widgets can coexist in a single + application. See the manual entry Notifier.3 for more information. + + 11. There is an "AssocData" mechanism that allows extensions to store + their own data in an interpreter and get called back when the interpreter + is deleted. This is visible at C level via the procedures Tcl_SetAssocData + and Tcl_GetAssocData. + + 12. When manual pages are installed, additional links are created for + each of the procedures described in the manual page, so that it's + easier to invoke the "man" command. + + 13. There is a new variable "tcl_platform" with platform information. + This is an associative array with elements like "os" and "machine" + that contain various pieces of information about the platform. + + 14. There is a new procedure Tcl_CreateExitHandler that you can use to + make sure a C procedure is called before the Tcl application exits. + + 15. There is a new procedure Tcl_UpdateLinkedVar to force the Tcl-level + variable to be updated after you've changed the corresponding C-level + variable. + + 16. The procedures Tk_Preserve, Tk_Release, and Tk_EventuallyFree + have been moved from Tk to Tcl and given names like Tcl_Preserve. + +Three incompatibilities were introduced by the changes. All of these +are at C-level, and only the first one should have much impact. Existing +scripts for Tcl 7.4 should run unchanged under Tcl 7.5. + + 1. The procedure Tcl_EnterFile no longer exists. However, a new + procedure Tcl_MakeFileChannel provides similar functionality. + Tcl_GetOpenFile still exists but only works under UNIX. + Tcl_CreatePipeline also remains, but it too works only under UNIX + now; use Tcl_OpenCommandChannel for better portability. + + 2. Tcl doesn't export any global C variables anymore, because this doesn't + work with Windows DLLs. The C variables tcl_AsyncReady and + tcl_FileCloseProc have been replaced with procedures Tcl_AsyncReady() + and Tcl_SetFileCloseProc(). The C variable tcl_RcFileName has been + replaced with a Tcl variable tcl_rcFileName (use Tcl_SetVar to set the + Tcl variable, instead of assigning to the old C variable). + + 3. Files are no longer shared between interpreters by default: if a + file is opened in one interpreter, it cannot normally be used in other + interpreters. However, the new procedure Tcl_ShareHandle allows files + to be shared between interpreters if requested explicitly. + +For a complete list of all changes in this release, see the file "changes" +in this directory. + +5. Tcl newsgroup +----------------- + +There is a network news group "comp.lang.tcl" intended for the exchange +of information about Tcl, Tk, and related applications. Feel free to use +the newsgroup both for general information questions and for bug reports. +We read the newsgroup and will attempt to fix bugs and problems reported +to it. + +When using comp.lang.tcl, please be sure that your e-mail return address +is correctly set in your postings. This allows people to respond directly +to you, rather than the entire newsgroup, for answers that are not of +general interest. A bad e-mail return address may prevent you from +getting answers to your questions. You may have to reconfigure your news +reading software to ensure that it is supplying valid e-mail addresses. + +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. + +7. Support and bug fixes +------------------------ + +We're very interested in receiving bug reports and suggestions for +improvements. We prefer that you send this information to the +comp.lang.tcl newsgroup rather than to any of us at Sun. We'll see +anything on comp.lang.tcl, and in addition someone else who reads +omp.lang.tcl may be able to offer a solution. The normal turn-around +time for bugs is 2-4 weeks. 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 turns into a kitchen sink). It's +very difficult to make incompatible changes to Tcl at this point, due +to the size of the installed base. + +When reporting bugs, please provide a short tclsh script that we can +use to reproduce the bug. Make sure that the script runs with a +bare-bones tclsh and doesn't depend on any extensions or other +programs, particularly those that exist only at your site. Also, +please include three additional pieces of information with the +script: + (a) how do we use the script to make the problem happen (e.g. + what things do we click on, in what order)? + (b) what happens when you do these things (presumably this is + undesirable)? + (c) what did you expect to happen instead? + +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 support and training are available commercially from +NeoSoft (info@neosoft.com), Computerized Processes Unlimited +(gwl@cpu.com), and Data Kinetics (education@dkl.com). + +8. Tcl version numbers +---------------------- + +Each Tcl release is identified by two numbers separated by a dot, e.g. +6.7 or 7.0. If a new release contains changes that are likely to break +existing C code or Tcl scripts then the major release number increments +and the minor number resets to zero: 6.0, 7.0, etc. If a new release +contains only bug fixes and compatible changes, then the minor number +increments without changing the major number, e.g. 7.1, 7.2, etc. If +you have C code or Tcl scripts that work with release X.Y, then they +should also work with any release X.Z as long as Z > Y. + +Alpha and beta releases have an additional suffix of the form a2 or b1. +For example, Tcl 7.0b1 is the first beta release of Tcl version 7.0, +Tcl 7.0b2 is the second beta release, and so on. A beta release is an +initial version of a new release, used to fix bugs and bad features before +declaring the release stable. An alpha release is like a beta release, +except it's likely to need even more work before it's "ready for prime +time". New releases are normally preceded by one or more alpha and beta +releases. We hope that lots of people will try out the alpha and beta +releases and report problems. We'll make new alpha/beta releases to fix +the problems, until eventually there is a beta release that appears to +be stable. Once this occurs we'll make the final release. + +We can't promise to maintain compatibility among alpha and beta releases. +For example, release 7.1b2 may not be backward compatible with 7.1b1, even +though the final 7.1 release will be backward compatible with 7.0. This +allows us to change new features as we find problems during beta testing. +We'll try to minimize incompatibilities between beta releases, but if +a major problem turns up then we'll fix it even if it introduces an +incompatibility. Once the official release is made then there won't +be any more incompatibilities until the next release with a new major +version number. diff --git a/contrib/tcl/README.FreeBSD b/contrib/tcl/README.FreeBSD new file mode 100644 index 0000000..a2436d7 --- /dev/null +++ b/contrib/tcl/README.FreeBSD @@ -0,0 +1,4 @@ +Tcl 7.5 + originals can be found at: ftp://ftp.smli.com/pub/tcl + removed subdirectories "win", "mac", "compat" + phk@FreeBSD.org diff --git a/contrib/tcl/changes b/contrib/tcl/changes new file mode 100644 index 0000000..f28f7e6 --- /dev/null +++ b/contrib/tcl/changes @@ -0,0 +1,2031 @@ +Recent user-visible changes to Tcl: + +SCCS: @(#) changes 1.115 96/04/18 16:43:36 + +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 *** + +15. 3/19/90 Added "info exists" option to see if variable exists. + +16. 3/19/90 Added "noAbbrev" variable to prohibit command abbreviations. + +17. 3/19/90 Added extra errorInfo option to "error" command. + +18. 3/21/90 Double-quotes now only affect space: command, variable, +and backslash substitutions still occur inside double-quotes. +*** POTENTIAL INCOMPATIBILITY *** + +19. 3/21/90 Added support for \r. + +20. 3/21/90 List, concat, eval, and glob commands all expect at least +one argument now. *** POTENTIAL INCOMPATIBILITY *** + +21. 3/22/90 Added "?:" operators to expressions. + +22. 3/25/90 Fixed bug in Tcl_Result that caused memory to get trashed. + +------------------- Released version 3.1 --------------------- + +23. 3/29/90 Fixed bug that caused "file a.b/c ext" to return ".b/c". + +24. 3/29/90 Semi-colon is not treated specially when enclosed in +double-quotes. + +------------------- Released version 3.2 --------------------- + +25. 4/16/90 Rewrote "exec" not to use select or signals anymore. +Should be more Sys-V compatible, and no slower in the normal case. + +26. 4/18/90 Rewrote "glob" to eliminate GNU code (there's no GNU code +left in Tcl, now), and added Tcl_TildeSubst procedure. Added automatic +tilde-substitution in many commands, including "glob". + +------------------- Released version 3.3 --------------------- + +27. 7/11/90 Added "Tcl_AppendResult" procedure. + +28. 7/20/90 "History" with no options now defaults to "history info" +rather than to "history redo". Although this is a backward incompatibility, +it should only be used interactively and thus shouldn't present any +compatibility problems with scripts. + +29. 7/20/90 Added "Tcl_GetInteger", "Tcl_GetDouble", and "Tcl_GetBoolean" +procedures. + +30. 7/22/90 Removed "Tcl_WatchInterp" procedure: doesn't seem to be +necessary, since the same effect can be achieved with the deletion +callbacks on individual commands. *** POTENTIAL INCOMPATIBILITY *** + +31. 7/23/90 Added variable tracing: Tcl_TraceVar, Tcl_UnTraceVar, +and Tcl_VarTraceInfo procedures, "trace" command. + +32. 8/9/90 Mailed out list of all bug fixes since 3.3 release. + +33. 8/29/90 Fixed bugs in Tcl_Merge relating to backslashes and +semi-colons. Mailed out patch. + +34. 9/3/90 Fixed bug in tclBasic.c: quotes weren't quoting ]'s. +Mailed out patch. + +35. 9/19/90 Rewrote exec to always use files both for input and +output to the process. The old pipe-based version didn't work if +the exec'ed process forked a child and then exited: Tcl waited +around for stdout to get closed, which didn't happen until the +grandchild exited. + +36. 11/5/90 ERR_IN_PROGRESS flag wasn't being cleared soon enough +in Tcl_Eval, allowing error messages from different commands to +pile up in $errorInfo. Fixed by re-arranging code in Tcl_Eval that +re-initializes result and ERR_IN_PROGRESS flag. Didn't mail out +patch: changes too complicated to describe. + +37. 12/19/90 Added Tcl_VarEval procedure as a convenience for +assembling and executing Tcl commands. + +38. 1/29/91 Fixed core leak in Tcl_AddErrorInfo. Also changed procedure +and Tcl_Eval so that first call to Tcl_AddErrorInfo need not come from +Tcl_Eval. + +----------------- Released version 5.0 with Tk ------------------ + +39. 4/3/91 Removed change bars from manual entries, leaving only those +that came after version 3.3 was released. + +40. 5/17/91 Changed tests to conform to Mary Ann May-Pumphrey's approach. + +41. 5/23/91 Massive revision to Tcl parser to simplify the implementation +of string and floating-point support in expressions. Newlines inside +[] are now treated as command separators rather than word separators +(this makes newline treatment consistent throughout Tcl). +*** POTENTIAL INCOMPATIBILITY *** + +42. 5/23/91 Massive rewrite of expression code to support floating-point +values and simple string comparisons. The C interfaces to expression +routines have changed (Tcl_Expr is replaced by Tcl_ExprLong, Tcl_ExprDouble, +etc.), but all old Tcl expression strings should be accepted by the new +expression code. +*** POTENTIAL INCOMPATIBILITY *** + +43. 5/23/91 Modified tclHistory.c to check for negative "keep" value. + +44. 5/23/91 Modified Tcl_Backslash to handle backslash-newline. It now +returns 0 to indicate that a backslash sequence should be replaced by +no character at all. +*** POTENTIAL INCOMPATIBILITY *** + +45. 5/29/91 Modified to use ANSI C function prototypes. Must set +"USE_ANSI" switch when compiling to get prototypes. + +46. 5/29/91 Completed test suite by providing tests for all of the +built-in Tcl commands. + +47. 5/29/91 Changed Tcl_Concat to eliminate leading and trailing +white-space in each of the things it concatenates and to ignore +elements that are empty or have only white space in them. This +produces cleaner output from the "concat" command. +*** POTENTIAL INCOMPATIBILITY *** + +48. 5/31/91 Changed "set" command and Tcl_SetVar procedure to return +new value of variable. + +49. 6/1/91 Added "while" and "cd" commands. + +50. 6/1/91 Changed "exec" to delete the last character of program +output if it is a newline. In most cases this makes it easier to +process program-generated output. +*** POTENTIAL INCOMPATIBILITY *** + +51. 6/1/91 Made sure that pointers are never used after freeing them. + +52. 6/1/91 Fixed bug in TclWordEnd where it wasn't dealing with +[] inside quotes correctly. + +53. 6/8/91 Fixed exec.test to accept return values of either 1 or +255 from "false" command. + +54. 7/6/91 Massive overhaul of variable management. Associative +arrays now available, along with "unset" command (and Tcl_UnsetVar +procedure). Variable traces have been completely reworked: +interfaces different both from Tcl and C, and multiple traces may +exist on same variable. Can no longer redefine existing local +variable to be global. Calling sequences have changed slightly +for Tcl_GetVar and Tcl_SetVar ("global" is now "flags"). Tcl_SetVar +can fail and return a NULL result. New forms of variable-manipulation +procedures: Tcl_GetVar2, Tcl_SetVar2, etc. Syntax of variable +$-notation changed to support array indexing. +*** POTENTIAL INCOMPATIBILITY *** + +55. 7/6/91 Added new list-manipulation procedures: Tcl_ScanElement, +Tcl_ConvertElement, Tcl_AppendElement. + +56. 7/12/91 Created new procedure Tcl_EvalFile, which does most of the +work of the "source" command. + +57. 7/20/91 Major reworking of "exec" command to allow pipelines, +more redirection, background. Added new procedures Tcl_Fork, +Tcl_WaitPids, Tcl_DetachPids, and Tcl_CreatePipeline. The old +"< input" notation has been replaced by "<< input" ("<" is for +redirection from a file). Also handles error returns and abnormal +terminations (e.g. signals) differently. +*** POTENTIAL INCOMPATIBILITY *** + +58. 7/21/91 Added "append" and "lappend" commands. + +59. 7/22/91 Reworked error messages and manual entries to use +?x? as the notation for an optional argument x, instead of [x]. The +bracket notation was often confused with the use of brackets for +command substitution. Also modified error messages to be more +consistent. + +60. 7/23/91 Tcl_DeleteCommand now returns an indication of whether +or not the command actually existed, and the "rename" command uses +this information to return an error if an attempt is made to delete +a non-existent command. +*** POTENTIAL INCOMPATIBILITY *** + +61. 7/25/91 Added new "errorCode" mechanism, along with procedures +Tcl_SetErrorCode, Tcl_UnixError, and Tcl_ResetResult. Renamed +Tcl_Return to Tcl_SetResult, but left a #define for Tcl_Return to +avoid compatibility problems. + +62. 7/26/91 Extended "case" command with alternate syntax where all +patterns and commands are together in a single list argument: makes +it easier to write multi-line case statements. + +63. 7/27/91 Changed "print" command to perform tilde-substitution on +the file name. + +64. 7/27/91 Added "tolower", "toupper", "trim", "trimleft", and "trimright" +options to "string" command. + +65. 7/29/91 Added "atime", "mtime", "size", and "stat" options to "file" +command. + +66. 8/1/91 Added "split" and "join" commands. + +67. 8/11/91 Added commands for file I/O, including "open", "close", +"read", "gets", "puts", "flush", "eof", "seek", and "tell". + +68. 8/14/91 Switched to use a hash table for command lookups. Command +abbreviations no longer have direct support in the Tcl interpreter, but +it should be possible to simulate them with the auto-load features +described below. The "noAbbrev" variable is no longer used by Tcl. +*** POTENTIAL INCOMPATIBILITY *** + +68.5 8/15/91 Added support for "unknown" command, which can be used to +complete abbreviations, auto-load library files, auto-exec shell +commands, etc. + +69. 8/15/91 Added -nocomplain switch to "glob" command. + +70. 8/20/91 Added "info library" option and TCL_LIBRARY #define. Also +added "info script" option. + +71. 8/20/91 Changed "file" command to take "option" argument as first +argument (before file name), for consistency with other Tcl commands. +*** POTENTIAL INCOMPATIBILITY *** + +72. 8/20/91 Changed format of information in $errorInfo variable: +comments such as + ("while" body line 1) +are now on separate lines from commands being executed. +*** POTENTIAL INCOMPATIBILITY *** + +73. 8/20/91 Changed Tcl_AppendResult so that it (eventually) frees +large buffers that it allocates. + +74. 8/21/91 Added "linsert", "lreplace", "lsearch", and "lsort" +commands. + +75. 8/28/91 Added "incr" and "exit" commands. + +76. 8/30/91 Added "regexp" and "regsub" commands. + +77. 9/4/91 Changed "dynamic" field in interpreters to "freeProc" (procedure +address). This allows for alternative storage managers. +*** POTENTIAL INCOMPATIBILITY *** + +78. 9/6/91 Added "index", "length", and "range" options to "string" +command. Added "lindex", "llength", and "lrange" commands. + +79. 9/8/91 Removed "index", "length", "print" and "range" commands. +"Print" is redundant with "puts", but less general, and the other +commands are replaced with the new commands described in change 78 +above. +*** POTENTIAL INCOMPATIBILITY *** + +80. 9/8/91 Changed history revision to occur even when history command +is nested; needed in order to allow "history" to be invoked from +"unknown" procedure. + +81. 9/13/91 Changed "panic" not to use vfprintf (it's uglier and less +general now, but makes it easier to run Tcl on systems that don't +have vfprintf). Also changed "strerror" not to redeclare sys_errlist. + +82. 9/19/91 Lots of changes to improve portability to different UNIX +systems, including addition of "config" script to adapt Tcl to the +configuration of the system it's being compiled on. + +83. 9/22/91 Added "pwd" command. + +84. 9/22/91 Renamed manual pages so that their filenames are no more +than 14 characters in length, moved to "doc" subdirectory. + +85. 9/24/91 Redid manual entries so they contain the supplemental +macros that they need; can just print with "troff -man" or "man" +now. + +86. 9/26/91 Created initial version of script library, including +a version of "unknown" that does auto-loading, auto-execution, and +abbreviation expansion. This library is used by tclTest +automatically. See the "library" manual entry for details. + +----------------- Released version 6.0, 9/26/91 ------------------ + +87. 9/30/91 Made "string tolower" and "string toupper" check case +before converting: on some systems, "tolower" and "toupper" assume +that character already has particular case. + +88. 9/30/91 Fixed bug in Tcl_SetResult: wasn't always setting freeProc +correctly when called with NULL value. This tended to cause memory +allocation errors later. + +89. 10/3/91 Added "upvar" command. + +90. 10/4/91 Changed "format" so that internally it converts %D to %ld, +%U to %lu, %O to %lo, and %F to %f. This eliminates some compatibility +problems on some machines without affecting behavior. + +91. 10/10/91 Fixed bug in "regsub" that caused core dumps with the -all +option when the last match wasn't at the end of the string. + +92. 10/17/91 Fixed problems with backslash sequences: \r support was +incomplete and \f and \v weren't supported at all. + +93. 10/24/91 Added Tcl_InitHistory procedure. + +94. 10/24/91 Changed "regexp" to store "-1 -1" in subMatchVars that +don't match, rather than returning an error. + +95. 10/27/91 Modified "regexp" to return actual strings in matchVar +and subMatchVars instead of indices. Added "-indices" switch to cause +indices to be returned. +*** POTENTIAL INCOMPATIBILITY *** + +96. 10/27/91 Fixed bug in "scan" where it used hardwired constants for +sizes of floats and doubles instead of using "sizeof". + +97. 10/31/91 Fixed bug in tclParse.c where parse-related error messages +weren't being storage-managed correctly, causing spurious free's. + +98. 10/31/91 Form feed and vertical tab characters are now considered +to be space characters by the parser. + +99. 10/31/91 Added TCL_LEAVE_ERR_MSG flag to procedures like Tcl_SetVar. + +100. 11/7/91 Fixed bug in "case" where "in" argument couldn't be omitted +if all case branches were embedded in a single list. + +101. 11/7/91 Switched to use "pid_t" and "uid_t" and other official +POSIC types and function prototypes. + +----------------- Released version 6.1, 11/7/91 ------------------ + +102. 12/2/91 Modified Tcl_ScanElement and Tcl_ConvertElement in several +ways. First, allowed caller to request that only backslashes be used +(no braces). Second, made Tcl_ConvertElement more aggressive in using +backslashes for braces and quotes. + +103. 12/5/91 Added "type", "lstat", and "readlink" options to "file" +command, plus added new "type" element to output of "stat" and "lstat" +options. + +104. 12/10/91 Manual entries had first lines that caused "man" program +to try weird preprocessor. Added blank comment lines to fix problem. + +105. 12/16/91 Fixed a few bugs in auto_mkindex proc: wasn't handling +errors properly, and hadn't been upgraded for new "regexp" syntax. + +106. 1/2/92 Fixed bug in "file" command where it didn't properly handle +a file names containing tildes where the indicated user doesn't exist. + +107. 1/2/92 Fixed lots of cases in tclUnixStr.c where two different +errno symbols (e.g. EWOULDBLOCK and EAGAIN) have the same number; Tcl +will only use one of them. + +108. 1/2/92 Lots of changes to configuration script to handle many more +systems more gracefully. E.g. should now detect the bogus strtoul that +comes with AIX and substitute Tcl's own version instead. + +----------------- Released version 6.2, 1/10/92 ------------------ + +109. 1/20/92 Config didn't have code to actually use "uid_t" variable +to set TCL_UIT_T #define. + +110. 2/10/92 Tcl_Eval didn't properly reset "numLevels" variable when +too-deep recursion occurred. + +111. 2/29/92 Added "on" and "off" to keywords accepted by Tcl_GetBoolean. + +112. 3/19/92 Config wasn't installing default version of strtod.c for +systems that don't have one in libc.a. + +113. 3/23/92 Fixed bug in tclExpr.c where numbers with leading "."s, +like 0.75, couldn't be properly substituted into expressions with +variable or command substitution. + +114. 3/25/92 Fixed bug in tclUnixAZ.c where "gets" command wasn't +checking to make sure that it was able to write the variable OK. + +115. 4/16/92 Fixed bug in tclUnixAZ.c where "read" command didn't +compute file size right for device files. + +116. 4/23/92 Fixed but in tclCmdMZ.c where "trace vinfo" was overwriting +the trace command. + +----------------- Released version 6.3, 5/1/92 ------------------ + +117. 5/1/92 Added Tcl_GlobalEval. + +118. 6/1/92 Changed auto-load facility to source files at global level. + +119. 6/8/92 Tcl_ParseVar wasn't always setting termPtr after errors, which +sometimes caused core dumps. + +120. 6/21/92 Fixed bug in initialization of regexp pattern cache. This +bug caused segmentation violations in regexp commands under some conditions. + +121. 6/22/92 Changed implementation of "glob" command to eliminate +trailing slashes on directory names: they confuse some systems. There +shouldn't be any user-visible changes in functionality except for names +in error messages not having trailing slashes. + +122. 7/2/92 Fixed bug that caused 'string match ** ""' to return 0. + +123. 7/2/92 Fixed bug in Tcl_CreateCmdBuf where it wasn't initializing +the buffer to an empty string. + +124. 7/6/92 Fixed bug in "case" command where it used NULL pattern string +after errors in the "default" clause. + +125. 7/25/92 Speeded up auto_load procedure: don't reread all the index +files unless the path has changed. + +126. 8/3/92 Changed tclUnix.h to define MAXPATHLEN from PATH_MAX, not +_POSIX_PATH_MAX. + +----------------- Released version 6.4, 8/7/92 ------------------ + +127. 8/10/92 Changed tclBasic.c so that comment lines can be continued by +putting a backslash before the newline. + +128. 8/21/92 Modified "unknown" to allow the source-ing of a file for +an auto-load to trigger other nested auto-loads, as long as there isn't +any recursion on the same command name. + +129. 8/25/92 Modified "format" command to allow " " and "+" flags, and +allow flags in any order. + +130. 9/14/92 Modified Tcl_ParseVar so that it doesn't actually attempt +to look up the variable if "noEval" mode is in effect in the interpreter +(it just parses the name). This avoids the errors that used to occur +in statements like "expr {[info exists foo] && $foo}". + +131. 9/14/92 Fixed bug in "uplevel" command where it didn't output the +correct error message if a level was specified but no command. + +132. 9/14/92 Renamed manual entries to have extensions like .3 and .n, +and added "install" target to Makefile. + +133. 9/18/92 Modified "unknown" command to emulate !!, !<num>, and +^<old>^<new> csh history substitutions. + +134. 9/21/92 Made the config script cleverer about figuring out which +switches to pass to "nm". + +135. 9/23/92 Fixed tclVar.c to be sure to copy flags when growing variables. +Used to forget about traces in progress and make extra recursive calls +on trace procs. + +136. 9/28/92 Fixed bug in auto_reset where it was unsetting variables +that might not exist. + +137. 10/7/92 Changed "parray" library procedure to print any array +accessible to caller, local or global. + +138. 10/15/92 Fixed bug where propagation of new environment variable +values among interpreters took N! time if there exist N interpreters. + +139. 10/16/92 Changed auto_reset procedure so that it also deletes any +existing procedures that are in the auto_load index (the assumption is +that they should be re-loaded to get the latest versions). + +140. 10/21/92 Fixed bug that caused lists to be incorrectly generated +for elements that contained backslash-newline sequences. + +141. 12/9/92 Added support for TCL_LIBRARY environment variable: use +it as library location if it's present. + +142. 12/9/92 Added "info complete" command, Tcl_CommandComplete procedure. + +143. 12/16/92 Changed the Makefile to check to make sure "config" has been +run (can't run config directly from the Makefile because it modifies the +Makefile; thus make has to be run again after running config). + +----------------- Released version 6.5, 12/17/92 ------------------ + +144. 12/21/92 Changed config to look in several places for libc file. + +145. 12/23/92 Added "elseif" support to if. Also, "then", "else", and +"elseif" may no longer be abbreviated. +*** POTENTIAL INCOMPATIBILITY *** + +146. 12/28/92 Changed "puts" and "read" to support initial "-nonewline" +switch instead of additional "nonewline" argument. The old form is +still supported, but it is discouraged and is no longer documented. +Also changed "puts" to make the file argument default to stdout: e.g. +"puts foo" will print foo on standard output. + +147. 1/6/93 Fixed bug whereby backslash-newline wasn't working when +typed interactively, or in "info complete". + +148. 1/22/93 Fixed bugs in "lreplace" and "linsert" where close +quotes were being lost from last element before replacement or +insertion. + +149. 1/29/93 Fixed bug in Tcl_AssembleCmd where it wasn't requiring +a newline at the end of a line before considering a command to be +complete. The bug caused some very long lines in script files to +be processed as multiple separate commands. + +150. 1/29/93 Various changes in Makefile to add more configuration +options, simplify installation, fix bugs (e.g. don't use -f switch +for cp), etc. + +151. 1/29/93 Changed "name1" and "name2" identifiers to "part1" and +"part2" to avoid name conflicts with stupid C++ implementations that +use "name1" and "name2" in a reserved way. + +152. 2/1/93 Added "putenv" procedure to replace the standard system +version so that it will work correctly with Tcl's environment handling. + +----------------- Released version 6.6, 2/5/93 ------------------ + +153. 2/10/93 Fixed bugs in config script: missing "endif" in libc loop, +and tried to use strncasecmp.c instead of strcasecmp.c. + +154. 2/10/93 Makefile improvements: added RANLIB variable for easier +Sys-V configuration, added SHELL variable for SGI systems. + +----------------- Released version 6.7, 2/11/93 ------------------ + +153. 2/6/93 Changes in backslash processing: + - \Cx, \Mx, \CMx, \e sequences no longer special + - \<newline> also eats up any space after the newline, replacing + the whole sequence with a single space character + - Hex sequences like \x24 are now supported, along with ANSI C's \a. + - "format" no longer does backslash processing on its format string + - there is no longer any special meaning to a 0 return value from + Tcl_Backslash + - unknown backslash sequences, like (e.g. \*), are replaced with + the following character (e.g. *), instead of just treating the + backslash as an ordinary character. +*** POTENTIAL INCOMPATIBILITY *** + +154. 2/6/93 Updated all copyright notices. The meaning hasn't changed +at all but the wording does a better job of protecting U.C. from +liability (according to U.C. lawyers, anyway). + +155. 2/6/93 Changed "regsub" so that it overwrites the result variable +in all cases, even if there is no match. +*** POTENTIAL INCOMPATIBILITY *** + +156. 2/8/93 Added support for XPG3 %n$ conversion specifiers to "format" +command. + +157. 2/17/93 Fixed bug in Tcl_Eval where errors due to infinite +recursion could result in core dumps. + +158. 2/17/93 Improved the auto-load mechanism to deal gracefully (i.e. +return an error) with a situation where a library file that supposedly +defines a procedure doesn't actually define it. + +159. 2/17/93 Renamed Tcl_UnixError procedure to Tcl_PosixError, and +changed errorCode variable usage to use POSIX as keyword instead of +UNIX. +*** POTENTIAL INCOMPATIBILITY *** + +160. 2/19/93 Changes to exec and process control: + - Added support for >>, >&, >>&, |&, <@, >@, and >&@ forms of redirection. + - When exec puts processes into background, it returns a list of + their pids as result. + - Added support for <file, >file, etc. (i.e. no space between + ">" and file name. + - Added -keepnewline option. + - Deleted Tcl_Fork and Tcl_WaitPids procedures (just use fork and + waitpid instead). + - Added waitpid compatibility procedure for systems that don't have + it. + - Added Tcl_ReapDetachedProcs procedure. + - Changed "exec" to return an error if there is stderr output, even + if the command returns a 0 exit status (it's always been documented + this way, but the implementation wasn't correct). + - If a process returns a non-zero exit status but doesn't generate + any diagnostic output, then Tcl generates an error message for it. +*** POTENTIAL INCOMPATIBILITY *** + +161. 2/25/93 Fixed two memory-management problems having to do with +managing the old result during variable trace callbacks. + +162. 3/1/93 Added dynamic string library: Tcl_DStringInit, Tcl_DStringAppend, +Tcl_DStringFree, Tcl_DStringResult, etc. + +163. 3/1/93 Modified glob command to only return the names of files that +exist, and to only return names ending in "/" if the file is a directory. +*** POTENTIAL INCOMPATIBILITY *** + +164. 3/19/93 Modified not to use system calls like "read" directly, +but instead to use special Tcl procedures that retry automatically +if interrupted by signals. + +165. 4/3/93 Eliminated "noSep" argument to Tcl_AppendElement, plus +TCL_NO_SPACE flag for Tcl_SetVar and Tcl_SetVar2. +*** POTENTIAL INCOMPATIBILITY *** + +166. 4/3/93 Eliminated "flags" and "termPtr" arguments to Tcl_Eval. +*** POTENTIAL INCOMPATIBILITY *** + +167. 4/3/93 Changes to expressions: + - The "expr" command now accepts multiple arguments, which are + concatenated together with space separators. + - Integers aren't automatically promoted to floating-point if they + overflow the word size: errors are generated instead. + - Tcl can now handle "NaN" and other special values if the underlying + library procedures handle them. + - When printing floating-point numbers, Tcl ensures that there is a "." + or "e" in the number, so it can't be treated as an integer accidentally. + The procedure Tcl_PrintDouble is available to provide this function + in other contexts. Also, the variable "tcl_precision" can be used + to set the precision for printing (must be a decimal number giving + digits of precision). + - Expressions now support transcendental and other functions, e.g. sin, + acos, hypot, ceil, and round. Can add new math functions with + Tcl_CreateMathFunc(). + - Boolean expressions can now have any of the string values accepted + by Tcl_GetBoolean, such as "yes" or "no". +*** POTENTIAL INCOMPATIBILITY *** + +168. 4/5/93 Changed Tcl_UnsetVar and Tcl_UnsetVar2 to return TCL_OK +or TCL_ERROR instead of 0 or -1. +*** POTENTIAL INCOMPATIBILITY *** + +169. 4/5/93 Eliminated Tcl_CmdBuf structure and associated procedures; +can use Tcl_DStrings instead. +*** POTENTIAL INCOMPATIBILITY *** + +170. 4/8/93 Changed interface to Tcl_TildeSubst to use a dynamic +string for buffer space. This makes the procedure re-entrant and +thread-safe, whereas it wasn't before. +*** POTENTIAL INCOMPATIBILITY *** + +171. 4/14/93 Eliminated tclHash.h, and moved everything from it to +tcl.h +*** POTENTIAL INCOMPATIBILITY *** + +172. 4/15/93 Eliminated Tcl_InitHistory, made "history" command always +be part of interpreter. +*** POTENTIAL INCOMPATIBILITY *** + +173. 4/16/93 Modified "file" command so that "readable" option always +exists, even on machines that don't support symbolic links (always returns +same error as if the file wasn't a symbolic link). + +174. 4/26/93 Fixed bugs in "regsub" where ^ patterns didn't get handled +right (pretended not to match when it really did, and looped infinitely +if -all was specified). + +175. 4/29/93 Various improvements in the handling of variables: + - Can create variables and array elements during a read trace. + - Can delete variables during traces (note: unset traces will be + invoked when this happens). + - Can upvar to array elements. + - Can retarget an upvar to another variable by re-issuing the + upvar command with a different "other" variable. + +176. 5/3/93 Added Tcl_GetCommandInfo, which returns info about a Tcl +command such as whether it exists and its ClientData. Also added +Tcl_SetCommandInfo, which allows any of this information to be modified +and also allows a command's delete procedure to have a different +ClientData value than its command procedure. + +177. 5/5/93 Added Tcl_RegExpMatch procedure. + +178. 5/6/93 Fixed bug in "scan" where it didn't properly handle +%% conversion specifiers. Also changed "scan" to use Tcl_PrintDouble +for printing real values. + +179. 5/7/93 Added "-exact", "-glob", and "-regexp" options to "lsearch" +command to allow different kinds of pattern matching. + +180. 5/7/93 Added many new switches to "lsort" to control the sorting +process: "-ascii", "-integer", "-real", "-command", "-increasing", +and "-decreasing". + +181. 5/10/93 Changes to file I/O: + - Modified "open" command to support a list of POSIX access flags + like {WRONLY CREAT TRUNC} in addition to current fopen-style + access modes. Also added "permissions" argument to set permissions + of newly-created files. + - Fixed Scott Bolte's bug (can close stdin etc. in application and + then re-open them with Tcl commands). + - Exported access to Tcl's file table with new procedures Tcl_EnterFile + and Tcl_GetOpenFile. + +182. 5/15/93 Added new "pid" command, which can be used to retrieve +either the current process id or a list of the process ids in a +pipeline opened with "open |..." + +183. 6/3/93 Changed to use GNU autoconfig for configuration instead of +the home-brew "config" script. Also made many other configuration-related +changes, such as using <unistd.h> instead of explicitly declaring system +calls in tclUnix.h. + +184. 6/4/93 Fixed bug where core-dumps could occur if a procedure +redefined itself (the memory for the procedure's body could get +reallocated in the middle of evaluating the body); implemented +simple reference count mechanism. + +185. 6/5/93 Changed tclIndex file format in two ways: (a) it's now +eval-ed instead of parsed, which makes it 3-4x faster; (b) the entries +in auto_index are now commands to evaluate, which allows commands to +be loaded in different ways such as dynamic-loading of C code. The +old tclIndex file format is still supported. + +186. 6/7/93 Eliminated tclTest program, added new "tclsh" program +that is more like wish (allows script files to be invoked automatically +using "#!/usr/local/bin/tclsh", makes arguments available to script, +etc.). Added support for Tcl_AppInit plus default version; this +allows new Tcl applications to be created without modifying the +main program for tclsh. + +187. 6/7/93 Fixed bug in TclWordEnd that kept backslash-newline from +working correctly in some cases during interactive input. + +188. 6/9/93 Added Tcl_LinkVar and related procedures, which automatically +keep a Tcl variable in sync with a C variable. + +189. 6/16/93 Increased maximum nesting depth from 100 to 1000. + +190. 6/16/93 Modified "trace var" command so that error messages from +within traces are returned properly as the result of the variable +access, instead of the generic "access disallowed by trace command" +message. + +191. 6/16/93 Added Tcl_CallWhenDeleted to provide callbacks when an +interpreter is deleted (same functionality as Tcl_WatchInterp, which +used to exist in versions before 6.0). + +193. 6/16/93 Added "-code" argument to "return" command; it's there +primarily for completeness, so that procedures implementing control +constructs can reflect exceptional conditions back to their callers. + +194. 6/16/93 Split up Tcl.n to make separate manual entries for each +Tcl command. Tcl.n now contains a summary of the language syntax. + +195. 6/17/93 Added new "switch" command to replace "case": allows +alternate forms of pattern matching (exact, glob, regexp), replaces +pattern lists with single patterns (but you can use "-" bodies to +share one body among several patterns), eliminates "in" noise word. +"Case" command is now obsolete. + +196. 6/17/93 Changed the "exec", "glob", "regexp", and "regsub" commands +to include a "--" switch. All initial arguments starting with "-" are now +treated as switches unless a "--" switch is present to end the list. +*** POTENTIAL INCOMPATIBILITY *** + +197. 6/17/93 Changed auto-exec so that the subprocess gets stdin, stdout, +and stderr from the parent. This allows truly interactive sub-processes +(e.g. vi) to be auto-exec'ed from a tcl shell command line. + +198. 6/18/93 Added patchlevel.h, for use in coordinating future patch +releases, and also added "info patchlevel" command to make the patch +level available to Tcl scripts. + +199. 6/19/93 Modified "glob" command so that a leading "//" in a name +gets left as is (this is needed for systems like Apollos where "//" is +the super-root; Tcl used to collapse the two slashes into a single +slash). + +200. 7/7/93 Added Tcl_SetRecursionLimit procedure so that the maximum +allowable nesting depth can be controlled for an interpreter from C. + +----------------- Released version 7.0 Beta 1, 7/9/93 ------------------ + +201. 7/12/93 Modified Tcl_GetInt and tclExpr.c so that full-precision +unsigned integers can be specified without overflow errors. + +202. 7/12/93 Configuration changes: eliminate leading blank line in +configure script; provide separate targets in Makefile for installing +binary and non-binary information; check for size_t and a few other +potentially missing typedefs; don't put tclAppInit.o into libtcl.a; +better checks for matherr support. + +203. 7/14/93 Changed tclExpr.c to check the termination pointer before +errno after strtod calls, to avoid problems with some versions of +strtod that set errno in unexpected ways. + +204. 7/16/93 Changed "scan" command to be more ANSI-conformant: +eliminated %F, %D, etc., added code to ignore "l", "h", and "L" +modifiers but always convert %e, %f, and %g with implicit "l"; +also added support for %u and %i. Also changed "format" command +to eliminate %D, %U, %O, and add %i. +*** POTENTIAL INCOMPATIBILITY *** + +205. 7/17/93 Changed "uplevel" and "upvar" so that they can be used +from global level to global level: this used to generate an error. + +206. 7/19/93 Renamed "setenv", "putenv", and "unsetenv" procedures +to avoid conflicts with system procedures with the same names. If +you want Tcl's procedures to override the system procedures, do it +in the Makefile (instructions are in the Makefile). +*** POTENTIAL INCOMPATIBILITY *** + +----------------- Released version 7.0 Beta 2, 7/21/93 ------------------ + +207. 7/21/93 Fixed bug in tclVar.c where freed memory was accidentally +used if a procedure returned an element of a local array. + +208. 7/22/93 Fixed bug in "unknown" where it didn't properly handle +errors occurring in the "auto_load" procedure, leaving its state +inconsistent. + +209. 7/23/93 Changed exec's ">2" redirection operator to "2>" for +consistency with sh. This is incompatible with earlier beta releases +of 7.0 but not with pre-7.0 releases, which didn't support either +operator. + +210. 7/28/93 Changed backslash-newline handling so that the resulting +space character *is* treated as a word separator unless the backslash +sequence is in quotes or braces. This is incompatible with 7.0b1 +and 7.0b2 but is more compatible with pre-7.0 versions that the b1 +and b2 releases were. + +211. 7/28/93 Eliminated Tcl_LinkedVarWritable, added TCL_LINK_READ_ONLY to +Tcl_LinkVar to accomplish same purpose. This change is incompatible +with earlier beta releases, but not with releases before Tcl 7.0. + +212. 7/29/93 Renamed regexp C functions so they won't clash with POSIX +regexp functions that use the same name. + +213. 8/3/93 Added "-errorinfo" and "-errorcode" options to "return" +command: these allow for much better handling of the errorInfo +and errorCode variables in some cases. + +214. 8/12/93 Changed "expr" so that % always returns a remainder with +the same sign as the divisor and absolute value smaller than the +divisor. + +215. 8/14/93 Turned off auto-exec in "unknown" unless the command +was typed interactively. This means you must use "exec" when +invoking subprocesses, unless it's a command that's typed interactively. +*** POTENTIAL INCOMPATIBILITY *** + +216. 8/14/93 Added support for tcl_prompt1 and tcl_prompt2 variables +to tclMain.c: makes prompts user-settable. + +217. 8/14/93 Added asynchronous handlers (Tcl_AsyncCreate etc.) so +that signals can be taken cleanly by Tcl applications. + +218. 8/16/93 Moved information about open files from the interpreter +structure to global variables so that a file can be opened in one +interpreter and read or written in another. + +219. 8/16/93 Removed ENV_FLAGS from Makefile, so that there's no +official support for overriding setenv, unsetenv, and putenv. + +220. 8/20/93 Various configuration improvements: coerce chars +to unsigned chars before using macros like isspace; source ~/.tclshrc +file during initialization if it exists and program is running +interactively; allow there to be directories in auto_path that don't +exist or don't have tclIndex files (ignore them); added Tcl_Init +procedure and changed Tcl_AppInit to call it. + +221. 8/21/93 Fixed bug in expr where "+", "-", and " " were all +getting treated as integers with value 0. + +222. 8/26/93 Added "tcl_interactive" variable to tclsh. + +223. 8/27/93 Added procedure Tcl_FilePermissions to return whether a +given file can be read or written or both. Modified Tcl_EnterFile +to take a permissions mask rather than separate read and write arguments. + +224. 8/28/93 Fixed performance bug in "glob" command (unnecessary call +to "access" for each file caused a 5-10x slow-down for big directories). + +----------------- Released version 7.0 Beta 3, 8/28/93 ------------------ + +225. 9/9/93 Renamed regexp.h to tclRegexp.h to avoid conflicts with system +include file by same name. + +226. 9/9/93 Added Tcl_DontCallWhenDeleted. + +227. 9/16/93 Changed not to call exit C procedure directly; instead +always invoke "exit" Tcl command so that application can redefine the +command to do additional cleanup. + +228. 9/17/93 Changed auto-exec to handle names that contain slashes +(i.e. don't use PATH for them). + +229. 9/23/93 Fixed bug in "read" and "gets" commands where they didn't +clear EOF conditions. + +----------------- Released version 7.0, 9/29/93 ------------------ + +230. 10/7/93 "Scan" command wasn't properly aligning things in memory, +so segmentation faults could arise under some circumstances. + +231. 10/7/93 Fixed bug in Tcl_ConvertElement where it forgot to +backslash leading curly brace when creating lists. + +232. 10/7/93 Eliminated dependency of tclMain.c on tclInt.h and +tclUnix.h, so that people can copy the file out of the Tcl source +directory to make modified private versions. + +233. 10/8/93 Fixed bug in auto-loader that reversed the priority order +of entries in auto_path for new-style index files. Now things are +back to the way they were before 3.0: first in auto_path is always +highest priority. + +234. 10/13/93 Fixed bug where Tcl_CommandComplete didn't recognize +comments and treat them as such. Thus if you typed the line + # { +interactively, Tcl would think that the command wasn't complete and +wait for more input before evaluating the script. + +235. 10/14/93 Fixed bug where "regsub" didn't set the output variable +if the input string was empty. + +236. 10/23/93 Fixed bug where Tcl_CreatePipeline didn't close off enough +file descriptors in child processes, causing children not to exit +properly in some cases. + +237. 10/28/93 Changed "list" and "concat" commands not to generate +errors if given zero arguments, but instead to just return an empty +string. + +----------------- Released version 7.1, 11/4/93 ------------------ + +Note: there is no 7.2 release. It was flawed and was thus withdrawn +shortly after it was released. + +238. 11/10/93 TclMain.c didn't compile on some systems because of +R_OK in call to "access". Changed to eliminate call to "access". + +----------------- Released version 7.3, 11/26/93 ------------------ + +239. 11/6/93 Modified "lindex", "linsert", "lrange", and "lreplace" +so that "end" can be specified as an index. + +240. 11/6/93 Modified "append" and "lappend" to allow only two +words total (i.e., nothing to append) without generating an error. + +241. 12/2/93 Changed to use EAGAIN as the errno for non-blocking +I/O instead of EWOULDBLOCK: this should fix problem where non-blocking +I/O didn't work correctly on System-V systems. + +242. 12/22/93 Fixed bug in expressions where cancelled evaluation +wasn't always working correctly (e.g. "set one 1; eval {1 || 1/$one}" +failed with a divide by zero error). + +243. 1/6/94 Changed TCL_VOLATILE definition from -1 to the address of +a dummy procedure Tcl_Volatile, since -1 causes portability problems on +some machines (e.g., Crays). + +244. 2/4/94 Added support for unary plus. + +245. 2/17/94 Changed Tcl_RecordAndEval and "history" command to +call Tcl_GlobalEval instead of Tcl_Eval. Otherwise, invocation of +these facilities in nested procedures can cause unwanted results. + +246. 2/17/94 Fixed bug in tclExpr.c where an expression such as +"expr {"12398712938788234-1298379" != ""}" triggers an integer +overflow error for the number in quotes, even though it isn't really +a proper integer anyway. + +247. 2/19/94 Added new procedure Tcl_DStringGetResult to move result +from interpreter to a dynamic string. + +248. 2/19/94 Fixed bug in Tcl_DStringResult that caused it to overwrite +the contents of a static result in some situations. This can cause +bizarre errors such as variables suddenly having empty values. + +249. 2/21/94 Fixed bug in Tcl_AppendElement, Tcl_DStringAppendElement, +and the "lappend" command that caused improper omission of a separator +space in some cases. For example, the script + set x "abc{"; lappend x "def" +used to return the result "abc{def" instead of "abc{ def". + +250. 3/3/94 Tcl_ConvertElement was outputting empty elements as \0 if +TCL_DONT_USE_BRACES was set. This depends on old pre-7.0 meaning of +\0, which is no longer in effect, so it didn't really work. Changed +to output empty elements as {} always. + +251. 3/3/94 Renamed Tcl_DStringTrunc to Tcl_DStringSetLength and extended +it so that it can be used to lengthen a string as well as shorten it. +Tcl_DStringTrunc is defined as a macro for backward compatibility, but +it is deprecated. + +252. 3/3/94 Added Tcl_AllowExceptions procedure. + +253. 3/13/94 Fixed bug in Tcl_FormatCmd that could cause "format" +to mis-behave on 64-bit Big-Endian machines. + +254. 3/13/94 Changed to use vfork instead of fork on systems where +vfork exists. + +255. 3/23/94 Fixed bug in expressions where ?: didn't associate +right-to-left as they should. + +256. 4/3/94 Fixed "exec" to flush any files used in >@ or >&@ +redirection in exec, so that data buffered for them is written +before any new data added by the subprocess. + +257. 4/3/94 Added "subst" command. + +258. 5/20/94 The tclsh main program is now called Tcl_Main; tclAppInit.c +has a "main" procedure that calls Tcl_Main. This makes it easier to use +Tcl with C++ programs, which need their own main programs, and it also +allows an application to prefilter the argument list before calling +Tcl_Main. +*** POTENTIAL INCOMPATIBILITY *** + +259. 6/6/94 Fixed bug in procedure returns where the errorInfo variable +could get truncated if an unset trace was invoked as part of returning +from the procedure. + +260. 6/13/94 Added "wordstart" and "wordend" options to "string" command. + +261. 6/27/94 Fixed bug in expressions where they didn't properly cancel +the evaluation of math functions in &&, ||, and ?:. + +262. 7/11/94 Incorrect boolean values, like "ogle", weren't being +handled properly. + +263. 7/15/94 Added Tcl_RegExpCompile, Tcl_RegExpExec, and Tcl_RegExpRange, +which provide lower-level access to regular expression pattern matching. + +264. 7/22/94 Fixed bug in "glob" command where "glob -nocomplain ~bad_user" +would complain about a missing user. Now it doesn't complain anymore. + +265. 8/4/94 Fixed bug with linked variables where they didn't behave +correctly when accessed via upvars. + +266. 8/17/94 Fixed bug in Tcl_EvalFile where it didn't clear interp->result. + +267. 8/31/94 Modified "open" command so that errors in exec-ing +subprocesses are returned by the open immediately, rather than +being delayed until the "close" is executed. + +268. 9/9/94 Modified "expr" command to generate errors for integer +overflow (includes addition, subtraction, negation, multiplication, +division). + +269. 9/23/94 Modified "regsub" to return a count of the number of +matches and replacements, rather than 0/1. + +279. 10/4/94 Added new features to "array" command: + - added "get" and "set" commands for easy conversion between arrays + and lists. + - added "exists" command to see if a variable is an array, changed + "names" and "size" commands to treat a non-existent array (or scalar + variable) just like an empty one. + - added pattern option to "names" command. + +280. 10/6/94 Modified Tcl_SetVar2 so that read traces on variables get +called during append operations. + +281. 10/20/94 Fixed bug in "read" command where reading from stdin +required two control-D's to stop the reading. + +282. 11/3/94 Changed "expr" command to use longs for division just like +all other expr operators; it previously used ints for division. + +283. 11/4/94 Fixed bugs in "unknown" procedure: it wasn't properly +handling exception returns from commands that were executed after +being auto-loaded. + +----------------- Released version 7.4b1, 12/23/94 ------------------ + +284. 12/26/94 Fixed "install" target in Makefile (couldn't always +find install program). + +285. 12/26/94 Added strcncasecmp procedure to compat directory. + +286. 1/3/95 Fixed all procedure calls to explicitly cast arguments: +implicit conversions from prototypes (especially integer->double) +don't work when compiling under non-ANSI compilers. Tcl is now clean +under gcc -Wconversion. + +287. 1/4/95 Fixed problem in Tcl_ArrayCmd where same name was used for +both a label and a variable; caused problems on several older compilers, +making array command misbehave and causing many errors in Tcl test suite. + +----------------- Released version 7.4b2, 1/12/95 ------------------ + +288. 2/9/95 Modified Tcl_CreateCommand to return a token, and added +Tcl_GetCommandName procedure. Together, these procedures make it possible +to track renames of a command. + +289. 2/13/95 Fixed bug in expr where "089" was interpreted as a +floating-point number rather than a bogus octal number. +*** POTENTIAL INCOMPATIBILITY *** + +290. 2/14/95 Added code to Tcl_GetInt and Tcl_GetDouble to check for +overflows when reading in numbers. + +291. 2/18/95 Changed "array set" to stop after first error, rather than +continuing after error. + +292. 2/20/95 Upgraded to use autoconf version 2.2. + +293. 2/20/95 Fixed core dump that could occur in "scan" command if a +close bracket was omitted. + +294. 2/27/95 Changed Makefile to always use install-sh for installations: +there's just too much variation among "install" system programs, which +makes installation flakey. + +----------------- Released version 7.4b3, 3/24/95 ------------------ + +3/25/95 (bug fix) Changed "install" to "./install" in Makefile so that +"make install" will work even when "." isn't in the search path. + +3/29/95 (bug fix) Fixed bug where the auto-loading mechanism wasn't +protecting the values of the errorCode and errorInfo variables. + +3/29/95 (new feature) Added optional pattern argument to "parray" procedure. + +3/29/95 (bug fix) Made the full functionality of + "return -code ... -errorcode ..." +work not just inside procedures, but also in sourced files and at +top level. + +4/6/95 (new feature) Added "pattern" option to "array names" command. + +4/18/95 (bug fix) Fixed bug in parser where it didn't allow backslash-newline +immediately after an argument in braces or quotes. + +4/19/95 (new feature) Added tcl_library variable, which application can +set to override default library directory. + +4/30/95 (bug fix) During trace callbacks for array elements, the variable +name used in the original reference would be temporarily modified to +separate the array name and element name; if the trace callback used +the same name string, it would get the wrong name (the array name without +element). Fixed to restore the variable name before making trace +callbacks. + +4/30/95 (new feature) Added -nobackslashes, -nocommands, and -novariables +switches to "subst" command. + +5/4/95 (new feature) Added TCL_EVAL_GLOBAL flag to Tcl_RecordAndEval. + +5/5/95 (bug fix) Format command would overrun memory when printing +integers with very large precision, as in "format %.1000d 0". + +5/5/95 (portability improvement) Changed to use BSDgettimeofday on +IRIX machines, to avoid compilation problems with the gettimeofday +declaration. + +5/6/95 (bug fix) Changed manual entries to use the standard .TH +macro instead of a custom .HS macro; the .HS macro confuses index +generators like makewhatis. + +5/9/95 (bug fix) Modified configure script to check for Solaris bug +that makes vfork unreliable (core dumps result if vforked child +changes a signal handler); will use fork instead of vfork if the +bug is present. + +6/5/95 (bug fix) Modified "lsort" command to disallow recursive calls +to lsort from a comparison function. This is needed because qsort +is not reentrant. + +6/5/95 (bug fix) Undid change 243 above: changed TCL_VOLATILE and +TCL_DYNAMIC back to integer constants rather than procedure addresses. +This was needed because procedure addresses can have multiple values +under some dynamic loading systems (e.g. SunOS 4.1 and Windows). + +6/8/95 (feature change) Modified interface to Tcl_Main to pass in the +address of the application-specific initialization procedure. +Tcl_AppInit is no longer hardwired into Tcl_Main. This is needed +in order to make Tcl a shared library. + +6/8/95 (feature change) Modified Makefile so that the installed versions +of tclsh and libtcl.a have version number in them (e.g. tclsh7.4 and +libtcl7.4.a) and the library directory name also has an embedded version +number (e.g., /usr/local/lib/tcl7.4). This should make it easier for +Tcl 7.4 to coexist with earlier versions. + +----------------- Released version 7.4b4, 6/16/95 ------------------ + +6/19/95 (bug fix) Fixed bugs in tclCkalloc.c that caused core dumps +if TCL_MEM_DEBUG was enabled on word-addressed machines such as Crays. + +6/21/95 (feature removal) Removed overflow checks for integer arithmetic: +they just cause too much trouble (e.g. for random number generators). + +6/28/95 (new features) Added tcl_patchLevel and tcl_version variables, +for consistency with Tk. + +6/29/95 (bug fix) Fixed problem in Tcl_Eval where it didn't record +the right termination character if a script ended with a comment. This +caused erroneous output for the following command, among others: +puts "[ +expr 1+1 +# duh! +]" + +6/29/95 (message change) Changed the error message for ECHILD slightly +to provide a hint about why the problem is occurring. + +----------------- Released version 7.4, 7/1/95 ------------------ + +7/18/95 (bug fix) Changed "lreplace" so that nothing is deleted if +the last index is less than the first index or if the last index +is < 0. + +7/18/95 (bug fix) Fixed bugs with backslashes in comments: +Tcl_CommandComplete (and "info complete") didn't properly handle +strings ending in backslash-newline, and neither Tcl_CommandComplete +nor the Tcl parser handled other backslash sequences right, such +as two backslashes before a newline. + +7/19/95 (bug fix) Modified Tcl_DeleteCommand to delete the hash table +entry for the command before invoking its callback. This is needed in +order to deal with reentrancy. + +7/22/95 (bug fix) "exec" wasn't reaping processes correctly after +certain errors (e.g. if the name of the executable was bogus, as +in "exec foobar"). + +7/27/95 (bug fix) Makefile.in wasn't using the LIBS variable provided +by the "configure" script. This caused problems on some SCO systems. + +7/27/95 (bug fix) The version of strtod in fixstrtod.c didn't properly +handle the case where endPtr == NULL. + +----------------- Released patch 7.4p1, 7/29/95 ----------------------- + +8/4/95 (bug fix) C-level trace callbacks for variables were sometimes +receiving the PART1_NOT_PARSED flag, which could cause errors in +subsequent Tcl library calls using the flags. (JO) + +8/4/95 (bug fix) Calls to toupper and tolower weren't using the +UCHAR macros, which caused trouble in non-U.S. locales. (JO) + +8/10/95 (new feature) Added the "load" command for dynamic loading of +binary packages, and the Tcl_PackageInitProc prototype for package +initialization procedures. (JO) + +8/23/95 (new features) Added "info sharedlibextension" and +"info nameofexecutable" commands, plus Tcl_FindExtension procedure. (JO) + +8/25/95 (bug fix) If the target of an "upvar" was non-existent but +had traces set, the traces were silently lost. Change to generate +an error instead. (JO) + +8/25/95 (bug fix) Undid change from 7/19, so that commands can stay +around while their deletion callbacks execute. Added lots of code to +handle all of the reentrancy problems that this opens up. (JO) + +8/25/95 (bug fix) Fixed core dump that could occur in TclDeleteVars +if there was an upvar from one entry in the table to the next entry +in the same table. (JO) + +8/28/95 (bug fix) Exec wasn't handling bad user names properly, as +in "exec ~bogus_user/foo". (JO) + +8/29/95 (bug fixes) Changed backslash-newline handling to correct two +problems: + - Only spaces and tabs following the backslash-newline are now + absorbed as part of the backslash-newline. Newlinew are no + longer absorbed (add another backslash if you want to absorb + another newline). + - TclWordEnd returns the character just before the backslash in + the sequence as the end of the sequence; it used to not consider + the backslash-newline as a word separator. (JO) + +8/31/95 (new feature) Changed man page installation (with "mkLinks" +script) to create additional links for manual pages corresponding to +each of the procedure and command names described in the pages. (JO) + +9/10/95 Reorganized Tcl sources for Windows and Mac ports. All sources +are now in subdirectories: "generic" contains sources that work on all +platforms, "windows", "mac", and "unix" directories contain platform- +specific sources. Some UNIX sources are also used on other platforms. (SS) + +9/10/95 (feature change) Eliminated exported global variables (they +don't work with Windows DLLs). Replaced tcl_AsyncReady and +tcl_FileCloseProc with procedures Tcl_AsyncReady() and +Tcl_SetFileCloseProc(). Replaced C variable tcl_RcFileName with +a Tcl variable tcl_rcFileName. (SS) +*** POTENTIAL INCOMPATIBILITY *** + +9/11/95 (new feature) Added procedure Tcl_SetPanicProc to override +the default implementation of "panic". (SS) + +9/11/95 (new feature) Added "interp" command to allow creation of +new interpreters and execution of untrusted scripts. Added many new +procedures, such as Tcl_CreateSlave, Tcl_CreateAlias,and Tcl_MakeSafe, +to provide C-level access to the interpreter facility. This mechanism +now provides almost all of the generic functions of Borenstein's and +Rose's Safe-Tcl (but not any Tk or email-related stuff). (JL) + +9/11/95 (feature change) Changed file management so that files are +no longer shared between interpreters: a file cannot normally be +referenced in one interpreter if it was opened in another. This +feature is needed to support safe interpreters. Added Tcl_ShareHandle() +procedure for allowing files to be shared, and added "interp" argument +to Tcl_FilePermissions procedure. +*** POTENTIAL INCOMPATIBILITY *** + +9/11/95 (new feature) Added "AssocData" mechanism, whereby extensions +can associate their own data with an interpreter and get called back +when the interpreter is deleted. This is visible at C level via the +procedures Tcl_SetAssocData and Tcl_GetAssocData. (JL) + +9/11/95 (new feature) Added Tcl_ErrnoMsg to translate an errno value +into a human-readable string. This is now used instead of calling +strerror because strerror mesages vary dramatically from platform +to platform, which messes up Tcl tests. Tcl_ErrnoMsg uses the standard +POSIX messages for all the common signals, and calls strerror for +signals it doesn't understand. + +----------------- Released patch 7.5p2, 9/15/95 ----------------------- + +----------------- Released 7.5a1, 9/15/95 ----------------------- + +9/22/95 (bug fix) Changed auto_mkindex to create tclIndex files that +handle directories whose paths might contain spaces. (RJ) + +9/27/95 (bug fix) The "format" command didn't check for huge or negative +width specifiers, which could cause core dumps. (JO) + +9/27/95 (bug fix) Core dumps could occur if an interactive command typed +to tclsh returned a very long result for tclsh to print out. The bug is +actually in printf (in Solaris 2.3 and 2.4, at least); switched to use +puts instead. (JO) + +9/28/95 (bug fix) Changed makefile.bc to eliminate a false dependency +for tcl1675.dll on the Borland run time library. (SS) + +9/28/95 (bug fix) Fixed tcl75.dll so it looks for tcl1675.dll instead +of tcl16.dll. (SS) + +9/28/95 (bug fix) Tcl was not correctly detecting the difference +between Win32s and Windows '95. (SS) + +9/28/95 (bug fix) "exec" was not passing environment changes to child +processes under Windows. (SS) + +9/28/95 (bug fix) Changed Tcl to ensure that open files are not passed +to child processes under Windows. (SS) + +9/28/95 (bug fix) Fixed Windows '95 and NT versions of exec so it can +handle both console and windows apps. (SS) + +9/28/95 (bug fix) Fixed Windows version of exec so it no longer leaves +temp files lying around. Also changed it so the temp files are +created in the appropriate system dependent temp directory. (SS) + +9/28/95 (bug fix) Eliminated source dependency on the Win32s Universal +Thunk header file, since it is not bundled with VC++. (SS) + +9/28/95 (bug fix) Under Windows, Tcl now constructs the HOME +environment variable from HOMEPATH and HOMEDRIVE when HOME is not +already set. (SS) + +9/28/95 (bug fix) Added support for "info nameofexecutable" and "info +sharedlibextension" to the Windows version. (SS) + +9/28/95 (bug fix) Changed tclsh to correctly parse command line +arguments so that backslashes are preserved under Windows. (SS) + +9/29/95 (bug fix) Tcl 7.5a1 treated either return or newline as end +of line in "gets", which caused lines ending in CRLF to be treated as +two separate lines. Changed to allow only character as end-of-line: +carriage return on Macs, newline elsewhere. (JO) + +9/29/95 (new feature) Changed to install "configInfo" file in same +directory as library scripts. It didn't used to get installed. (JO) + +9/29/95 (bug fix) Tcl was not converting Win32 errors into POSIX +errors under some circumstances. (SS) + +10/2/95 (bug fix) Safe interpreters no longer get initialized with +a call to Tcl_Init(). (JL) + +10/1/95 (new feature) Added "tcl_platform" global variable to provide +environment information such as the instruction set and operating +system. (JO) + +10/1/95 (bug fix) "exec" command wasn't always generating the +"child process exited abnormally" message when it should have. (JO) + +10/2/95 (bug fix) Changed "mkLinks.tcl" so that the scripts it generates +won't create links that overwrite original manual entries (there was +a problem where pack-old.n was overwriting pack.n). (JO) + +10/2/95 (feature change) Changed to use -ldl for dynamic loading under +Linux if it is available, but fall back to -ldld if it isn't. (JO) + +10/2/95 (bug fix) File sharing was causing refcounts to reach 0 +prematurely for stdin, stdout and stderr, under some circumstances. (JL) + +10/2/95 (platform support) Added support for Visual C++ compiler on +Windows, Windows '95 and Windows NT, code donated by Gordon Chaffee. (JL) + +10/3/95 (bug fix) Tcl now frees any libraries that it loads before it +exits. (SS) + +10/03/95 (bug fix) Fixed bug in Macintosh ls command where the -l +and -C options would fail in anything but the HOME directory. (RJ) + +----------------- Released 7.5a2, 10/6/95 ----------------------- + +10/10/95 (bug fix) "file dirnam /." was returning ":" on UNIX instead +of "/". (JO) + +10/13/95 (bug fix) Eliminated dependency on MKS toolkit for generating +the tcl.def file from Borland object files. (SS) + +10/17/95 (new features) Moved the event loop from Tcl to Tk, made major +revisions along the way: + - New Tcl commands: after, update, vwait (replaces "tkwait variable"). + - "tkerror" is now replaced with "bgerror". + - The following procedures are similar to their old Tk counterparts: + Tcl_DoOneEvent, Tcl_Sleep, Tcl_DoWhenIdle, Tcl_CancelIdleCall, + Tcl_CreateFileHandler, Tcl_DeleteFileHandler, Tcl_CreateTimerHandler, + Tcl_DeleteTimerHandler, Tcl_BackgroundError. + - Revised notifier, add new concept of "event source" with the following + procedures: Tcl_CreateEventSource, Tcl_DeleteEventSource, + Tcl_WatchFile, Tcl_SetMaxBlockTime, Tcl_FileReady, Tcl_QueueEvent, + Tcl_WaitForEvent. (JO) + +10/31/95 (new features) Implemented cross platform file name support to make +it easier to write cross platform scripts. Tcl now understands 4 file naming +conventions: Windows (both DOS and UNC), Mac, Unix, and Network. The network +convention is a new naming mechanism that can be used to paths in a platform +independent fashion. See the "file" command manual page for more details. +The primary interfaces changes are: + - All Tcl commands that expect a file name now accept both network and + native form. + - Two new "file" subcommands, "nativename" and "networkname", provide a + way to convert between network and native form. + - Renamed Tcl_TildeSubst to Tcl_TranslateFileName, and changed it so that + it always returns a filename in native form. Tcl_TildeSubst is defined + as a macro for backward compatibility, but it is deprecated. (SS) + +11/5/95 (new feature) Made "tkerror" and "bgerror" synonyms, so that +either name can be used to manipulate the command (provides temporary +backward compatibility for existing scripts that use tkerror). (JO) + +11/5/95 (new feature) Added exit handlers and new C procedures +Tcl_CreateExitHandler, Tcl_DeleteExitHandler, and Tcl_Exit. (JO) + +11/6/95 (new feature) Added pid command for Macintosh version of +Tcl (it didn't previously exist on the Mac). (RJ) + +11/7/95 (new feature) New generic IO facility and support for IO to +files, pipes and sockets based on a common buffering scheme. Support +for asynchronous (non-blocking) IO and for event driver IO. Support +for automatic (background) asynchronous flushing and asynchronous +closing of channels. (JL) + +11/7/95 (new feature) Added new commands "fconfigure" and "fblocked" +to support new I/O features such as nonblocking I/O. Added "socket" +command for creating TCP client and server sockets. (JL). + +11/7/95 (new feature) Complete set of C APIs to the new generic IO +facility: + - Opening channels: Tcl_OpenFileChannel, Tcl_OpenCommandChannel, + Tcl_OpenTcpClient, Tcl_OpenTcpServer. + - I/O procedures on channels, which roughly mirror the ANSI C stdio + library: Tcl_Read, Tcl_Gets, Tcl_Write, Tcl_Flush, Tcl_Seek, + Tcl_Tell, Tcl_Close, Tcl_Eof, Tcl_InputBlocked, Tcl_GetChannelOption, + Tcl_SetChannelOption. + - Extension mechanism for creating new kinds of channels: + Tcl_CreateChannel, Tcl_GetChannelInstanceData, Tcl_GetChannelType, + Tcl_GetChannelName, Tcl_GetChannelFile, Tcl_RegisterChannel, + Tcl_UnregisterChannel, Tcl_GetChannel. + - Event-driven I/O on channels: Tcl_CreateChannelHandler, + Tcl_DeleteChannelHandler. (JL) + +11/7/95 (new feature) Channel driver interface specification to allow +new types of channels to be added easily to Tcl. Currently being used +in three drivers - for files, pipes and TCP-based sockets. (JL). + +11/7/95 (new feature) interp delete now takes any number of path +names of interpreters to delete, including zero. (JL). + +11/8/95 (new feature) implemented 'info hostname' and Tcl_GetHostName +command to get host name of machine on which the Tcl process is running. (JL) + +11/9/95 (new feature) Implemented file APIs for access to low level files +on each system. The APIs are: Tcl_CloseFile, Tcl_OpenFile, Tcl_ReadFile, +Tcl_WriteFile and Tcl_SeekFile. Also implemented Tcl_WaitPid which waits +in a system dependent manner for a child process. (JL) + +11/9/95 (new feature) Added Tcl_UpdateLinkedVar procedure to force a +Tcl variable to be updated after its C variable changes. (JO) + +11/9/95 (bug fix) The glob command has been totally reimplemented so +that it can support different file name conventions. It now handles +Windows file names (both UNC and drive-relative) properly. It also +supports nested braces correctly now. (SS) + +11/13/95 (bug fix) Fixed Makefile.in so that configure can be run +from a clean directory separate from the Tcl source tree, and compilations +can be performed there. (JO) + +11/14/95 (bug fix) Fixed file sharing between interpreters and file +transferring between interpreters to correctly manage the refcount so that +files are closed when the last reference to them is discarded. (JL) + +11/14/95 (bug fix) Fixed gettimeofday implementation for the +Macintosh. This fixes several timing related bugs. (RJ) + +11/17/95 (new feature) Added missing support for info nameofexecutable +on the Macintosh. (RJ) + +11/17/95 (bug fix) The Tcl variables argc argv and argv0 now return +something reasonable on the Mac. (RJ) + +11/22/95 (new feature) Implemented "auto-detect" mode for end of line +translations. On input, standalone "\r" mean MAC mode, standalone "\n" +mean Unix mode and "\r\n" means Windows mode. On output, the mode is +modified to whatever the platform specific mode for that platform is. (JL) + +11/24/95 (feature change) Replaced "configInfo" file with tclConfig.sh, +which is more complete and uses slightly different names. Also +arranged for tclConfig.sh to be installed in the platform-specific +library directory instead of Tcl's script library directory. (JO) +*** POTENTIAL INCOMPATIBILITY with Tcl 7.5a2, but not with Tcl 7.4 *** + +----------------- Released patch 7.4p3, 11/28/95 ----------------------- + +12/5/95 (new feature) Added Tcl_File facility to support platform- +independent file handles. Changed all interfaces that used Unix- +style integer fd's to use Tcl_File's instead. (SS) +*** POTENTIAL INCOMPATIBILITY *** + +12/5/95 (new feature) Added a new "clock" command to Tcl. The command +allows you to get the current "clicks" or seconds & allows you to +format or scan human readable time/date strings. (RJ) + +12/18/95 (new feature) Moved Tk_Preserve, Tk_Release, and Tk_EventuallyFree +to Tcl, renamed to Tcl_Preserve, Tcl_Release, and Tcl_EventuallyFree. (JO) + +12/18/95 (new feature) Added new "package" command and associated +procedures Tcl_PkgRequire and Tcl_PkgProvide. Also wrote +pkg_mkIndex library procedure to create index files from binaries +and scripts. (JO) + +12/20/95 (new feature) Added Tcl_WaitForFile procedure. (JO) + +12/21/95 (new features) Made package name argument to "load" optional +(Tcl will now attempt to guess the package name if necessary). Also +added Tcl_StaticPackage and support in "load" for statically linked +packages. (JO) + +12/22/95 (new feature) Upgraded the foreach command to accept multiple +loop variables and multiple value lists. This lets you iterate over +multiple lists in parallel, and/or assign multiple loop variables from +one value list during each iteration. The only potential compatibility +problem is with scripts that used loop variables with a name that could be +construed to be a list of variable names (i.e. contained spaces). (BW) + +1/5/96 (new feature) Changed tclsh so it builds as a console mode +application under Windows. Now tclsh can be used from the command +line with pipes or interactively. Note that this only works under +Windows 95 or NT. (SS) + +1/17/96 (new feature) Modified Makefile and configure script to allow +Tcl to be compiled as a shared library: use the --enable-shared option +when configuing. (JO) + +1/17/96 (removed obsolete features) Removed the procedures Tcl_EnterFile +and Tcl_GetOpenFile: these no longer make sense with the new I/O system. (JL) +*** POTENTIAL INCOMPATIBILITY *** + +1/19/96 (bug fixes) Prevented formation of circular aliases, through the +Tcl 'interp alias' command and through the 'rename' command, as well as +through the C API Tcl_CreateAlias. (JL) + +1/19/96 (bug fixes) Fixed several bugs in direct deletion of interpreters +with Tcl_DeleteInterp when the interpreter is a slave; fixes based on a +patch received from Viktor Dukhovni of ESM. (JL) + +1/19/96 (new feature) Implemented on-close handlers for channels; added +the C APIs Tcl_CreateCloseHandler and Tcl_DeleteCloseHandler. (JL) + +1/19/96 (new feature) Implemented portable error reporting mechanism; added +the C APIs Tcl_SetErrno and Tcl_GetErrno. (JL) + +1/24/96 (bug fix) Unknown command processing properly invokes external +commands under Windows NT and Windows '95 now. (SS) + +1/23/96 (bug fix) Eliminated extremely long startup times under Windows '95. +The problem was a result of the option database initialization code that +concatenated $HOME with /.Xdefaults, resulting in a // in the middle of the +file name. Under Windows '95, this is incorrectly interpreted as a UNC +path. They delays came from the network timeouts needed to determine that +the file name was invalid. Tcl_TranslateFileName now suppresses duplicate +slashes that aren't at the beginning of the file name. (SS) + +1/25/96 (bug fix) Changed exec and open to create children so they are +attached to the application's console if it exists. (SS) + +1/31/96 (bug fix) Fixed command line parsing to handle embedded +spaces under Windows. (SS) + +----------------- Released 7.5b1, 2/1/96 ----------------------- + +2/7/96 (bug fix) Fixed off by one error in argument parsing code under +Windows. (SS) + +2/7/96 (bug fix) Fixed bugs in VC++ makefile that improperly +initialized the tcl75.dll. Fixed bugs in Borland makefile that caused +build failures under Windows NT. (SS) + +2/9/96 (bug fix) Fixed deadlock problem in AUTO end of line translation +mode which would cause a socket server with several concurrent clients +writing in CRLF mode to hang. (JL) + +2/9/96 (API change) Replaced -linemode option to fconfigure with a +new -buffering option, added "none" setting to enable immediate write. (JL) +*** INCOMPATIBILITY with b1 *** + +2/9/96 (new feature) Added C API Tcl_InputBuffered which returns the count +of bytes currently buffered in the input buffer of a channel, and o for +output only channels. (JL) + +2/9/96 (new feature) Implemented asynchronous connect for sockets. (JL) + +2/9/96 (new feature) Added C API Tcl_SetDefaultTranslation to set (per +channel) the default end of line translation mode. This is the mode that +will be installed if an output operation is done on the channel while it is +still in AUTO mode. (JL) + +2/9/96 (bug fix) Changed Tcl_OpenCommandChannel interface to properly +handle all of the combinations of stdio inheritance in background +pipelines. See the Tcl_OpenFileChannel(3) man page for more +info. This change fixes the bug where exec of a background pipeline +was not getting passed the stdio handles properly. (SS) + +2/9/96 (bug fix) Removed the new Tcl_CreatePipeline interface, and +restored the old version for Unix platforms only. All new code should +use Tcl_CreateCommandChannel instead. (SS) + +2/9/96 (bug fix) Changed Makefile.in to use -L and -ltcl7.5 for Tcl +library so that shared libraries are more likely to be found correctly +on more platforms. (JO) + +2/13/96 (new feature) Added C API Tcl_SetNotifierData and +Tcl_GetNotifierData to allow notifier and channel driver writers to +associate data with a Tcl_File. The result of this change is that +Tcl_GetFileInfo now always returns an OS file handle, and Tcl_GetFile +can be used to construct a Tcl_File for an externally constructed OS +handle. (SS) + +2/13/96 (bug fix) Changed Windows socket implementation so it doesn't +set SO_REUSEADDR on server sockets. Now attempts to create a server +socket on a port that is already in use will be properly identified +and an error will be generated. (SS) + +2/13/96 (bug fix) Fixed problems with DLL initialization under Visual +C++ that left the C run time library uninitialized. (SS) + +2/13/96 (bug fix) Fixed Windows socket initialization so it loads +winsock the first time it is used, rather than at the time tcl75.dll +is loaded. This should fix the bug where the modem immediately starts +trying to connect to a service provider when wish or tclsh are +started. (SS) + +2/13/96 (new feature) Added C APIs Tcl_MakeFileChannel and +Tcl_MakeTcpClientChannel to wrap up existing fds and sockets into +channels. Provided implementations on Unix and Windows. (JL) + +2/13/96 (bug fix) Fixed bug with seek leaving EOF and BLOCKING set. (JL) + +2/14/96 (bug fix) Fixed reentrancy problem in fileevent handling +and made it more robust in the face of errors. (JL) + +2/14/96 (feature change) Made generic IO level emulate blocking mode if the +channel driver is unable to provide it, e.g. if the low level device is +always nonblocking. Thus, now blocking behavior is an advisory setting for +channel drivers and can be ignored safely if the channel driver is unable +to provide it. (JL) + +2/15/96 (new feature) Added "binary" end of line translation mode, which is +a synonym of "lf" mode. (JL) + +2/15/96 (bug fix) Fixed reentrancy problem in fileevent handling vs +deletion of channel event handlers. (JL) + +2/15/96 (bug fix) Fixed bug in event handling which would cause a +nonblocking channel to not see further readable events after the first +readable event that had insufficient input. (JL) + +2/17/96 (bug fix) "info complete" didn't properly handle comments +in nested commands. (JO) + +2/21/96 (bug fix) "exec" under Windows NT/95 did not properly handle +very long command lines (>200 chars). (SS) + +2/21/96 (bug fix) Sockets could get into an infinite loop if a read +event arrived after all of the available data had been read. (SS) + +2/22/96 (bug fix) Added cast of st_size elements to (long) before +sprintf-ing in "file size" command. This is needed to handle systems +like NetBSD with 64-bit file offsets. (JO) + +----------------- Released 7.5b2, 2/23/96 ----------------------- + +2/23/96 (bug fix) TCL_VARARGS macro in tcl.h wasn't defined properly +when compiling with C++. (JO) + +2/24/96 (bug fix) Removed dependencies on Makefile in the UNIX Makefile: +this caused problems on some platforms (like Linux?). (JO) + +2/24/96 (bug fix) Fixed configuration bug that made Tcl not compile +correctly on Linux machines with neither -ldl or -ldld. (JO) + +2/24/96 (new feature) Added a block of comments and definitions to +Makefile.in to make it easier to have Tcl's TclSetEnv etc. replace +the library procedures setenv etc, so that calls to setenv etc. in +the application automatically update the Tcl "env" variable. (JO) + +2/27/96 (feature change) Added optional Tcl_Interp * argument (may be NULL) +to C API Tcl_Close and simplified closing of command channels. (JL) +*** INCOMPATIBILITY with Tcl 7.5b2, but not with Tcl 7.4 *** + +2/27/96 (feature change) Added optional Tcl_Interp * argument (may be NULL) +to C type definition Tcl_DriverCloseProc; modified all channel drivers to +implement close procedures that accept the additional argument. (JL) +*** INCOMPATIBILITY with Tcl 7.5b2, but not with Tcl 7.4 *** + +2/28/96 (bug fix) Fixed memory leak that could occur if an upvar +referred to an element of an array in the same stack frame as the +upvar. (JO) + +2/29/96 (feature change) Modified both Tcl_DoOneEvent and Tcl_WaitForEvent +so that they return immediately in cases where they would otherwise +block forever (e.g. if there are no event handlers of any sort). (JO) + +2/29/96 (new feature) Added C APIs Tcl_GetChannelBufferSize and +Tcl_SetChannelBufferSize to set and retrieve the size, in bytes, for +buffers allocated to store input or output in a channel. (JL) + +2/29/96 (new feature) Added option -buffersize to Tcl fconfigure command +to allow Tcl scripts to query and set the size of channel buffers. (JL) + +2/29/96 (feature removed) Removed channel driver function to specify +the buffer size to use when allocating a buffer. Removed the C typedef +for Tcl_DriverBufferSizeProc. Channels are now created with a default +buffer size of 4K. (JL) +*** INCOMPATIBILITY with Tcl 7.5b2, but not with Tcl 7.4 *** + +2/29/96 (feature change) The channel driver function for setting blocking +mode on the device may now be NULL. If the generic code detects that the +function is NULL, operations that set the blocking mode on the channel +simply succeed. (JL) + +3/2/96 (bug fix) Fixed core dump that could occur if a syntax error +(such as missing close paren) occurred in an array reference with a +very long array name. (JO) + +3/4/96 (bug fix) Removed code in the "auto_load" procedure that deletes +all existing auto-load information whenever the "auto_path" variable +is changed. Instead, new information adds to what was already there. +Otherwise, changing the "auto_path" variable causes all package- +related information to be lost. If you really want to get rid of +existing auto-load information, use auto_reset before setting auto_path. (JO) + +3/5/96 (new feature) Added version suffix to shared library names so that +Tcl will compile under NetBSD and FreeBSD (I hope). (JO) + +3/6/96 (bug fix) Cleaned up error messages in new I/O system to correspond +more closely to old I/O system. (JO) + +3/6/96 (new feature) Added -myaddr and -myport options to the socket +command, removed -tcp and -- options. This lets clients and servers +choose a particular interface. Also changed the default server address +from the hostname to INADDR_ANY. The server accept callback now gets +passed the client's port as well as IP address. The C interfaces for +Tcl_OpenTcpClient and Tcl_OpenTcpServer have changed to support the +above changes. (BW) +*** POTENTIAL INCOMPATIBILITY with Tcl 7.5b2, but not with Tcl 7.4 *** + +3/6/96 (changed feature) The library function auto_mkindex will now +default to using the pattern "*.tcl" if no pattern is given. (RJ) + +3/6/96 (bug fix) The socket channel code for the Macintosh has been +rewritten to use native MacTcp. (RJ) + +3/7/96 (new feature) Added Tcl_SetStdChannel and Tcl_GetStdChannel +interfaces to allow applications to explicitly set and get the global +standard channels. (SS) + +3/7/96 (bug fix) Tcl did close not the file descriptors associated +with "stdout", etc. when the corresponding channels were closed. (SS) + +3/7/96 (bug fix) Reworked shared library and dynamic loading stuff to +try to get it working under AIX. Added new @SHLIB_LD_LIBS@ autoconf +symbol as part of this. AIX probably doesn't work yet, but it should +be a lot closer. (JO) + +3/7/96 (feature change) Added Tcl_ChannelProc typedef and changed the +signature of Tcl_CreateChannelHandler and Tcl_DeleteChannelHandler to take +Tcl_ChannelProc arguments instead of Tcl_FileProc arguments. This change +should not affect any code outside Tcl because the signatures of +Tcl_ChannelProc and Tcl_FileProc are compatible. (JL) + +3/7/96 (API change) Modified signature of Tcl_GetChannelOption to return +an int instead of char *, and to take a Tcl_DString * argument. Modified +the implementation so that the option name can be NULL, to mean that the +call should retrieve a list of alternating option names and values. (JL) +*** INCOMPATIBILITY with Tcl 7.5b2, but not with Tcl 7.4 *** + +3/7/96 (API change) Added Tcl_DriverSetOptionProc, Tcl_DriverGetOptionProc +typedefs, added two slots setOptionProc and getOptionProc to the channel +type structure. These may be NULL to indicate that the channel type does +not support any options. (JL) +*** INCOMPATIBILITY with Tcl 7.5b2, but not with Tcl 7.4 *** + +3/7/96 (feature change) stdin, stdout and stderr can now be put into +nonblocking mode. (JL) + +3/8/96 (feature change) Eliminated dependence on the registry for +finding the Tcl library files. (SS) + +----------------- Released 7.5b3, 3/8/96 ----------------------- + +3/12/96 (feature improvement) Modified startup script to look in several +different places for the Tcl library directory. This should allow Tcl +to find the libraries under all but the weirdest conditions, even without +the TCL_LIBRARY environment variable being set. (JO) + +3/13/96 (bug fix) Eliminated use of the "linger" option from the Windows +socket implementation. (JL) + +3/13/96 (new feature) Added -peername and -sockname options for fconfigure +for socket channels. Code contributed by John Haxby of HP. (JL) + +3/13/96 (bug fix) Fixed panic and core dump that would occur if the accept +callback script on a server socket encountered an error. (JL) + +3/13/96 (feature change) Added -async option to the Tcl socket command. +If the command is creating a client socket and the flag is present, the +client is connected asynchronously. If the option is absent (the default), +the client socket is connected synchronously, and the command returns only +when the connection has been completed or failed. This change was suggested +by Mark Diekhans. (JL) + +3/13/96 (feature change) Modified the signature of Tcl_OpenTcpClient to +take an additional int argument, async. If nonzero, the client is connected +to the server asynchronously. If the value is zero, the connection is made +synchronously, and the call to Tcl_OpenTcpClient returns only when the +connection fails or succeeds. This change was suggested by Mark Diekhans. (JL) +*** INCOMPATIBILITY with Tcl 7.5b3, but not with Tcl 7.4 *** + +3/14/96 (bug fix) "tclsh bogus_file_name" didn't print an error message. (JO) + +3/14/96 (bug fix) Added new procedures to tclCkalloc.c so that libraries +and applications can be compiled with TCL_MEM_DEBUG even if Tcl isn't +(however, the converse is still not true). Patches provided by Jan +Nijtmans. (JO) + +3/15/96 (bug fix) Marked standard IO handles of a process as close-on-exec +to fix bug in Ultrix where exec was not sharing standard IO handles with +subprocesses. Fix suggested by Mark Diekhans. (JL) + +3/15/96 (bug fix) Fixed asynchronous close mechanism so that it closes the +channel instead of leaking system resources. The manifestation was that Tcl +would eventually run out of file descriptors if it was handling a large +number of nonblocking sockets or pipes with high congestion. (JL) + +3/15/96 (bug fix) Fixed tests so that they no longer leak file descriptors. +The manifestation was that Tcl would eventually run out of file descriptors +if the tests were rerun many times (> a hundred times on Solaris). (JL) + +3/15/96 (bug fix) Fixed channel creation code so that it never creates +unnamed channels. This would cause a panic and core dump when the channel +was closed. (JL) + +3/16/96 (bug fixes) Made lots of changes in configuration stuff to get +Tcl working under AIX (finally). Tcl should now support the "load" +command under AIX and should work either with or without shared +libraries for Tcl and Tk. (JO) + +3/21/96 (configuration improvement) Changed configure script so it +doesn't use version numbers (as in -ltcl7.5 and libtcl7.5.so) under +SunOS 4.1, where they don't work anyway. (JO) + +3/22/96 (new feature) Added C API Tcl_InterpDeleted that allows extension +writers to discover when an interpreter is being deleted. (JL) + +3/22/96 (bug fix) The standard IO channels are now added to each +trusted interpreter as soon as the interpreter is created. This ensures +against the bug where a child would do IO before the master had done any, +and then the child is destroyed - the standard IO channels would be then +closed and the master would be unable to do any IO. (JL) + +3/22/96 (bug fix) Made Tcl more robust against interpreter deletion, by +using Tcl_Preserve, Tcl_Release and Tcl_EventuallyFree to split the process +of interpreter deletion into two distinct phases. Also went through all of +Tcl and added calls to Tcl_Preserve and Tcl_Delete where needed. (JL) + +3/22/96 (bug fix) Fixed several places where C code was reading and writing +into freed memory, especially during interpreter deletion. (JL) + +3/22/96 (bug fix) Fixed very deep bug in Tcl_Release that caused memory to +be freed twice if the release callback did Tcl_Preserve and Tcl_Release on +the same memory as the chunk currently being freed. (JL) + +3/22/96 (bug fix) Removed several memory leaks that would cause memory +buildup on half-K chunks in the generic IO level. (JL) + +3/22/96 (bug fix) Fixed several core dumps which occurred when new +AssocData was being created during the cleanups in interpreter deletion. +The solution implemented now is to loop repeatedly over the AssocData until +none is left to clean up. (JL) + +3/22/96 (bug fix) Fixed a bug in event handling which caused an infinite +loop if there were no files being watched and no timer. Fix suggested by +Jan Nijtmans. (JL) + +3/22/96 (bug fix) Fixed Tcl_CreateCommand, Tcl_DeleteCommand to be more +robust if the interpreter is being deleted. Also fixed several order +dependency bugs in Tcl_DeleteCommand which kicked in when an interpreter +was being deleted. (JL) + +3/26/96 (bug fix) Upon a "short read", the generic code no longer calls +the driver for more input. Doing this caused blocking on some platforms +even on nonblocking channels. Bug and fix courtesy Mark Roseman. (JL) + +3/26/96 (new feature) Added 'package Tcltest' which is present only in +test versions of Tcl; this allows the testing commands to be loaded into +new interpreters besides the main one. (JL) + +3/26/96 (restored feature) Recreated the Tcl_GetOpenFile C API. You can +now get a FILE * from a registered channel; Unix only. (JL) + +3/27/96 (bug fix) The regular expression code did not support more +than 9 subexpressions. It now supports up to 20. (SS) + +4/1/96 (bug fixes) The CHANNEL_BLOCKED bit was being left on on a short +read, so that fileevents wouldn't fire correctly. Bug reported by Mark +Roseman.(JL, RJ) + +4/1/96 (bug fix) Moved Tcl_Release to match Tcl_Preserve exactly, in +tclInterp.c; previously interpreters were being freed only conditionally +and sometimes not at all. (JL) + +4/1/96 (bug fix) Fixed error reporting in slave interpreters when the +error message was being generated directly by C code. Fix suggested by +Viktor Dukhovni of ESM. (JL) + +4/2/96 (bug fixes) Fixed a series of bugs in Windows sockets that caused +events to variously get lost, to get sent multiple times, or to be ignored +by the driver. The manifestation was blocking if the channel is blocking, +and either getting EAGAIN or infinite loops if the channel is nonblocking. +This series of bugs was found by Ian Wallis of Cisco. Now all tests (also +those that were previously commented out) in socket.test pass. (JL, SS) + +4/2/96 (feature change/bug fix) Eliminated network name support in +favor of better native name support. Added "file split", "file join", +and "file pathtype" commands. See the "file" man page for more +details. (SS) +*** INCOMPATIBILITY with Tcl 7.5b3, but not with Tcl 7.4 *** + +4/2/96 (bug fix) Changed implementation of auto_mkindex so tclIndex +files will properly handle path names in a cross platform context. (SS) + +4/5/96 (bug fix) Fixed Tcl_ReadCmd to use the channel buffer size as the +chunk size it reads, instead of a fixed 4K size. Thus, on large reads, the +user can set the channel buffer size to a large size and the read will +occur orders of magnitude faster. For example, on a 2MB file, reading in 4K +chunks took 34 seconds, while reading in 1MB chunks took 1.5 seconds (on a +SS-20). Problem identified and fix suggested by John Haxby of HP. (JL) + +4/5/96 (bug fix) Fixed socket creation code to invoke gethostbyname only if +inet_addr failed (very unlikely). Before this change the order was reversed +and this made things much slower than they needed to be (gethostbyname +generally requires an RPC, which is slow). Problem identified and fix +suggested by John Loverso of OSF. (JL) + +4/9/96 (feature change) Modified "auto" translation mode so that it +recognizes any of "\n", "\r" and "\r\n" in input as end of line, so +that a file can have mixed end-of-line sequences. It now outputs +the platform specific end of line sequence on each platform for files and +pipes, and for sockets it produces crlf in output on all platforms. (JL) +*** INCOMPATIBILITY with Tcl 7.5b3, but not with Tcl 7.4 *** + +4/11/96 (new feature) Added -eofchar option to Tcl_SetChannelOption to allow +setting of an end of file character for input and output. If an input eof +char is set, it is recognized as EOF and further input from the channel is +not presented to the caller. If an output eof char is set, on output, that +byte is appended to the channel when it is closed. On Unix and Macintosh, +all channels start with no eof char set for input or output. On Windows, +files and pipes start with input and output eof chars set to Crlt-Z (ascii +26), and sockets start with no input or output eof char. (JL) +*** INCOMPATIBILITY with Tcl 7.5b3, but not with Tcl 7.4 *** + +4/17/96 (bug fix) Fixed series of bugs with handling of crlf sequence split +across buffer boundaries in input, in AUTO mode. (JL, BW) + +4/17/96 (test suite improvement) Fixed test suite so that tests that +depend on the availability of Unix commands such as echo, cat and others +are not run if these commands are not present. (JL) + +4/17/96 (test suite improvement) The socket test now automatically starts, +on platformst that support exec, a separate process for remote testsing. (JL) + +----------------- Released 7.5, 4/21/96 ----------------------- diff --git a/contrib/tcl/doc/AddErrInfo.3 b/contrib/tcl/doc/AddErrInfo.3 new file mode 100644 index 0000000..51e75c2 --- /dev/null +++ b/contrib/tcl/doc/AddErrInfo.3 @@ -0,0 +1,135 @@ +'\" +'\" Copyright (c) 1989-1993 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: @(#) AddErrInfo.3 1.21 96/03/25 19:55:32 +'\" +.so man.macros +.TH Tcl_AddErrorInfo 3 7.5 Tcl "Tcl Library Procedures" +.BS +.SH NAME +Tcl_AddErrorInfo, Tcl_SetErrorCode, Tcl_PosixError \- record information about errors +.SH SYNOPSIS +.nf +\fB#include <tcl.h>\fR +.sp +\fBTcl_AddErrorInfo\fR(\fIinterp, message\fR) +.sp +\fBTcl_SetErrorCode\fR(\fIinterp, element, element, ...\fB (char *) NULL\fR) +.sp +char * +\fBTcl_PosixError\fR(\fIinterp\fR) +.SH ARGUMENTS +.AS Tcl_Interp *message +.AP Tcl_Interp *interp in +Interpreter in which to record information. +.AP char *message in +Identifying string to record in \fBerrorInfo\fR variable. +.AP char *element in +String to record as one element of \fBerrorCode\fR variable. +Last \fIelement\fR argument must be NULL. +.BE + +.SH DESCRIPTION +.PP +These procedures are used to manipulate two Tcl global variables +that hold information about errors. +The variable \fBerrorInfo\fR holds a stack trace of the +operations that were in progress when an error occurred, and +is intended to be human-readable. +The variable \fBerrorCode\fR holds a list of items that +are intended to be machine-readable. +The first item in \fBerrorCode\fR identifies the class of +.VS +error that occurred (e.g. POSIX means an error occurred in +.VE +a POSIX system call) and additional elements in \fBerrorCode\fR +hold additional pieces of information that depend on the class. +See the Tcl overview manual entry for details on the various +formats for \fBerrorCode\fR. +.PP +The \fBerrorInfo\fR variable is gradually built up as an +error unwinds through the nested operations. +Each time an error code is returned to \fBTcl_Eval\fR +it calls the procedure \fBTcl_AddErrorInfo\fR to add +additional text to \fBerrorInfo\fR describing the +command that was being executed when the error occurred. +By the time the error has been passed all the way back +to the application, it will contain a complete trace +of the activity in progress when the error occurred. +.PP +It is sometimes useful to add additional information to +\fBerrorInfo\fR beyond what can be supplied automatically +by \fBTcl_Eval\fR. +\fBTcl_AddErrorInfo\fR may be used for this purpose: +its \fImessage\fR argument contains an additional +string to be appended to \fBerrorInfo\fR. +For example, the \fBsource\fR command calls \fBTcl_AddErrorInfo\fR +to record the name of the file being processed and the +line number on which the error occurred; for Tcl procedures, the +procedure name and line number within the procedure are recorded, +and so on. +The best time to call \fBTcl_AddErrorInfo\fR is just after +\fBTcl_Eval\fR has returned \fBTCL_ERROR\fR. +In calling \fBTcl_AddErrorInfo\fR, you may find it useful to +use the \fBerrorLine\fR field of the interpreter (see the +\fBTcl_Interp\fR manual entry for details). +.PP +The procedure \fBTcl_SetErrorCode\fR is used to set the +\fBerrorCode\fR variable. +Its \fIelement\fR arguments give one or more strings to record +in \fBerrorCode\fR: each \fIelement\fR will become one item +of a properly-formed Tcl list stored in \fBerrorCode\fR. +\fBTcl_SetErrorCode\fR is typically invoked just before returning +an error. +If an error is returned without calling \fBTcl_SetErrorCode\fR +then the Tcl interpreter automatically sets \fBerrorCode\fR +to \fBNONE\fR. +.PP +\fBTcl_PosixError\fR +.VS +sets the \fBerrorCode\fR variable after an error in a POSIX kernel call. +It reads the value of the \fBerrno\fR C variable and calls +\fBTcl_SetErrorCode\fR to set \fBerrorCode\fR in the \fBPOSIX\fR format. +The caller must previously have called \fBTcl_SetErrno\fR to set +\fBerrno\fR; this is necessary on some platforms (e.g. Windows) where Tcl +is linked into an application as a shared library, or when the error +occurs in a dynamically loaded extension. See the manual entry for +\fBTcl_SetErrno\fR for more information. +.PP +\fBTcl_PosixError\fR returns a human-readable +.VE +diagnostic message for the error (this is the same value that +will appear as the third element in \fBerrorCode\fR). +It may be convenient to include this string as part of the +error message returned to the application in \fIinterp->result\fR. +.PP +It is important to call the procedures described here rather than +setting \fBerrorInfo\fR or \fBerrorCode\fR directly with +\fBTcl_SetVar\fR. +The reason for this is that the Tcl interpreter keeps information +about whether these procedures have been called. +For example, the first time \fBTcl_AppendResult\fR is called +for an error, it clears the existing value of \fBerrorInfo\fR +and adds the error message in \fIinterp->result\fR to the variable +before appending \fImessage\fR; in subsequent calls, it just +appends the new \fImessage\fR. +When \fBTcl_SetErrorCode\fR is called, it sets a flag indicating +that \fBerrorCode\fR has been set; this allows the Tcl interpreter +to set \fBerrorCode\fR to \fBNONE\fB if it receives an error return +when \fBTcl_SetErrorCode\fR hasn't been called. +.PP +If the procedure \fBTcl_ResetResult\fR is called, it clears all +of the state associated with \fBerrorInfo\fR and \fBerrorCode\fR +(but it doesn't actually modify the variables). +If an error had occurred, this will clear the error state to +make it appear as if no error had occurred after all. + +.SH "SEE ALSO" +Tcl_Interp, Tcl_ResetResult, Tcl_SetErrno + +.SH KEYWORDS +error, stack, trace, variable diff --git a/contrib/tcl/doc/AllowExc.3 b/contrib/tcl/doc/AllowExc.3 new file mode 100644 index 0000000..b5b4b5c --- /dev/null +++ b/contrib/tcl/doc/AllowExc.3 @@ -0,0 +1,42 @@ +'\" +'\" Copyright (c) 1989-1993 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: @(#) AllowExc.3 1.5 96/03/25 19:55:47 +'\" +.so man.macros +.TH Tcl_AllowExceptions 3 7.4 Tcl "Tcl Library Procedures" +.BS +.SH NAME +Tcl_AllowExceptions \- allow all exceptions in next script evaluation +.SH SYNOPSIS +.nf +\fB#include <tcl.h>\fR +.sp +\fBTcl_AllowExceptions\fR(\fIinterp\fR) +.SH ARGUMENTS +.AS Tcl_Interp *doublePtr +.AP Tcl_Interp *interp in +Interpreter in which script will be evaluated. +.BE + +.SH DESCRIPTION +.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 +or TCL_RETURN, then Tcl normally converts this into a TCL_ERROR +return with an appropriate message. +.PP +However, if \fBTcl_AllowExceptions\fR is invoked immediately before +calling a procedure such as \fBTcl_Eval\fR, 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 +such as TCL_BREAK or TCL_CONTINUE in a meaningful way. + +.SH KEYWORDS +continue, break, exception, interpreter diff --git a/contrib/tcl/doc/AppInit.3 b/contrib/tcl/doc/AppInit.3 new file mode 100644 index 0000000..8742661 --- /dev/null +++ b/contrib/tcl/doc/AppInit.3 @@ -0,0 +1,75 @@ +'\" +'\" Copyright (c) 1993 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: @(#) AppInit.3 1.9 96/03/25 19:56:02 +'\" +.so man.macros +.TH Tcl_AppInit 3 7.0 Tcl "Tcl Library Procedures" +.BS +.SH NAME +Tcl_AppInit \- perform application-specific initialization +.SH SYNOPSIS +.nf +\fB#include <tcl.h>\fR +.sp +int +\fBTcl_AppInit\fR(\fIinterp\fR) +.SH ARGUMENTS +.AS Tcl_Interp *interp +.AP Tcl_Interp *interp in +Interpreter for the application. +.BE + +.SH DESCRIPTION +.PP +\fBTcl_AppInit\fR is a ``hook'' procedure that is invoked by +the main programs for Tcl applications such as \fBtclsh\fR and \fBwish\fR. +Its purpose is to allow new Tcl applications to be created without +modifying the main programs provided as part of Tcl and Tk. +To create a new application you write a new version of +\fBTcl_AppInit\fR to replace the default version provided by Tcl, +then link your new \fBTcl_AppInit\fR with the Tcl library. +.PP +\fBTcl_AppInit\fR is invoked after by \fBTcl_Main\fR and \fBTk_Main\fR +after their own initialization and before entering the main loop +to process commands. +Here are some examples of things that \fBTcl_AppInit\fR might do: +.IP [1] +Call initialization procedures for various packages used by +the application. +Each initialization procedure adds new commands to \fIinterp\fR +for its package and performs other package-specific initialization. +.IP [2] +Process command-line arguments, which can be accessed from the +Tcl variables \fBargv\fR and \fBargv0\fR in \fIinterp\fR. +.IP [3] +Invoke a startup script to initialize the application. +.LP +.VS +\fBTcl_AppInit\fR returns TCL_OK or TCL_ERROR. +If it returns TCL_ERROR then it must leave an error message in +\fIinterp->result\fR; otherwise the result is ignored. +.PP +In addition to \fBTcl_AppInit\fR, your application should also contain +a procedure \fBmain\fR that calls \fBTcl_Main\fR as follows: +.CS +Tcl_Main(argc, argv, Tcl_AppInit); +.CE +The third argument to \fBTcl_Main\fR gives the address of the +application-specific initialization procedure to invoke. +This means that you don't have to use the name \fBTcl_AppInit\fR +for the procedure, but in practice the name is nearly always +\fBTcl_AppInit\fR (in versions before Tcl 7.4 the name \fBTcl_AppInit\fR +was implicit; there was no way to specify the procedure explicitly). +The best way to get started is to make a copy of the file +\fBtclAppInit.c\fR from the Tcl library or source directory. +It already contains a \fBmain\fR procedure and a template for +\fBTcl_AppInit\fR that you can modify for your application. +.VE + +.SH KEYWORDS +application, argument, command, initialization, interpreter diff --git a/contrib/tcl/doc/AssocData.3 b/contrib/tcl/doc/AssocData.3 new file mode 100644 index 0000000..aef7a67 --- /dev/null +++ b/contrib/tcl/doc/AssocData.3 @@ -0,0 +1,89 @@ +'\" +'\" Copyright (c) 1995-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: @(#) AssocData.3 1.8 96/03/25 19:56:17 +.so man.macros +.TH Tcl_SetAssocData 3 7.5 Tcl "Tcl Library Procedures" +.BS +.SH NAME +Tcl_GetAssocData, Tcl_SetAssocData, Tcl_DeleteAssocData \- manage +associations of string keys and user specified data with Tcl +interpreters. +.SH SYNOPSIS +.nf +\fB#include <tcl.h>\fR +.sp +ClientData +\fBTcl_GetAssocData\fR(\fIinterp, key, delProcPtr\fR) +.sp +\fBTcl_SetAssocData\fR(\fIinterp, key, delProc, clientData\fR) +.sp +\fBTcl_DeleteAssocData\fR(\fIinterp, key\fR) +.SH ARGUMENTS +.AS Tcl_InterpDeleteProc *delProcPtr +.AP Tcl_Interp *interp in +Interpreter in which to execute the specified command. +.AP char *key in +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 +Procedure to call when \fIinterp\fR is deleted. +.AP Tcl_InterpDeleteProc **delProcPtr in +Pointer to location in which to store address of current deletion procedure +for association. Ignored if NULL. +.AP ClientData clientData in +Arbitrary one-word value associated with the given key in this +interpreter. This data is owned by the caller. +.BE + +.SH DESCRIPTION +.PP +These procedures allow extensions to associate their own data with +a Tcl interpreter. +An association consists of a string key, typically the name of +the extension, and a one-word value, which is typically a pointer +to a data structure holding data specific to the extension. +Tcl makes no interpretation of either the key or the value for +an association. +.PP +Storage management is facilitated by storing with each association a +procedure to call when the interpreter is deleted. This +procedure can dispose of the storage occupied by the client's data in any +way it sees fit. +.PP +\fBTcl_SetAssocData\fR creates an association between a string +key and a user specified datum in the given interpreter. +If there is already an association with the given \fIkey\fR, +\fBTcl_SetAssocData\fR overwrites it with the new information. +It is up to callers to organize their use of names to avoid conflicts, +for example, by using package names as the keys. +If the \fIdeleteProc\fR argument is non-NULL it specifies the address of a +procedure to invoke if the interpreter is deleted before the association +is deleted. \fIDeleteProc\fR should have arguments and result that match +the type \fBTcl_InterpDeleteProc\fR: +.CS +typedef void Tcl_InterpDeleteProc( + ClientData \fIclientData\fR, + Tcl_Interp *\fIinterp\fR); +.CE +When \fIdeleteProc\fR is invoked the \fIclientData\fR and \fIinterp\fR +arguments will be the same as the corresponding arguments passed to +\fBTcl_SetAssocData\fR. +The deletion procedure will \fInot\fR be invoked if the association +is deleted before the interpreter is deleted. +.PP +\fBTcl_GetAssocData\fR returns the datum stored in the association with the +specified key in the given interpreter, and if the \fIdelProcPtr\fR field +is non-\fBNULL\fR, the address indicated by it gets the address of the +delete procedure stored with this association. If no association with the +specified key exists in the given interpreter \fBTcl_GetAssocData\fR +returns \fBNULL\fR. +.PP +\fBTcl_DeleteAssocData\fR deletes an association with a specified key in +the given interpreter. It does not call the deletion procedure. +.SH KEYWORDS +association, data, deletion procedure, interpreter, key diff --git a/contrib/tcl/doc/Async.3 b/contrib/tcl/doc/Async.3 new file mode 100644 index 0000000..e40cbca --- /dev/null +++ b/contrib/tcl/doc/Async.3 @@ -0,0 +1,164 @@ +'\" +'\" Copyright (c) 1989-1993 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: @(#) Async.3 1.13 96/03/25 19:56:31 +'\" +.so man.macros +.TH Tcl_AsyncCreate 3 7.0 Tcl "Tcl Library Procedures" +.BS +.SH NAME +Tcl_AsyncCreate, Tcl_AsyncMark, Tcl_AsyncInvoke, Tcl_AsyncDelete \- handle asynchronous events +.SH SYNOPSIS +.nf +\fB#include <tcl.h>\fR +.sp +Tcl_AsyncHandler +\fBTcl_AsyncCreate\fR(\fIproc, clientData\fR) +.sp +\fBTcl_AsyncMark\fR(\fIasync\fR) +.sp +int +\fBTcl_AsyncInvoke\fR(\fIinterp, code\fR) +.sp +\fBTcl_AsyncDelete\fR(\fIasync\fR) +.VS +.sp +int +\fBTcl_AsyncReady\fR() +.VE +.SH ARGUMENTS +.AS Tcl_AsyncHandler clientData +.AP Tcl_AsyncProc *proc in +Procedure to invoke to handle an asynchronous event. +.AP ClientData clientData in +One-word value to pass to \fIproc\fR. +.AP Tcl_AsyncHandler async in +Token for asynchronous event handler. +.AP Tcl_Interp *interp in +Tcl interpreter in which command was being evaluated when handler was +invoked, or NULL if handler was invoked when there was no interpreter +active. +.AP int code in +Completion code from command that just completed in \fIinterp\fR, +or 0 if \fIinterp\fR is NULL. +.BE + +.SH DESCRIPTION +.PP +These procedures provide a safe mechanism for dealing with +asynchronous events such as signals. +If an event such as a signal occurs while a Tcl script is being +evaluated then it isn't safe to take any substantive action to +process the event. +For example, it isn't safe to evaluate a Tcl script since the +interpreter may already be in the middle of evaluating a script; +it may not even be safe to allocate memory, since a memory +allocation could have been in progress when the event occurred. +The only safe approach is to set a flag indicating that the event +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 creates an asynchronous handler and returns +a token for it. +The asynchronous handler must be created before +any occurrences of the asynchronous event that it is intended +to handle (it is not safe to create a handler at the time of +an event). +When an asynchronous event occurs the code that detects the event +(such as a signal handler) should call \fBTcl_AsyncMark\fR with the +token for the handler. +\fBTcl_AsyncMark\fR will mark the handler as ready to execute, but it +will not invoke the handler immediately. +Tcl will call the \fIproc\fR associated with the handler later, when +the world is in a safe state, and \fIproc\fR can then carry out +the actions associated with the asynchronous event. +\fIProc\fR should have arguments and result that match the +type \fBTcl_AsyncProc\fR: +.CS +typedef int Tcl_AsyncProc( + ClientData \fIclientData\fR, + Tcl_Interp *\fIinterp\fR, + int \fIcode\fR); +.CE +The \fIclientData\fR will be the same as the \fIclientData\fR +argument passed to \fBTcl_AsyncCreate\fR when the handler was +created. +If \fIproc\fR is invoked just after a command has completed +execution in an interpreter, then \fIinterp\fR will identify +the interpreter in which the command was evaluated and +\fIcode\fR will be the completion code returned by that +command. +The command's result will be present in \fIinterp->result\fR. +When \fIproc\fR returns, whatever it leaves in \fIinterp->result\fR +will be returned as the result of the command and the integer +value returned by \fIproc\fR will be used as the new completion +code for the command. +.PP +It is also possible for \fIproc\fR to be invoked when no interpreter +is active. +This can happen, for example, if an asynchronous event occurs while +the application is waiting for interactive input or an X event. +In this case \fIinterp\fR will be NULL and \fIcode\fR will be +0, and the return value from \fIproc\fR will be ignored. +.PP +The procedure \fBTcl_AsyncInvoke\fR is called to invoke all of the +handlers that are ready. +.VS +The procedure \fBTcl_AsyncReady\fR will return non-zero whenever any +.VE +asynchronous handlers are ready; it can be checked to avoid calls +to \fBTcl_AsyncInvoke\fR when there are no ready handlers. +.VS +Tcl calls \fBTcl_AsyncReady\fR after each command is evaluated +.VE +and calls \fBTcl_AsyncInvoke\fR if needed. +Applications may also call \fBTcl_AsyncInvoke\fR at interesting +times for that application. +.VS +For example, Tcl's event handler calls \fBTcl_AsyncReady\fR +after each event and calls \fBTcl_AsyncInvoke\fR if needed. +.VE +The \fIinterp\fR and \fIcode\fR arguments to \fBTcl_AsyncInvoke\fR +have the same meaning as for \fIproc\fR: they identify the active +interpreter, if any, and the completion code from the command +that just completed. +.PP +\fBTcl_AsyncDelete\fR removes an asynchronous handler so that +its \fIproc\fR will never be invoked again. +A handler can be deleted even when ready, and it will still +not be invoked. +.PP +If multiple handlers become active at the same time, the +handlers are invoked in the order they were created (oldest +handler first). +The \fIcode\fR and \fIinterp->result\fR for later handlers +reflect the values returned by earlier handlers, so that +the most recently created handler has last say about +the interpreter's result and completion code. +If new handlers become ready while handlers are executing, +\fBTcl_AsyncInvoke\fR will invoke them all; at each point it +invokes the highest-priority (oldest) ready handler, repeating +this over and over until there are no longer any ready handlers. + +.SH WARNING +.PP +It is almost always a bad idea for an asynchronous event +handler to modify \fIinterp->result\fR or return a code different +from its \fIcode\fR argument. +This sort of behavior can disrupt the execution of scripts in +subtle ways and result in bugs that are extremely difficult +to track down. +If an asynchronous event handler needs to evaluate Tcl scripts +then it should first save \fIinterp->result\fR plus the values +of the variables \fBerrorInfo\fR and \fBerrorCode\fR (this can +be done, for example, by storing them in dynamic strings). +When the asynchronous handler is finished it should restore +\fIinterp->result\fR, \fBerrorInfo\fR, and \fBerrorCode\fR, +and return the \fIcode\fR argument. + +.SH KEYWORDS +asynchronous event, handler, signal diff --git a/contrib/tcl/doc/BackgdErr.3 b/contrib/tcl/doc/BackgdErr.3 new file mode 100644 index 0000000..005f5b6 --- /dev/null +++ b/contrib/tcl/doc/BackgdErr.3 @@ -0,0 +1,58 @@ +'\" +'\" Copyright (c) 1992-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: @(#) BackgdErr.3 1.3 96/03/25 19:56:51 +'\" +.so man.macros +.TH Tcl_BackgroundError 3 7.5 Tcl "Tcl Library Procedures" +.BS +.SH NAME +Tcl_BackgroundError \- report Tcl error that occurred in background processing +.SH SYNOPSIS +.nf +\fB#include <tcl.h>\fR +.sp +\fBTcl_BackgroundError\fR(\fIinterp\fR) +.SH ARGUMENTS +.AS Tcl_Interp *interp +.AP Tcl_Interp *interp in +Interpreter in which the error occurred. +.BE + +.SH DESCRIPTION +.PP +This procedure is typically invoked when a Tcl error occurs during +``background processing'' such as executing an event handler. +When such an error occurs, the error condition is reported to Tcl +or to a widget or some other C code, and there is not usually any +obvious way for that code to report the error to the user. +In these cases the code calls \fBTcl_BackgroundError\fR with an +\fIinterp\fR argument identifying the interpreter in which the +error occurred. At the time \fBTcl_BackgroundError\fR is invoked, +\fIinterp->result\fR is expected to contain an error message. +\fBTcl_BackgroundError\fR will invoke the \fBbgerror\fR +Tcl command to report the error in an application-specific fashion. +If no \fBbgerror\fR command exists, or if it returns with an error condition, +then \fBTcl_BackgroundError\fR reports the error itself by printing +a message on the standard error file. +.PP +\fBTcl_BackgroundError\fR does not invoke \fBbgerror\fR immediately +because this could potentially interfere with scripts that are in process +at the time the error occurred. +Instead, it invokes \fBbgerror\fR later as an idle callback. +\fBTcl_BackgroundError\fR saves the values of the \fBerrorInfo\fR and +\fBerrorCode\fR variables and restores these values just before +invoking \fBbgerror\fR. +.PP +It is possible for many background errors to accumulate before +\fBbgerror\fR is invoked. When this happens, each of the errors +is processed in order. However, if \fBbgerror\fR returns a +break exception, then all remaining error reports for the +interpreter are skipped. + +.SH KEYWORDS +background, bgerror, error diff --git a/contrib/tcl/doc/Backslash.3 b/contrib/tcl/doc/Backslash.3 new file mode 100644 index 0000000..e7ac1f7 --- /dev/null +++ b/contrib/tcl/doc/Backslash.3 @@ -0,0 +1,45 @@ +'\" +'\" Copyright (c) 1989-1993 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: @(#) Backslash.3 1.16 96/03/25 19:57:09 +'\" +.so man.macros +.TH Tcl_Backslash 3 "" Tcl "Tcl Library Procedures" +.BS +.SH NAME +Tcl_Backslash \- parse a backslash sequence +.SH SYNOPSIS +.nf +\fB#include <tcl.h>\fR +.sp +char +\fBTcl_Backslash\fR(\fIsrc, countPtr\fR) +.SH ARGUMENTS +.AS char *countPtr +.AP char *src in +Pointer to a string starting with a backslash. +.AP int *countPtr out +If \fIcountPtr\fR isn't NULL, \fI*countPtr\fR gets filled +in with number of characters in the backslash sequence, including +the backslash character. +.BE + +.SH DESCRIPTION +.PP +This is a utility procedure used by several of the Tcl +commands. It parses a backslash sequence and returns +the single character corresponding to the sequence. +\fBTcl_Backslash\fR modifies \fI*countPtr\fR to contain the number +of characters in the backslash sequence. +.PP +See the Tcl manual entry for information on the valid +backslash sequences. +All of the sequences described in the Tcl +manual entry are supported by \fBTcl_Backslash\fR. + +.SH KEYWORDS +backslash, parse diff --git a/contrib/tcl/doc/CallDel.3 b/contrib/tcl/doc/CallDel.3 new file mode 100644 index 0000000..544afdf --- /dev/null +++ b/contrib/tcl/doc/CallDel.3 @@ -0,0 +1,63 @@ +'\" +'\" Copyright (c) 1993 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: @(#) CallDel.3 1.11 96/03/25 19:57:25 +'\" +.so man.macros +.TH Tcl_CallWhenDeleted 3 7.0 Tcl "Tcl Library Procedures" +.BS +.SH NAME +Tcl_CallWhenDeleted, Tcl_DontCallWhenDeleted \- Arrange for callback when interpreter is deleted +.SH SYNOPSIS +.nf +\fB#include <tcl.h>\fR +.sp +\fBTcl_CallWhenDeleted\fR(\fIinterp\fR, \fIproc\fR, \fIclientData\fR) +.sp +\fBTcl_DontCallWhenDeleted\fR(\fIinterp\fR, \fIproc\fR, \fIclientData\fR) +.SH ARGUMENTS +.AS Tcl_InterpDeleteProc clientData +.AP Tcl_Interp *interp in +Interpreter with which to associated callback. +.AP Tcl_InterpDeleteProc *proc in +Procedure to call when \fIinterp\fR is deleted. +.AP ClientData clientData in +Arbitrary one-word value to pass to \fIproc\fR. +.BE + +.SH DESCRIPTION +.PP +\fBTcl_CallWhenDeleted\fR arranges for \fIproc\fR to be called by +\fBTcl_DeleteInterp\fR if/when \fIinterp\fR is deleted at some future +time. \fIProc\fR will be invoked just before the interpreter +is deleted, but the interpreter will still be valid at the +time of the call. +\fIProc\fR should have arguments and result that match the +type \fBTcl_InterpDeleteProc\fR: +.CS +typedef void Tcl_InterpDeleteProc( + ClientData \fIclientData\fR, + Tcl_Interp *\fIinterp\fR); +.CE +The \fIclientData\fR and \fIinterp\fR parameters are +copies of the \fIclientData\fR and \fIinterp\fR arguments given +to \fBTcl_CallWhenDeleted\fR. +Typically, \fIclientData\fR points to an application-specific +data structure that \fIproc\fR uses to perform cleanup when an +interpreter is about to go away. +\fIProc\fR does not return a value. +.PP +\fBTcl_DontCallWhenDeleted\fR cancels a previous call to +\fBTcl_CallWhenDeleted\fR with the same arguments, so that +\fIproc\fR won't be called after all when \fIinterp\fR is +deleted. +If there is no deletion callback that matches \fIinterp\fR, +\fIproc\fR, and \fIclientData\fR then the call to +\fBTcl_DontCallWhenDeleted\fR has no effect. + +.SH KEYWORDS +callback, delete, interpreter diff --git a/contrib/tcl/doc/CmdCmplt.3 b/contrib/tcl/doc/CmdCmplt.3 new file mode 100644 index 0000000..b700343 --- /dev/null +++ b/contrib/tcl/doc/CmdCmplt.3 @@ -0,0 +1,36 @@ +'\" +'\" Copyright (c) 1989-1993 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: @(#) CmdCmplt.3 1.6 96/03/25 19:57:46 +'\" +.so man.macros +.TH Tcl_CommandComplete 3 "" Tcl "Tcl Library Procedures" +.BS +.SH NAME +Tcl_CommandComplete \- Check for unmatched braces in a Tcl command +.SH SYNOPSIS +.nf +\fB#include <tcl.h>\fR +.sp +int +\fBTcl_CommandComplete\fR(\fIcmd\fR) +.SH ARGUMENTS +.AS char *cmd +.AP char *cmd in +Command string to test for completeness. +.BE + +.SH DESCRIPTION +.PP +\fBTcl_CommandComplete\fR takes a Tcl command string +as argument and determines whether it contains one or more +complete commands (i.e. there are no unclosed quotes, braces, +brackets, or variable references). +If the command string is complete then it returns 1; otherwise it returns 0. + +.SH KEYWORDS +complete command, partial command diff --git a/contrib/tcl/doc/Concat.3 b/contrib/tcl/doc/Concat.3 new file mode 100644 index 0000000..f25d2bc --- /dev/null +++ b/contrib/tcl/doc/Concat.3 @@ -0,0 +1,51 @@ +'\" +'\" Copyright (c) 1989-1993 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: @(#) Concat.3 1.10 96/03/25 19:58:01 +'\" +.so man.macros +.TH Tcl_Concat 3 "" Tcl "Tcl Library Procedures" +.BS +.SH NAME +Tcl_Concat \- concatenate a collection of strings +.SH SYNOPSIS +.nf +\fB#include <tcl.h>\fR +.sp +char * +\fBTcl_Concat\fR(\fIargc, argv\fR) +.SH ARGUMENTS +.AP int argc in +Number of strings. +.AP char *argv[] in +Array of strings to concatenate. Must have \fIargc\fR entries. +.BE + +.SH DESCRIPTION +.PP +\fBTcl_Concat\fR is a utility procedure used by several of the +Tcl commands. Given a collection of strings, it concatenates +them together into a single string, with the original strings +separated by spaces. This procedure behaves differently than +\fBTcl_Merge\fR, in that the arguments are simply concatenated: +no effort is made to ensure proper list structure. +However, in most common usage the arguments will all be proper +lists themselves; if this is true, then the result will also have +proper list structure. +.PP +\fBTcl_Concat\fR eliminates leading and trailing white space as it +copies strings from \fBargv\fR to the result. If an element of +\fBargv\fR consists of nothing but white space, then that string +is ignored entirely. This white-space removal was added to make +the output of the \fBconcat\fR command cleaner-looking. +.PP +The result string is dynamically allocated +using \fBmalloc()\fR; the caller must eventually release the space +by calling \fBfree()\fR. + +.SH KEYWORDS +concatenate, strings diff --git a/contrib/tcl/doc/CrtChannel.3 b/contrib/tcl/doc/CrtChannel.3 new file mode 100644 index 0000000..e54f74e --- /dev/null +++ b/contrib/tcl/doc/CrtChannel.3 @@ -0,0 +1,427 @@ +'\" +'\" Copyright (c) 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: @(#) CrtChannel.3 1.23 96/03/28 17:55:41 +.so man.macros +.TH Tcl_CreateChannel 3 7.5 Tcl "Tcl Library Procedures" +.BS +'\" Note: do not modify the .SH NAME line immediately below! +.SH NAME +Tcl_CreateChannel, Tcl_GetChannelInstanceData, Tcl_GetChannelType, Tcl_GetChannelName, Tcl_GetChannelFile, Tcl_GetChannelBufferSize, Tcl_SetDefaultTranslation, Tcl_SetChannelBufferSize \- procedures for creating and manipulating channels +.SH SYNOPSIS +.nf +\fB#include <tcl.h>\fR +.sp +Tcl_Channel +\fBTcl_CreateChannel\fR(\fItypePtr, channelName, inFile, outFile, instanceData\fR) +.sp +ClientData +\fBTcl_GetChannelInstanceData\fR(\fIchannel\fR) +.sp +Tcl_ChannelType * +\fBTcl_GetChannelType\fR(\fIchannel\fR) +.sp +char * +\fBTcl_GetChannelName\fR(\fIchannel\fR) +.sp +Tcl_File +\fBTcl_GetChannelFile\fR(\fIchannel, direction\fR) +.sp +void +\fBTcl_SetDefaultTranslation\fR(\fIchannel, transMode\fR) +.sp +int +\fBTcl_GetChannelBufferSize\fR(\fIchannel\fR) +.sp +void +\fBTcl_SetChannelBufferSize\fR(\fIchannel, size\fR) +.sp +.SH ARGUMENTS +.AS Tcl_FileHandle pipelineSpec 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 +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 Tcl_File inFile in +Tcl file for the input device to associate with this channel. If NULL, +input will not be allowed on the channel. +.AP Tcl_File outFile in +Tcl file for the output device to associate with this channel. If NULL, +output will not be allowed on the channel. +.AP ClientData instanceData in +Arbitrary one-word value to be associated with this channel. This +value is passed to procedures in \fItypePtr\fR when they are invoked. +.AP Tcl_Channel channel in +The channel to operate on. +.AP int direction in +\fBTCL_READABLE\fR means the input file is wanted; \fBTCL_WRITABLE\fR +means the output file is wanted. +.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. +.BE + +.SH DESCRIPTION +.PP +Tcl uses a two-layered channel architecture. It provides a generic upper +layer to enable C and Tcl programs to perform input and output using the +same APIs for a variety of files, devices, sockets etc. The generic C APIs +are described in the manual entry for \fBTcl_OpenFileChannel\fR. +.PP +The lower layer provides type-specific channel drivers for each type of +file, socket and device supported on each platform. +This manual entry describes the C APIs +used by the generic layer to communicate with type-specific channel drivers +to perform the input and output operations. It also explains how new types +of channels can be added by providing new channel drivers. +.PP +Channel drivers consist of a number of components: First, each channel +driver provides a \fBTcl_ChannelType\fR structure containing pointers to +functions implementing the various operations used by the generic layer to +communicate with the channel driver. The \fBTcl_ChannelType\fR structure +and the functions referenced by it are described in the section +TCL_CHANNELTYPE, below. +.PP +Second, channel drivers usually provide a Tcl command to create instances +of that type of channel. For example, the Tcl \fBopen\fR command creates +channels that use the \fBfile\fR and \fBcommand\fR channel drivers, and +the Tcl \fBsocket\fR command creates channels that use TCP sockets for +network communication. +.PP +Third, a channel driver optionally provides a C function to open channel +instances of that type. For example, \fBTcl_OpenFileChannel\fR opens a +channel that uses the \fBfile\fR channel driver, and +\fBTcl_OpenTcpClient\fR opens a channel that uses the TCP network protocol. +These creation functions typically use +\fBTcl_CreateChannel\fR internally to open the channel. +.PP +To add a new type of channel you must implement a C API or a Tcl command +that opens a channel by invoking \fBTcl_CreateChannel\fR. +When your driver calls \fBTcl_CreateChannel\fR it passes in +a \fBTcl_ChannelType\fR structure describing the driver's I/O +procedures. +The generic layer will then invoke the functions referenced in that +structure to perform operations on the channel. +.PP +\fBTcl_CreateChannel\fR opens a new channel and associates the supplied +\fItypePtr\fR, \fIinFile\fR, \fIoutFile\fR and \fIinstanceData\fR with it. +For a discussion of channel drivers, their operations and the +\fBTcl_ChannelType\fR structure, see the section TCL_CHANNELTYPE, below. +.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. +.PP +\fBTcl_GetChannelType\fR returns a pointer to the \fBTcl_ChannelType\fR +structure used by the channel in the \fIchannel\fR argument. This is +the same as the \fItypePtr\fR argument in the call to +\fBTcl_CreateChannel\fR that created this channel. +.PP +\fBTcl_GetChannelName\fR returns a string containing the name associated +with the channel, or NULL if the \fIchannelName\fR argument to +\fBTcl_CreateChannel\fR was NULL. +.PP +\fBTcl_GetChannelFile\fR returns the \fIinFile\fR associated with +\fIchannel\fR if \fIdirection\fR is \fBTCL_READABLE\fR, or the +\fIoutFile\fR if \fIdirection\fR is \fBTCL_WRITABLE\fR. The operation +returns NULL if the respective value was specified as NULL in the call to +\fBTcl_CreateChannel\fR that created \fIchannel\fR. +.PP +\fBTcl_SetDefaultTranslation\fR sets the default end of line translation +mode. This mode will be installed as the translation mode for the channel +if an attempt is made to output on the channel while it is still in +\fBTCL_TRANSLATE_AUTO\fR mode. For a description of end of line translation +modes, see the manual entry for \fBfconfigure\fR. +.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 +by a previous call to \fBTcl_SetChannelBufferSize\fR, described below, then +the default value of 4096 is returned. +.PP +\fBTcl_SetChannelBufferSize\fR sets the size, in bytes, of buffers that +will be allocated in subsequent operations on the channel to store input or +output. The \fIsize\fR argument should be between ten and one million, +allowing buffers of ten bytes to one million bytes. If \fIsize\fR is +outside this range, \fBTcl_SetChannelBufferSize\fR sets the buffer size to +4096. + +.SH TCL_CHANNELTYPE +.PP +A channel driver provides a \fBTcl_ChannelType\fR structure that contains +pointers to functions that implement the various operations on a channel; +these operations are invoked as needed by the generic layer. The +\fBTcl_ChannelType\fR structure contains the following fields: +.PP +.CS +typedef struct Tcl_ChannelType { + char *\fItypeName\fR; + Tcl_DriverBlockModeProc *\fIblockModeProc\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_ChannelType; +.CE +.PP +The driver must provide implementations for all functions except +\fIblockModeProc\fR, \fIseekProc\fR, \fIsetOptionProc\fR, and +\fIgetOptionProc\fR, which may be specified as NULL to indicate that the +channel does not support seeking. Other functions that can not be +implemented for this type of device should return \fBEINVAL\fR when invoked +to indicate that they are not implemented. + +.SH TYPENAME +.PP +The \fItypeName\fR field contains a null-terminated string that +identifies the type of the device implemented by this driver, e.g. +\fBfile\fR or \fBsocket\fR. + +.SH BLOCKMODEPROC +.PP +The \fIblockModeProc\fR field contains the address of a function called by +the generic layer to set blocking and nonblocking mode on the device. +\fIBlockModeProc\fR should match the following prototype: +.PP +.CS +typedef int Tcl_DriverBlockModeProc( + ClientData \fIinstanceData\fR, + Tcl_File \fIinFile\fR, + Tcl_File \fIoutFile\fR, + int \fImode\fR); +.CE +.PP +The \fIinstanceData\fR, \fIinFile\fR and \fIoutFile\fR arguments are the same +as the values passed to \fBTcl_CreateChannel\fR when this channel was created. +The \fImode\fR argument is either \fBTCL_MODE_BLOCKING\fR or +\fBTCL_MODE_NONBLOCKING\fR to set the device into blocking or nonblocking +mode. The function should return zero if the operation was successful, +or a nonzero POSIX error code if the operation failed. +.PP +If the operation is successful, the function can modify the supplied +\fIinstanceData\fR to record that the channel +entered blocking or nonblocking mode, and modify \fIinFile\fR and +\fIoutFile\fR to implement the blocking or nonblocking behavior. +For some device types, the blocking and nonblocking behavior can be +implemented by the underlying operating system; for other device types, +the behavior must be emulated in the channel driver. + +.SH CLOSEPROC +.PP +The \fIcloseProc\fR field contains the address of a function called by the +generic layer to clean up driver-related information when the channel is +closed. \fICloseProc\fR must match the following prototype: +.PP +.CS +typedef int Tcl_DriverCloseProc( + ClientData \fIinstanceData\fR, + Tcl_Interp *\fIinterp\fR, + Tcl_File \fIinFile\fR, + Tcl_File \fIoutFile\fR); +.CE +.PP +The \fIinstanceData\fR, \fIinFile\fR, and \fIoutFile\fR arguments are the +same as the respective values provided to \fBTcl_CreateChannel\fR when the +channel was created. The function should release any storage maintained by +the channel driver for this channel, and close the input and output devices +identified by \fIinFile\fR and \fIoutFile\fR. All queued output will have +been flushed to the device before this function is called, and no further +driver operations will be invoked on this instance after calling the +\fIcloseProc\fR. If the close operation is successful, the procedure should +return zero; otherwise it should return a nonzero POSIX error code. In +addition, if an error occurs and \fIinterp\fR is not NULL, the procedure +should store an error message in \fIinterp->result\fR. + +.SH INPUTPROC +.PP +The \fIinputProc\fR field contains the address of a function called by the +generic layer to read data from the file or device and store it in an +internal buffer. \fIInputProc\fR must match the following prototype: +.PP +.CS +typedef int Tcl_DriverInputProc( + ClientData \fIinstanceData\fR, + Tcl_File \fIinFile\fR, + char *\fIbuf\fR, + int \fIbufSize\fR, + int *\fIerrorCodePtr\fR); +.CE +.PP +\fIInstanceData\fR and \fIInFile\fR are the same as the values passed to +\fBTcl_CreateChannel\fR when the channel was created. The \fIbuf\fR +argument points to an array of bytes in which to store input from +the device, and the \fIbufSize\fR argument indicates how many bytes are +available at \fIbuf\fR. +.PP +The \fIerrorCodePtr\fR argument points to an integer variable provided by +the generic layer. If an error occurs, the function should set the variable +to a POSIX error code that identifies the error that occurred. +.PP +The function should read data from the input device identified by +\fIinFile\fR and store it at \fIbuf\fR. On success, the function should +return a positive integer indicating how many bytes were read from the +input device and stored at \fIbuf\fR. On error, the function should return +-1. If an error occurs after some data has been read from the device, that +data is lost. +.PP +If \fIinputProc\fR can determine that the input device has some data +available but less than requested by the \fIbufSize\fR argument, the +function should only attempt to read as much data as is available and +return without blocking. If the input device has no data available +whatsoever and the channel is in nonblocking mode, the function should +return an \fBEAGAIN\fR error. If the input device has no data available +whatsoever and the channel is in blocking mode, the function should block +for the shortest possible time until at least one byte of data can be read +from the device; then, it should return as much data as it can read without +blocking. + +.SH OUTPUTPROC +.PP +The \fIoutputProc\fR field contains the address of a function called by the +generic layer to transfer data from an internal buffer to the output device. +\fIOutputProc\fR must match the following prototype: +.PP +.CS +typedef int Tcl_DriverOutputProc( + ClientData \fIinstanceData\fR, + Tcl_File \fIoutFile\fR, + char *\fIbuf\fR, + int \fItoWrite\fR, + int *\fIerrorCodePtr\fR); +.CE +.PP +\fIInstanceData\fR and \fIOutFile\fR are the same as the values passed to +\fBTcl_CreateChannel\fR when the channel was created. The \fIbuf\fR +argument contains an array of bytes to be written to the device, and the +\fItoWrite\fR argument indicates how many bytes are to be written from the +\fIbuf\fR argument. +.PP +The \fIerrorCodePtr\fR argument points to an integer variable provided by +the generic layer. If an error occurs, the function should set this +variable to a POSIX error code that identifies the error. +.PP +The function should write the data at \fIbuf\fR to the output device +identified by \fIoutFile\fR. On success, the function should return a +positive integer indicating how many bytes were written to the output +device. +The return value is normally the same as \fItoWrite\fR, but may be +less in some cases such as if the output operation is interrupted +by a signal. +If an error occurs the function should return -1. +In case of error, some data may have been written to the device. +.PP +If the channel is nonblocking and the output device is unable to absorb any +data whatsoever, the function should return -1 with an \fBEAGAIN\fR error +without writing any data. + +.SH SEEKPROC +.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 +operations will be applied. \fISeekProc\fR must match the following +prototype: +.PP +.CS +typedef int Tcl_DriverSeekProc( + ClientData \fIinstanceData\fR, + Tcl_File \fIinFile\fR, + Tcl_File \fIoutFile\fR, + long \fIoffset\fR, + int \fIseekMode\fR, + int *\fIerrorCodePtr\fR); +.CE +.PP +The \fIinstanceData\fR, \fIinFile\fR and \fIoutFile\fR arguments are the +same as the values given to \fBTcl_CreateChannel\fR when this channel was +created. \fIOffset\fR and \fIseekMode\fR have the same meaning as for the +\fBTcl_SeekChannel\fR procedure (described in the manual entry for +\fBTcl_OpenFileChannel\fR). +.PP +The \fIerrorCodePtr\fR argument points to +an integer variable provided by the generic layer for returning +\fBerrno\fR values from the function. +The function should set this variable to a POSIX error code +if an error occurs. The function should store an \fBEINVAL\fR error code if +the channel type does not implement seeking. +.PP +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. + +.SH SETOPTIONPROC +.PP +The \fIsetOptionProc\fR field contains the address of a function called by +the generic layer to set a channel type specific option on a channel. +\fIsetOptionProc\fR must match the following prototype: +.PP +.CS +typedef int Tcl_DriverSetOptionProc( + ClientData \fIinstanceData\fR, + Tcl_Interp *\fIinterp\fR, + char *\fIoptionName\fR, + char *\fIoptionValue\fR); +.CE +.PP +\fIoptionName\fR is the name of an option to set, and \fIoptionValue\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 +required to implement the new value of the option. +.PP +Some options are handled by the generic code and this function is never +called to set them, e.g. \fB-blockmode\fR. Other options are specific to +each channel type and the \fIsetOptionProc\fR procedure of the channel +driver will get called to implement them. The \fIsetOptionProc\fR field can +be NULL, which indicates that this channel type supports no type specific +options. +.PP +If the option value is successfully modified to the new value, the function +returns \fBTCL_OK\fR. It returns \fBTCL_ERROR\fR if the \fIoptionName\fR is +unrecognized or if \fIoptionValue\fR specifies a value for the option that +is not supported. In this case, the function leaves 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. + +.SH GETOPTIONPROC +.PP +The \fIgetOptionProc\fR field contains the address of a function called by +the generic layer to get the value of a channel type specific option on a +channel. \fIgetOptionProc\fR must match the following prototype: +.PP +.CS +typedef int Tcl_DriverGetOptionProc( + ClientData \fIinstanceData\fR, + char *\fIoptionName\fR, + Tcl_DString *\fIdsPtr\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 +alternating list of all supported options and their current values. +On success, the function returns \fBTCL_OK\fR. If an error occurs, the +function returns \fBTCL_ERROR\fR and calls \fBTcl_SetErrno\fR to store an +appropriate POSIX error code. +.PP +Some options are handled by the generic code and this function is never +called to retrieve their value, e.g. \fB-blockmode\fR. Other options are +specific to each channel type and the \fIgetOptionProc\fR procedure of the +channel driver will get called to implement them. The \fIgetOptionProc\fR +field can be NULL, which indicates that this channel type supports no type +specific options. + +.SH "SEE ALSO" +Tcl_Close(3), Tcl_OpenFileChannel(3), Tcl_SetErrno(3) + +.SH KEYWORDS +blocking, channel driver, channel registration, channel type, nonblocking diff --git a/contrib/tcl/doc/CrtChnlHdlr.3 b/contrib/tcl/doc/CrtChnlHdlr.3 new file mode 100644 index 0000000..388f01f --- /dev/null +++ b/contrib/tcl/doc/CrtChnlHdlr.3 @@ -0,0 +1,92 @@ +'\" +'\" Copyright (c) 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: @(#) CrtChnlHdlr.3 1.10 96/03/14 10:54:43 +.so man.macros +.TH Tcl_CreateChannelHandler 3 7.5 Tcl "Tcl Library Procedures" +.BS +'\" Note: do not modify the .SH NAME line immediately below! +.SH NAME +Tcl_CreateChannelHandler, Tcl_DeleteChannelHandler \- call a procedure when a channel becomes readable or writable +.SH SYNOPSIS +.nf +.nf +\fB#include <tcl.h>\fR +.sp +void +\fBTcl_CreateChannelHandler\fR(\fIchannel, mask, proc, clientData\fR) +.sp +void +\fBTcl_DeleteChannelHandler\fR(\fIchannel, proc, clientData\fR) +.sp +.SH ARGUMENTS +.AS Tcl_ChannelProc clientData +.AP Tcl_Channel channel in +Tcl channel such as returned by \fBTcl_CreateChannel\fR. +.AP int mask in +Conditions under which \fIproc\fR should be called: OR-ed combination of +\fBTCL_READABLE\fR, \fBTCL_WRITABLE\fR and \fBTCL_EXCEPTION\fR. Specify +a zero value to temporarily disable an existing handler. +.AP Tcl_FileProc *proc in +Procedure to invoke whenever the channel indicated by \fIchannel\fR meets +the conditions specified by \fImask\fR. +.AP ClientData clientData in +Arbitrary one-word value to pass to \fIproc\fR. +.BE + +.SH DESCRIPTION +.PP +\fBTcl_CreateChannelHandler\fR arranges for \fIproc\fR to be called in the +future whenever input or output becomes possible on the channel identified +by \fIchannel\fR, or whenever an exceptional condition exists for +\fIchannel\fR. The conditions of interest under which \fIproc\fR will be +invoked are specified by the \fImask\fR argument. +See the manual entry for \fBfileevent\fR for a precise description of +what it means for a channel to be readable or writable. +\fIProc\fR must conform to the following prototype: +.CS +typedef void Tcl_ChannelProc( + ClientData \fIclientData\fR, + int \fImask\fR); +.CE +.PP +The \fIclientData\fR argument is the same as the value passed to +\fBTcl_CreateChannelHandler\fR when the handler was created. Typically, +\fIclientData\fR points to a data structure containing application-specific +information about the channel. \fIMask\fR is an integer mask indicating +which of the requested conditions actually exists for the channel; it will +contain a subset of the bits from the \fImask\fR argument to +\fBTcl_CreateChannelHandler\fR when the handler was created. +.PP +Each channel handler is identified by a unique combination of \fIchannel\fR, +\fIproc\fR and \fIclientData\fR. +There may be many handlers for a given channel as long as they don't +have the same \fIchannel\fR, \fIproc\fR, and \fIclientData\fR. +If \fBTcl_CreateChannelHandler\fR is invoked when there is already a handler +for \fIchannel\fR, \fIproc\fR, and \fIclientData\fR, then no new +handler is created; instead, the \fImask\fR is changed for the +existing handler. +.PP +\fBTcl_DeleteChannelHandler\fR deletes a channel handler identified by +\fIchannel\fR, \fIproc\fR and \fIclientData\fR; if no such handler exists, +the call has no effect. +.PP +Channel handlers are invoked via the Tcl event mechanism, so they +are only useful in applications that are event-driven. +Note also that the conditions specified in the \fImask\fR argument +to \fIproc\fR may no longer exist when \fIproc\fR is invoked: for +example, if there are two handlers for \fBTCL_READABLE\fR on the same +channel, the first handler could consume all of the available input +so that the channel is no longer readable when the second handler +is invoked. +For this reason it may be useful to use nonblocking I/O on channels +for which there are event handlers. + +.SH "SEE ALSO" +Notifier(3), Tcl_CreateChannel(3), Tcl_OpenFileChannel(3), vwait(n). + +.SH KEYWORDS +blocking, callback, channel, events, handler, nonblocking. diff --git a/contrib/tcl/doc/CrtCloseHdlr.3 b/contrib/tcl/doc/CrtCloseHdlr.3 new file mode 100644 index 0000000..3ceff18 --- /dev/null +++ b/contrib/tcl/doc/CrtCloseHdlr.3 @@ -0,0 +1,59 @@ +'\" +'\" 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: @(#) CrtCloseHdlr.3 1.7 96/04/15 13:08:19 +.so man.macros +.TH Tcl_CreateCloseHandler 3 7.5 Tcl "Tcl Library Procedures" +.BS +'\" Note: do not modify the .SH NAME line immediately below! +.SH NAME +Tcl_CreateCloseHandler, Tcl_DeleteCloseHandler \- arrange for callbacks when channels are closed +.SH SYNOPSIS +.nf +\fB#include <tcl.h>\fR +.sp +void +\fBTcl_CreateCloseHandler\fR(\fIchannel, proc, clientData\fR) +.sp +void +\fBTcl_DeleteCloseHandler\fR(\fIchannel, proc, clientData\fR) +.sp +.SH ARGUMENTS +.AS Tcl_CloseProc callbackData in +.AP Tcl_Channel channel in +The channel for which to create or delete a close callback. +.AP Tcl_CloseProc *proc in +The procedure to call as the callback. +.AP ClientData clientData in +Arbitrary one-word value to pass to \fIproc\fR. +.BE + +.SH DESCRIPTION +.PP +\fBTcl_CreateCloseHandler\fR arranges for \fIproc\fR to be called when +\fIchannel\fR is closed with \fBTcl_Close\fR or +\fBTcl_UnregisterChannel\fR, or using the Tcl \fBclose\fR command. +\fIProc\fR should match the following prototype: +.PP +.CS +typedef void Tcl_CloseProc( + ClientData \fIclientData\fR); +.CE +.PP +The \fIclientData\fR is the same as the value provided in the call to +\fBTcl_CreateCloseHandler\fR. +.PP +\fBTcl_DeleteCloseHandler\fR removes a close callback for \fIchannel\fR. +The \fIproc\fR and \fIclientData\fR identify which close callback to +remove; \fBTcl_DeleteCloseHandler\fR does nothing if its \fIproc\fR and +\fIclientData\fR arguments do not match the \fIproc\fR and \fIclientData\fR +for a close handler for \fIchannel\fR. + +.SH "SEE ALSO" +close(n), Tcl_Close(3), Tcl_UnregisterChannel(3) + +.SH KEYWORDS +callback, channel closing diff --git a/contrib/tcl/doc/CrtCommand.3 b/contrib/tcl/doc/CrtCommand.3 new file mode 100644 index 0000000..8c27e2f --- /dev/null +++ b/contrib/tcl/doc/CrtCommand.3 @@ -0,0 +1,181 @@ +'\" +'\" Copyright (c) 1989-1993 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: @(#) CrtCommand.3 1.22 96/03/25 19:58:44 +'\" +.so man.macros +.TH Tcl_CreateCommand 3 "" Tcl "Tcl Library Procedures" +.BS +.SH NAME +Tcl_CreateCommand, Tcl_DeleteCommand, Tcl_GetCommandInfo, Tcl_SetCommandInfo \- implement new commands in C +.SH SYNOPSIS +.nf +\fB#include <tcl.h>\fR +.sp +.VS +.VE +Tcl_Command +\fBTcl_CreateCommand\fR(\fIinterp, cmdName, proc, clientData, deleteProc\fR) +.sp +int +\fBTcl_DeleteCommand\fR(\fIinterp, cmdName\fR) +.sp +.VS +int +\fBTcl_GetCommandInfo\fR(\fIinterp, cmdName, infoPtr\fR) +.sp +int +\fBTcl_SetCommandInfo\fR(\fIinterp, cmdName, infoPtr\fR) +.sp +.VS +char * +\fBTcl_GetCommandName\fR(\fIinterp, token\fR) +.VE +.VE +.SH ARGUMENTS +.AS Tcl_CmdDeleteProc **deleteProcPtr +.AP Tcl_Interp *interp in +Interpreter in which to create new command. +.AP char *cmdName in +Name of command. +.AP Tcl_CmdProc *proc in +Implementation of new command: \fIproc\fR will be called whenever +\fIcmdName\fR is invoked as a command. +.AP ClientData clientData in +Arbitrary one-word value to pass to \fIproc\fR and \fIdeleteProc\fR. +.AP Tcl_CmdDeleteProc *deleteProc in +Procedure to call before \fIcmdName\fR is deleted from the interpreter; +allows for command-specific cleanup. If NULL, then no procedure is +called before the command is deleted. +.AP Tcl_CmdInfo *infoPtr in/out +.VS +Pointer to structure containing various information about a +Tcl command. +.AP Tcl_Command token in +Token for command, returned by previous call to \fBTcl_CreateCommand\fR. +The command must not have been deleted. +.VE +.BE + +.SH DESCRIPTION +.PP +\fBTcl_CreateCommand\fR defines a new command in \fIinterp\fR and associates +it with procedure \fIproc\fR such that whenever \fIcmdName\fR is +invoked as a Tcl command (via a call to \fBTcl_Eval\fR) the Tcl interpreter +will call \fIproc\fR +to process the command. If there is already a command \fIcmdName\fR +associated with the interpreter, it is deleted. +.VS +\fBTcl_CreateCommand\fR returns a token that may be used to refer +to the command in subsequent calls to \fBTcl_GetCommandName\fR. +If \fBTcl_CreateCommand\fR is called for an interpreter that is in +the process of being deleted, then it does not create a new command +and it returns NULL. +.VE +\fIProc\fR should have arguments and result that match the type +\fBTcl_CmdProc\fR: +.CS +typedef int Tcl_CmdProc( + ClientData \fIclientData\fR, + Tcl_Interp *\fIinterp\fR, + int \fIargc\fR, + 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 +arguments given to \fBTcl_CreateCommand\fR. +Typically, \fIclientData\fR points to an application-specific +data structure that describes what to do when the command procedure +is invoked. \fIArgc\fR and \fIargv\fR describe the arguments to +the command, \fIargc\fR giving the number of arguments (including +the command name) and \fIargv\fR giving the values of the arguments +as strings. The \fIargv\fR array will contain \fIargc\fR+1 values; +the first \fIargc\fR values point to the argument strings, and the +last value is NULL. +.PP +\fIProc\fR must return an integer code that is either \fBTCL_OK\fR, \fBTCL_ERROR\fR, +\fBTCL_RETURN\fR, \fBTCL_BREAK\fR, or \fBTCL_CONTINUE\fR. See the Tcl overview man page +for details on what these codes mean. Most normal commands will only +return \fBTCL_OK\fR or \fBTCL_ERROR\fR. In addition, \fIproc\fR must set +\fIinterp->result\fR to point to a string value; +in the case of a \fBTCL_OK\fR return code this gives the result +of the command, and in the case of \fBTCL_ERROR\fR it gives an error message. +The \fBTcl_SetResult\fR procedure provides an easy interface for setting +the return value; for complete details on how the \fIinterp->result\fR +field is managed, see the \fBTcl_Interp\fR man page. +Before invoking a command procedure, +\fBTcl_Eval\fR sets \fIinterp->result\fR to point to an empty string, so simple +commands can return an empty result by doing nothing at all. +.PP +.VS +The contents of the \fIargv\fR array belong to Tcl and are not +guaranteed to persist once \fIproc\fR returns: \fIproc\fR should +not modify them, nor should it set \fIinterp->result\fR to point +anywhere within the \fIargv\fR values. +Call \fBTcl_SetResult\fR with status \fBTCL_VOLATILE\fR if you want +to return something from the \fIargv\fR array. +.VE +.PP +\fIDeleteProc\fR will be invoked when (if) \fIcmdName\fR is deleted. +This can occur through a call to \fBTcl_DeleteCommand\fR or \fBTcl_DeleteInterp\fR, +or by replacing \fIcmdName\fR in another call to \fBTcl_CreateCommand\fR. +\fIDeleteProc\fR is invoked before the command is deleted, and gives the +application an opportunity to release any structures associated +with the command. \fIDeleteProc\fR should have arguments and +result that match the type \fBTcl_CmdDeleteProc\fR: +.CS +typedef void Tcl_CmdDeleteProc(ClientData \fIclientData\fR); +.CE +The \fIclientData\fR argument will be the same as the \fIclientData\fR +argument passed to \fBTcl_CreateCommand\fR. +.PP +\fBTcl_DeleteCommand\fR deletes a command from a command interpreter. +Once the call completes, attempts to invoke \fIcmdName\fR in +\fIinterp\fR will result in errors. +If \fIcmdName\fR isn't bound as a command in \fIinterp\fR then +\fBTcl_DeleteCommand\fR does nothing and returns -1; otherwise +it returns 0. +There are no restrictions on \fIcmdName\fR: it may refer to +a built-in command, an application-specific command, or a Tcl procedure. +.PP +.VS +\fBTcl_GetCommandInfo\fR checks to see whether its \fIcmdName\fR argument +exists as a command in \fIinterp\fR. If not then it returns 0. +Otherwise it places information about the command in the structure +pointed to by \fIinfoPtr\fR and returns 1. +Tcl_CmdInfo structures have fields named \fIproc\fR, \fIclientData\fR, +and \fIdeleteProc\fR, which have the same meaning as the corresponding +arguments to \fBTcl_CreateCommand\fR. +There is also a field \fIdeleteData\fR, which is the ClientData value +to pass to \fIdeleteProc\fR; it is normally the same as +\fIclientData\fR but may be set independently using the +\fBTcl_SetCommandInfo\fR procedure. +.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. +.PP +\fBTcl_GetCommandName\fR provides a mechanism for tracking commands +that have been renamed. Given a token returned by \fBTcl_CreateCommand\fR +when the command was created, \fBTcl_GetCommandName\fR returns the +string name of the command. If the command has been renamed since it +was created, then \fBTcl_GetCommandName\fR returns the current name. +The command corresponding to \fItoken\fR must not have been deleted. +The string returned by \fBTcl_GetCommandName\fR is in dynamic memory +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. +.VE + +.SH KEYWORDS +bind, command, create, delete, interpreter diff --git a/contrib/tcl/doc/CrtFileHdlr.3 b/contrib/tcl/doc/CrtFileHdlr.3 new file mode 100644 index 0000000..31a5466 --- /dev/null +++ b/contrib/tcl/doc/CrtFileHdlr.3 @@ -0,0 +1,90 @@ +'\" +'\" 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. +'\" +'\" SCCS: @(#) CrtFileHdlr.3 1.6 96/03/25 19:59:08 +'\" +.so man.macros +.TH Tcl_CreateFileHandler 3 7.5 Tcl "Tcl Library Procedures" +.BS +.SH NAME +Tcl_CreateFileHandler, Tcl_DeleteFileHandler \- associate procedure callbacks with files or devices +.SH SYNOPSIS +.nf +\fB#include <tcl.h>\fR +.sp +\fBTcl_CreateFileHandler\fR(\fIfile, mask, proc, clientData\fR) +.sp +\fBTcl_DeleteFileHandler\fR(\fIfile\fR) +.SH ARGUMENTS +.AS Tcl_FileProc clientData +.AP Tcl_File file in +Generic file handle for an open file or device (such as returned by +\fBTcl_GetFile\fR call). +.AP int mask in +Conditions under which \fIproc\fR should be called: +OR-ed combination of \fBTCL_READABLE\fR, \fBTCL_WRITABLE\fR, +and \fBTCL_EXCEPTION\fR. May be set to 0 to temporarily disable +a handler. +.AP Tcl_FileProc *proc in +Procedure to invoke whenever the file or device indicated +by \fIfile\fR meets the conditions specified by \fImask\fR. +.AP ClientData clientData in +Arbitrary one-word value to pass to \fIproc\fR. +.BE + +.SH DESCRIPTION +.PP +\fBTcl_CreateFileHandler\fR arranges for \fIproc\fR to be +invoked in the future whenever I/O becomes possible on a file +or an exceptional condition exists for the file. The file +is indicated by \fIfile\fR, and the conditions of interest +are indicated by \fImask\fR. For example, if \fImask\fR +is \fBTCL_READABLE\fR, \fIproc\fR will be called when +the file is readable. +The callback to \fIproc\fR is made by \fBTcl_DoOneEvent\fR, so +\fBTcl_CreateFileHandler\fR is only useful in programs that dispatch +events through \fBTcl_DoOneEvent\fR or through Tcl commands such +as \fBvwait\fR. +.PP +\fIProc\fR should have arguments and result that match the +type \fBTcl_FileProc\fR: +.CS +typedef void Tcl_FileProc( + ClientData \fIclientData\fR, + int \fImask\fR); +.CE +The \fIclientData\fR parameter to \fIproc\fR is a copy +of the \fIclientData\fR +argument given to \fBTcl_CreateFileHandler\fR when the callback +was created. Typically, \fIclientData\fR points to a data +structure containing application-specific information about +the file. \fIMask\fR is an integer mask indicating which +of the requested conditions actually exists for the file; it +will contain a subset of the bits in the \fImask\fR argument +to \fBTcl_CreateFileHandler\fR. +.PP +.PP +There may exist only one handler for a given file at a given time. +If \fBTcl_CreateFileHandler\fR is called when a handler already +exists for \fIfile\fR, then the new callback replaces the information +that was previously recorded. +.PP +\fBTcl_DeleteFileHandler\fR may be called to delete the +file handler for \fIfile\fR; if no handler exists for the +file given by \fIfile\fR then the procedure has no effect. +.PP +The purpose of file handlers is to enable an application to respond to +events while waiting for files to become ready for I/O. For this to work +correctly, the application may need to use non-blocking I/O operations on +the files for which handlers are declared. Otherwise the application may +block if it reads or writes too much data; while waiting for the I/O to +complete the application won't be able to service other events. Use +\fBTcl_SetChannelOption\fR with \fB\-blocking\fR to set the channel into +blocking or nonblocking mode as required. + +.SH KEYWORDS +callback, file, handler diff --git a/contrib/tcl/doc/CrtInterp.3 b/contrib/tcl/doc/CrtInterp.3 new file mode 100644 index 0000000..b50d34e --- /dev/null +++ b/contrib/tcl/doc/CrtInterp.3 @@ -0,0 +1,131 @@ +'\" +'\" Copyright (c) 1989-1993 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: @(#) CrtInterp.3 1.14 96/03/26 15:14:45 +'\" +.so man.macros +.TH Tcl_CreateInterp 3 7.5 Tcl "Tcl Library Procedures" +.BS +.SH NAME +Tcl_CreateInterp, Tcl_DeleteInterp, Tcl_InterpDeleted \- create and delete Tcl command interpreters +.SH SYNOPSIS +.nf +\fB#include <tcl.h>\fR +.sp +Tcl_Interp * +\fBTcl_CreateInterp\fR() +.sp +\fBTcl_DeleteInterp\fR(\fIinterp\fR) +.sp +int +\fBTcl_InterpDeleted\fR(\fIinterp\fR) +.SH ARGUMENTS +.AS Tcl_Interp *interp +.AP Tcl_Interp *interp in +Token for interpreter to be destroyed. +.BE + +.SH DESCRIPTION +.PP +\fBTcl_CreateInterp\fR creates a new interpreter structure and returns +a token for it. The token is required in calls to most other Tcl +procedures, such as \fBTcl_CreateCommand\fR, \fBTcl_Eval\fR, and +\fBTcl_DeleteInterp\fR. +Clients are only allowed to access a few of the fields of +Tcl_Interp structures; see the Tcl_Interp +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. +.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 +been matched by calls to \fBTcl_Release\fR. At that time, all of the +resources associated with it, including variables, procedures, and +application-specific command bindings, will be deleted. After +\fBTcl_DeleteInterp\fR returns any attempt to use \fBTcl_Eval\fR on the +interpreter will fail and return \fBTCL_ERROR\fR. After the call to +\fBTcl_DeleteInterp\fR it is safe to examine \fIinterp->result\fR, query or +set the values of variables, define, undefine or retrieve procedures, and +examine the runtime evaluation stack. See below, in the section +\fBINTERPRETERS AND MEMORY MANAGEMENT\fR for details. +.PP +\fBTcl_InterpDeleted\fR returns nonzero if \fBTcl_DeleteInterp\fR was +called with \fIinterp\fR as its argument; this indicates that the +interpreter will eventually be deleted, when the last call to +\fBTcl_Preserve\fR for it is matched by a call to \fBTcl_Release\fR. If +nonzero is returned, further calls to \fBTcl_Eval\fR in this interpreter +will return \fBTCL_ERROR\fR. +.PP +\fBTcl_InterpDeleted\fR is useful in deletion callbacks to distinguish +between when only the memory the callback is responsible for is being +deleted and when the whole interpreter is being deleted. In the former case +the callback may recreate the data being deleted, but this would lead to an +infinite loop if the interpreter were being deleted. + +.SH "INTERPRETERS AND MEMORY MANAGEMENT" +.PP +\fBTcl_DeleteInterp\fR can be called at any time on an interpreter that may +be used by nested evaluations and C code in various extensions. Tcl +implements a simple mechanism that allows callers to use interpreters +without worrying about the interpreter being deleted in a nested call, and +without requiring special code to protect the interpreter, in most cases. +This mechanism ensures that nested uses of an interpreter can safely +continue using it even after \fBTcl_DeleteInterp\fR is called. +.PP +The mechanism relies on matching up calls to \fBTcl_Preserve\fR with calls +to \fBTcl_Release\fR. If \fBTcl_DeleteInterp\fR has been called, only when +the last call to \fBTcl_Preserve\fR is matched by a call to +\fBTcl_Release\fR, will the interpreter be freed. See the manual entry for +\fBTcl_Preserve\fR for a description of these functions. +.PP +The rules for when the user of an interpreter must call \fBTcl_Preserve\fR +and \fBTcl_Release\fR are simple: +.TP +Interpreters Passed As Arguments +Functions that are passed an interpreter as an argument can safely use the +interpreter without any special protection. Thus, when you write an +extension consisting of new Tcl commands, no special code is needed to +protect interpreters received as arguments. This covers the majority of all +uses. +.TP +Interpreter Creation And Deletion +When a new interpreter is created and used in a call to \fBTcl_Eval\fR, +\fBTcl_VarEval\fR, \fBTcl_GlobalEval\fR, \fBTcl_SetVar\fR, or +\fBTcl_GetVar\fR, a pair of calls to \fBTcl_Preserve\fR and +\fBTcl_Release\fR should be wrapped around all uses of the interpreter. +Remember that it is unsafe to use the interpreter once \fBTcl_Release\fR +has been called. To ensure that the interpreter is properly deleted when +it is no longer needed, call \fBTcl_InterpDeleted\fB to test if some other +code already called \fBTcl_DeleteInterp\fB; if not, call +\fBTcl_DeleteInterp\fR before calling \fBTcl_Release\fB 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 +data of a callback) for use in \fBTcl_Eval\fR, \fBTcl_VarEval\fR, +\fBTcl_GlobalEval\fR, \fBTcl_SetVar\fR, or \fBTcl_GetVar\fR, a pair of +calls to \fBTcl_Preserve\fR and \fBTcl_Release\fR should be wrapped around +all uses of the interpreter; it is unsafe to reuse the interpreter once +\fBTcl_Release\fR has been called. If an interpreter is stored inside a +callback data structure, an appropriate deletion cleanup mechanism should +be set up by the code that creates the data structure so that the +interpreter is removed from the data structure (e.g. by setting the field +to NULL) when the interpreter is deleted. Otherwise, you may be using an +interpreter that has been freed and whose memory may already have been +reused. +.PP +All uses of interpreters in Tcl and Tk have already been protected. +Extension writers should ensure that their code also properly protects any +additional interpreters used, as described above. + +.SH KEYWORDS +command, create, delete, interpreter + +.SH "SEE ALSO" +Tcl_Preserve(3), Tcl_Release(3) diff --git a/contrib/tcl/doc/CrtMathFnc.3 b/contrib/tcl/doc/CrtMathFnc.3 new file mode 100644 index 0000000..f3f458d --- /dev/null +++ b/contrib/tcl/doc/CrtMathFnc.3 @@ -0,0 +1,95 @@ +'\" +'\" Copyright (c) 1989-1993 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: @(#) CrtMathFnc.3 1.8 96/03/25 19:59:55 +'\" +.so man.macros +.TH Tcl_CreateMathFunc 3 7.0 Tcl "Tcl Library Procedures" +.BS +.SH NAME +Tcl_CreateMathFunc \- Define a new math function for expressions +.SH SYNOPSIS +.nf +\fB#include <tcl.h>\fR +.sp +\fBTcl_CreateMathFunc\fR(\fIinterp, name, numArgs, argTypes, proc, clientData\fR) +.SH ARGUMENTS +.AS Tcl_ValueType clientData +.AP Tcl_Interp *interp in +Interpreter in which new function will be defined. +.AP char *name in +Name for new function. +.AP int numArgs in +Number of arguments to new function; also gives size of \fIargTypes\fR array. +.AP Tcl_ValueType *argTypes in +Points to an array giving the permissible types for each argument to +function. +.AP Tcl_MathProc *proc in +Procedure that implements the function. +.AP ClientData clientData in +Arbitrary one-word value to pass to \fIproc\fR when it is invoked. +.BE + +.SH DESCRIPTION +.PP +Tcl allows a number of mathematical functions to be used in +expressions, such as \fBsin\fR, \fBcos\fR, and \fBhypot\fR. +\fBTcl_CreateMathFunc\fR allows applications to add additional functions +to those already provided by Tcl or to replace existing functions. +\fIName\fR is the name of the function as it will appear in expressions. +If \fIname\fR doesn't already exist as a function then a new function +is created. If it does exist, then the existing function is replaced. +\fINumArgs\fR and \fIargTypes\fR describe the arguments to the function. +Each entry in the \fIargTypes\fR array must be either TCL_INT, TCL_DOUBLE, +or TCL_EITHER to indicate whether the corresponding argument must be an +integer, a double-precision floating value, or either, respectively. +.PP +Whenever the function is invoked in an expression Tcl will invoke +\fIproc\fR. \fIProc\fR should have arguments and result that match +the type \fBTcl_MathProc\fR: +.CS +typedef int Tcl_MathProc( + ClientData \fIclientData\fR, + Tcl_Interp *\fIinterp\fR, + Tcl_Value *\fIargs\fR, + Tcl_Value *\fIresultPtr\fR); +.CE +.PP +When \fIproc\fR is invoked the \fIclientData\fR and \fIinterp\fR +arguments will be the same as those passed to \fBTcl_CreateMathFunc\fR. +\fIArgs\fR will point to an array of \fInumArgs\fR Tcl_Value structures, +which describe the actual arguments to the function: +.CS +typedef struct Tcl_Value { + Tcl_ValueType \fItype\fR; +.VS +.VE + long \fIintValue\fR; + double \fIdoubleValue\fR; +} Tcl_Value; +.CE +.PP +The \fItype\fR field indicates the type of the argument and is +either TCL_INT or TCL_DOUBLE. +It will match the \fIargTypes\fR value specified for the function unless +the \fIargTypes\fR value was TCL_EITHER. Tcl converts +the argument supplied in the expression to the type requested in +\fIargTypes\fR, if that is necessary. +Depending on the value of the \fItype\fR field, the \fIintValue\fR +or \fIdoubleValue\fR field will contain the actual value of the argument. +.PP +\fIProc\fR should compute its result and store it either as an integer +in \fIresultPtr->intValue\fR or as a floating value in +\fIresultPtr->doubleValue\fR. +It should set also \fIresultPtr->type\fR to either TCL_INT or TCL_DOUBLE +to indicate which value was set. +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 \fIinterp->result\fR. + +.SH KEYWORDS +expression, mathematical function diff --git a/contrib/tcl/doc/CrtModalTmt.3 b/contrib/tcl/doc/CrtModalTmt.3 new file mode 100644 index 0000000..85f079f --- /dev/null +++ b/contrib/tcl/doc/CrtModalTmt.3 @@ -0,0 +1,71 @@ +'\" +'\" Copyright (c) 1995-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: @(#) CrtModalTmt.3 1.3 96/03/25 20:00:19 +'\" +.so man.macros +.TH Tcl_CreateModalTimeout 3 7.5 Tcl "Tcl Library Procedures" +.BS +.SH NAME +Tcl_CreateModalTimeout, Tcl_DeleteModalTimeout \- special timer for modal operations +.SH SYNOPSIS +.nf +\fB#include <tcl.h>\fR +.sp +\fBTcl_CreateModalTimeout\fR(\fImilliseconds, proc, clientData\fR) +.sp +\fBTcl_DeleteModalTimeout\fR(\fIproc, clientData\fR) +.SH ARGUMENTS +.AS Tcl_TimerToken milliseconds +.AP int milliseconds in +How many milliseconds to wait before invoking \fIproc\fR. +.AP Tcl_TimerProc *proc in +Procedure to invoke after \fImilliseconds\fR have elapsed. +.AP ClientData clientData in +Arbitrary one-word value to pass to \fIproc\fR. +.BE + +.SH DESCRIPTION +.PP +\fBTcl_CreateModalTimeout\fR provides an alternate form of timer +from those provided by \fBTcl_CreateTimerHandler\fR. +These timers are called ``modal'' because they are typically +used in situations where a particular operation must be completed +before the application does anything else. +If such an operation needs a timeout, it cannot use normal timer +events: if normal timer events were processed, arbitrary Tcl scripts +might be invoked via other event handlers, which could interfere with +the completion of the modal operation. +The purpose of modal timers is to allow a single timeout to occur +without allowing any normal timer events to occur. +.PP +\fBTcl_CreateModalTimeout\fR behaves just like \fBTcl_CreateTimerHandler\fR +except that it creates a modal timeout. +Its arguments have the same meaning as for \fBTcl_CreateTimerHandler\fR +and \fIproc\fR is invoked just as for \fBTcl_CreateTimerHandler\fR. +\fBTcl_DeleteModalTimeout\fR deletes the most recently created +modal timeout; its arguments must match the corresponding arguments +to the most recent call to \fBTcl_CreateModalTimeout\fR. +.PP +Modal timeouts differ from a normal timers in three ways. First, +they will trigger regardless of whether the TCL_TIMER_EVENTS flag +has been passed to \fBTcl_DoOneEvent\fR. +Typically modal timers are used with the TCL_TIMER_EVENTS flag +off so that normal timers don't fire but modal ones do. +Second, if several modal timers have been created they stack: +only the top timer on the stack (the most recently created one) +is active at any point in time. +Modal timeouts must be deleted in inverse order from their creation. +Third, modal timeouts are not deleted when they fire: once a modal +timeout has fired, it will continue firing every time \fBTcl_DoOneEvent\fR +is called, until the timeout is deleted by calling +\fBTcl_DeleteModalTimeout\fR. +.PP +Modal timeouts are only needed in a few special situations, and they +should be used with caution. + +.SH KEYWORDS +callback, clock, handler, modal timeout diff --git a/contrib/tcl/doc/CrtSlave.3 b/contrib/tcl/doc/CrtSlave.3 new file mode 100644 index 0000000..7979bbb --- /dev/null +++ b/contrib/tcl/doc/CrtSlave.3 @@ -0,0 +1,142 @@ +'\" +'\" Copyright (c) 1995-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: @(#) CrtSlave.3 1.13 96/03/25 20:00:42 +'\" +.so man.macros +.TH Tcl_CreateSlave 3 7.5 Tcl "Tcl Library Procedures" +.BS +.SH NAME +Tcl_IsSafe, Tcl_MakeSafe, Tcl_CreateSlave, Tcl_GetSlave, Tcl_GetSlaves, Tcl_GetMaster, Tcl_CreateAlias, Tcl_GetAlias, Tcl_GetAliases \- manage +multiple Tcl interpreters and aliases. +.SH SYNOPSIS +.nf +\fB#include <tcl.h>\fR +.sp +int +\fBTcl_IsSafe\fR(\fIinterp\fR) +.sp +int +\fBTcl_MakeSafe\fR(\fIinterp\fR) +.sp +Tcl_Interp * +\fBTcl_CreateSlave\fR(\fIinterp, slaveName, isSafe\fR) +.sp +Tcl_Interp * +\fBTcl_GetSlave\fR(\fIinterp, slaveName\fR) +.sp +Tcl_Interp * +\fBTcl_GetMaster\fR(\fIinterp\fR) +.sp +int +\fBTcl_GetInterpPath\fR(\fIaskingInterp, slaveInterp\fR) +.sp +int +\fBTcl_CreateAlias\fR(\fIslaveInterp, srcCmd, targetInterp, targetCmd, argc, argv\fR) +.sp +int +\fBTcl_GetAlias\fR(\fIinterp, srcCmd, targetInterpPtr, targetCmdPtr, argcPtr, argvPtr\fR) +.SH ARGUMENTS +.AS Tcl_InterpDeleteProc **delProcPtr +.AP Tcl_Interp *interp in +Interpreter in which to execute the specified command. +.AP char *slaveName in +Name of slave interpreter to create or manipulate. +.AP int isSafe in +Zero means the interpreter may have all Tcl functions. Non-zero means the +new interpreter's functionality should be limited to make it safe. +.AP Tcl_Interp *slaveInterp in +Interpreter to use for creating the source command for an alias (see +below). +.AP char *srcCmd 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 +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 +Vector of strings, the additional arguments to pass to the alias 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 +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 +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. +.BE + +.SH DESCRIPTION +.PP +These procedures are intended for access to the multiple interpreter +facility from inside C programs. They enable managing multiple interpreters +in a hierarchical relationship, and the management of aliases, commands +that when invoked in one interpreter execute a command in another +interpreter. The return value for those procedures that return an \fBint\fR +is either \fBTCL_OK\fR or \fBTCL_ERROR\fR. If \fBTCL_ERROR\fR is returned +then the \fBresult\fR field of the interpreter contains an error message. +.PP +\fBTcl_CreateSlave\fR creates a new interpreter as a slave of the given +interpreter. It also creates a slave command in the given interpreter which +allows the master interpreter to manipulate the slave. The slave +interpreter and the slave command have the specified name. If \fIisSafe\fR +is \fB1\fR, the new slave interpreter is made ``safe'' by removing all +unsafe functionality. If the creation failed, \fBNULL\fR is returned. +.PP +\fBTcl_IsSafe\fR returns \fB1\fR if the given interpreter is ``safe'', +\fB0\fR otherwise. +.PP +\fBTcl_MakeSafe\fR makes the given interpreter ``safe'' by removing all +non-core and core unsafe functionality. Note that if you call this after +adding some extension to an interpreter, all traces of that extension will +be removed from the interpreter. This operation always succeeds and returns +\fBTCL_OK\fR. +.PP +\fBTcl_GetSlave\fR returns a pointer to a slave interpreter of the given +interpreter. The slave interpreter is identified by the name specified. +If no such slave interpreter exists, \fBNULL\fR is returned. +.PP +\fBTcl_GetMaster\fR returns a pointer to the master interpreter of the +given interpreter. If the given interpreter has no master (it is a +top-level interpreter) then \fBNULL\fR is returned. +.PP +\fBTcl_GetInterpPath\fR sets the \fIresult\fR field in \fIaskingInterp\fR +to the relative path between \fIaskingInterp\fR and \fIslaveInterp\fR; +\fIslaveInterp\fR must be a slave of \fIaskingInterp\fR. If the computation +of the relative path succeeds, \fBTCL_OK\fR is returned, else +\fBTCL_ERROR\fR is returned and the \fIresult\fR field in +\fIaskingInterp\fR contains the error message. +.PP +\fBTcl_GetAlias\fR returns information about an alias of a specified name +in a given interpreter. Any of the result fields can be \fBNULL\fR, in +which case the corresponding datum is not returned. If a result field is +non\-\fBNULL\fR, the address indicated is set to the corresponding datum. +For example, if \fItargetNamePtr\fR is non\-\fBNULL\fR it is set to a +pointer to the string containing the name of the target command. +.PP +In order to map over all slave interpreters, use \fBTcl_Eval\fR with the +command \fBinterp slaves\fR and use the value (a Tcl list) deposited in the +\fBresult\fR field of the interpreter. Similarly, to map over all aliases +whose source commands are defined in an interpreter, use \fBTcl_Eval\fR +with the command \fBinterp aliases\fR and use the value (a Tcl list) +deposited in the \fBresult\fR field. Note that the storage of this list +belongs to Tcl, so you should copy it before invoking any other Tcl +commands in that interpreter. +.SH "SEE ALSO" +For a description of the Tcl interface to multiple interpreters, see +\fIinterp(n)\fR. + +.SH KEYWORDS +alias, command, interpreter, master, slave + diff --git a/contrib/tcl/doc/CrtTimerHdlr.3 b/contrib/tcl/doc/CrtTimerHdlr.3 new file mode 100644 index 0000000..75a13c6 --- /dev/null +++ b/contrib/tcl/doc/CrtTimerHdlr.3 @@ -0,0 +1,73 @@ +'\" +'\" Copyright (c) 1990 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: @(#) CrtTimerHdlr.3 1.3 96/03/25 20:00:55 +'\" +.so man.macros +.TH Tcl_CreateTimerHandler 3 7.5 Tcl "Tcl Library Procedures" +.BS +.SH NAME +Tcl_CreateTimerHandler, Tcl_DeleteTimerHandler \- call a procedure at a +given time +.SH SYNOPSIS +.nf +\fB#include <tcl.h>\fR +.sp +Tcl_TimerToken +\fBTcl_CreateTimerHandler\fR(\fImilliseconds, proc, clientData\fR) +.sp +\fBTcl_DeleteTimerHandler\fR(\fItoken\fR) +.SH ARGUMENTS +.AS Tcl_TimerToken milliseconds +.AP int milliseconds in +How many milliseconds to wait before invoking \fIproc\fR. +.AP Tcl_TimerProc *proc in +Procedure to invoke after \fImilliseconds\fR have elapsed. +.AP ClientData clientData in +Arbitrary one-word value to pass to \fIproc\fR. +.AP Tcl_TimerToken token in +Token for previously-created timer handler (the return value +from some previous call to \fBTcl_CreateTimerHandler\fR). +.BE + +.SH DESCRIPTION +.PP +\fBTcl_CreateTimerHandler\fR arranges for \fIproc\fR to be +invoked at a time \fImilliseconds\fR milliseconds in the +future. +The callback to \fIproc\fR will be made by \fBTcl_DoOneEvent\fR, +so \fBTcl_CreateTimerHandler\fR is only useful in programs that +dispatch events through \fBTcl_DoOneEvent\fR or through Tcl commands +such as \fBvwait\fR. +The call to \fIproc\fR may not be made at the exact time given by +\fImilliseconds\fR: it will be made at the next opportunity +after that time. For example, if \fBTcl_DoOneEvent\fR isn't +called until long after the time has elapsed, or if there +are other pending events to process before the call to +\fIproc\fR, then the call to \fIproc\fR will be delayed. +.PP +\fIProc\fR should have arguments and return value that match +the type \fBTcl_TimerProc\fR: +.CS +typedef void Tcl_TimerProc(ClientData \fIclientData\fR); +.CE +The \fIclientData\fR parameter to \fIproc\fR is a +copy of the \fIclientData\fR argument given to +\fBTcl_CreateTimerHandler\fR when the callback +was created. Typically, \fIclientData\fR points to a data +structure containing application-specific information about +what to do in \fIproc\fR. +.PP +\fBTcl_DeleteTimerHandler\fR may be called to delete a +previously-created timer handler. It deletes the handler +indicated by \fItoken\fR so that no call to \fIproc\fR +will be made; if that handler no longer exists +(e.g. because the time period has already elapsed and \fIproc\fR +has been invoked) then \fBTcl_DeleteTimerHandler\fR does nothing. + +.SH KEYWORDS +callback, clock, handler, timer diff --git a/contrib/tcl/doc/CrtTrace.3 b/contrib/tcl/doc/CrtTrace.3 new file mode 100644 index 0000000..e9f3bb3 --- /dev/null +++ b/contrib/tcl/doc/CrtTrace.3 @@ -0,0 +1,106 @@ +'\" +'\" Copyright (c) 1989-1993 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: @(#) CrtTrace.3 1.14 96/03/25 20:01:10 +'\" +.so man.macros +.TH Tcl_CreateTrace 3 "" Tcl "Tcl Library Procedures" +.BS +.SH NAME +Tcl_CreateTrace, Tcl_DeleteTrace \- arrange for command execution to be traced +.SH SYNOPSIS +.nf +\fB#include <tcl.h>\fR +.sp +Tcl_Trace +\fBTcl_CreateTrace\fR(\fIinterp, level, proc, clientData\fR) +.sp +\fBTcl_DeleteTrace\fR(\fIinterp, trace\fR) +.SH ARGUMENTS +.AS Tcl_CmdTraceProc (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 +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. +.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. +.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. +.PP +\fIProc\fR 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, + char *\fIargv\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. +.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 +\fIlevel\fR parameter to \fBTcl_CreateTrace\fR). +.PP +Calls to \fIproc\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 +containing the substitutions. If there is a syntax error in a +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. +.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. + +.SH KEYWORDS +command, create, delete, interpreter, trace diff --git a/contrib/tcl/doc/DString.3 b/contrib/tcl/doc/DString.3 new file mode 100644 index 0000000..330d67d --- /dev/null +++ b/contrib/tcl/doc/DString.3 @@ -0,0 +1,153 @@ +'\" +'\" Copyright (c) 1993 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: @(#) DString.3 1.19 96/03/25 20:01:32 +'\" +.so man.macros +.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 +.SH SYNOPSIS +.nf +\fB#include <tcl.h>\fR +.sp +\fBTcl_DStringInit\fR(\fIdsPtr\fR) +.sp +char * +\fBTcl_DStringAppend\fR(\fIdsPtr, string, length\fR) +.sp +char * +\fBTcl_DStringAppendElement\fR(\fIdsPtr, string\fR) +.sp +\fBTcl_DStringStartSublist\fR(\fIdsPtr\fR) +.sp +\fBTcl_DStringEndSublist\fR(\fIdsPtr\fR) +.sp +int +\fBTcl_DStringLength\fR(\fIdsPtr\fR) +.sp +char * +\fBTcl_DStringValue\fR(\fIdsPtr\fR) +.sp +.VS +\fBTcl_DStringSetLength\fR(\fIdsPtr, newLength\fR) +.VE +.sp +\fBTcl_DStringFree\fR(\fIdsPtr\fR) +.sp +\fBTcl_DStringResult\fR(\fIinterp, dsPtr\fR) +.sp +.VS +\fBTcl_DStringGetResult\fR(\fIinterp, dsPtr\fR) +.VE +.SH ARGUMENTS +.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 +Pointer to characters to add to dynamic string. +.AP int length in +Number of characters from string to add to dynamic string. If -1, +add all characters up to null terminating character. +.AP int newLength in +New length for dynamic string, not including null terminating +character. +.AP Tcl_Interp *interp in/out +Interpreter whose result is to be set from or moved to the +dynamic string. +.BE + +.SH DESCRIPTION +.PP +Dynamic strings provide a mechanism for building up arbitrarily long +strings by gradually appending information. If the dynamic string is +short then there will be no memory allocation overhead; as the string +gets larger, additional space will be allocated as needed. +.PP +\fBTcl_DStringInit\fR initializes a dynamic string to zero length. +The Tcl_DString structure must have been allocated by the caller. +No assumptions are made about the current state of the structure; +anything already in it is discarded. +If the structure has been used previously, \fBTcl_DStringFree\fR should +be called first to free up any memory allocated for the old +string. +.PP +\fBTcl_DStringAppend\fR adds new information to a dynamic string, +allocating more memory for the string if needed. +If \fIlength\fR is less than zero then everything in \fIstring\fR +is appended to the dynamic string; otherwise \fIlength\fR +specifies the number of bytes to append. +\fBTcl_DStringAppend\fR returns a pointer to the characters of +the new string. The string can also be retrieved from the +\fIstring\fR field of the Tcl_DString structure. +.PP +\fBTcl_DStringAppendElement\fR is similar to \fBTcl_DStringAppend\fR +except that it doesn't take a \fIlength\fR argument (it appends +all of \fIstring\fR) and it converts the string to a proper list element +before appending. +\fBTcl_DStringAppendElement\fR adds a separator space before the +new list element unless the new list element is the first in a +list or sub-list (i.e. either the current string is empty, or it +contains the single character ``{'', or the last two characters of +the current string are `` {''). +\fBTcl_DStringAppendElement\fR returns a pointer to the +characters of the new string. +.PP +\fBTcl_DStringStartSublist\fR and \fBTcl_DStringEndSublist\fR can be +used to create nested lists. +To append a list element that is itself a sublist, first +call \fBTcl_DStringStartSublist\fR, then call \fBTcl_DStringAppendElement\fR +for each of the elements in the sublist, then call +\fBTcl_DStringEndSublist\fR to end the sublist. +\fBTcl_DStringStartSublist\fR appends a space character if needed, +followed by an open brace; \fBTcl_DStringEndSublist\fR appends +a close brace. +Lists can be nested to any depth. +.PP +\fBTcl_DStringLength\fR is a macro that returns the current length +of a dynamic string (not including the terminating null character). +\fBTcl_DStringValue\fR is a macro that returns a pointer to the +current contents of a dynamic string. +.PP +.VS +.PP +\fBTcl_DStringSetLength\fR changes the length of a dynamic string. +If \fInewLength\fR is less than the string's current length, then +the string is truncated. +If \fInewLength\fR is greater than the string's current length, +then the string will become longer and new space will be allocated +for the string if needed. +However, \fBTcl_DStringSetLength\fR will not initialize the new +space except to provide a terminating null character; it is up to the +caller to fill in the new space. +\fBTcl_DStringSetLength\fR does not free up the string's storage space +even if the string is truncated to zero length, so \fBTcl_DStringFree\fR +will still need to be called. +.VE +.PP +\fBTcl_DStringFree\fR should be called when you're finished using +the string. It frees up any memory that was allocated for the string +and reinitializes the string's value to an empty string. +.PP +\fBTcl_DStringResult\fR sets the result of \fIinterp\fR to the value of +the dynamic string given by \fIdsPtr\fR. It does this by moving +a pointer from \fIdsPtr\fR to \fIinterp->result\fR. +This saves the cost of allocating new memory and copying the string. +\fBTcl_DStringResult\fR also reinitializes the dynamic string to +an empty string. +.PP +.VS +\fBTcl_DStringGetResult\fR does the opposite of \fBTcl_DStringResult\fR. +It sets the value of \fIdsPtr\fR to the result of \fIinterp\fR and +it clears \fIinterp\fR's result. +If possible it does this by moving a pointer rather than by copying +the string. +.VE + +.SH KEYWORDS +append, dynamic string, free, result diff --git a/contrib/tcl/doc/DetachPids.3 b/contrib/tcl/doc/DetachPids.3 new file mode 100644 index 0000000..7c14721 --- /dev/null +++ b/contrib/tcl/doc/DetachPids.3 @@ -0,0 +1,66 @@ +'\" +'\" Copyright (c) 1989-1993 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: @(#) DetachPids.3 1.14 96/03/25 20:01:48 +'\" +.so man.macros +.TH Tcl_DetachPids 3 "" Tcl "Tcl Library Procedures" +.BS +.SH NAME +Tcl_DetachPids, Tcl_ReapDetachedProcs \- manage child processes in background +.SH SYNOPSIS +.nf +\fB#include <tcl.h>\fR +.sp +\fBTcl_DetachPids\fR(\fInumPids, pidPtr\fR) +.sp +.VS +\fBTcl_ReapDetachedProcs\fR() +.VE +.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. +.BE + +.SH DESCRIPTION +.PP +.VS +\fBTcl_DetachPids\fR and \fBTcl_ReapDetachedProcs\fR provide a +mechanism for managing subprocesses that are running in background. +These procedures are needed because the parent of a process must +eventually invoke the \fBwaitpid\fR kernel call (or one of a few other +similar kernel calls) to wait for the child to exit. Until the +parent waits for the child, the child's state cannot be completely +reclaimed by the system. If a parent continually creates children +and doesn't wait on them, the system's process table will eventually +overflow, even if all the children have exited. +.PP +\fBTcl_DetachPids\fR may be called to ask Tcl to take responsibility +for one or more processes whose process ids are contained in the +\fIpidPtr\fR array passed as argument. The caller presumably +has started these processes running in background and doesn't +want to have to deal with them again. +.PP +\fBTcl_ReapDetachedProcs\fR invokes the \fBwaitpid\fR kernel call +on each of the background processes so that its state can be cleaned +up if it has exited. If the process hasn't exited yet, +\fBTcl_ReapDetachedProcs\fR doesn't wait for it to exit; it will check again +the next time it is invoked. +Tcl automatically calls \fBTcl_ReapDetachedProcs\fR each time the +\fBexec\fR command is executed, so in most cases it isn't necessary +for any code outside of Tcl to invoke \fBTcl_ReapDetachedProcs\fR. +However, if you call \fBTcl_DetachPids\fR in situations where the +\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. +.VE + +.SH KEYWORDS +background, child, detach, process, wait diff --git a/contrib/tcl/doc/DoOneEvent.3 b/contrib/tcl/doc/DoOneEvent.3 new file mode 100644 index 0000000..a9e0bc9 --- /dev/null +++ b/contrib/tcl/doc/DoOneEvent.3 @@ -0,0 +1,108 @@ +'\" +'\" Copyright (c) 1990-1992 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: @(#) DoOneEvent.3 1.5 96/03/25 20:02:05 +'\" +.so man.macros +.TH Tcl_DoOneEvent 3 7.5 Tcl "Tcl Library Procedures" +.BS +.SH NAME +Tcl_DoOneEvent \- wait for events and invoke event handlers +.SH SYNOPSIS +.nf +\fB#include <tcl.h>\fR +.sp +int +\fBTcl_DoOneEvent\fR(\fIflags\fR) +.SH ARGUMENTS +.AS int flags +.AP int flags in +This parameter is normally zero. It may be an OR-ed combination +of any of the following flag bits: +TCL_WINDOW_EVENTS, +TCL_FILE_EVENTS, TCL_TIMER_EVENTS, TCL_IDLE_EVENTS, TCL_ALL_EVENTS, or +TCL_DONT_WAIT. +.BE + +.SH DESCRIPTION +.PP +This procedure is the entry point to Tcl's event loop; it is responsible for +waiting for events and dispatching event handlers created with +procedures such as \fBTk_CreateEventHandler\fR, \fBTcl_CreateFileHandler\fR, +\fBTcl_CreateTimerHandler\fR, and \fBTcl_DoWhenIdle\fR. +\fBTcl_DoOneEvent\fR checks to see if +events are already present on the Tcl event queue; if so, +it calls the handler(s) for the first (oldest) event, removes it from +the queue, and returns. +If there are no events ready to be handled, then \fBTcl_DoOneEvent\fR +checks for new events from all possible sources. +If any are found, it puts all of them on Tcl's event queue, calls +handlers for the first event on the queue, and returns. +If no events are found, \fBTcl_DoOneEvent\fR checks for \fBTcl_DoWhenIdle\fR +callbacks; if any are found, it invokes all of them and returns. +Finally, if no events or idle callbacks have been found, then +\fBTcl_DoOneEvent\fR sleeps until an event occurs; then it adds any +ew events to the Tcl event queue, calls handlers for the first event, +and returns. +The normal return value is 1 to signify that some event +was processed (see below for other alternatives). +.PP +If the \fIflags\fR argument to \fBTcl_DoOneEvent\fR is non-zero, +it restricts the kinds of events that will be processed by +\fBTcl_DoOneEvent\fR. +\fIFlags\fR may be an OR-ed combination of any of the following bits: +.TP 27 +\fBTCL_WINDOW_EVENTS\fR \- +Process window system events. +.TP 27 +\fBTCL_FILE_EVENTS\fR \- +Process file events. +.TP 27 +\fBTCL_TIMER_EVENTS\fR \- +Process timer events. +.TP 27 +\fBTCL_IDLE_EVENTS\fR \- +Process idle callbacks. +.TP 27 +\fBTCL_ALL_EVENTS\fR \- +Process all kinds of events: equivalent to OR-ing together all of the +above flags or specifying none of them. +.TP 27 +\fBTCL_DONT_WAIT\fR \- +Don't sleep: process only events that are ready at the time of the +call. +.LP +If any of the flags \fBTCL_WINDOW_EVENTS\fR, \fBTCL_FILE_EVENTS\fR, +\fBTCL_TIMER_EVENTS\fR, or \fBTCL_IDLE_EVENTS\fR is set, then the only +events that will be considered are those for which flags are set. +Setting none of these flags is equivalent to the value +\fBTCL_ALL_EVENTS\fR, which causes all event types to be processed. +If an application has defined additional event sources with +\fBTcl_CreateEventSource\fR, then additional \fIflag\fR values +may also be valid, depending on those event sources. +.PP +The \fBTCL_DONT_WAIT\fR flag causes \fBTcl_DoOneEvent\fR not to put +the process to sleep: it will check for events but if none are found +then it returns immediately with a return value of 0 to indicate +that no work was done. +\fBTcl_DoOneEvent\fR will also return 0 without doing anything if +the only alternative is to block forever (this can happen, for example, +if \fIflags\fR is \fBTCL_IDLE_EVENTS\fR and there are no +\fBTcl_DoWhenIdle\fR callbacks pending, or if no event handlers or +timer handlers exist). +.PP +\fBTcl_DoOneEvent\fR may be invoked recursively. For example, +it is possible to invoke \fBTcl_DoOneEvent\fR recursively +from a handler called by \fBTcl_DoOneEvent\fR. This sort +of operation is useful in some modal situations, such +as when a +notification dialog has been popped up and an application wishes to +wait for the user to click a button in the dialog before +doing anything else. + +.SH KEYWORDS +callback, event, handler, idle, timer diff --git a/contrib/tcl/doc/DoWhenIdle.3 b/contrib/tcl/doc/DoWhenIdle.3 new file mode 100644 index 0000000..2b43b05 --- /dev/null +++ b/contrib/tcl/doc/DoWhenIdle.3 @@ -0,0 +1,87 @@ +'\" +'\" Copyright (c) 1990 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: @(#) DoWhenIdle.3 1.4 96/03/25 20:02:20 +'\" +.so man.macros +.TH Tcl_DoWhenIdle 3 7.5 Tcl "Tcl Library Procedures" +.BS +.SH NAME +Tcl_DoWhenIdle, Tcl_CancelIdleCall \- invoke a procedure when there are no pending events +.SH SYNOPSIS +.nf +\fB#include <tcl.h>\fR +.sp +\fBTcl_DoWhenIdle\fR(\fIproc, clientData\fR) +.sp +\fBTcl_CancelIdleCall\fR(\fIproc, clientData\fR) +.SH ARGUMENTS +.AS Tcl_IdleProc clientData +.AP Tcl_IdleProc *proc in +Procedure to invoke. +.AP ClientData clientData in +Arbitrary one-word value to pass to \fIproc\fR. +.BE + +.SH DESCRIPTION +.PP +\fBTcl_DoWhenIdle\fR arranges for \fIproc\fR to be invoked +when the application becomes idle. The application is +considered to be idle when \fBTcl_DoOneEvent\fR has been +called, couldn't find any events to handle, and is about +to go to sleep waiting for an event to occur. At this +point all pending \fBTcl_DoWhenIdle\fR handlers are +invoked. For each call to \fBTcl_DoWhenIdle\fR there will +be a single call to \fIproc\fR; after \fIproc\fR is +invoked the handler is automatically removed. +\fBTcl_DoWhenIdle\fR is only usable in programs that +use \fBTcl_DoOneEvent\fR to dispatch events. +.PP +\fIProc\fR should have arguments and result that match the +type \fBTcl_IdleProc\fR: +.CS +typedef void Tcl_IdleProc(ClientData \fIclientData\fR); +.CE +The \fIclientData\fR parameter to \fIproc\fR is a copy of the \fIclientData\fR +argument given to \fBTcl_DoWhenIdle\fR. Typically, \fIclientData\fR +points to a data structure containing application-specific information about +what \fIproc\fR should do. +.PP +\fBTcl_CancelIdleCall\fR +may be used to cancel one or more previous +calls to \fBTcl_DoWhenIdle\fR: if there is a \fBTcl_DoWhenIdle\fR +handler registered for \fIproc\fR and \fIclientData\fR, then it +is removed without invoking it. If there is more than one +handler on the idle list that refers to \fIproc\fR and \fIclientData\fR, +all of the handlers are removed. If no existing handlers match +\fIproc\fR and \fIclientData\fR then nothing happens. +.PP +\fBTcl_DoWhenIdle\fR is most useful in situations where +(a) a piece of work will have to be done but (b) it's +possible that something will happen in the near future +that will change what has to be done or require something +different to be done. \fBTcl_DoWhenIdle\fR allows the +actual work to be deferred until all pending events have +been processed. At this point the exact work to be done +will presumably be known and it can be done exactly once. +.PP +For example, \fBTcl_DoWhenIdle\fR might be used by an editor +to defer display updates until all pending commands have +been processed. Without this feature, redundant redisplays +might occur in some situations, such as the processing of +a command file. + +.SH BUGS +.PP +At present it is not safe for an idle callback to reschedule itself +continuously. This will interact badly with certain features of Tk +that attempt to wait for all idle callbacks to complete. If you would +like for an idle callback to reschedule itself continuously, it is +better to use a timer handler with a zero timeout period. + +.SH KEYWORDS +callback, defer, idle callback diff --git a/contrib/tcl/doc/Eval.3 b/contrib/tcl/doc/Eval.3 new file mode 100644 index 0000000..f1a78c8 --- /dev/null +++ b/contrib/tcl/doc/Eval.3 @@ -0,0 +1,106 @@ +'\" +'\" Copyright (c) 1989-1993 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: @(#) Eval.3 1.17 96/03/25 20:02:33 +'\" +.so man.macros +.TH Tcl_Eval 3 7.0 Tcl "Tcl Library Procedures" +.BS +.SH NAME +Tcl_Eval, Tcl_VarEval, Tcl_EvalFile, Tcl_GlobalEval \- execute Tcl commands +.SH SYNOPSIS +.nf +\fB#include <tcl.h>\fR +.sp +int +.VS +\fBTcl_Eval\fR(\fIinterp, cmd\fR) +.VE +.sp +int +\fBTcl_VarEval\fR(\fIinterp, string, string, ... \fB(char *) NULL\fR) +.sp +int +\fBTcl_EvalFile\fR(\fIinterp, fileName\fR) +.sp +int +\fBTcl_GlobalEval\fR(\fIinterp, cmd\fR) +.SH ARGUMENTS +.AS Tcl_Interp **termPtr; +.AP Tcl_Interp *interp in +Interpreter in which to execute the command. String result will be +stored in \fIinterp->result\fR. +.AP char *cmd in +Command (or sequence of commands) to execute. Must be in writable +memory (\fBTcl_Eval\fR makes temporary modifications to the command). +.AP char *string in +String forming part of Tcl command. +.AP char *fileName in +Name of file containing Tcl command string. +.BE + +.SH DESCRIPTION +.PP +All four of these procedures execute Tcl commands. +\fBTcl_Eval\fR is the core procedure: it parses commands +from \fIcmd\fR and executes them in +.VS +order until either an error occurs or it reaches the end of the string. +.VE +The return value from \fBTcl_Eval\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 \fIinterp->result\fR will point to +a string with additional information (result value or error message). +This return information corresponds to the last command executed from +\fIcmd\fR. +.PP +\fBTcl_VarEval\fR takes any number of string arguments +of any length, concatenates +them into a single string, then calls \fBTcl_Eval\fR to +execute that string as a Tcl command. +It returns the result of the command and also modifies +\fIinterp->result\fR in the usual fashion for Tcl commands. The +last argument to \fBTcl_VarEval\fR must be NULL to indicate the end +of arguments. +.PP +\fBTcl_EvalFile\fR reads the file given by \fIfileName\fR and evaluates +its contents as a Tcl command by calling \fBTcl_Eval\fR. It returns +a standard Tcl result that reflects the result of evaluating the +file. +If the file couldn't be read then a Tcl error is returned to describe +why the file couldn't be read. +.PP +\fBTcl_GlobalEval\fR is similar to \fBTcl_Eval\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 conditionals, loops, +and procedures are implemented). +If a code other than +\fBTCL_OK\fR is returned from a nested \fBTcl_Eval\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_Eval\fR keeps track of how many nested Tcl_Eval 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_Eval\fR invocation for +\fIinterp\fR, then \fBTcl_Eval\fR converts the return code to \fBTCL_ERROR\fR +and sets \fIinterp->result\fR 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_Eval\fR other then +\fBTCL_OK\fR or \fBTCL_ERROR\fR. + +.SH KEYWORDS +command, execute, file, global, interpreter, variable diff --git a/contrib/tcl/doc/Exit.3 b/contrib/tcl/doc/Exit.3 new file mode 100644 index 0000000..dc370bd --- /dev/null +++ b/contrib/tcl/doc/Exit.3 @@ -0,0 +1,66 @@ +'\" +'\" Copyright (c) 1995-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: @(#) Exit.3 1.4 96/03/25 20:02:50 +'\" +.so man.macros +.TH Tcl_Exit 3 7.5 Tcl "Tcl Library Procedures" +.BS +.SH NAME +Tcl_Exit, Tcl_CreateExitHandler, Tcl_DeleteExitHandler \- end the application (and invoke exit handlers) +.SH SYNOPSIS +.nf +\fB#include <tcl.h>\fR +.sp +\fBTcl_Exit\fR(\fIstatus\fR) +.sp +\fBTcl_CreateExitHandler\fR(\fIproc, clientData\fR) +.sp +\fBTcl_DeleteExitHandler\fR(\fIproc, clientData\fR) +.SH ARGUMENTS +.AS Tcl_ExitProc clientData +.AP int status in +Provides information about why application exited. Exact meaning may +be platform-specific. 0 usually means a normal exit, 1 means that an +error occurred. +.AP Tcl_ExitProc *proc in +Procedure to invoke before exiting application. +.AP ClientData clientData in +Arbitrary one-word value to pass to \fIproc\fR. +.BE + +.SH DESCRIPTION +.PP +\fBTcl_Exit\fR is the procedure that is invoked to end a Tcl application. +It is invoked by the \fBexit\fR command, as well as anyplace else that +terminates the application. +No-one should ever invoke the \fBexit\fR procedure directly; always +invoke \fBTcl_Exit\fR instead, so that it can invoke exit handlers. +.PP +\fBTcl_CreateExitHandler\fR arranges for \fIproc\fR to be invoked +by \fBTcl_Exit\fR before it terminates the application. +This provides a hook for cleanup operations such as flushing buffers +and freeing global memory. +\fIProc\fR should have arguments and return value that match +the type \fBTcl_ExitProc\fR: +.CS +typedef void Tcl_ExitProc(ClientData \fIclientData\fR); +.CE +The \fIclientData\fR parameter to \fIproc\fR is a +copy of the \fIclientData\fR argument given to +\fBTcl_CreateExitHandler\fR when the callback +was created. Typically, \fIclientData\fR points to a data +structure containing application-specific information about +what to do in \fIproc\fR. +.PP +\fBTcl_DeleteExitHandler\fR may be called to delete a +previously-created exit handler. It removes the handler +indicated by \fIproc\fR and \fIclientData\fR so that no call +to \fIproc\fR will be made. If no such handler exists then +\fBTcl_DeleteExitHandler\fR does nothing. + +.SH KEYWORDS +callback, end application, exit diff --git a/contrib/tcl/doc/ExprLong.3 b/contrib/tcl/doc/ExprLong.3 new file mode 100644 index 0000000..100bec3 --- /dev/null +++ b/contrib/tcl/doc/ExprLong.3 @@ -0,0 +1,106 @@ +'\" +'\" Copyright (c) 1989-1993 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: @(#) ExprLong.3 1.17 96/03/25 20:03:03 +'\" +.so man.macros +.TH Tcl_ExprLong 3 7.0 Tcl "Tcl Library Procedures" +.BS +.SH NAME +Tcl_ExprLong, Tcl_ExprDouble, Tcl_ExprBoolean, Tcl_ExprString \- evaluate an expression +.SH SYNOPSIS +.nf +\fB#include <tcl.h>\fR +.sp +int +\fBTcl_ExprLong\fR(\fIinterp, string, longPtr\fR) +.sp +int +\fBTcl_ExprDouble\fR(\fIinterp, string, doublePtr\fR) +.sp +int +\fBTcl_ExprBoolean\fR(\fIinterp, string, booleanPtr\fR) +.sp +int +\fBTcl_ExprString\fR(\fIinterp, string\fR) +.SH ARGUMENTS +.AS Tcl_Interp *booleanPtr +.AP Tcl_Interp *interp in +Interpreter in whose context to evaluate \fIstring\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). +.AP long *longPtr out +Pointer to location in which to store the integer value of the +expression. +.AP int *doublePtr out +Pointer to location in which to store the floating-point value of the +expression. +.AP int *booleanPtr out +Pointer to location in which to store the 0/1 boolean value of the +expression. +.BE + +.SH DESCRIPTION +.PP +These four procedures all evaluate an expression, returning +the result in one of four different forms. +The expression is given by the \fIstring\fR argument, and it +can have any of the forms accepted by the \fBexpr\fR command. +The \fIinterp\fR argument refers to an interpreter used to +evaluate the expression (e.g. for variables and nested Tcl +commands) and to return error information. \fIInterp->result\fR +is assumed to be initialized in the standard fashion when any +of the procedures are invoked. +.PP +For all of these procedures the return value is a standard +Tcl result: \fBTCL_OK\fR means the expression was successfully +evaluated, and \fBTCL_ERROR\fR means that an error occurred while +evaluating the expression. If \fBTCL_ERROR\fR is returned then +\fIinterp->result\fR will hold a message describing the error. +If an error occurs while executing a Tcl command embedded in +the expression then that error will be returned. +.PP +If the expression is successfully evaluated, then its value is +returned in one of four forms, depending on which procedure +is invoked. +\fBTcl_ExprLong\fR stores an integer value at \fI*longPtr\fR. +If the expression's actual value is a floating-point number, +then it is truncated to an integer. +If the expression's actual value is a non-numeric string then +an error is returned. +.PP +\fBTcl_ExprDouble\fR stores a floating-point value at \fI*doublePtr\fR. +If the expression's actual value is an integer, it is converted to +floating-point. +If the expression's actual value is a non-numeric string then +an error is returned. +.PP +\fBTcl_ExprBoolean\fR stores a 0/1 integer value at \fI*booleanPtr\fR. +If the expression's actual value is an integer or floating-point +number, then \fBTcl_ExprBoolean\fR stores 0 at \fI*booleanPtr\fR if +the value was zero and 1 otherwise. +.VS +If the expression's actual value is a non-numeric string then +it must be one of the values accepted by \fBTcl_GetBoolean\fR, +such as ``yes'' or ``no'', or else an error occurs. +.VE +.PP +\fBTcl_ExprString\fR returns the value of the expression as a +string stored in \fIinterp->result\fR. +.VS +If the expression's actual value is an integer +then \fBTcl_ExprString\fR converts it to a string using \fBsprintf\fR +with a ``%d'' converter. +If the expression's actual value is a floating-point +number, then \fBTcl_ExprString\fR calls \fBTcl_PrintDouble\fR +to convert it to a string. +.VE + +.SH KEYWORDS +boolean, double, evaluate, expression, integer, string diff --git a/contrib/tcl/doc/FindExec.3 b/contrib/tcl/doc/FindExec.3 new file mode 100644 index 0000000..10342cc --- /dev/null +++ b/contrib/tcl/doc/FindExec.3 @@ -0,0 +1,46 @@ +'\" +'\" Copyright (c) 1995-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: @(#) FindExec.3 1.3 96/03/25 20:03:17 +'\" +.so man.macros +.TH Tcl_FindExecutable 3 7.5 Tcl "Tcl Library Procedures" +.BS +.SH NAME +Tcl_FindExecutable \- identify the binary file containing the application +.SH SYNOPSIS +.nf +\fB#include <tcl.h>\fR +.sp +char * +\fBTcl_FindExecutable\fR(\fIargv0\fR) +.SH ARGUMENTS +.AS char *argv0 in +.AP char *argv0 in +The first command-line argument to the program, which gives the +application's name. +.BE + +.SH DESCRIPTION +.PP +This procedure computes the full path name of the executable file +from which the application was invoked and saves it for Tcl's +internal use. +The executable's path name is needed for several purposes in +Tcl. For example, is is needed on some platforms in the +implementation of the \fBload\fR command. +It is also returned by the \fBinfo nameofexecutable\fR command. +.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 +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 +will return an empty string. + +.SH KEYWORDS +binary, executable file diff --git a/contrib/tcl/doc/GetFile.3 b/contrib/tcl/doc/GetFile.3 new file mode 100644 index 0000000..68ffd21 --- /dev/null +++ b/contrib/tcl/doc/GetFile.3 @@ -0,0 +1,130 @@ +'\" +'\" Copyright (c) 1995-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: @(#) GetFile.3 1.8 96/03/25 20:03:31 +'\" +.so man.macros +.TH Tcl_GetFile 3 7.5 Tcl "Tcl Library Procedures" +.BS +.SH NAME +Tcl_GetFile, Tcl_FreeFile, Tcl_GetFileInfo \- procedures to manipulate generic file handles +.SH SYNOPSIS +.nf +\fB#include <tcl.h>\fR +.sp +Tcl_File +\fBTcl_GetFile\fR(\fIosHandle, type\fR) +.sp +\fBTcl_FreeFile\fR(\fIhandle\fR) +.sp +ClientData +\fBTcl_GetFileInfo\fR(\fIhandle, typePtr\fR) +.sp +ClientData +\fBTcl_GetNotifierData\fR(\fIhandle, freeProcPtr\fR) +.sp +\fBTcl_SetNotifierData\fR(\fIhandle, freeProc, clientData\fR) +.SH ARGUMENTS +.AS Tcl_FileFreeProc **freeProcPtr +.AP ClientData osHandle in +Platform-specific file handle to be associated with the generic file handle. +.AP int type in +The type of platform-specific file handle associated with the generic file +handle. See below for a list of valid types. +.AP Tcl_File handle in +Generic file handle associated with platform-specific file information. +.AP int *typePtr in/out +If \fI*typePtr\fR is not NULL, then the specified word is set to +contain the type associated with \fIhandle\fR. +.AP Tcl_FileFreeProc *freeProc in +Procedure to call when \fIhandle\fR is deleted. +.AP Tcl_FileFreeProc **freeProcPtr in/out +Pointer to location in which to store address of current free procedure +for file handle. Ignored if NULL. +.AP ClientData clientData in +Arbitrary one-word value associated with the given file handle. This +data is owned by the caller. +.BE + +.SH DESCRIPTION +.PP +A \fBTcl_File\fR is an opaque handle used to refer to files in a +platform independent way in Tcl routines like +\fBTcl_CreateFileHandler\fR. A file handle has an associated +platform-dependent \fIosHandle\fR, a \fItype\fR and additional private +data used by the notifier to generate events for the file. The type +is an integer that determines how the platform-specific drivers will +interpret the \fIosHandle\fR. The types that are defined by the core +are: +.TP 22 +\fBTCL_UNIX_FD\fR +The \fIosHandle\fR is a Unix file descriptor. +.TP 22 +\fBTCL_MAC_FILE\fR +The file is a Macintosh file handle. +.TP 22 +\fBTCL_WIN_FILE\fR +The \fIosHandle\fR is a Windows normal file \fBHANDLE\fR. +.TP 22 +\fBTCL_WIN_PIPE\fR +The \fIosHandle\fR is a Windows anonymous pipe \fBHANDLE\fR. +.TP 22 +\fBTCL_WIN_SOCKET\fR +The \fIosHandle\fR is a Windows \fBSOCKET\fR. +.TP 22 +\fBTCL_WIN_CONSOLE\fR +The \fIosHandle\fR is a Windows console buffer \fBHANDLE\fR. +.PP +\fBTcl_GetFile\fR locates the file handle corresponding to a particular +\fIosHandle\fR and a \fItype\fR. If a file handle already existed for the +given file, then that handle will be returned. If this is the first time that +the file handle for a particular file is being retrieved, then a new file +handle will be allocated and returned. +.PP +When a file handle is no longer in use, it should be deallocated with +a call to \fBTcl_FreeFile\fR. A call to this function will invoke the +notifier free procedure \fIproc\fR, if there is one. After the +notifier has cleaned up, any resources used by the file handle will be +deallocated. \fBTcl_FreeFile\fR will not close the platform-specific +\fIosHandle\fR. +.PP +\fBTcl_GetFileInfo\fR may be used to retrieve the platform-specific +\fIosHandle\fR and type associated with a file handle. If +\fItypePtr\fR is not NULL, then the word at \fI*typePtr\fR is set to +the type of the file handle. The return value of the function is the +associated platform-specific \fIosHandle\fR. Note that this function +may be used to extract the platform-specific file handle from a +\fBTcl_File\fR so that it may be used in external interfaces. +However, programs written using this interface will be +platform-specific. +.PP +The \fBTcl_SetNotifierData\fR and \fBTcl_GetNotifierData\fR procedures are +intended to be used only by notifier writers. See the +\fITcl_CreateEventSource(3)\fR manual entry for more information on +the notifier. +.PP +\fBTcl_SetNotifierData\fR may be used by notifier writers to associate +notifier-specific information with a \fBTcl_File\fR. The \fIdata\fR +argument specifies a word that may be retrieved with a later call to +\fBTcl_GetNotifierData\fR. If the \fIfreeProc\fR argument is non-NULL +it specifies the address of a procedure to invoke when the +\fBTcl_File\fR is deleted. \fIfreeProc\fR should have arguments and +result that match the type \fBTcl_FileFreeProc\fR: +.CS +typedef void Tcl_FileFreeProc( + ClientData \fIclientData\fR); +.CE +When \fIfreeProc\fR is invoked the \fIclientData\fR argument will be +the same as the corresponding argument passed to +\fBTcl_SetNotifierData\fR. +.PP +\fBTcl_GetNotifierData\fR returns the \fIclientData\fR associated with +the given \fBTcl_File\fR, and if the \fIfreeProcPtr\fR field is +non-\fBNULL\fR, the address indicated by it gets the address of the +free procedure stored with this file. + +.SH KEYWORDS +generic file handle, file type, file descriptor, notifier diff --git a/contrib/tcl/doc/GetInt.3 b/contrib/tcl/doc/GetInt.3 new file mode 100644 index 0000000..8f1da08 --- /dev/null +++ b/contrib/tcl/doc/GetInt.3 @@ -0,0 +1,81 @@ +'\" +'\" Copyright (c) 1989-1993 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: @(#) GetInt.3 1.12 96/03/25 20:03:44 +'\" +.so man.macros +.TH Tcl_GetInt 3 "" Tcl "Tcl Library Procedures" +.BS +.SH NAME +Tcl_GetInt, Tcl_GetDouble, Tcl_GetBoolean \- convert from string to integer, double, or boolean +.SH SYNOPSIS +.nf +\fB#include <tcl.h>\fR +.sp +int +\fBTcl_GetInt\fR(\fIinterp, string, intPtr\fR) +.sp +int +\fBTcl_GetDouble\fR(\fIinterp, string, doublePtr\fR) +.sp +int +\fBTcl_GetBoolean\fR(\fIinterp, string, boolPtr\fR) +.SH ARGUMENTS +.AS Tcl_Interp *doublePtr +.AP Tcl_Interp *interp in +Interpreter to use for error reporting. +.AP char *string in +Textual value to be converted. +.AP int *intPtr out +Points to place to store integer value converted from \fIstring\fR. +.AP double *doublePtr out +Points to place to store double-precision floating-point +value converted from \fIstring\fR. +.AP int *boolPtr out +Points to place to store boolean value (0 or 1) converted from \fIstring\fR. +.BE + +.SH DESCRIPTION +.PP +These procedures convert from strings to integers or double-precision +floating-point values or booleans (represented as 0- or 1-valued +integers). Each of the procedures takes a \fIstring\fR argument, +converts it to an internal form of a particular type, and stores +the converted value at the location indicated by the procedure's +third argument. If all goes well, each of the procedures returns +TCL_OK. If \fIstring\fR doesn't have the proper syntax for the +desired type then TCL_ERROR is returned, an error message is left +in \fIinterp->result\fR, and nothing is stored at *\fIintPtr\fR +or *\fIdoublePtr\fR or *\fIboolPtr\fR. +.PP +\fBTcl_GetInt\fR expects \fIstring\fR to consist of a collection +of integer digits, optionally signed and optionally preceded by +white space. If the first two characters of \fIstring\fR are ``0x'' +then \fIstring\fR is expected to be in hexadecimal form; otherwise, +if the first character of \fIstring\fR is ``0'' then \fIstring\fR +is expected to be in octal form; otherwise, \fIstring\fR is +expected to be in decimal form. +.PP +\fBTcl_GetDouble\fR expects \fIstring\fR to consist of a floating-point +number, which is: white space; a sign; a sequence of digits; a +decimal point; a sequence of digits; the letter ``e''; and a +signed decimal exponent. Any of the fields may be omitted, except that +the digits either before or after the decimal point must be present +and if the ``e'' is present then it must be followed by the +exponent number. +.PP +\fBTcl_GetBoolean\fR expects \fIstring\fR to specify a boolean +value. If \fIstring\fR is any of \fB0\fR, \fBfalse\fR, +\fBno\fR, or \fBoff\fR, then \fBTcl_GetBoolean\fR stores a zero +value at \fI*boolPtr\fR. +If \fIstring\fR is any of \fB1\fR, \fBtrue\fR, \fByes\fR, or \fBon\fR, +then 1 is stored at \fI*boolPtr\fR. +Any of these values may be abbreviated, and upper-case spellings +are also acceptable. + +.SH KEYWORDS +boolean, conversion, double, floating-point, integer diff --git a/contrib/tcl/doc/GetOpnFl.3 b/contrib/tcl/doc/GetOpnFl.3 new file mode 100644 index 0000000..8f37d11 --- /dev/null +++ b/contrib/tcl/doc/GetOpnFl.3 @@ -0,0 +1,57 @@ +'\" +'\" Copyright (c) 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: @(#) GetOpnFl.3 1.2 96/03/26 13:40:26 +.so man.macros +.TH Tcl_GetOpenFile 3 7.5 Tcl "Tcl Library Procedures" +.BS +.SH NAME +Tcl_GetOpenFile \- Get a standard IO File * handle from a channel. +.SH SYNOPSIS +.nf +\fB#include <tcl.h>\fR +.sp +int +\fBTcl_GetOpenFile\fR(\fIinterp, string, write, checkUsage, filePtr\fR) +.sp +.SH ARGUMENTS +.AS Tcl_Interp checkUsage +.AP Tcl_Interp *interp in +Tcl interpreter from which file handle is to be obtained. +.AP 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 +be used for reading. +.AP int checkUsage in +If non-zero, then an error will be generated if the file wasn't opened +for the access indicated by \fIwrite\fR. +.AP ClientData *filePtr out +Points to word in which to store pointer to FILE structure for +the file given by \fIstring\fR. +.BE + +.SH DESCRIPTION +.PP +\fBTcl_GetOpenFile\fR takes as argument a file identifier of the form +returned by the \fBopen\fR command and +returns at \fI*filePtr\fR a pointer to the FILE structure for +the file. +The \fIwrite\fR argument indicates whether the FILE pointer will +be used for reading or writing. +In some cases, such as a channel that connects to a pipeline of +subprocesses, different FILE pointers will be returned for reading +and writing. +\fBTcl_GetOpenFile\fR normally returns TCL_OK. +If an error occurs in \fBTcl_GetOpenFile\fR (e.g. \fIstring\fR didn't +make any sense or \fIcheckUsage\fR was set and the file wasn't opened +for the access specified by \fIwrite\fR) then TCL_ERROR is returned +and \fIinterp->result\fR will contain an error message. +In the current implementation \fIcheckUsage\fR is ignored and consistency +checks are always performed. + +.SH KEYWORDS +channel, file handle, permissions, pipeline, read, write diff --git a/contrib/tcl/doc/GetStdChan.3 b/contrib/tcl/doc/GetStdChan.3 new file mode 100644 index 0000000..bc81e4c --- /dev/null +++ b/contrib/tcl/doc/GetStdChan.3 @@ -0,0 +1,73 @@ +'\" +'\" Copyright (c) 1996 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. +'\" +'\" @(#) GetStdChan.3 1.2 96/03/08 13:59:57 +'\" +.so man.macros +.TH Tcl_GetStdChannel 3 7.5 Tcl "Tcl Library Procedures" +.BS +'\" Note: do not modify the .SH NAME line immediately below! +.SH NAME +Tcl_GetStdChannel, Tcl_SetStdChannel \- procedures for retrieving and replacing the standard channels +.SH SYNOPSIS +.nf +\fB#include <tcl.h>\fR +.sp +Tcl_Channel +\fBTcl_GetStdChannel\fR(\fItype\fR) +.sp +\fBTcl_SetStdChannel\fR(\fIchannel, type\fR) +.sp +.SH ARGUMENTS +.AS Tcl_Channel channel in +.AP int type in +The identifier for the standard channel to retrieve or modify. Must be one of +\fBTCL_STDIN\fR, \fBTCL_STDOUT\fR, or \fBTCL_STDERR\fR. +.AP Tcl_Channel channel in +The channel to use as the new value for the specified standard channel. +.BE + +.SH DESCRIPTION +.PP +Tcl defines three special channels that are used by various I/O related +commands if no other channels are specified. The standard input channel +has a channel name of \fBstdin\fR and is used by \fBread\fR and \fBgets\fR. +The standard output channel is named \fBstdout\fR and is used by +\fBputs\fR. The standard error channel is named \fBstderr\fR and is used for +reporting errors. In addition, the standard channels are inherited by any +child processes created using \fBexec\fR or \fBopen\fR in the absence of any +other redirections. +.PP +The standard channels are actually aliases for other normal channels. The +current channel associated with a standard channel can be retrieved by calling +\fBTcl_GetStdChannel\fR with one of +\fBTCL_STDIN\fR, \fBTCL_STDOUT\fR, or \fBTCL_STDERR\fR as the \fItype\fR. The +return value will be a valid channel, or NULL. +.PP +A new channel can be set for the standard channel specified by \fItype\fR +by calling \fBTcl_SetStdChannel\fR with a new channel or NULL in the +\fIchannel\fR argument. If the specified channel is closed by a later call to +\fBTcl_Close\fR, then the corresponding standard channel will automatically be +set to NULL. +.PP +If \fBTcl_GetStdChannel\fR is called before \fBTcl_SetStdChannel\fR, Tcl will +construct a new channel to wrap the appropriate platform-specific standard +file handle. If \fBTcl_SetStdChannel\fR is called before +\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_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. + +.SH "SEE ALSO" +Tcl_Close(3), Tcl_CreateChannel(3) + +.SH KEYWORDS +standard channel, standard input, standard output, standard error diff --git a/contrib/tcl/doc/Hash.3 b/contrib/tcl/doc/Hash.3 new file mode 100644 index 0000000..48835a3 --- /dev/null +++ b/contrib/tcl/doc/Hash.3 @@ -0,0 +1,208 @@ +'\" +'\" Copyright (c) 1989-1993 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: @(#) Hash.3 1.15 96/03/25 20:04:01 +'\" +.so man.macros +.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 +.SH SYNOPSIS +.nf +\fB#include <tcl.h>\fR +.sp +\fBTcl_InitHashTable\fR(\fItablePtr, keyType\fR) +.sp +\fBTcl_DeleteHashTable\fR(\fItablePtr\fR) +.sp +Tcl_HashEntry * +\fBTcl_CreateHashEntry\fR(\fItablePtr, key, newPtr\fR) +.sp +\fBTcl_DeleteHashEntry\fR(\fIentryPtr\fR) +.sp +Tcl_HashEntry * +\fBTcl_FindHashEntry\fR(\fItablePtr, key\fR) +.sp +ClientData +\fBTcl_GetHashValue\fR(\fIentryPtr\fR) +.sp +\fBTcl_SetHashValue\fR(\fIentryPtr, value\fR) +.sp +char * +\fBTcl_GetHashKey\fR(\fItablePtr, entryPtr\fR) +.sp +Tcl_HashEntry * +\fBTcl_FirstHashEntry\fR(\fItablePtr, searchPtr\fR) +.sp +Tcl_HashEntry * +\fBTcl_NextHashEntry\fR(\fIsearchPtr\fR) +.sp +char * +\fBTcl_HashStats\fR(\fItablePtr\fR) +.SH ARGUMENTS +.AS Tcl_HashSearch *searchPtr +.AP Tcl_HashTable *tablePtr in +Address of hash table structure (for all procedures but +\fBTcl_InitHashTable\fR, this must have been initialized by +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 +Key to use for probe into table. Exact form depends on +\fIkeyType\fR used to create table. +.AP int *newPtr out +The word at \fI*newPtr\fR is set to 1 if a new entry was created +and 0 if there was already an entry for \fIkey\fR. +.AP Tcl_HashEntry *entryPtr in +Pointer to hash table entry. +.AP ClientData value in +New value to assign to hash table entry. Need not have type +ClientData, but must fit in same space as ClientData. +.AP Tcl_HashSearch *searchPtr in +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: +.IP \fBTCL_STRING_KEYS\fR 25 +Keys are null-terminated ASCII strings. +They are passed to hashing routines using the address of the +first character of the string. +.IP \fBTCL_ONE_WORD_KEYS\fR 25 +Keys are single-word values; they are passed to hashing routines +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 \fIother\fR 25 +If \fIkeyType\fR is not TCL_STRING_KEYS or TCL_ONE_WORD_KEYS, +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. +This allows structures to be used as keys. +All keys must have the same size. +Array keys are passed into hashing functions using the address +of the first int in the array. +.PP +\fBTcl_DeleteHashTable\fR deletes all of the entries in a hash +table and frees up the memory associated with the table's +bucket array and entries. +It does not free the actual table structure (pointed to +by \fItablePtr\fR), since that memory is assumed to be managed +by the client. +\fBTcl_DeleteHashTable\fR also does not free or otherwise +manipulate the values of the hash table entries. +If the entry values point to dynamically-allocated memory, then +it is the client's responsibility to free these structures +before deleting the table. +.PP +\fBTcl_CreateHashEntry\fR locates the entry corresponding to a +particular key, creating a new entry in the table if there +wasn't already one with the given key. +If an entry already existed with the given key then \fI*newPtr\fR +is set to zero. +If a new entry was created, then \fI*newPtr\fR is set to a non-zero +value and the value of the new entry will be set to zero. +The return value from \fBTcl_CreateHashEntry\fR is a pointer to +the entry, which may be used to retrieve and modify the entry's +value or to delete the entry from the table. +.PP +\fBTcl_DeleteHashEntry\fR will remove an existing entry from a +table. +The memory associated with the entry itself will be freed, but +the client is responsible for any cleanup associated with the +entry's value, such as freeing a structure that it points to. +.PP +\fBTcl_FindHashEntry\fR is similar to \fBTcl_CreateHashEntry\fR +except that it doesn't create a new entry if the key doesn't exist; +instead, it returns NULL as result. +.PP +\fBTcl_GetHashValue\fR and \fBTcl_SetHashValue\fR are used to +read and write an entry's value, respectively. +Values are stored and retrieved as type ``ClientData'', which is +large enough to hold a pointer value. On almost all machines this is +large enough to hold an integer value too. +.PP +\fBTcl_GetHashKey\fR returns the key for a given hash table entry, +either as a pointer to a string, a one-word (``char *'') key, or +as a pointer to the first word of an array of integers, depending +on the \fIkeyType\fR used to create a hash table. +In all cases \fBTcl_GetHashKey\fR returns a result with type +``char *''. +When the key is a string or array, the result of \fBTcl_GetHashKey\fR +points to information in the table entry; this information will +remain valid until the entry is deleted or its table is deleted. +.PP +\fBTcl_FirstHashEntry\fR and \fBTcl_NextHashEntry\fR may be used +to scan all of the entries in a hash table. +A structure of type ``Tcl_HashSearch'', provided by the client, +is used to keep track of progress through the table. +\fBTcl_FirstHashEntry\fR initializes the search record and +returns the first entry in the table (or NULL if the table is +empty). +Each subsequent call to \fBTcl_NextHashEntry\fR returns the +next entry in the table or +NULL if the end of the table has been reached. +A call to \fBTcl_FirstHashEntry\fR followed by calls to +\fBTcl_NextHashEntry\fR will return each of the entries in +the table exactly once, in an arbitrary order. +It is unadvisable to modify the structure of the table, e.g. +by creating or deleting entries, while the search is in +progress. +.PP +\fBTcl_HashStats\fR returns a dynamically-allocated string with +overall information about a hash table, such as the number of +entries it contains, the number of buckets in its hash array, +and the utilization of the buckets. +It is the caller's responsibility to free the result string +by passing it to \fBfree\fR. +.PP +The header file \fBtcl.h\fR defines the actual data structures +used to implement hash tables. +This is necessary so that clients can allocate Tcl_HashTable +structures and so that macros can be used to read and write +the values of entries. +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 KEYWORDS +hash table, key, lookup, search, value diff --git a/contrib/tcl/doc/Interp.3 b/contrib/tcl/doc/Interp.3 new file mode 100644 index 0000000..7ef7bb5 --- /dev/null +++ b/contrib/tcl/doc/Interp.3 @@ -0,0 +1,119 @@ +'\" +'\" Copyright (c) 1989-1993 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: @(#) Interp.3 1.14 96/03/25 20:04:19 +'\" +.so man.macros +.TH Tcl_Interp 3 "" Tcl "Tcl Library Procedures" +.BS +.SH NAME +Tcl_Interp \- client-visible fields of interpreter structures +.SH SYNOPSIS +.nf +\fB#include <tcl.h>\fR +.sp +typedef struct { + char *\fIresult\fR; + Tcl_FreeProc *\fIfreeProc\fR; + int \fIerrorLine\fR; +} Tcl_Interp; + +typedef void Tcl_FreeProc(char *\fIblockPtr\fR); +.BE + +.SH DESCRIPTION +.PP +The \fBTcl_CreateInterp\fR procedure returns a pointer to a Tcl_Interp +structure. This pointer is then passed into other Tcl procedures +to process commands in the interpreter and perform other operations +on the interpreter. Interpreter structures contain many many fields +that are used by Tcl, but only three that may be accessed by +clients: \fIresult\fR, \fIfreeProc\fR, and \fIerrorLine\fR. +.PP +The \fIresult\fR and \fIfreeProc\fR fields are used to return +results or error messages from commands. +This information is returned by command procedures back to \fBTcl_Eval\fR, +and by \fBTcl_Eval\fR back to its callers. +The \fIresult\fR field points to the string that represents the +result or error message, and the \fIfreeProc\fR field tells how +to dispose of the storage for the string when it isn't needed anymore. +The easiest way for command procedures to manipulate these +fields is to call procedures like \fBTcl_SetResult\fR +or \fBTcl_AppendResult\fR; they +will hide all the details of managing the fields. +The description below is for those procedures that manipulate the +fields directly. +.PP +Whenever a command procedure returns, it must ensure +that the \fIresult\fR field of its interpreter points to the string +being returned by the command. +The \fIresult\fR field must always point to a valid string. +If a command wishes to return no result then \fIinterp->result\fR +should point to an empty string. +Normally, results are assumed to be statically allocated, +which means that the contents will not change before the next time +\fBTcl_Eval\fR is called or some other command procedure is invoked. +In this case, the \fIfreeProc\fR field must be zero. +Alternatively, a command procedure may dynamically +allocate its return value (e.g. using \fBmalloc\fR) +and store a pointer to it in \fIinterp->result\fR. +In this case, the command procedure must also set \fIinterp->freeProc\fR +to the address of a procedure that can free the value (usually \fBfree\fR). +If \fIinterp->freeProc\fR is non-zero, then Tcl will call \fIfreeProc\fR +to free the space pointed to by \fIinterp->result\fR before it +invokes the next command. +If a client procedure overwrites \fIinterp->result\fR when +\fIinterp->freeProc\fR is non-zero, then it is responsible for calling +\fIfreeProc\fR to free the old \fIinterp->result\fR (the \fBTcl_FreeResult\fR +macro should be used for this purpose). +.PP +\fIFreeProc\fR should have arguments and result that match the +\fBTcl_FreeProc\fR declaration above: it receives a single +argument which is a pointer to the result value to free. +In most applications \fBfree\fR is the only non-zero value ever +used for \fIfreeProc\fR. +However, an application may store a different procedure address +in \fIfreeProc\fR in order to use an alternate memory allocator +or in order to do other cleanup when the result memory is freed. +.PP +As part of processing each command, \fBTcl_Eval\fR initializes +\fIinterp->result\fR +and \fIinterp->freeProc\fR just before calling the command procedure for +the command. The \fIfreeProc\fR field will be initialized to zero, +and \fIinterp->result\fR will point to an empty string. Commands that +do not return any value can simply leave the fields alone. +Furthermore, the empty string pointed to by \fIresult\fR is actually +part of an array of \fBTCL_RESULT_SIZE\fR characters (approximately 200). +If a command wishes to return a short string, it can simply copy +it to the area pointed to by \fIinterp->result\fR. Or, it can use +the sprintf procedure to generate a short result string at the location +pointed to by \fIinterp->result\fR. +.PP +It is a general convention in Tcl-based applications that the result +of an interpreter is normally in the initialized state described +in the previous paragraph. +Procedures that manipulate an interpreter's result (e.g. by +returning an error) will generally assume that the result +has been initialized when the procedure is called. +If such a procedure is to be called after the result has been +changed, then \fBTcl_ResetResult\fR should be called first to +reset the result to its initialized state. +.PP +The \fIerrorLine\fR +field is valid only after \fBTcl_Eval\fR returns +a \fBTCL_ERROR\fR return code. In this situation the \fIerrorLine\fR +field identifies the line number of the command being executed when +the error occurred. The line numbers are relative to the command +being executed: 1 means the first line of the command passed to +\fBTcl_Eval\fR, 2 means the second line, and so on. +The \fIerrorLine\fR field is typically used in conjunction with +\fBTcl_AddErrorInfo\fR to report information about where an error +occurred. +\fIErrorLine\fR should not normally be modified except by \fBTcl_Eval\fR. + +.SH KEYWORDS +free, initialized, interpreter, malloc, result diff --git a/contrib/tcl/doc/LinkVar.3 b/contrib/tcl/doc/LinkVar.3 new file mode 100644 index 0000000..88937d8 --- /dev/null +++ b/contrib/tcl/doc/LinkVar.3 @@ -0,0 +1,116 @@ +'\" +'\" Copyright (c) 1993 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: @(#) LinkVar.3 1.12 96/03/25 20:04:31 +'\" +.so man.macros +.TH Tcl_LinkVar 3 7.5 Tcl "Tcl Library Procedures" +.BS +.SH NAME +Tcl_LinkVar, Tcl_UnlinkVar, Tcl_UpdateLinkedVar \- link Tcl variable to C variable +.SH SYNOPSIS +.nf +\fB#include <tcl.h>\fR +.sp +int +\fBTcl_LinkVar\fR(\fIinterp, varName, addr, type\fR) +.sp +\fBTcl_UnlinkVar\fR(\fIinterp, varName\fR) +.sp +.VS +\fBTcl_UpdateLinkedVar\fR(\fIinterp, varName\fR) +.VE +.SH ARGUMENTS +.AS Tcl_Interp writable +.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. +.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, +TCL_LINK_BOOLEAN, or TCL_LINK_STRING, optionally OR'ed with +TCL_LINK_READ_ONLY to make Tcl variable read-only. +.BE + +.SH DESCRIPTION +.PP +\fBTcl_LinkVar\fR uses variable traces to keep the Tcl variable +named by \fIvarName\fR in sync with the C variable at the address +given by \fIaddr\fR. +Whenever the Tcl variable is read the value of the C variable will +be returned, and whenever the Tcl variable is written the C +variable will be updated to have the same value. +\fBTcl_LinkVar\fR normally returns TCL_OK; if an error occurs +while setting up the link (e.g. because \fIvarName\fR is the +name of array) then TCL_ERROR is returned and \fIinterp->result\fR +contains an error message. +.PP +The \fItype\fR argument specifies the type of the C variable, +and must have one of the following values, optionally OR'ed with +TCL_LINK_READ_ONLY: +.TP +\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 +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 +non-real values into \fIvarName\fR will be rejected with +Tcl errors. +.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''; +otherwise it will read from Tcl as ``1''. +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 +non-boolean values into \fIvarName\fR will be rejected with +Tcl errors. +.TP +\fBTCL_LINK_STRING\fR +The C variable is of type \fBchar *\fR. +If its value is not null then it must be a pointer to a string +allocated with \fBmalloc\fR. +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 +new value. +If the C variable contains a null pointer then the Tcl variable +will read as ``NULL''. +.PP +If the TCL_LINK_READ_ONLY flag is present in \fItype\fR then the +variable will be read-only from Tcl, so that its value can only be +changed by modifying the C variable. +Attempts to write the variable from Tcl will be rejected with errors. +.PP +\fBTcl_UnlinkVar\fR removes the link previously set up for the +variable given by \fIvarName\fR. If there does not exist a link +for \fIvarName\fR then the procedure has no effect. +.PP +.VS +\fBTcl_UpdateLinkedVar\fR may be invoked after the C variable has +changed to force the Tcl variable to be updated immediately. +In many cases this procedure is not needed, since any attempt to +read the Tcl variable will return the latest value of the C variable. +However, if a trace has been set on the Tcl variable (such as a +Tk widget that wishes to display the value of the variable), the +trace will not trigger when the C variable has changed. +\fBTcl_UpdateLinkedVar\fR ensures that any traces on the Tcl +variable are invoked. +.VE + +.SH KEYWORDS +boolean, integer, link, read-only, real, string, traces, variable diff --git a/contrib/tcl/doc/Notifier.3 b/contrib/tcl/doc/Notifier.3 new file mode 100644 index 0000000..fea97e0 --- /dev/null +++ b/contrib/tcl/doc/Notifier.3 @@ -0,0 +1,366 @@ +'\" +'\" Copyright (c) 1995-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: @(#) Notifier.3 1.10 96/03/28 09:38:26 +'\" +.so man.macros +.TH Tcl_CreateEventSource 3 7.5 Tcl "Tcl Library Procedures" +.BS +.SH NAME +Tcl_CreateEventSource, Tcl_DeleteEventSource, Tcl_WatchFile, Tcl_FileReady, Tcl_SetMaxBlockTime, Tcl_QueueEvent, Tcl_WaitForEvent \- Event sources, the event notifier, and the event queue +.SH SYNOPSIS +.nf +\fB#include <tcl.h>\fR +.sp +\fBTcl_CreateEventSource(\fIsetupProc, checkProc, clientData\fB)\fR +.sp +\fBTcl_DeleteEventSource(\fIsetupProc, checkProc, clientData\fB)\fR +.sp +\fBTcl_WatchFile(\fIfile, mask\fB)\fR +.sp +\fBTcl_SetMaxBlockTime(\fItimePtr\fB)\fR +.sp +int +\fBTcl_FileReady(\fIfile, mask\fB)\fR +.sp +\fBTcl_QueueEvent(\fIevPtr, position\fB)\fR +.sp +int +\fBTcl_WaitForEvent(\fItimePtr\fB)\fR +.SH ARGUMENTS +.AS Tcl_EventSetupProc *setupProc +.AP Tcl_EventSetupProc *setupProc in +Procedure to invoke to prepare for event wait in \fBTcl_DoWhenIdle\fR. +.AP Tcl_EventCheckProc *checkProc in +Procedure for \fBTcl_DoWhenIdle\fR to invoke after waiting for +events. Checks to see if any events have occurred and, if so, +queues them. +.AP ClientData clientData in +Arbitrary one-word value to pass to \fIsetupProc\fR and \fIcheckProc\fR. +.AP Tcl_File file in +Generic file handle as returned by \fBTcl_GetFile\fR. +.AP int mask in +Indicates the events of interest on \fIfile\fR: an OR'ed combination +of \fBTCL_READABLE\fR, \fBTCL_WRITABLE\fR, and \fBTCL_EXCEPTION\fR. +.AP Tcl_Time *timePtr in +Indicates the maximum amount of time to wait for an event. This +is specified as an interval (how long to wait), not an absolute +time (when to wakeup). If the pointer passed to \fBTcl_WaitForEvent\fR +is NULL, it means there is no maximum wait time: wait forever if +necessary. +.AP Tcl_Event *evPtr in +An event to add to the event queue. The storage for the event must +have been allocated by the caller using \fBmalloc\fR or \fBckalloc\fR. +.AP Tcl_QueuePosition position in +Where to add the new event in the queue: \fBTCL_QUEUE_TAIL\fR, +\fBTCL_QUEUE_HEAD\fR, or \fBTCL_QUEUE_MARK\fR. +.AP int flags in +A copy of the \fIflags\fR argument passed to \fBTcl_DoOneEvent\fR. +.BE + +.SH INTRODUCTION +.PP +The procedures described here are the building blocks out of which +the Tcl event notifier is constructed. The event notifier is the +lowest layer in the Tcl event mechanism. It consists of three +things: +.IP [1] +Event sources: these represent the ways in which events can be +generated. For example, there is a timer event source that implements +the \fBTcl_CreateTimerHandler\fR procedure and the \fBafter\fR command, +and there is a file event source that implements the +\fBTcl_CreateFileHandler\fR procedure. An event source must work +with the notifier to detect events at the right times, record them +on the event queue, and eventually notify higher-level software that +they have occurred. +.IP [2] +The event queue: there is a single queue for the whole application, +containing events that have been detected but not yet serviced. +The event queue guarantees a fair discipline of event handling, so +that no event source can starve the others. It also allows events +to be saved for servicing at a future time. +.IP [3] +The procedure \fBTcl_DoOneEvent\fR: this is procedure that is invoked +by the application to service events. It works with the event sources +and the event queue to detect and handle events, and calls +\fBTcl_WaitForEvent\fR to actually wait for an event to occur. +.PP +The easiest way to understand how the notifier works is to consider +what happens when \fBTcl_DoOneEvent\fR is called. +\fBTcl_DoOneEvent\fR is passed a \fIflags\fR +argument that indicates what sort of events it is OK to process and +also whether or not to block if no events are ready. +\fBTcl_DoOneEvent\fR does the following things: +.IP [1] +Check the event queue to see if it contains any events that can +be serviced. If so, service the first possible event, remove it +from the queue, and return. +.IP [2] +Prepare to block for an event. To do this, \fBTcl_DoOneEvent\fR +invokes a \fIsetup procedure\fR in each event source. +The event source will call procedures like \fBTcl_WatchFile\fR and +\fBTcl_SetMaxBlockTime\fR to indicate what low-level events to look +for in \fBTcl_WaitForEvent\fR. +.IP [3] +Call \fBTcl_WaitForEvent\fR. This procedure is implemented differently +on different platforms; it waits for an event to occur, based on the +information provided by the event sources. +It may cause the application to block if \fItimePtr\fR specifies +an interval other than 0. +\fBTcl_WaitForEvent\fR returns when something has happened, +such as a file becoming readable or the interval given by \fItimePtr\fR +expiring. If there are no events for \fBTcl_WaitForEvent\fR to +wait for, so that it would block forever, then it returns immediately +and \fBTcl_DoOneEvent\fR returns 0. +.IP [4] +Call a \fIcheck procedure\fR in each event source. The check +procedure determines whether any events of interest to this source +occurred (e.g. by calling \fBTcl_FileReady\fR). If so, +the events are added to the event queue. +.IP [5] +Check the event queue to see if it contains any events that can +be serviced. If so, service the first possible event, remove it +from the queue, and return. +.IP [6] +See if there are idle callbacks pending. +If so, invoke all of them and return. +.IP [7] +Either return 0 to indicate that no events were ready, or go back to +step [2] if blocking was requested by the caller. +.PP +The procedures in this file allow you to do two things. First, they +allow you to create new event sources, such as one for UNIX signals +or one to notify when subprocesses have exited. Second, the procedures +can be used to build a new version of \fBTcl_DoOneEvent\fR. This +might be necessary to support a new operating system with different +low-level event reporting mechanisms, or it might be necessary to +merge Tcl's event loop with that of some other toolkit like Xt. + +.SH "CREATING A NEW EVENT SOURCE" +.PP +An event source consists of three procedures invoked by the notifier, +plus additional C procedures that are invoked by higher-level code +to arrange for event-driven callbacks. The three procedures called +by the notifier consist of the setup and check procedures described +above, plus an additional procedure that is invoked when an event +is removed from the event queue for servicing. +.PP +The procedure \fBTcl_CreateEventSource\fR creates a new event source. +Its arguments specify the setup procedure and check procedure for +the event source. +\fISetupProc\fR should match the following prototype: +.CS +typedef void Tcl_EventSetupProc( + ClientData \fIclientData\fR, + int \fIflags\fR); +.CE +The \fIclientData\fR argument will be the same as the \fIclientData\fR +argument to \fBTcl_CreateEventSource\fR; it is typically used to +point to private information managed by the event source. +The \fIflags\fR argument will be the same as the \fIflags\fR +argument passed to \fBTcl_DoOneEvent\fR except that it will never +by 0 (\fBTcl_DoOneEvent\fR replaces 0 with \fBTCL_ALL_EVENTS\fR). +\fIFlags\fR indicates what kinds of events should be considered; +if the bit corresponding to this event source isn't set, the event +source should return immediately without doing anything. For +example, the file event source checks for the \fBTCL_FILE_EVENTS\fR +bit. +.PP +\fISetupProc\fR's job is to provide information to +\fBTcl_WaitForEvent\fR about how to wait for events. +It usually does this by calling \fBTcl_WatchFile\fR or +\fBTcl_SetMaxBlockTime\fR. +For example, \fIsetupProc\fR can call \fBTcl_WatchFile\fR to indicate +that \fBTcl_WaitForEvent\fR should return when the conditions +given by the \fImask\fR argument become true for the file given +by \fIfile\fR. +The UNIX version of \fBTcl_WaitForEvent\fR uses the +information passed to \fBTcl_WatchFile\fR to set the file masks +for \fBselect\fR, which it uses to wait for events. +If \fBTcl_WatchFile\fR isn't called by any event sources then +\fBTcl_WaitForEvent\fR will ignore files while waiting. +.PP +\fISetupProc\fR can also invoke \fBTcl_SetMaxBlockTime\fR to set an +upper bound on how long \fBTcl_WaitForEvent\fR will block. +If no event source calls \fBTcl_SetMaxBlockTime\fR then +\fBTcl_WaitForEvent\fR will wait as long as necessary for an event +to occur; otherwise, it will only wait as long as the shortest +interval passed to \fBTcl_SetMaxBlockTime\fR by one of the event +sources. +For example, the timer event source uses this procedure to limit the +wait time to the interval before the next timer event is ready. +If an event source knows that it already has events ready to report, +it can request a zero maximum block time. +The \fItimePtr\fR argument to \fBTcl_WaitForEvent\fR points to +a structure that describes a time interval in seconds and +microseconds: +.CS +typedef struct Tcl_Time { + long \fIsec\fR; + long \fIusec\fR; +} Tcl_Time; +.CE +The \fIusec\fR field should be less than 1000000. +.PP +Information provided to \fBTcl_WatchFile\fR and \fBTcl_SetMaxBlockTime\fR +is only used for the next call to \fBTcl_WaitForEvent\fR; it is +discarded after \fBTcl_WaitForEvent\fR returns. +The next time an event wait is done each of the event sources' +setup procedures will be called again, and they can specify new +information for that event wait. +.PP +In addition to the generic procedures \fBTcl_WatchFile\fR and +\fBTcl_SetMaxBlockTime\fR, other platform-specific procedures may +also be available for \fIsetupProc\fR, if there is additional +information needed by \fBTcl_WaitForEvent\fR on that platform. +.PP +The second procedure provided by each event source is its check +procedure, indicated by the \fIcheckProc\fR argument to +\fBTcl_CreateEventSource\fR. \fICheckProc\fR must match the +following prototype: +.CS +typedef void Tcl_EventCheckProc( + ClientData \fIclientData\fR, + int \fIflags\fR); +.CE +The arguments to this procedure are the same as those for \fIsetupProc\fR. +\fBCheckProc\fR is invoked by \fBTcl_DoOneEvent\fR after it has waited +for events. Presumably at least one event source is now prepared to +queue an event. \fBTcl_DoOneEvent\fR calls each of the event sources +in turn, so they all have a chance to queue any events that are ready. +The check procedure does two things. First, it must see if any events +have triggered. Different event sources do this in different ways, +but the procedure \fBTcl_FileReady\fR may be useful for some event +sources. It takes as arguments a file identifier \fIfile\fR and +a mask of interesting conditions; it returns another mask indicating +which of those conditions were found to be present on the file during +the most recent call to \fBTcl_WaitForEvent\fR. +\fBTcl_WaitForEvent\fR only checks a file if \fBTcl_WatchFile\fR was +called by at least one event source, so it is possible for +\fBTcl_FileReady\fR to return 0 even if the file is ready. +.PP +If an event source's check procedure detects that an interesting +event has occurred, then it must add the event to Tcl's event queue. +To do this, the event source calls \fBTcl_QueueEvent\fR. +The \fIevPtr\fR argument is a pointer to a dynamically allocated +structure containing the event (see below for more information +on memory management issues). +Each event source can define its own event structure with +whatever information is relevant to that event source. +However, the first element of the structure must be a structure +of type \fBTcl_Event\fR, and the address of this structure is used when +communicating between the event source and the rest of the notifier. +A \fBTcl_Event\fR has the following definition: +.CS +typedef struct Tcl_Event { + Tcl_EventProc *\fIproc\fR; + struct Tcl_Event *\fInextPtr\fR; +}; +.CE +The event source must fill in the \fIproc\fR field of +the event before calling \fBTcl_QueueEvent\fR. +The \fInextPtr\fR is used to link together the events in the queue +and should not be modified by the event source. +.PP +An event may be added to the queue at any of three positions, depending +on the \fIposition\fR argument to \fBTcl_QueueEvent\fR: +.IP \fBTCL_QUEUE_TAIL\fR 24 +Add the event at the back of the queue, so that all other pending +events will be serviced first. This is almost always the right +place for new events. +.IP \fBTCL_QUEUE_HEAD\fR 24 +Add the event at the front of the queue, so that it will be serviced +before all other queued events. +.IP \fBTCL_QUEUE_MARK\fR 24 +Add the event at the front of the queue, unless there are other +events at the front whose position is \fBTCL_QUEUE_MARK\fR; if so, +add the new event just after all other \fBTCL_QUEUE_MARK\fR events. +This value of \fIposition\fR is used to insert an ordered sequence of +events at the front of the queue, such as a series of +Enter and Leave events synthesized during a grab or ungrab operation +in Tk. +.PP +When it is time to handle an event from the queue (steps 1 and 5 +above) \fBTcl_DoOneEvent\fR will invoke the \fIproc\fR specified +in the first queued \fBTcl_Event\fR structure. +\fIProc\fR must match the following prototype: +.CS +typedef int Tcl_EventProc( + Tcl_Event *\fIevPtr\fR, + int \fIflags\fR); +.CE +The first argument to \fIproc\fR is a pointer to the event, which will +be the same as the first argument to the \fBTcl_QueueEvent\fR call that +added the event to the queue. +The second argument to \fIproc\fR is the \fIflags\fR argument for the +current call to \fBTcl_DoOneEvent\fR; this is used by the event source +to return immediately if its events are not relevant. +.PP +It is up to \fIproc\fR to handle the event, typically by invoking +one or more Tcl commands or C-level callbacks. +Once the event source has finished handling the event it returns 1 +to indicate that the event can be removed from the queue. +If for some reason the event source decides that the event cannot +be handled at this time, it may return 0 to indicate that the event +should be deferred for processing later; in this case \fBTcl_DoOneEvent\fR +will go on to the next event in the queue and attempt to service it. +There are several reasons why an event source might defer an event. +One possibility is that events of this type are excluded by the +\fIflags\fR argument. +For example, the file event source will always return 0 if the +\fBTCL_FILE_EVENTS\fR bit isn't set in \fIflags\fR. +Another example of deferring events happens in Tk if +\fBTk_RestrictEvents\fR has been invoked to defer certain kinds +of window events. +.PP +When \fIproc\fR returns 1, \fBTcl_DoOneEvent\fR will remove the +event from the event queue and free its storage. +Note that the storage for an event must be allocated by +the event source (using \fBmalloc\fR or the Tcl macro \fBckalloc\fR) +before calling \fBTcl_QueueEvent\fR, but it +will be freed by \fBTcl_DoOneEvent\fR, not by the event source. + +.SH "CREATING A NEW NOTIFIER" +.PP +The notifier consists of all the procedures described in this +manual entry, plus \fBTcl_DoOneEvent\fR and \fBTcl_Sleep\fR. +Most of these procedures are generic, in that they are the +same for all platforms. However, four of the procedures are +platform-dependent: \fBTcl_WatchFile\fR, +\fBTcl_FileReady\fR, \fBTcl_WaitForEvent\fR, and \fBTcl_Sleep\fR. +To support a new platform, you must write new versions of these +procedures. +\fBTcl_WatchFile\fR and \fBTcl_FileReady\fR have already been +described previously in this document, and \fBTcl_Sleep\fR +is described in its own manual entry. +.PP +\fBTcl_WaitForEvent\fR is the lowest-level procedure in the +notifier; it is responsible for waiting for an ``interesting'' +event to occur or for a given time to elapse. +Before \fBTcl_WaitForEvent\fR is invoked, each of the event +sources' setup procedure will have been invoked; the setup +procedures will have provided information about what to wait +for by invoking procedures like \fBTcl_WatchFile\fR. +The \fItimePtr\fR argument to \fBTcl_WaitForEvent\fR gives +the maximum time to block for an event, based on calls to +\fBTcl_SetMaxBlockTime\fR made by setup procedures and +on other information (such as the \fBTCL_DONT_WAIT\fR bit in \fIflags\fR). +\fBTcl_WaitForEvent\fR uses information saved by \fBTcl_WatchFile\fR, +plus the \fItimePtr\fR argument to decide what to wait for +and how long to block. +It returns TCL_OK as soon as one of the specified events has occurred +or the given amount of time has elapsed. +However, if there are no event handlers (neither \fBTcl_WatchFile\fR nor +\fBTcl_SetMaxBlockTime\fR has been called since the last call to +\fBTcl_WaitForEvent\fR), so that the procedure would block forever, +then it returns immediately with a result of TCL_ERROR. +.PP +The easiest way to create a new notifier is to look at the code +for an existing notifier, such as the files \fBgeneric/tclNotify.c\fR +and \fBunix/tclUnixNotfy.c\fR. + +.SH KEYWORDS +block time, event notifier, event queue, event sources, file events diff --git a/contrib/tcl/doc/OpenFileChnl.3 b/contrib/tcl/doc/OpenFileChnl.3 new file mode 100644 index 0000000..c17cc64 --- /dev/null +++ b/contrib/tcl/doc/OpenFileChnl.3 @@ -0,0 +1,441 @@ +'\" +'\" Copyright (c) 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: @(#) OpenFileChnl.3 1.27 96/03/22 14:55:07 +.so man.macros +.TH Tcl_OpenFileChannel 3 7.5 Tcl "Tcl Library Procedures" +.BS +'\" Note: do not modify the .SH NAME line immediately below! +.SH NAME +Tcl_OpenFileChannel, Tcl_OpenCommandChannel, Tcl_Close, Tcl_Read, Tcl_Gets, Tcl_Write, Tcl_Flush, Tcl_Seek, Tcl_Tell, Tcl_Eof, Tcl_InputBlocked, Tcl_GetChannelOption, Tcl_SetChannelOption \- 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) +.sp +Tcl_Channel +\fBTcl_MakeFileChannel\fR(\fIinOsFile, outOsFile, readOrWrite\fR) +.sp +Tcl_Channel +\fBTcl_GetChannel\fR(\fIinterp, channelName, modePtr\fR) +.sp +void +\fBTcl_RegisterChannel\fR(\fIinterp, channel\fR) +.sp +int +\fBTcl_UnregisterChannel\fR(\fIinterp, channel\fR) +.sp +int +\fBTcl_Close\fR(\fIinterp, channel\fR) +.sp +int +\fBTcl_Read\fR(\fIchannel, buf, toRead\fR) +.sp +int +\fBTcl_Gets\fR(\fIchannel, lineRead\fR) +.sp +int +\fBTcl_Write\fR(\fIchannel, buf, toWrite\fR) +.sp +int +\fBTcl_Flush\fR(\fIchannel\fR) +.sp +int +\fBTcl_Seek\fR(\fIchannel, offset, seekMode\fR) +.sp +int +\fBTcl_Tell\fR(\fIchannel\fR) +.sp +int +\fBTcl_GetChannelOption\fR(\fIchannel, optionName, optionValue\fR) +.sp +int +\fBTcl_SetChannelOption\fR(\fIinterp, channel, optionName, newValue\fR) +.sp +int +\fBTcl_Eof\fR(\fIchannel\fR) +.sp +int +\fBTcl_InputBlocked\fR(\fIchannel\fR) +.sp +int +\fBTcl_InputBuffered\fR(\fIchannel\fR) +.sp +.SH ARGUMENTS +.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 +The name of a local or network file. +.AP 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. +.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 +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 +Specifies the disposition of the stdio handles in pipeline: OR-ed +combination of \fBTCL_STDIN\fR, \fBTCL_STDOUT\fR, \fBTCL_STDERR\fR, +and \fBTCL_ENFORCE_MODE\fR. If \fBTCL_STDIN\fR is set, stdin for +the first child in the pipe is the pipe channel, otherwise it is the same +as the standard input of the invoking process; likewise for +\fBTCL_STDOUT\fR and \fBTCL_STDERR\fR. If \fBTCL_ENFORCE_MODE\fR is not set, +then the pipe can 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. +.AP ClientData inOsFile in +Operating system specific handle for input from a file. For Unix this is a +file descriptor, for Windows it is a HANDLE, etc. +.AP ClientData outOsFile in +Operating system specific handle for output to a file. +.AP int readOrWrite in +OR-ed combination of \fBTCL_READABLE\fR and \fBTCL_WRITABLE\fR to indicate +which of \fIinOsFile\fR and \fIoutOsFile\fR contains a valid value. +.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. +.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. +.AP char *buf in +An array of bytes in which to store channel input, or from which +to read channel output. +.AP int toRead in +The number of bytes to read from the channel. +.AP Tcl_DString *lineRead in +A pointer to a Tcl dynamic string in which to store the line read from the +channel. Must have been initialized by the caller. +.AP int toWrite in +The number of bytes to read from \fIbuf\fR and output to the channel. +.AP int offset in +How far to move the access point in the channel at which the next input or +output operation will be applied, measured in bytes from the position +given by \fIseekMode\fR. May be either positive or negative. +.AP int seekMode in +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 +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 +New value for the option given by \fIoptionName\fR. +.BE + +.SH DESCRIPTION +.PP +The Tcl channel mechanism provides a device-independent and +platform-independent mechanism for performing buffered input +and output operations on a variety of file, socket, and device +types. +The channel mechanism is extensible to new channel types, by +providing a low level channel driver for the new type; the channel driver +interface is described in the manual entry for \fBTcl_CreateChannel\fR. The +channel mechanism provides a buffering scheme modelled after +Unix's standard I/O, and it also allows for nonblocking I/O on +channels. +.PP +The procedures described in this manual entry comprise the C APIs of the +generic layer of the channel architecture. For a description of the channel +driver architecture and how to implement channel drivers for new types of +channels, see the manual entry for \fBTcl_CreateChannel\fR. + +.SH TCL_OPENFILECHANNEL +.PP +\fBTcl_OpenFileChannel\fR opens a file specified by \fIfileName\fR and +returns a channel handle that can be used to perform input and output on +the file. This API is modelled after the \fBfopen\fR procedure of +the Unix standard I/O library. +The syntax and meaning of all arguments is similar to those +given in the Tcl \fBopen\fR command when opening a file. +If an error occurs while opening the channel, \fBTcl_OpenFileChannel\fR +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->result\fR after any error. + +.SH TCL_OPENCOMMANDCHANNEL +.PP +\fBTcl_OpenCommandChannel\fR provides a C-level interface to the +functions of the \fBexec\fR and \fBopen\fR commands. +It creates a sequence of subprocesses specified +by the \fIargv\fR and \fIargc\fR arguments and returns a channel that can +be used to communicate with these subprocesses. +The \fIflags\fR argument indicates what sort of communication will +exist with the command pipeline. +.PP +If the \fBTCL_STDIN\fR flag is set then the standard input for the +first subprocess will be tied to the channel: writing to the channel +will provide input to the subprocess. If \fBTCL_STDIN\fR is not set, +then standard input for the first subprocess will be the same as this +application's standard input. If \fBTCL_STDOUT\fR is set then +standard output from the last subprocess can be read from the channel; +otherwise it goes to this application's standard output. If +\fBTCL_STDERR\fR is set, standard error output for all subprocesses is +returned to the channel and results in an error when the channel is +closed; otherwise it goes to this application's standard error. If +\fBTCL_ENFORCE_MODE\fR is not set, then \fIargc\fR and \fIargv\fR can +redirect the stdio handles to override \fBTCL_STDIN\fR, +\fBTCL_STDOUT\fR, and \fBTCL_STDERR\fR; if it is set, then it is an +error for argc and argv to override stdio channels for which +\fBTCL_STDIN\fR, \fBTCL_STDOUT\fR, and \fBTCL_STDERR\fR have been set. +.PP +If an error occurs while opening the channel, \fBTcl_OpenCommandChannel\fR +returns NULL and records a POSIX error code that can be retrieved with +\fBTcl_GetErrno\fR. +In addition, \fBTcl_OpenCommandChannel\fR leaves an error message in +\fIinterp->result\fR if \fIinterp\fR is not NULL. + +.SH TCL_MAKEFILECHANNEL +.PP +\fBTcl_MakeFileChannel\fR makes a \fBTcl_Channel\fR from an existing, +platform-specific, file handle. + +.SH TCL_GETCHANNEL +.PP +\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 +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. + +.SH TCL_REGISTERCHANNEL +.PP +\fBTcl_RegisterChannel\fR adds a channel to the set of channels accessible +in \fIinterp\fR. After this call, Tcl programs executing in that +interpreter can refer to the channel in input or output operations using the +name given in the call to \fBTcl_CreateChannel\fR. +After this call the channel becomes the property of the interpreter. +The caller should not call \fBTcl_Close\fR for the channel; the +channel will be closed automatically when it is unregistered from +the interpreter. +Furthermore, it is not generally safe to reference the channel +anymore, since it could be deleted at any time by a \fBclose\fR +command in the interpreter. + +.SH TCL_UNREGISTERCHANNEL +.PP +\fBTcl_UnregisterChannel\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. If this operation removed the last registration of the channel +in any interpreter, the channel is also closed and destroyed. + +.SH TCL_CLOSE +.PP +\fBTcl_Close\fR destroys the channel \fIchannel\fR, which must denote a +currently open channel. +The channel should not be registered in any interpreter when +\fBTcl_Close\fR is called; see the manual entry for \fBTcl_CreateChannel\fR +for a description of \fBTcl_RegisterChannel\fR and \fBTcl_UnregisterChannel\fR. +Buffered output is flushed to the channel's output device prior to +destroying the channel, and any buffered input is discarded. +If this is a blocking channel, the call does not return until all +buffered data is successfully sent to the channel's output device. +If this is a nonblocking channel and there is buffered output that +cannot be written without blocking, the call +returns immediately; output is flushed in the background and +the channel will be closed once all of the buffered data has +been output. +In this case errors during flushing are not reported. +.PP +If the channel was closed successfully, \fBTcl_Close\fR returns \fBTCL_OK\fR. +If an error occurs, \fBTcl_Close\fR returns \fBTCL_ERROR\fR and records a +POSIX error code that can be retrieved with \fBTcl_GetErrno\fR. +If the channel is being closed synchronously and an error occurs during +closing of the channel and \fIinterp\fR is not NULL, an error message is +left in \fIinterp->result\fR. +.PP +Note: it is not safe to call \fBTcl_Close\fR on a channel that has +been registered in an interpreter using \fBTcl_RegisterChannel\fR; +see the documentation for \fBTcl_RegisterChannel\fR for details. + +.SH TCL_READ +.PP +\fBTcl_Read\fR consumes up to \fItoRead\fR bytes of data from +\fIchannel\fR and stores it at \fIbuf\fR. +The return value of \fBTcl_Read\fR is the number of characters written +at \fIbuf\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. +If an error occurs, the return value is -1 and \fBTcl_Read\fR records +a POSIX error code that can be retrieved with \fBTcl_GetErrno\fR. +.PP +The return value may be smaller than the value of \fItoRead\fR, indicating +that less data than requested was available, also called a \fIshort +read\fR. +In blocking mode, this can only happen on an end-of-file. +In nonblocking mode, a short read can also occur if there is not +enough input currently available: \fBTcl_Read\fR returns a short +count rather than waiting for more data. +.PP +If the channel is in blocking mode, a return value of zero indicates an end +of file condition. If the channel is in nonblocking mode, a return value of +zero indicates either that no input is currently available or an end of +file condition. Use \fBTcl_Eof\fR and \fBTcl_InputBlocked\fR +to tell which of these conditions actually occurred. +.PP +\fBTcl_Read\fR translates platform-specific end-of-line representations +into the canonical \fB\en\fR internal representation according to the +current end-of-line recognition mode. End-of-line recognition and the +various platform-specific modes are described in the manual entry for the +Tcl \fBfconfigure\fR command. + +.SH TCL_GETS +.PP +\fBTcl_Gets\fR reads a line of input from a channel and appends all of +the characters of the line except for the terminating end-of-line character(s) +to the dynamic string given by \fIdsPtr\fR. +The end-of-line character(s) are read and discarded. +.PP +If a line was successfully read, the return value is greater than or +equal to zero, and it indicates the number of characters stored +in the dynamic string. +If an error occurs, \fBTcl_Gets\fR returns -1 and records a POSIX error +code that can be retrieved with \fBTcl_GetErrno\fR. +\fBTcl_Gets\fR also returns -1 if the end of the file is reached; +the \fBTcl_Eof\fR procedure can be used to distinguish an error +from an end-of-file condition. +.PP +If the channel is in nonblocking mode, the return value can also +be -1 if no data was available or the data that was available +did not contain an end-of-line character. +When -1 is returned, the \fBTcl_InputBlocked\fR procedure may be +invoked to determine if the channel is blocked because of input +unavailability. + +.SH TCL_WRITE +.PP +\fBTcl_Write\fR accepts \fItoWrite\fR bytes of data at \fIbuf\fR for output +on \fIchannel\fR. This data may not appear on the output device +immediately. If the data should appear immediately, call \fBTcl_Flush\fR +after the call to \fBTcl_Write\fR, or set the \fB-buffering\fR option on +the channel to \fBnone\fR. If you wish the data to appear as soon as an end +of line is accepted for output, set the \fB\-buffering\fR option on the +channel to \fBline\fR mode. +.PP +The \fItoWrite\fR argument specifies how many bytes of data are provided in +the \fIbuf\fR argument. If it is negative, \fBTcl_Write\fR expects the data +to be NULL terminated and it outputs everything up to the NULL. +.PP +The return value of \fBTcl_Write\fR is a count of how many +characters were accepted for output to the channel. This is either equal to +\fItoWrite\fR or -1 to indicate that an error occurred. +If an error occurs, \fBTcl_Write\fR also records a POSIX error code +that may be retrieved with \fBTcl_GetErrno\fR. +.PP +Newline characters in the output data are translated to platform-specific +end-of-line sequences according to the \fB\-translation\fR option for +the channel. + +.SH TCL_FLUSH +.PP +\fBTcl_Flush\fR causes all of the buffered output data for \fIchannel\fR +to be written to its underlying file or device as soon as possible. +If the channel is in blocking mode, the call does not return until +all the buffered data has been sent to the channel or some error occurred. +The call returns immediately if the channel is nonblocking; it starts +a background flush that will write the buffered data to the channel +eventually, as fast as the channel is able to absorb it. +.PP +The return value is normally \fBTCL_OK\fR. +If an error occurs, \fBTcl_Flush\fR returns \fBTCL_ERROR\fR and +records a POSIX error code that can be retrieved with \fBTcl_GetErrno\fR. + +.SH TCL_SEEK +.PP +\fBTcl_Seek\fR moves the access point in \fIchannel\fR where subsequent +data will be read or written. Buffered output is flushed to the channel and +buffered input is discarded, prior to the seek operation. +.PP +\fBTcl_Seek\fR normally returns the new access point. +If an error occurs, \fBTcl_Seek\fR returns -1 and records a POSIX error +code that can be retrieved with \fBTcl_GetErrno\fR. +After an error, the access point may or may not have been moved. + +.SH TCL_TELL +.PP +\fBTcl_Tell\fR returns the current access point for a channel. The returned +value is -1 if the channel does not support seeking. + +.SH TCL_GETCHANNELOPTION +.PP +\fBTcl_GetChannelOption\fR retrieves, in \fIdsPtr\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. +If \fIoptionName\fR is not NULL, it is the name of the +option to query; the option's value is copied to the Tcl dynamic string +denoted by \fIoptionValue\fR. If +\fIoptionName\fR is NULL, the function stores an alternating list of option +names and their values in \fIoptionValue\fR, using a series of calls to +\fBTcl_DStringAppendElement\fR. The various preexisting options and +their possible values are described in the manual entry for the Tcl +\fBfconfigure\fR command. Other options can be added by each channel type. +These channel type specific options are described in the manual entry for +the Tcl command that creates a channel of that type; for example, the +additional options for TCP based channels are described in the manual entry +for the Tcl \fBsocket\fR command. +The procedure normally returns \fBTCL_OK\fR. If an error occurs, it returns +\fBTCL_ERROR\fR and calls \fBTcl_SetErrno\fR to store an appropriate POSIX +error code. + +.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. +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 \fIinterp->result\fR. + +.SH TCL_EOF +.PP +\fBTcl_Eof\fR returns a nonzero value if \fIchannel\fR encountered +an end of file during the last input operation. + +.SH TCL_INPUTBLOCKED +.PP +\fBTcl_InputBlocked\fR returns a nonzero value if \fIchannel\fR is in +nonblocking mode and the last input operation returned less data than +requested because there was insufficient data available. +The call always returns zero if the channel is in blocking mode. + +.SH TCL_INPUTBUFFERED +.PP +\fBTcl_InputBuffered\fR returns the number of bytes of input currently +buffered in the internal buffers for a channel. If the channel is not open +for reading, this function always returns zero. + +.SH "SEE ALSO" +DString(3), fconfigure(n), filename(n), fopen(2), Tcl_CreateChannel(3) + +.SH KEYWORDS +access point, blocking, buffered I/O, channel, channel driver, end of file, +flush, input, nonblocking, output, read, seek, write diff --git a/contrib/tcl/doc/OpenTcp.3 b/contrib/tcl/doc/OpenTcp.3 new file mode 100644 index 0000000..3f6d1d3 --- /dev/null +++ b/contrib/tcl/doc/OpenTcp.3 @@ -0,0 +1,152 @@ +'\" +'\" Copyright (c) 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: @(#) OpenTcp.3 1.16 96/03/17 09:51:18 +.so man.macros +.TH Tcl_OpenTcpClient 3 7.5 Tcl "Tcl Library Procedures" +.BS +'\" Note: do not modify the .SH NAME line immediately below! +.SH NAME +Tcl_OpenTcpClient, Tcl_OpenTcpServer \- procedures to open channels using TCP sockets +.SH SYNOPSIS +.nf +\fB#include <tcl.h> \fR +.sp +Tcl_Channel +\fBTcl_OpenTcpClient\fR(\fIinterp, port, host, myaddr, myport, async\fR) +.sp +Tcl_Channel +\fBTcl_MakeTcpClientChannel\fR(\fIsock\fR) +.sp +Tcl_Channel +\fBTcl_OpenTcpServer\fR(\fIinterp, port, myaddr, proc, clientData\fR) +.sp +.SH ARGUMENTS +.AS Tcl_ChannelType newClientProcPtr in +.AP Tcl_Interp *interp in +Tcl interpreter to use for error reporting. If non-NULL and an +error occurs, an error message is left in \fIinterp->result\fR. +.AP int port in +A port number to connect to as a client or to listen on as a server. +.AP 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 +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. +.AP int async in +If nonzero, the client socket is connected asynchronously to the server. +.AP ClientData sock in +Platform-specific handle for client TCP socket. +.AP Tcl_TcpAcceptProc *proc in +Pointer to a procedure to invoke each time a new connection is +accepted via the socket. +.AP ClientData clientData in +Arbitrary one-word value to pass to \fIproc\fR. +.BE + +.SH DESCRIPTION +.PP +These functions are convenience procedures for creating +channels that communicate over TCP sockets. +The operations on a channel +are described in the manual entry for \fBTcl_OpenFileChannel\fR. + +.SH TCL_OPENTCPCLIENT +.PP +\fBTcl_OpenTcpClient\fR opens a client TCP socket connected to a \fIport\fR +on a specific \fIhost\fR, and returns a channel that can be used to +communicate with the server. The host to connect to can be specified either +as a domain name style name (e.g. \fBwww.sunlabs.com\fR), or as a string +containing the alphanumeric representation of its four-byte address (e.g. +\fB127.0.0.1\fR). Use the string \fBlocalhost\fR to connect to a TCP socket on +the host on which the function is invoked. +.PP +The \fImyaddr\fR and \fImyport\fR arguments allow a client to specify an +address for the local end of the connection. If \fImyaddr\fR is NULL, then +an interface is chosen automatically by the operating system. +If \fImyport\fR is 0, then a port number is chosen at random by +the operating system. +.PP +If \fIasync\fR is zero, the call to \fBTcl_OpenTcpClient\fR returns only +after the client socket has either successfully connected to the server, or +the attempted connection has failed. +If \fIasync\fR is nonzero the socket is connected asynchronously and the +returned channel may not yet be connected to the server when the call to +\fBTcl_OpenTcpClient\fR returns. If the channel is in blocking mode and an +input or output operation is done on the channel before the connection is +completed or fails, that operation will wait until the connection either +completes successfully or fails. If the channel is in nonblocking mode, the +input or output operation will return immediately and a subsequent call to +\fBTcl_InputBlocked\fR on the channel will return nonzero. +.PP +The returned channel is opened for reading and writing. +If an error occurs in opening the socket, \fBTcl_OpenTcpClient\fR returns +NULL and records a POSIX error code that can be retrieved +with \fBTcl_GetErrno\fR. +In addition, if \fIinterp\fR is non-NULL, an error message +is left in \fIinterp->result\fR. + +.SH TCL_MAKETCPCLIENTCHANNEL +.PP +\fBTcl_MakeTcpClientChannel\fR creates a \fBTcl_Channel\fR around an +existing, platform specific, handle for a client TCP socket. + +.SH TCL_OPENTCPSERVER +.PP +\fBTcl_OpenTcpServer\fR opens a TCP socket on the local host on a specified +\fIport\fR and uses the Tcl event mechanism to accept requests from clients +to connect to it. The \fImyaddr\fP argument specifies the network interface. +If \fImyaddr\fP is NULL the special address INADDR_ANY should be used to +allow connections from any network interface. +Each time a client connects to this socket, Tcl creates a channel +for the new connection and invokes \fIproc\fR with information about +the channel. \fIProc\fR must match the following prototype: +.CS +typedef void Tcl_TcpAcceptProc( + ClientData \fIclientData\fR, + Tcl_Channel \fIchannel\fR, + char *\fIhostName\fR, + int \fIport\fP); +.CE +.PP +The \fIclientData\fR argument will be the same as the \fIclientData\fR +argument to \fBTcl_OpenTcpServer\fR, \fIchannel\fR will be the handle +for the new channel, \fIhostName\fR points to a string containing +the name of the client host making the connection, and \fIport\fP +will contain the client's port number. +The new channel +is opened for both input and output. +If \fIproc\fR raises an error, the connection is closed automatically. +\fIProc\fR has no return value, but if it wishes to reject the +connection it can close \fIchannel\fR. +.PP +\fBTcl_OpenTcpServer\fR normally returns a pointer to a channel +representing the server socket. +If an error occurs, \fBTcl_OpenTcpServer\fR returns NULL and +records a POSIX error code that can be retrieved with \fBTcl_GetErrno\fR. +In addition, if \fIinterp->result\fR is non-NULL, an error message +is left in \fIinterp->result\fR. +.PP +The channel returned by \fBTcl_OpenTcpServer\fR cannot be used for +either input or output. +It is simply a handle for the socket used to accept connections. +The caller can close the channel to shut down the server and disallow +further connections from new clients. +.PP +TCP server channels operate correctly only in applications that dispatch +events through \fBTcl_DoOneEvent\fR or through Tcl commands such as +\fBvwait\fR; otherwise Tcl will never notice that a connection request from +a remote client is pending. + +.SH "SEE ALSO" +Tcl_OpenFileChannel(3), vwait(n) + +.SH KEYWORDS +client, server, TCP diff --git a/contrib/tcl/doc/PkgRequire.3 b/contrib/tcl/doc/PkgRequire.3 new file mode 100644 index 0000000..62e2cd0 --- /dev/null +++ b/contrib/tcl/doc/PkgRequire.3 @@ -0,0 +1,59 @@ +'\" +'\" Copyright (c) 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: @(#) PkgRequire.3 1.4 96/02/15 20:03:16 +'\" +.so man.macros +.TH Tcl_PkgRequire 3 7.5 Tcl "Tcl Library Procedures" +.BS +.SH NAME +Tcl_PkgRequire, Tcl_PkgProvide \- package version control +.SH SYNOPSIS +.nf +\fB#include <tcl.h>\fR +.sp +char * +\fBTcl_PkgRequire\fR(\fIinterp, name, version, exact\fR) +.sp +int +\fBTcl_PkgProvide\fR(\fIinterp, name, version\fR) +.SH ARGUMENTS +.AS Tcl_FreeProc clientData +.AP Tcl_Interp *interp in +Interpreter where package is needed or available. +.AP char *name in +Name of package. +.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 newer versions than \fIversion\fR are also +acceptable as long as they have the same major version number +as \fIversion\fR. +.BE + +.SH DESCRIPTION +.PP +These procedures provide C-level interfaces to Tcl's package and +version management facilities. +\fBTcl_PkgRequire\fR is equivalent to the \fBpackage require\fR +command, and \fBTcl_PkgProvide\fR is equivalent to the +\fBpackage provide\fR command. +See the documentation for the Tcl commands for details on what these +procedures do. +If \fBTcl_PkgRequire\fR completes successfully it returns a pointer +to the version string for the version of the package that is provided +in the interpreter (which may be different than \fIversion\fR); if +an error occurs it returns NULL and leaves an error message in +\fIinterp->result\fR. +\fBTcl_PkgProvide\fR returns TCL_OK if it completes successfully; +if an error occurs it returns TCL_ERROR and leaves an error message +in \fIinterp->result\fR. + +.SH KEYWORDS +package, provide, require, version diff --git a/contrib/tcl/doc/Preserve.3 b/contrib/tcl/doc/Preserve.3 new file mode 100644 index 0000000..ade7f04 --- /dev/null +++ b/contrib/tcl/doc/Preserve.3 @@ -0,0 +1,100 @@ +'\" +'\" Copyright (c) 1990 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: @(#) Preserve.3 1.12 96/03/25 20:05:27 +'\" +.so man.macros +.TH Tcl_Preserve 3 7.5 Tcl "Tcl Library Procedures" +.BS +.SH NAME +Tcl_Preserve, Tcl_Release, Tcl_EventuallyFree \- avoid freeing storage while it's being used +.SH SYNOPSIS +.nf +\fB#include <tcl.h>\fR +.sp +\fBTcl_Preserve\fR(\fIclientData\fR) +.sp +\fBTcl_Release\fR(\fIclientData\fR) +.sp +\fBTcl_EventuallyFree\fR(\fIclientData, freeProc\fR) +.SH ARGUMENTS +.AS Tcl_FreeProc clientData +.AP ClientData clientData in +Token describing structure to be freed or reallocated. Usually a pointer +to memory for structure. +.AP Tcl_FreeProc *freeProc in +Procedure to invoke to free \fIclientData\fR. +.BE + +.SH DESCRIPTION +.PP +These three procedures help implement a simple reference count mechanism +for managing storage. They are designed to solve a problem +having to do with widget deletion, but are also useful in many other +situations. When a widget is deleted, its +widget record (the structure holding information specific to the +widget) must be returned to the storage allocator. +However, it's possible that the widget record is in active use +by one of the procedures on the stack at the time of the deletion. +This can happen, for example, if the command associated with a button +widget causes the button to be destroyed: an X event causes an +event-handling C procedure in the button to be invoked, which in +turn causes the button's associated Tcl command to be executed, +which in turn causes the button to be deleted, which in turn causes +the button's widget record to be de-allocated. +Unfortunately, when the Tcl command returns, the button's +event-handling procedure will need to reference the +button's widget record. +Because of this, the widget record must not be freed as part of the +deletion, but must be retained until the event-handling procedure has +finished with it. +In other situations where the widget is deleted, it may be possible +to free the widget record immediately. +.PP +\fBTcl_Preserve\fR and \fBTcl_Release\fR +implement short-term reference counts for their \fIclientData\fR +argument. +The \fIclientData\fR argument identifies an object and usually +consists of the address of a structure. +The reference counts guarantee that an object will not be freed +until each call to \fBTcl_Preserve\fR for the object has been +matched by calls to \fBTcl_Release\fR. +There may be any number of unmatched \fBTcl_Preserve\fR calls +in effect at once. +.PP +\fBTcl_EventuallyFree\fR is invoked to free up its \fIclientData\fR +argument. +It checks to see if there are unmatched \fBTcl_Preserve\fR calls +for the object. +If not, then \fBTcl_EventuallyFree\fR calls \fIfreeProc\fR immediately. +Otherwise \fBTcl_EventuallyFree\fR records the fact that \fIclientData\fR +needs eventually to be freed. +When all calls to \fBTcl_Preserve\fR have been matched with +calls to \fBTcl_Release\fR then \fIfreeProc\fR will be called by +\fBTcl_Release\fR to do the cleanup. +.PP +All the work of freeing the object is carried out by \fIfreeProc\fR. +\fIFreeProc\fR must have arguments and result that match the +type \fBTcl_FreeProc\fR: +.CS +typedef void Tcl_FreeProc(ClientData \fIclientData\fR); +.CE +The \fIclientData\fR argument to \fIfreeProc\fR will be the +same as the \fIclientData\fR argument to \fBTcl_EventuallyFree\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 +mechanism is intended only for short-term use (i.e. while procedures +are pending on the stack); it will not work efficiently as a +mechanism for long-term reference counts. +The implementation does not depend in any way on the internal +structure of the objects being freed; it keeps the reference +counts in a separate structure. + +.SH KEYWORDS +free, reference count, storage diff --git a/contrib/tcl/doc/PrintDbl.3 b/contrib/tcl/doc/PrintDbl.3 new file mode 100644 index 0000000..413e2b7 --- /dev/null +++ b/contrib/tcl/doc/PrintDbl.3 @@ -0,0 +1,45 @@ +'\" +'\" Copyright (c) 1989-1993 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: @(#) PrintDbl.3 1.6 96/03/25 20:05:45 +'\" +.so man.macros +.TH Tcl_PrintDouble 3 7.0 Tcl "Tcl Library Procedures" +.BS +.SH NAME +Tcl_PrintDouble \- Convert floating value to string +.SH SYNOPSIS +.nf +\fB#include <tcl.h>\fR +.sp +\fBTcl_PrintDouble\fR(\fIinterp, value, dst\fR) +.SH ARGUMENTS +.AS Tcl_Interp *interp +.AP Tcl_Interp *interp in +Interpreter that controls the conversion. +.AP double value in +Floating-point value to be converted. +.AP char *dst out +Where to store string representing \fIvalue\fR. Must have at +least TCL_DOUBLE_SPACE characters of storage. +.BE + +.SH DESCRIPTION +.PP +\fBTcl_PrintDouble\fR generates a string that represents the value +of \fIvalue\fR and stores it in memory at the location given by +\fIdst\fR. It uses %g format to generate the string, with two +special twists. First, the string is guaranteed to contain either +a ``.'' or an ``e'' so that it doesn't look like an integer (where +%g would generate an integer with no decimal point, \fBTcl_PrintDouble\fR +adds ``.0''). Second, the number of significant digits printed at +\fIdst\fR is controlled by the \fBtcl_precision\fR variable in +\fIinterp\fR; if \fBtcl_precision\fR is undefined then 6 significant +digits are printed. + +.SH KEYWORDS +conversion, double-precision, floating-point, string diff --git a/contrib/tcl/doc/RecordEval.3 b/contrib/tcl/doc/RecordEval.3 new file mode 100644 index 0000000..36567d9 --- /dev/null +++ b/contrib/tcl/doc/RecordEval.3 @@ -0,0 +1,53 @@ +'\" +'\" Copyright (c) 1989-1993 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: @(#) RecordEval.3 1.16 96/03/25 20:06:06 +'\" +.so man.macros +.TH Tcl_RecordAndEval 3 7.4 Tcl "Tcl Library Procedures" +.BS +.SH NAME +Tcl_RecordAndEval \- save command on history list before evaluating +.SH SYNOPSIS +.nf +\fB#include <tcl.h>\fR +.sp +int +\fBTcl_RecordAndEval\fR(\fIinterp, cmd, eval\fR) +.SH ARGUMENTS +.AS Tcl_Interp *interp; +.AP Tcl_Interp *interp in +Tcl interpreter in which to evaluate command. +.AP char *cmd in +Command (or sequence of commands) to execute. +.AP int flags in +.VS +An OR'ed combination of flag bits. TCL_NO_EVAL means record the +command but don't evaluate it. TCL_EVAL_GLOBAL means evaluate +the command at global level instead of the current stack level. +.VE +.BE + +.SH DESCRIPTION +.PP +\fBTcl_RecordAndEval\fR is invoked to record a command as an event +on the history list and then execute it using \fBTcl_Eval\fR +.VS +(or \fBTcl_GlobalEval\fR if the TCL_EVAL_GLOBAL bit is set in \fIflags\fR). +.VE +It returns a completion code such as TCL_OK just like \fBTcl_Eval\fR +and it leaves information in \fIinterp->result\fR. +If you don't want the command recorded on the history list then +you should invoke \fBTcl_Eval\fR instead of \fBTcl_RecordAndEval\fR. +Normally \fBTcl_RecordAndEval\fR is only called with top-level +commands typed by the user, since the purpose of history is to +allow the user to re-issue recently-invoked commands. +If the \fIflags\fR argument contains the TCL_NO_EVAL bit then +the command is recorded without being evaluated. + +.SH KEYWORDS +command, event, execute, history, interpreter, record diff --git a/contrib/tcl/doc/RegExp.3 b/contrib/tcl/doc/RegExp.3 new file mode 100644 index 0000000..eea3f42 --- /dev/null +++ b/contrib/tcl/doc/RegExp.3 @@ -0,0 +1,124 @@ +'\" +'\" Copyright (c) 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: @(#) RegExp.3 1.8 96/02/15 20:01:42 +'\" +.so man.macros +.TH Tcl_RegExpMatch 3 7.4 Tcl "Tcl Library Procedures" +.BS +.SH NAME +Tcl_RegExpMatch, Tcl_RegExpCompile, Tcl_RegExpExec, Tcl_RegExpRange \- Pattern matching with regular expressions +.SH SYNOPSIS +.nf +\fB#include <tcl.h>\fR +.sp +int +\fBTcl_RegExpMatch\fR(\fIinterp\fR, \fIstring\fR, \fIpattern\fR) +.sp +.VS +Tcl_RegExp +\fBTcl_RegExpCompile\fR(\fIinterp\fR, \fIpattern\fR) +.sp +int +\fBTcl_RegExpExec\fR(\fIinterp\fR, \fIregexp\fR, \fIstring\fR, \fIstart\fR) +.sp +\fBTcl_RegExpRange\fR(\fIregexp\fR, \fIindex\fR, \fIstartPtr\fR, \fIendPtr\fR) +.VE +.SH ARGUMENTS +.AS Tcl_Interp *interp +.AP Tcl_Interp *interp in +Tcl interpreter to use for error reporting. +.AP char *string in +String to check for a match with a regular expression. +.AP char *pattern in +String in the form of a regular expression pattern. +.AP Tcl_RegExp regexp in +.VS +Compiled regular expression. Must have been returned previously +by \fBTcl_RegExpCompile\fR. +.AP char *start in +If \fIstring\fR is just a portion of some other string, this argument +identifies the beginning of the larger string. +If it isn't the same as \fIstring\fR, then no \fB^\fR matches +will be allowed. +.AP int index in +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 +The address of the first character in the range is stored here, or +NULL if there is no such range. +.AP 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 +.BE + +.SH DESCRIPTION +.PP +\fBTcl_RegExpMatch\fR determines whether its \fIpattern\fR argument +matches \fIregexp\fR, where \fIregexp\fR is interpreted +as a regular expression using the same rules as for the +\fBregexp\fR Tcl command. +If there is a match then \fBTcl_RegExpMatch\fR returns 1. +If there is no match then \fBTcl_RegExpMatch\fR returns 0. +If an error occurs in the matching process (e.g. \fIpattern\fR +is not a valid regular expression) then \fBTcl_RegExpMatch\fR +returns \-1 and leaves an error message in \fIinterp->result\fR. +.PP +.VS +\fBTcl_RegExpCompile\fR, \fBTcl_RegExpExec\fR, and \fBTcl_RegExpRange\fR +provide lower-level access to the regular expression pattern matcher. +\fBTcl_RegExpCompile\fR compiles a regular expression string into +the internal form used for efficient pattern matching. +The return value is a token for this compiled form, which can be +used in subsequent calls to \fBTcl_RegExpExec\fR or \fBTcl_RegExpRange\fR. +If an error occurs while compiling the regular expression then +\fBTcl_RegExpCompile\fR returns NULL and leaves an error message +in \fIinterp->result\fR. +.VS +Note: the return value from \fBTcl_RegExpCompile\fR is only valid +up to the next call to \fBTcl_RegExpCompile\fR; it is not safe to +retain these values for long periods of time. +.VE +.PP +\fBTcl_RegExpExec\fR executes the regular expression pattern matcher. +It returns 1 if \fIstring\fR contains a range of characters that +match \fIregexp\fR, 0 if no match is found, and +\-1 if an error occurs. +In the case of an error, \fBTcl_RegExpExec\fR leaves an error +message in \fIinterp->result\fR. +When searching a string for multiple matches of a pattern, +it is important to distinguish between the start of the original +string and the start of the current search. +For example, when searching for the second occurrence of a +match, the \fIstring\fR argument might point to the character +just after the first match; however, it is important for the +pattern matcher to know that this is not the start of the entire string, +so that it doesn't allow \fB^\fR atoms in the pattern to match. +The \fIstart\fR argument provides this information by pointing +to the start of the overall string containing \fIstring\fR. +\fIStart\fR will be less than or equal to \fIstring\fR; if it +is less than \fIstring\fR then no \fB^\fR matches will be allowed. +.PP +\fBTcl_RegExpRange\fR may be invoked after \fBTcl_RegExpExec\fR +returns; it provides detailed information about what ranges of +the string matched what parts of the pattern. +\fBTcl_RegExpRange\fR returns a pair of pointers in \fI*startPtr\fR +and \fI*endPtr\fR that identify a range of characters in +the source string for the most recent call to \fBTcl_RegExpExec\fR. +\fIIndex\fR indicates which of several ranges is desired: +if \fIindex\fR is 0, information is returned about the overall range +of characters that matched the entire pattern; otherwise, +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. +.VE + +.SH KEYWORDS +match, pattern, regular expression, string, subexpression diff --git a/contrib/tcl/doc/SetErrno.3 b/contrib/tcl/doc/SetErrno.3 new file mode 100644 index 0000000..b3c6277 --- /dev/null +++ b/contrib/tcl/doc/SetErrno.3 @@ -0,0 +1,48 @@ +'\" +'\" Copyright (c) 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: @(#) SetErrno.3 1.5 96/02/15 20:01:31 +.so man.macros +.TH Tcl_SetErrno 3 7.5 Tcl "Tcl Library Procedures" +.BS +.SH NAME +Tcl_SetErrno, Tcl_GetErrno \- manipulate errno to store and retrieve error codes +.SH SYNOPSIS +.nf +\fB#include <tcl.h>\fR +.sp +void +\fBTcl_SetErrno\fR(\fIerrorCode\fR) +.sp +int +\fBTcl_GetErrno\fR() +.sp +.SH ARGUMENTS +.AS Tcl_Interp *errorCode in +.AP int errorCode in +A POSIX error code such as \fBENOENT\fR. +.BE + +.SH DESCRIPTION +.PP +\fBTcl_SetErrno\fR and \fBTcl_GetErrno\fR provide portable access +to the \fBerrno\fR variable, which is used to record a POSIX error +code after system calls and other operations such as \fBTcl_Gets\fR. +These procedures are necessary because global variable accesses cannot +be made across module boundaries on some platforms. +.PP +\fBTcl_SetErrno\fR sets the \fBerrno\fR variable to the value of the +\fIerrorCode\fR argument +C procedures that wish to return error information to their callers +via \fBerrno\fR should call \fBTcl_SetErrno\fR rather than setting +\fBerrno\fR directly. +.PP +\fBTcl_GetErrno\fR returns the current value of \fBerrno\fR. +Procedures wishing to access \fBerrno\fR should call this procedure +instead of accessing \fBerrno\fR directly. + +.SH KEYWORDS +errno, error code, global variables diff --git a/contrib/tcl/doc/SetRecLmt.3 b/contrib/tcl/doc/SetRecLmt.3 new file mode 100644 index 0000000..3a07481 --- /dev/null +++ b/contrib/tcl/doc/SetRecLmt.3 @@ -0,0 +1,55 @@ +'\" +'\" Copyright (c) 1989-1993 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: @(#) SetRecLmt.3 1.6 96/03/25 20:06:36 +'\" +.so man.macros +.TH Tcl_SetRecursionLimit 3 7.0 Tcl "Tcl Library Procedures" +.BS +.SH NAME +Tcl_SetRecursionLimit \- set maximum allowable nesting depth in interpreter +.SH SYNOPSIS +.nf +\fB#include <tcl.h>\fR +.sp +int +\fBTcl_SetRecursionLimit\fR(\fIinterp, depth\fR) +.SH ARGUMENTS +.AS Tcl_Interp *interp +.AP Tcl_Interp *interp in +Interpreter whose recursion limit is to be set. +Must be greater than zero. +.AP int depth in +New limit for nested calls to \fBTcl_Eval\fR for \fIinterp\fR. +.BE + +.SH DESCRIPTION +.PP +At any given time Tcl enforces a limit on the number of recursive +calls that may be active for \fBTcl_Eval\fR and related procedures +such as \fBTcl_GlobalEval\fR. +Any call to \fBTcl_Eval\fR that exceeds this depth is aborted with +an error. +By default the recursion limit is 1000. +.PP +\fBTcl_SetRecursionLimit\fR may be used to change the maximum +allowable nesting depth for an interpreter. +The \fIdepth\fR argument specifies a new limit for \fIinterp\fR, +and \fBTcl_SetRecursionLimit\fR returns the old limit. +To read out the old limit without modifying it, invoke +\fBTcl_SetRecursionDepth\fR with \fIdepth\fR equal to 0. +.PP +The \fBTcl_SetRecursionLimit\fR only sets the size of the Tcl +call stack: 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 \fBTcl_SetRecursionLimit\fR. +If this happens, see if there is a mechanism in your system for +increasing the maximum size of the C stack. + +.SH KEYWORDS +nesting depth, recursion diff --git a/contrib/tcl/doc/SetResult.3 b/contrib/tcl/doc/SetResult.3 new file mode 100644 index 0000000..af2d323 --- /dev/null +++ b/contrib/tcl/doc/SetResult.3 @@ -0,0 +1,145 @@ +'\" +'\" Copyright (c) 1989-1993 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: @(#) SetResult.3 1.18 96/03/25 20:06:54 +'\" +.so man.macros +.TH Tcl_SetResult 3 7.0 Tcl "Tcl Library Procedures" +.BS +.SH NAME +Tcl_SetResult, Tcl_AppendResult, Tcl_AppendElement, Tcl_ResetResult \- manipulate Tcl result string +.SH SYNOPSIS +.nf +\fB#include <tcl.h>\fR +.sp +\fBTcl_SetResult\fR(\fIinterp, string, freeProc\fR) +.sp +\fBTcl_AppendResult(\fIinterp, string, string, ... , \fB(char *) NULL\fR) +.sp +.VS +\fBTcl_AppendElement\fR(\fIinterp, string\fR) +.VE +.sp +\fBTcl_ResetResult\fR(\fIinterp\fR) +.sp +\fBTcl_FreeResult\fR(\fIinterp\fR) +.SH ARGUMENTS +.AS Tcl_FreeProc freeProc +.AP Tcl_Interp *interp out +Interpreter whose result is to be modified. +.AP char *string in +String value to become result for \fIinterp\fR or to be +appended to existing result. +.AP Tcl_FreeProc *freeProc in +Address of procedure to call to release storage at +\fIstring\fR, or \fBTCL_STATIC\fR, \fBTCL_DYNAMIC\fR, or +\fBTCL_VOLATILE\fR. +.BE + +.SH DESCRIPTION +.PP +The procedures described here are utilities for setting the +result/error string in a Tcl interpreter. +.PP +\fBTcl_SetResult\fR +arranges for \fIstring\fR to be the return string for the current Tcl +command in \fIinterp\fR, replacing any existing result. +If \fIfreeProc\fR is \fBTCL_STATIC\fR it means that \fIstring\fR +refers to an area of static storage that is guaranteed not to be +modified until at least the next call to \fBTcl_Eval\fR. +If \fIfreeProc\fR +is \fBTCL_DYNAMIC\fR it means that \fIstring\fR was allocated with a call +to \fBmalloc()\fR and is now the property of the Tcl system. +\fBTcl_SetResult\fR will arrange for the string's storage to be +released by calling \fBfree()\fR when it is no longer needed. +If \fIfreeProc\fR is \fBTCL_VOLATILE\fR it means that \fIstring\fR +points to an area of memory that is likely to be overwritten when +\fBTcl_SetResult\fR returns (e.g. it points to something in a stack frame). +In this case \fBTcl_SetResult\fR will make a copy of the string in +dynamically allocated storage and arrange for the copy to be the +return string for the current Tcl command. +.PP +If \fIfreeProc\fR isn't one of the values \fBTCL_STATIC\fR, +\fBTCL_DYNAMIC\fR, and \fBTCL_VOLATILE\fR, then it is the address +of a procedure that Tcl should call to free the string. +This allows applications to use non-standard storage allocators. +When Tcl no longer needs the storage for the string, it will +call \fIfreeProc\fR. \fIFreeProc\fR should have arguments and +result that match the type \fBTcl_FreeProc\fR: +.CS +typedef void Tcl_FreeProc(char *\fIblockPtr\fR); +.CE +When \fIfreeProc\fR is called, its \fIblockPtr\fR will be set to +the value of \fIstring\fR passed to \fBTcl_SetResult\fR. +.PP +If \fIstring\fR is \fBNULL\fR, then \fIfreeProc\fR is ignored +and \fBTcl_SetResult\fR +re-initializes \fIinterp\fR's result to point to the pre-allocated result +area, with an empty string in the result area. +.PP +If \fBTcl_SetResult\fR is called at a time when \fIinterp\fR holds a +result, \fBTcl_SetResult\fR does whatever is necessary to dispose +of the old result (see the \fBTcl_Interp\fR manual entry for details +on this). +.PP +\fBTcl_AppendResult\fR makes it easy to build up Tcl results in pieces. +It takes each of its \fIstring\fR arguments and appends them in order +to the current result associated with \fIinterp\fR. +If the result is in its initialized empty state (e.g. a command procedure +was just invoked or \fBTcl_ResetResult\fR was just called), +then \fBTcl_AppendResult\fR sets the result to the concatenation of +its \fIstring\fR arguments. +\fBTcl_AppendResult\fR may be called repeatedly as additional pieces +of the result are produced. +\fBTcl_AppendResult\fR takes care of all the +storage management issues associated with managing \fIinterp\fR's +result, such as allocating a larger result area if necessary. +Any number of \fIstring\fR arguments may be passed in a single +call; the last argument in the list must be a NULL pointer. +.PP +\fBTcl_AppendElement\fR is similar to \fBTcl_AppendResult\fR in +that it allows results to be built up in pieces. +However, \fBTcl_AppendElement\fR takes only a single \fIstring\fR +argument and it appends that argument to the current result +as a proper Tcl list element. +\fBTcl_AppendElement\fR adds backslashes or braces if necessary +to ensure that \fIinterp\fR's result can be parsed as a list and that +\fIstring\fR will be extracted as a single element. +Under normal conditions, \fBTcl_AppendElement\fR will add a space +character to \fIinterp\fR's result just before adding the new +list element, so that the list elements in the result are properly +separated. +.VS +However if the new list element is the first in a list or sub-list +(i.e. \fIinterp\fR's current result is empty, or consists of the +single character ``{'', or ends in the characters `` {'') then no +space is added. +.VE +.PP +\fBTcl_ResetResult\fR clears the result for \fIinterp\fR, +freeing the memory associated with it if the current result was +dynamically allocated. +It leaves the result in its normal initialized state with +\fIinterp->result\fR pointing to a static buffer containing +\fBTCL_RESULT_SIZE\fR characters, of which the first character +is zero. +\fBTcl_ResetResult\fR also clears the error state managed by +\fBTcl_AddErrorInfo\fR and \fBTcl_SetErrorCode\fR. +.PP +\fBTcl_FreeResult\fR is a macro that performs part of the work +of \fBTcl_ResetResult\fR. +It frees up the memory associated with \fIinterp\fR's result +and sets \fIinterp->freeProc\fR to zero, but it doesn't +change \fIinterp->result\fR or clear error state. +\fBTcl_FreeResult\fR is most commonly used when a procedure +is about to replace one result value with another. + +.SH "SEE ALSO" +Tcl_AddErrorInfo, Tcl_SetErrorCode, Tcl_Interp + +.SH KEYWORDS +append, command, element, list, result, return value, interpreter diff --git a/contrib/tcl/doc/SetVar.3 b/contrib/tcl/doc/SetVar.3 new file mode 100644 index 0000000..8d1696f --- /dev/null +++ b/contrib/tcl/doc/SetVar.3 @@ -0,0 +1,162 @@ +'\" +'\" Copyright (c) 1989-1993 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: @(#) SetVar.3 1.22 96/03/25 20:07:08 +'\" +.so man.macros +.TH Tcl_SetVar 3 7.4 Tcl "Tcl Library Procedures" +.BS +.SH NAME +Tcl_SetVar, Tcl_SetVar2, Tcl_GetVar, Tcl_GetVar2, Tcl_UnsetVar, Tcl_UnsetVar2 \- manipulate Tcl variables +.SH SYNOPSIS +.nf +\fB#include <tcl.h>\fR +.sp +char * +\fBTcl_SetVar\fR(\fIinterp, varName, newValue, flags\fR) +.sp +char * +\fBTcl_SetVar2\fR(\fIinterp, name1, name2, newValue, flags\fR) +.sp +char * +\fBTcl_GetVar\fR(\fIinterp, varName, flags\fR) +.sp +char * +\fBTcl_GetVar2\fR(\fIinterp, name1, name2, flags\fR) +.sp +int +\fBTcl_UnsetVar\fR(\fIinterp, varName, flags\fR) +.sp +int +\fBTcl_UnsetVar2\fR(\fIinterp, name1, name2, flags\fR) +.SH ARGUMENTS +.AS Tcl_Interp *newValue +.AP Tcl_Interp *interp in +Interpreter containing variable. +.AP char *varName in +Name of variable. May refer to a scalar variable or an element of +an array variable. +.VS +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. +.VE +.AP char *newValue in +New value for variable. +.AP int flags in +OR-ed combination of bits providing additional information for +operation. See below for valid values. +.AP char *name1 in +Name of scalar variable, or name of array variable if \fIname2\fR +is non-NULL. +.AP char *name2 in +If non-NULL, gives name of element within array and \fIname1\fR +must refer to an array variable. +.BE + +.SH DESCRIPTION +.PP +These procedures may be used to create, modify, read, and delete +Tcl variables from C code. +\fBTcl_SetVar\fR and \fBTcl_SetVar2\fR will create a new variable +or modify an existing one. +Both of these procedures set the given variable to the value +given by \fInewValue\fR, and they return a pointer to a +copy of the variable's new value, which is stored in Tcl's +variable structure. +Tcl keeps a private copy of the variable's value, so the caller +may change \fInewValue\fR after these procedures return without +affecting the value of the variable. +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 name of the variable may be specified in either of two ways. +If \fBTcl_SetVar\fR is called, the variable name is given as +a single string, \fIvarName\fR. +If \fIvarName\fR contains an open parenthesis and ends with a +close parenthesis, then the value between the parentheses is +treated as an index (which can have any string value) and +the characters before the first open +parenthesis are treated as the name of an array variable. +If \fIvarName\fR doesn't have parentheses as described above, then +the entire string is treated as the name of a scalar variable. +If \fBTcl_SetVar2\fR is called, then the array name and index +have been separated by the caller into two separate strings, +\fIname1\fR and \fIname2\fR respectively; if \fIname2\fR is +zero it means that a scalar variable is being referenced. +.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 +at the current level of procedure call for \fIinterp\fR, or +at global level if there is no call active. +However, if this bit is set in \fIflags\fR then the variable +is looked up at global level 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 \fI\%interp->result\fR. If this +flag bit isn't set then no error message is left (\fI\%interp->result\fR +will not be modified). +.TP +\fBTCL_APPEND_VALUE\fR +If this bit is set then \fInewValue\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 \fInewValue\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 +.VS +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 `` }''). +.VE +.PP +\fBTcl_GetVar\fR and \fBTcl_GetVar2\fR return the current value +of a variable. +The arguments to these procedures are treated in the same way +as the arguments to \fBTcl_SetVar\fR and \fBTcl_SetVar2\fR. +Under normal circumstances, the return value is a pointer +to the variable's value (which is stored in Tcl's variable +structure and will not change before the next call to \fBTcl_SetVar\fR +or \fBTcl_SetVar2\fR). +The only bits of \fIflags\fR that are used are TCL_GLOBAL_ONLY +and TCL_LEAVE_ERR_MSG, both of +which have +the same meaning as for \fBTcl_SetVar\fR. +If an error occurs in reading the variable (e.g. the variable +doesn't exist or an array element is specified for a scalar +variable), then NULL is returned. +.PP +\fBTcl_UnsetVar\fR and \fBTcl_UnsetVar2\fR may be used to remove +a variable, so that future calls to \fBTcl_GetVar\fR or \fBTcl_GetVar2\fR +for the variable will return an error. +The arguments to these procedures are treated in the same way +as the arguments to \fBTcl_GetVar\fR and \fBTcl_GetVar2\fR. +.VS +If the variable is successfully removed then TCL_OK is returned. +If the variable cannot be removed because it doesn't exist then +TCL_ERROR is returned. +.VE +If an array element is specified, the given element is removed +but the array remains. +If an array name is specified without an index, then the entire +array is removed. + +.SH "SEE ALSO" +Tcl_TraceVar + +.SH KEYWORDS +array, interpreter, scalar, set, unset, variable diff --git a/contrib/tcl/doc/Sleep.3 b/contrib/tcl/doc/Sleep.3 new file mode 100644 index 0000000..0c7956a --- /dev/null +++ b/contrib/tcl/doc/Sleep.3 @@ -0,0 +1,37 @@ +'\" +'\" Copyright (c) 1990 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: @(#) Sleep.3 1.3 96/03/25 20:07:21 +'\" +.so man.macros +.TH Tcl_Sleep 3 7.5 Tcl "Tcl Library Procedures" +.BS +.SH NAME +Tcl_Sleep \- delay execution for a given number of milliseconds +.SH SYNOPSIS +.nf +\fB#include <tcl.h>\fR +.sp +\fBTcl_Sleep\fR(\fIms\fR) +.SH ARGUMENTS +.AP int ms in +Number of milliseconds to sleep. +.BE + +.SH DESCRIPTION +.PP +This procedure delays the calling process by the number of +milliseconds given by the \fIms\fR parameter and returns +after that time has elapsed. It is typically used for things +like flashing a button, where the delay is short and the +application needn't do anything while it waits. For longer +delays where the application needs to respond to other events +during the delay, the procedure \fBTcl_CreateTimerHandler\fR +should be used instead of \fBTcl_Sleep\fR. + +.SH KEYWORDS +sleep, time, wait diff --git a/contrib/tcl/doc/SplitList.3 b/contrib/tcl/doc/SplitList.3 new file mode 100644 index 0000000..dfc9b41 --- /dev/null +++ b/contrib/tcl/doc/SplitList.3 @@ -0,0 +1,166 @@ +'\" +'\" Copyright (c) 1989-1993 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: @(#) SplitList.3 1.19 96/03/25 20:07:46 +'\" +.so man.macros +.TH Tcl_SplitList 3 7.4 Tcl "Tcl Library Procedures" +.BS +.SH NAME +Tcl_SplitList, Tcl_Merge, Tcl_ScanElement, Tcl_ConvertElement \- manipulate Tcl lists +.SH SYNOPSIS +.nf +\fB#include <tcl.h>\fR +.sp +int +\fBTcl_SplitList\fR(\fIinterp, list, argcPtr, argvPtr\fR) +.sp +char * +\fBTcl_Merge\fR(\fIargc, argv\fR) +.sp +int +\fBTcl_ScanElement\fR(\fIsrc, flagsPtr\fR) +.sp +int +\fBTcl_ConvertElement\fR(\fIsrc, dst, flags\fR) +.SH ARGUMENTS +.AS Tcl_Interp ***argvPtr +.AP Tcl_Interp *interp out +.VS +Interpreter to use for error reporting. If NULL, then no error message +is left. +.VE +.AP char *list in +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 +\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 +Array of strings to merge together into a single list. +Each string will become a separate element of the list. +.AP 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. +The value of *\fIflagsPtr\fR must be passed to \fBTcl_ConvertElement\fR. +.AP char *dst in +Place to copy converted list element. Must contain enough characters +to hold converted string. +.AP int flags in +Information about \fIsrc\fR. Must be value returned by previous +call to \fBTcl_ScanElement\fR, possibly OR-ed +with \fBTCL_DONT_USE_BRACES\fR. +.BE + +.SH DESCRIPTION +.PP +These procedures may be used to disassemble and reassemble Tcl lists. +\fBTcl_SplitList\fR breaks a list up into its constituent elements, +returning an array of pointers to the elements using +\fIargcPtr\fR and \fIargvPtr\fR. +While extracting the arguments, \fBTcl_SplitList\fR obeys the usual +rules for backslash substitutions and braces. The area of +memory pointed to by \fI*argvPtr\fR is dynamically allocated; in +addition to the array of pointers, it +also holds copies of all the list elements. It is the caller's +responsibility to free up all of this storage. +For example, suppose that you have called \fBTcl_SplitList\fR with +the following code: +.CS +int argc, code; +char *string; +char **argv; +\&... +code = Tcl_SplitList(interp, string, &argc, &argv); +.CE +Then you should eventually free the storage with a call like the +following: +.CS +free((char *) argv); +.CE +.PP +\fBTcl_SplitList\fR normally returns \fBTCL_OK\fR, which means the list was +successfully parsed. +If there was a syntax error in \fIlist\fR, then \fBTCL_ERROR\fR is returned +and \fIinterp->result\fR will point to an error message describing the +.VS +problem (if \fIinterp\fR was not NULL). +.VE +If \fBTCL_ERROR\fR is returned then no memory is allocated and \fI*argvPtr\fR +is not modified. +.PP +\fBTcl_Merge\fR is the inverse of \fBTcl_SplitList\fR: it +takes a collection of strings given by \fIargc\fR +and \fIargv\fR and generates a result string +that has proper list structure. +This means that commands like \fBindex\fR may be used to +extract the original elements again. +In addition, if the result of \fBTcl_Merge\fR is passed to \fBTcl_Eval\fR, +it will be parsed into \fIargc\fR words whose values will +be the same as the \fIargv\fR strings passed to \fBTcl_Merge\fR. +\fBTcl_Merge\fR will modify the list elements with braces and/or +backslashes in order to produce proper Tcl list structure. +The result string is dynamically allocated +using \fBmalloc()\fR; the caller must eventually release the space +using \fBfree()\fR. +.PP +If the result of \fBTcl_Merge\fR is passed to \fBTcl_SplitList\fR, +the elements returned by \fBTcl_SplitList\fR will be identical to +those passed into \fBTcl_Merge\fR. +However, the converse is not true: if \fBTcl_SplitList\fR +is passed a given string, and the resulting \fIargc\fR and +\fIargv\fR are passed to \fBTcl_Merge\fR, the resulting string +may not be the same as the original string passed to \fBTcl_SplitList\fR. +This is because \fBTcl_Merge\fR may use backslashes and braces +differently than the original string. +.PP +\fBTcl_ScanElement\fR and \fBTcl_ConvertElement\fR are the +procedures that do all of the real work of \fBTcl_Merge\fR. +\fBTcl_ScanElement\fR scans its \fIsrc\fR argument +and determines how to use backslashes and braces +when converting it to a list element. +It returns an overestimate of the number of characters +required to represent \fIsrc\fR as a list element, and +it stores information in \fI*flagsPtr\fR that is needed +by \fBTcl_ConvertElement\fR. +.PP +\fBTcl_ConvertElement\fR is a companion procedure to \fBTcl_ScanElement\fR. +It does the actual work of converting a string to a list element. +Its \fIflags\fR argument must be the same as the value returned +by \fBTcl_ScanElement\fR. +\fBTcl_ConvertElement\fR writes a proper list element to memory +starting at *\fIdst\fR and returns a count of the total number +of characters written, which will be no more than the result +returned by \fBTcl_ScanElement\fR. +\fBTcl_ConvertElement\fR writes out only the actual list element +without any leading or trailing spaces: it is up to the caller to +include spaces between adjacent list elements. +.PP +\fBTcl_ConvertElement\fR uses one of two different approaches to +handle the special characters in \fIsrc\fR. Wherever possible, it +handles special characters by surrounding the string with braces. +This produces clean-looking output, but can't be used in some situations, +such as when \fIsrc\fR contains unmatched braces. +In these situations, \fBTcl_ConvertElement\fR handles special +characters by generating backslash sequences for them. +The caller may insist on the second approach by OR-ing the +flag value returned by \fBTcl_ScanElement\fR with +\fBTCL_DONT_USE_BRACES\fR. +Although this will produce an uglier result, it is useful in some +special situations, such as when \fBTcl_ConvertElement\fR is being +used to generate a portion of an argument for a Tcl command. +In this case, surrounding \fIsrc\fR with curly braces would cause +the command not to be parsed correctly. + +.SH KEYWORDS +backslash, convert, element, list, merge, split, strings diff --git a/contrib/tcl/doc/StaticPkg.3 b/contrib/tcl/doc/StaticPkg.3 new file mode 100644 index 0000000..729e91c --- /dev/null +++ b/contrib/tcl/doc/StaticPkg.3 @@ -0,0 +1,67 @@ +'\" +'\" Copyright (c) 1995-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: @(#) StaticPkg.3 1.3 96/03/15 08:29:37 +'\" +.so man.macros +.TH Tcl_StaticPackage 3 7.5 Tcl "Tcl Library Procedures" +.BS +.SH NAME +Tcl_StaticPackage \- make a statically linked package available via the \fBload\fR command +.SH SYNOPSIS +.nf +\fB#include <tcl.h>\fR +.sp +\fBTcl_StaticPackage\fR(\fIinterp, pkgName, initProc, safeInitProc\fR) +.SH ARGUMENTS +.AS Tcl_PackageInitProc *safeInitProc +.AP Tcl_Interp *interp in +If not NULL, points to an interpreter into which the package has +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 +Name of the package; should be properly capitalized (first letter +upper-case, all others lower-case). +.AP Tcl_PackageInitProc *initProc in +Procedure to invoke to incorporate this package into a trusted +interpreter. +.AP Tcl_PackageInitProc *safeInitProc in +Procedure to call to incorporate this package into a safe interpreter +(one that will execute untrusted scripts). NULL means the package +can't be used in safe interpreters. +.BE + +.SH DESCRIPTION +.PP +This procedure may be invoked to announce that a package has been +linked statically with a Tcl application and, optionally, that it +has already been loaded into an interpreter. +\fBTcl_StaticPackage\fR is typically invoked by the \fBTcl_AppInit\fR +procedure for the application. +Once \fBTcl_StaticPackage\fR has been invoked for a package, it +may be loaded into interpreters using the \fBload\fR command. +.PP +When the \fBload\fR command is used later to load the package into +an interpreter, one of \fIinitProc\fR and \fIsafeInitProc\fR will +be invoked, depending on whether the target interpreter is safe +or not. +\fIinitProc\fR and \fIsafeInitProc\fR must both match the +following prototype: +.CS +typedef int Tcl_PackageInitProc(Tcl_Interp *\fIinterp\fR); +.CE +The \fIinterp\fR argument identifies the interpreter in which the +package is to be loaded. The initialization procedure must return +\fBTCL_OK\fR or \fBTCL_ERROR\fR to indicate whether or not it completed +successfully; in the event of an error it should set \fIinterp->result\fR +to point to an error message. +The result or error from the initialization procedure will be returned +as the result of the \fBload\fR command that caused the +initialization procedure to be invoked. + +.SH KEYWORDS +initialization procedure, package, static linking diff --git a/contrib/tcl/doc/StrMatch.3 b/contrib/tcl/doc/StrMatch.3 new file mode 100644 index 0000000..354193b --- /dev/null +++ b/contrib/tcl/doc/StrMatch.3 @@ -0,0 +1,39 @@ +'\" +'\" Copyright (c) 1989-1993 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: @(#) StrMatch.3 1.11 96/03/25 20:08:06 +'\" +.so man.macros +.TH Tcl_StringMatch 3 "" Tcl "Tcl Library Procedures" +.BS +.SH NAME +Tcl_StringMatch \- test whether a string matches a pattern +.SH SYNOPSIS +.nf +\fB#include <tcl.h>\fR +.sp +int +\fBTcl_StringMatch\fR(\fIstring\fR, \fIpattern\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[]. +.BE + +.SH DESCRIPTION +.PP +This utility procedure determines whether a string matches +a given pattern. If it does, then \fBTcl_StringMatch\fR returns +1. Otherwise \fBTcl_StringMatch\fR returns 0. The algorithm +used for matching is the same algorithm used in the ``string match'' +Tcl command and is similar to the algorithm used by the C-shell +for file name matching; see the Tcl manual entry for details. + +.SH KEYWORDS +match, pattern, string diff --git a/contrib/tcl/doc/Tcl.n b/contrib/tcl/doc/Tcl.n new file mode 100644 index 0000000..d0b60e5 --- /dev/null +++ b/contrib/tcl/doc/Tcl.n @@ -0,0 +1,189 @@ +'\" +'\" Copyright (c) 1993 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: @(#) Tcl.n 1.127 96/03/25 20:08:20 +' +.so man.macros +.TH Tcl n "" Tcl "Tcl Built-In Commands" +.BS +.SH NAME +Tcl \- Summary of Tcl language syntax. +.BE + +.SH DESCRIPTION +.PP +The following rules define the syntax and semantics of the Tcl language: +.IP [1] +A Tcl script is a string containing one or more commands. +Semi-colons and newlines are command separators unless quoted as +described below. +Close brackets are command terminators during command substitution +(see below) unless quoted. +.IP [2] +A command is evaluated in two steps. +First, the Tcl interpreter breaks the command into \fIwords\fR +and performs substitutions as described below. +These substitutions are performed in the same way for all +commands. +The first word is used to locate a command procedure to +carry out the command, then all of the words of the command are +passed to the command procedure. +The command procedure is free to interpret each of its words +in any way it likes, such as an integer, variable name, list, +or Tcl script. +Different commands interpret their words differently. +.IP [3] +Words of a command are separated by white space (except for +newlines, which are command separators). +.IP [4] +If the first character of a word is double-quote (``"'') then +the word is terminated by the next double-quote character. +If semi-colons, close brackets, or white space characters +(including newlines) appear between the quotes then they are treated +as ordinary characters and included in the word. +Command substitution, variable substitution, and backslash substitution +are performed on the characters between the quotes as described below. +The double-quotes are not retained as part of the word. +.IP [5] +If the first character of a word is an open brace (``{'') then +the word is terminated by the matching close brace (``}''). +Braces nest within the word: for each additional open +brace there must be an additional close brace (however, +if an open brace or close brace within the word is +quoted with a backslash then it is not counted in locating the +matching close brace). +No substitutions are performed on the characters between the +braces except for backslash-newline substitutions described +below, nor do semi-colons, newlines, close brackets, +or white space receive any special interpretation. +The word will consist of exactly the characters between the +outer braces, not including the braces themselves. +.IP [6] +If a word contains an open bracket (``['') then Tcl performs +\fIcommand substitution\fR. +To do this it invokes the Tcl interpreter recursively to process +the characters following the open bracket as a Tcl script. +The script may contain any number of commands and must be terminated +by a close bracket (``]''). +The result of the script (i.e. the result of its last command) is +substituted into the word in place of the brackets and all of the +characters between them. +There may be any number of command substitutions in a single word. +Command substitution is not performed on words enclosed in braces. +.IP [7] +If a word contains a dollar-sign (``$'') then Tcl performs \fIvariable +substitution\fR: the dollar-sign and the following characters are +replaced in the word by the value of a variable. +Variable substitution may take any of the following forms: +.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. +.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. +Command substitutions, variable substitutions, and backslash +substitutions are performed on the characters of \fIindex\fR. +.TP 15 +\fB${\fIname\fB}\fR +\fIName\fR is the name of a scalar variable. It may contain any +characters whatsoever except for close braces. +.LP +There may be any number of variable substitutions in a single word. +Variable substitution is not performed on words enclosed in braces. +.RE +.IP [8] +If a backslash (``\e'') appears within a word then +\fIbackslash substitution\fR occurs. +.VS +In all cases but those described below the backslash is dropped and +the following character is treated as an ordinary +character and included in the word. +.VE +This allows characters such as double quotes, close brackets, +and dollar signs to be included in words without triggering +special processing. +The following table lists the backslash sequences that are +handled specially, along with the value that replaces each sequence. +.RS +.VS +.TP 6 +\e\fBa\fR +Audible alert (bell) (0x7). +.VE +.TP 6 +\e\fBb\fR +Backspace (0x8). +.TP 6 +\e\fBf\fR +Form feed (0xc). +.TP 6 +\e\fBn\fR +Newline (0xa). +.TP 6 +\e\fBr\fR +Carriage-return (0xd). +.TP 6 +\e\fBt\fR +Tab (0x9). +.TP 6 +\e\fBv\fR +Vertical tab (0xb). +.TP 6 +\e\fB<newline>\fIwhiteSpace\fR +.VS +A single space character replaces the backslash, newline, and all +spaces and tabs after the newline. +This backslash sequence is unique in that it is replaced in a separate +pre-pass before the command is actually parsed. +This means that it will be replaced even when it occurs between +braces, and the resulting space will be treated as a word separator +if it isn't in braces or quotes. +.VE +.TP 6 +\e\e +Backslash (``\e''). +.TP 6 +\e\fIooo\fR +The digits \fIooo\fR (one, two, or three of them) give the octal value of +the character. +.TP 6 +\e\fBx\fIhh\fR +.VS +The hexadecimal digits \fIhh\fR give the hexadecimal value of +the character. Any number of digits may be present. +.VE +.LP +Backslash substitution is not performed on words enclosed in braces, +except for backslash-newline as described above. +.RE +.IP [9] +If a hash character (``#'') appears at a point where Tcl is +expecting the first character of the first word of a command, +then the hash character and the characters that follow it, up +through the next newline, are treated as a comment and ignored. +The comment character only has significance when it appears +at the beginning of a command. +.IP [10] +Each character is processed exactly once by the Tcl interpreter +as part of creating the words of a command. +For example, if variable substitution occurs then no further +substitutions are performed on the value of the variable; the +value is inserted into the word verbatim. +If command substitution occurs then the nested command is +processed entirely by the recursive call to the Tcl interpreter; +no substitutions are performed before making the recursive +call and no additional substitutions are performed on the result +of the nested script. +.IP [11] +Substitutions do not affect the word boundaries of a command. +For example, during variable substitution the entire value of +the variable becomes part of a single word, even if the variable's +value contains spaces. diff --git a/contrib/tcl/doc/Tcl_Main.3 b/contrib/tcl/doc/Tcl_Main.3 new file mode 100644 index 0000000..15c0f3e --- /dev/null +++ b/contrib/tcl/doc/Tcl_Main.3 @@ -0,0 +1,61 @@ +'\" +'\" Copyright (c) 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: @(#) Tcl_Main.3 1.8 96/03/25 20:08:33 +'\" +.so man.macros +.TH Tcl_Main 3 7.4 Tcl "Tcl Library Procedures" +.BS +.SH NAME +Tcl_Main \- main program for Tcl-based applications +.SH SYNOPSIS +.nf +\fB#include <tcl.h>\fR +.sp +\fBTcl_Main\fR(\fIargc, argv, appInitProc\fR) +.SH ARGUMENTS +.AS Tcl_AppInitProc *appInitProc +.AP int argc in +Number of elements in \fIargv\fR. +.AP char *argv[] in +Array of strings containing command-line arguments. +.AP Tcl_AppInitProc *appInitProc in +Address of an application-specific initialization procedure. +The value for this argument is usually \fBTcl_AppInit\fR. +.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. +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. +\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: +.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. + +.SH KEYWORDS +application-specific initialization, command-line arguments, main program diff --git a/contrib/tcl/doc/TraceVar.3 b/contrib/tcl/doc/TraceVar.3 new file mode 100644 index 0000000..ecfdc3e --- /dev/null +++ b/contrib/tcl/doc/TraceVar.3 @@ -0,0 +1,349 @@ +'\" +'\" Copyright (c) 1989-1993 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: @(#) TraceVar.3 1.25 96/03/25 20:08:44 +'\" +.so man.macros +.TH Tcl_TraceVar 3 7.4 Tcl "Tcl Library Procedures" +.BS +.SH NAME +Tcl_TraceVar, Tcl_TraceVar2, Tcl_UntraceVar, Tcl_UntraceVar2, Tcl_VarTraceInfo, Tcl_VarTraceInfo2 \- monitor accesses to a variable +.SH SYNOPSIS +.nf +\fB#include <tcl.h>\fR +.sp +int +\fBTcl_TraceVar(\fIinterp, varName, flags, proc, clientData\fB)\fR +.sp +int +\fBTcl_TraceVar2(\fIinterp, name1, name2, flags, proc, clientData\fB)\fR +.sp +\fBTcl_UntraceVar(\fIinterp, varName, flags, proc, clientData\fB)\fR +.sp +\fBTcl_UntraceVar2(\fIinterp, name1, name2, flags, proc, clientData\fB)\fR +.sp +ClientData +\fBTcl_VarTraceInfo(\fIinterp, varName, flags, proc, prevClientData\fB)\fR +.sp +ClientData +\fBTcl_VarTraceInfo2(\fIinterp, name1, name2, flags, proc, prevClientData\fB)\fR +.SH ARGUMENTS +.AS Tcl_VarTraceProc prevClientData +.AP Tcl_Interp *interp in +Interpreter containing variable. +.AP 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. +.VS +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. +.VE +.AP int flags in +OR-ed combination of the values TCL_TRACE_READS, TCL_TRACE_WRITES, and +TCL_TRACE_UNSETS, and TCL_GLOBAL_ONLY. 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 +Name of scalar or array variable (without array index). +.AP 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. +.AP ClientData prevClientData in +If non-NULL, gives last value returned by \fBTcl_VarTraceInfo\fR or +\fBTcl_VarTraceInfo2\fR, so this call will return information about +next trace. If NULL, this call will return information about first +trace. +.BE + +.SH DESCRIPTION +.PP +\fBTcl_TraceVar\fR allows a C procedure to monitor and control +access to a Tcl variable, so that the C procedure is invoked +whenever the variable is read or written or unset. +If the trace is created successfully then \fBTcl_TraceVar\fR returns +TCL_OK. If an error occurred (e.g. \fIvarName\fR specifies an element +of an array, but the actual variable isn't an array) then TCL_ERROR +is returned and an error message is left in \fIinterp->result\fR. +.PP +The \fIflags\fR argument to \fBTcl_TraceVar\fR indicates when the +trace procedure is to be invoked and provides information +for setting up the trace. It consists of an OR-ed combination +of any of the following values: +.TP +\fBTCL_GLOBAL_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 at global level, ignoring any active procedures. +.TP +\fBTCL_TRACE_READS\fR +Invoke \fIproc\fR whenever an attempt is made to read the variable. +.TP +\fBTCL_TRACE_WRITES\fR +Invoke \fIproc\fR whenever an attempt is made to modify the variable. +.TP +\fBTCL_TRACE_UNSETS\fR +Invoke \fIproc\fR whenever the variable is unset. +A variable may be unset either explicitly by an \fBunset\fR command, +or implicitly when a procedure returns (its local variables are +automatically unset) or when the interpreter is deleted (all +variables are automatically unset). +.PP +Whenever one of the specified operations occurs on the variable, +\fIproc\fR will be invoked. +It should have arguments and result that match the type +\fBTcl_VarTraceProc\fR: +.CS +typedef char *Tcl_VarTraceProc( + ClientData \fIclientData\fR, + Tcl_Interp *\fIinterp\fR, + char *\fIname1\fR, + char *\fIname2\fR, + int \fIflags\fR); +.CE +The \fIclientData\fR and \fIinterp\fR parameters will +have the same values as those passed to \fBTcl_TraceVar\fR when the +trace was created. +\fIClientData\fR typically points to an application-specific +data structure that describes what to do when \fIproc\fR +is invoked. +\fIName1\fR and \fIname2\fR give the name of the traced variable +in the normal two-part form (see the description of \fBTcl_TraceVar2\fR +below for details). +\fIFlags\fR is an OR-ed combination of bits providing several +pieces of information. +One of the bits TCL_TRACE_READS, TCL_TRACE_WRITES, or TCL_TRACE_UNSETS +will be set in \fIflags\fR to indicate which operation is being performed +on the variable. +The bit TCL_GLOBAL_ONLY will be set whenever the variable being +accessed is a global 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 section TCL_TRACE_DESTROYED below for more details). +Lastly, the bit TCL_INTERP_DESTROYED will be set if the entire +interpreter is being destroyed. +When this bit is set, \fIproc\fR must be especially careful in +the things it does (see the section TCL_INTERP_DESTROYED below). +The trace procedure's return value should normally be NULL; see +ERROR RETURNS below for information on other possibilities. +.PP +\fBTcl_UntraceVar\fR may be used to remove a trace. +If the variable specified by \fIinterp\fR, \fIvarName\fR, and \fIflags\fR +has a trace set with \fIflags\fR, \fIproc\fR, and +\fIclientData\fR, then the corresponding trace is removed. +If no such trace exists, then the call to \fBTcl_UntraceVar\fR +has no effect. +The same bits are valid for \fIflags\fR as for calls to \fBTcl_TraceVar\fR. +.PP +\fBTcl_VarTraceInfo\fR may be used to retrieve information about +traces set on a given variable. +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. +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 the \fIprevClientData\fR argument isn't NULL, then it should +be the return value from a previous call to \fBTcl_VarTraceInfo\fR. +In this case, the new return value will correspond to the next +matching trace after the one whose \fIclientData\fR matches +\fIprevClientData\fR, or NULL if no trace matches \fIprevClientData\fR +or if there are no more matching traces after it. +This mechanism makes it possible to step through all of the +traces for a given variable that have the same \fIproc\fR. + +.SH "TWO-PART NAMES" +.PP +The procedures \fBTcl_TraceVar2\fR, \fBTcl_UntraceVar2\fR, and +\fBTcl_VarTraceInfo2\fR are identical to \fBTcl_TraceVar\fR, +\fBTcl_UntraceVar\fR, and \fBTcl_VarTraceInfo\fR, respectively, +except that the name of the variable has already been +separated by the caller into two parts. +\fIName1\fR gives the name of a scalar variable or array, +and \fIname2\fR gives the name of an element within an +array. +If \fIname2\fR is NULL it means that either the variable is +a scalar or the trace is to be set on the entire array rather +than an individual element (see WHOLE-ARRAY TRACES below for +more information). + +.SH "ACCESSING VARIABLES DURING TRACES" +.PP +During read and write traces, the +trace procedure can read, write, or unset the traced +variable using \fBTcl_GetVar2\fR, \fBTcl_SetVar2\fR, and +other procedures. +While \fIproc\fR is executing, traces are temporarily disabled +for the variable, so that calls to \fBTcl_GetVar2\fR and +\fBTcl_SetVar2\fR will not cause \fIproc\fR or other trace procedures +to be invoked again. +Disabling only occurs for the variable whose trace procedure +is active; accesses to other variables will still be traced. +.VS +However, if a variable is unset during a read or write trace then unset +traces will be invoked. +.VE +.PP +During unset traces the variable has already been completely +expunged. +It is possible for the trace procedure to read or write the +variable, but this will be a new version of the variable. +Traces are not disabled during unset traces as they are for +read and write traces, but existing traces have been removed +from the variable before any trace procedures are invoked. +If new traces are set by unset trace procedures, these traces +will be invoked on accesses to the variable by the trace +procedures. + +.SH "CALLBACK TIMING" +.PP +When read tracing has been specified for a variable, the trace +procedure will be invoked whenever the variable's value is +read. This includes \fBset\fR Tcl commands, \fB$\fR-notation +in Tcl commands, and invocations of the \fBTcl_GetVar\fR +and \fBTcl_GetVar2\fR procedures. +\fIProc\fR is invoked just before the variable's value is +returned. +It may modify the value of the variable to affect what +is returned by the traced access. +.VS +If it unsets the variable then the access will return an error +just as if the variable never existed. +.VE +.PP +When write tracing has been specified for a variable, the +trace procedure will be invoked whenever the variable's value +is modified. This includes \fBset\fR commands, +commands that modify variables as side effects (such as +\fBcatch\fR and \fBscan\fR), and calls to the \fBTcl_SetVar\fR +and \fBTcl_SetVar2\fR procedures). +\fIProc\fR will be invoked after the variable's value has been +modified, but before the new value of the variable has been +returned. +It may modify the value of the variable to override the change +and to determine the value actually returned by the traced +access. +.VS +If it deletes the variable then the traced access will return +an empty string. +.VE +.PP +When unset tracing has been specified, the trace procedure +will be invoked whenever the variable is destroyed. +The traces will be called after the variable has been +completely unset. + +.SH "WHOLE-ARRAY TRACES" +.PP +If a call to \fBTcl_TraceVar\fR or \fBTcl_TraceVar2\fR specifies +the name of an array variable without an index into the array, +then the trace will be set on the array as a whole. +This means that \fIproc\fR will be invoked whenever any +element of the array is accessed in the ways specified by +\fIflags\fR. +When an array is unset, a whole-array trace will be invoked +just once, with \fIname1\fR equal to the name of the array +and \fIname2\fR NULL; it will not be invoked once for each +element. + +.SH "MULTIPLE TRACES" +.PP +It is possible for multiple traces to exist on the same variable. +When this happens, all of the trace procedures will be invoked on each +access, in order from most-recently-created to least-recently-created. +When there exist whole-array traces for an array as well as +traces on individual elements, the whole-array traces are invoked +before the individual-element traces. +.VS +If a read or write trace unsets the variable then all of the unset +traces will be invoked but the remainder of the read and write traces +will be skipped. +.VE + +.SH "ERROR RETURNS" +.PP +Under normal conditions trace procedures should return NULL, indicating +successful completion. +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. +If a trace procedure returns an error, no further traces are +invoked for the access and the traced access aborts with the +given message. +Trace procedures can use this facility to make variables +read-only, for example (but note that the value of the variable +will already have been modified before the trace procedure is +called, so the trace procedure will have to restore the correct +value). +.PP +The return value from \fIproc\fR is only used during read and +write tracing. +During unset traces, the return value is ignored and all relevant +trace procedures will always be invoked. + +.SH "RESTRICTIONS" +.PP +A trace procedure can be called at any time, even when there +is a partially-formed result in the interpreter's result area. If +the trace procedure does anything that could damage this result (such +as calling \fBTcl_Eval\fR) then it must save the original values of +the interpreter's \fBresult\fR and \fBfreeProc\fR fields and restore +them before it returns. + +.SH "UNDEFINED VARIABLES" +.PP +It is legal to set a trace on an undefined variable. +The variable will still appear to be undefined until the +first time its value is set. +If an undefined variable is traced and then unset, the unset will fail +with an error (``no such variable''), but the trace +procedure will still be invoked. + +.SH "TCL_TRACE_DESTROYED FLAG" +.PP +In an unset callback to \fIproc\fR, the TCL_TRACE_DESTROYED bit +is set in \fIflags\fR if the trace is being removed as part +of the deletion. +Traces on a variable are always removed whenever the variable +is deleted; the only time TCL_TRACE_DESTROYED isn't set is for +a whole-array trace invoked when only a single element of an +array is unset. + +.SH "TCL_INTERP_DESTROYED" +.PP +When an interpreter is destroyed, unset traces are called for +all of its variables. +The TCL_INTERP_DESTROYED bit will be set in the \fIflags\fR +argument passed to the trace procedures. +Trace procedures must be extremely careful in what they do if +the TCL_INTERP_DESTROYED bit is set. +It is not safe for the procedures to invoke any Tcl procedures +on the interpreter, since its state is partially deleted. +All that trace procedures should do under these circumstances is +to clean up and free their own internal data structures. + +.SH BUGS +.PP +Tcl doesn't do any error checking to prevent trace procedures +from misusing the interpreter during traces with TCL_INTERP_DESTROYED +set. + +.SH KEYWORDS +clientData, trace, variable diff --git a/contrib/tcl/doc/Translate.3 b/contrib/tcl/doc/Translate.3 new file mode 100644 index 0000000..81a16da --- /dev/null +++ b/contrib/tcl/doc/Translate.3 @@ -0,0 +1,76 @@ +'\" +'\" Copyright (c) 1989-1993 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: @(#) Translate.3 1.21 96/03/25 20:08:58 +'\" +.so man.macros +.TH Tcl_TranslateFileName 3 7.5 Tcl "Tcl Library Procedures" +.BS +.SH NAME +Tcl_TranslateFileName \- convert file name to native form and replace tilde with home directory +.SH SYNOPSIS +.nf +\fB#include <tcl.h>\fR +.sp +char * +.VS +\fBTcl_TranslateFileName\fR(\fIinterp\fR, \fIname\fR, \fIbufferPtr\fR) +.VE +.SH ARGUMENTS +.AS Tcl_DString *bufferPtr +.AP Tcl_Interp *interp in +Interpreter in which to report an error, if any. +.AP char *name in +File name, which may start with a ``~''. +.AP Tcl_DString *bufferPtr in/out +.VS +If needed, this dynamic string is used to store the new file name. +At the time of the call it should be uninitialized or empty. The +caller must eventually call \fBTcl_DStringFree\fR to free up +anything stored here. +.VE +.BE + +.SH DESCRIPTION +.PP +.VS +This utility procedure translates a file name to a form suitable for +passing to the local operating system. It converts network names into +native form and does tilde substitution. +.PP +If +\fBTcl_TranslateFileName\fR has to do tilde substitution or translate +the name then it uses +the dynamic string at \fI*bufferPtr\fR to hold the new string it +generates. +After \fBTcl_TranslateFileName\fR returns a non-NULL result, the caller must +eventually invoke \fBTcl_DStringFree\fR to free any information +placed in \fI*bufferPtr\fR. The caller need not know whether or +not \fBTcl_TranslateFileName\fR actually used the string; \fBTcl_TranslateFileName\fR +initializes \fI*bufferPtr\fR even if it doesn't use it, so the call to +\fBTcl_DStringFree\fR will be safe in either case. +.VE +.PP +If an error occurs (e.g. because there was no user by the given +name) then NULL is returned and an error message will be left +at \fIinterp->result\fR. +.VS +When an error occurs, \fBTcl_TranslateFileName\fR +frees the dynamic string itself so that the caller need not call +\fBTcl_DStringFree\fR. +.VE +.PP +The caller is responsible for making sure that \fIinterp->result\fR +has its default empty value when \fBTcl_TranslateFileName\fR is invoked. + +.VS +.SH "SEE ALSO" +filename +.VE + +.SH KEYWORDS +file name, home directory, tilde, translate, user diff --git a/contrib/tcl/doc/UpVar.3 b/contrib/tcl/doc/UpVar.3 new file mode 100644 index 0000000..ca0cc74 --- /dev/null +++ b/contrib/tcl/doc/UpVar.3 @@ -0,0 +1,76 @@ +'\" +'\" Copyright (c) 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: @(#) UpVar.3 1.6 96/03/25 20:09:19 +'\" +.so man.macros +.TH Tcl_UpVar 3 7.4 Tcl "Tcl Library Procedures" +.BS +.SH NAME +Tcl_UpVar, Tcl_UpVar2 \- link one variable to another +.SH SYNOPSIS +.nf +\fB#include <tcl.h>\fR +.sp +int +\fBTcl_UpVar(\fIinterp, frameName, sourceName, destName, flags\fB)\fR +.sp +int +\fBTcl_UpVar2(\fIinterp, frameName, name1, name2, destName, flags\fB)\fR +.SH ARGUMENTS +.AS Tcl_VarTraceProc prevClientData +.AP Tcl_Interp *interp in +Interpreter containing variables; also used for error reporting. +.AP 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 +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 +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 +an upvar-ed variable. +.AP int flags in +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 +First part of source variable's name (scalar name, or name of array +without array index). +.AP 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 DESCRIPTION +.PP +\fBTcl_UpVar\fR and \fBTcl_UpVar2\fR provide the same functionality +as the \fBupvar\fR command: they make a link from a source variable +to a destination variable, so that references to the destination are +passed transparently through to the source. +The name of the source variable may be specified either as a single +string such as \fBxyx\fR or \fBa(24)\fR (by calling \fBTcl_UpVar\fR) +or in two parts where the array name has been separated from the +element name (by calling \fBTcl_UpVar2\fR). +The destination variable name is specified in a single string; it +may not be an array element. +.PP +Both procedures return either TCL_OK or TCL_ERROR, and they +leave an error message in \fIinterp->result\fR if an error +occurs. +.PP +As with the \fBupvar\fR command, the source variable need not exist; +if it does exist, unsetting it later does not destroy the link. The +destination variable may exist at the time of the call, but if so +it must exist as a linked variable. + +.SH KEYWORDS +linked variable, upvar, variable diff --git a/contrib/tcl/doc/after.n b/contrib/tcl/doc/after.n new file mode 100644 index 0000000..cf4aaeb --- /dev/null +++ b/contrib/tcl/doc/after.n @@ -0,0 +1,109 @@ +'\" +'\" 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. +'\" +'\" SCCS: @(#) after.n 1.4 96/03/25 20:09:33 +'\" +.so man.macros +.TH after n 7.5 Tcl "Tcl Built-In Commands" +.BS +'\" Note: do not modify the .SH NAME line immediately below! +.SH NAME +after \- Execute a command after a time delay +.SH SYNOPSIS +\fBafter \fIms\fR +.sp +\fBafter \fIms \fR?\fIscript script script ...\fR? +.sp +\fBafter cancel \fIid\fR +.sp +\fBafter cancel \fIscript script script ...\fR +.sp +\fBafter idle \fR?\fIscript script script ...\fR? +.sp +\fBafter info \fR?\fIid\fR? +.BE + +.SH DESCRIPTION +.PP +This command is used to delay execution of the program or to execute +a command in background sometime in the future. It has several forms, +depending on the first argument to the command: +.TP +\fBafter \fIms\fR +\fIMs\fR must be an integer giving a time in milliseconds. +The command sleeps for \fIms\fR milliseconds and then returns. +While the command is sleeping the application does not respond to +events. +.TP +\fBafter \fIms \fR?\fIscript script script ...\fR? +In this form the command returns immediately, but it arranges +for a Tcl command to be executed \fIms\fR milliseconds later as an +event handler. +The command will be executed exactly once, at the given time. +The delayed command is formed by concatenating all the \fIscript\fR +arguments in the same fashion as the \fBconcat\fR command. +The command will be executed at global level (outside the context +of any Tcl procedure). +If an error occurs while executing the delayed command then the +\fBbgerror\fR mechanism is used to report the error. +The \fBafter\fR command returns an identifier that can be used +to cancel the delayed command using \fBafter cancel\fR. +.TP +\fBafter cancel \fIid\fR +Cancels the execution of a delayed command that +was previously scheduled. +\fIId\fR indicates which command should be canceled; it must have +been the return value from a previous \fBafter\fR command. +If the command given by \fIid\fR has already been executed then +the \fBafter cancel\fR command has no effect. +.TP +\fBafter cancel \fIscript script ...\fR +This command also cancels the execution of a delayed command. +The \fIscript\fR arguments are concatenated together with space +separators (just as in the \fBconcat\fR command). +If there is a pending command that matches the string, it is +cancelled and will never be executed; if no such command is +currently pending then the \fBafter cancel\fR command has no effect. +.TP +\fBafter idle \fIscript \fR?\fIscript script ...\fR? +Concatenates the \fIscript\fR arguments together with space +separators (just as in the \fBconcat\fR command), and arranges +for the resulting script to be evaluated later as an idle callback. +The script will be run exactly once, the next time the event +loop is entered and there are no events to process. +The command returns an identifier that can be used +to cancel the delayed command using \fBafter cancel\fR. +If an error occurs while executing the script then the +\fBbgerror\fR mechanism is used to report the error. +.TP +\fBafter info \fR?\fIid\fR? +This command returns information about existing event handlers. +If no \fIid\fR argument is supplied, the command returns +a list of the identifiers for all existing +event handlers created by the \fBafter\fR command for this +interpreter. +If \fIid\fR is supplied, it specifies an existing handler; +\fIid\fR must have been the return value from some previous call +to \fBafter\fR and it must not have triggered yet or been cancelled. +In this case the command returns a list with two elements. +The first element of the list is the script associated +with \fIid\fR, and the second element is either +\fBidle\fR or \fBtimer\fR to indicate what kind of event +handler it is. +.LP +The \fBafter \fIms\fR and \fBafter idle\fR forms of the command +assume that the application is event driven: the delayed commands +will not be executed unless the application enters the event loop. +In applications that are not normally event-driven, such as +\fBtclsh\fR, the event loop can be entered with the \fBvwait\fR +and \fBupdate\fR commands. + +.SH "SEE ALSO" +bgerror + +.SH KEYWORDS +cancel, delay, idle callback, sleep, time diff --git a/contrib/tcl/doc/append.n b/contrib/tcl/doc/append.n new file mode 100644 index 0000000..9d2ba34 --- /dev/null +++ b/contrib/tcl/doc/append.n @@ -0,0 +1,32 @@ +'\" +'\" Copyright (c) 1993 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: @(#) append.n 1.6 96/03/25 20:09:44 +'\" +.so man.macros +.TH append n "" Tcl "Tcl Built-In Commands" +.BS +'\" Note: do not modify the .SH NAME line immediately below! +.SH NAME +append \- Append to variable +.SH SYNOPSIS +\fBappend \fIvarName \fR?\fIvalue value value ...\fR? +.BE + +.SH DESCRIPTION +.PP +Append all of the \fIvalue\fR arguments to the current value +of variable \fIvarName\fR. If \fIvarName\fR doesn't exist, +it is given a value equal to the concatenation of all the +\fIvalue\fR arguments. +This command provides an efficient way to build up long +variables incrementally. +For example, ``\fBappend a $b\fR'' is much more efficient than +``\fBset a $a$b\fR'' if \fB$a\fR is long. + +.SH KEYWORDS +append, variable diff --git a/contrib/tcl/doc/array.n b/contrib/tcl/doc/array.n new file mode 100644 index 0000000..37265f1 --- /dev/null +++ b/contrib/tcl/doc/array.n @@ -0,0 +1,125 @@ +'\" +'\" 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: @(#) array.n 1.7 96/03/25 20:09:58 +'\" +.so man.macros +.TH array n 7.4 Tcl "Tcl Built-In Commands" +.BS +'\" Note: do not modify the .SH NAME line immediately below! +.SH NAME +array \- Manipulate array variables +.SH SYNOPSIS +\fBarray \fIoption arrayName\fR ?\fIarg arg ...\fR? +.BE + +.SH DESCRIPTION +.PP +This command performs one of several operations on the +variable given by \fIarrayName\fR. +Unless otherwise specified for individual commands below, +\fIarrayName\fR must be the name of an existing array variable. +The \fIoption\fR argument determines what action is carried +out by the command. +The legal \fIoptions\fR (which may be abbreviated) are: +.TP +\fBarray anymore \fIarrayName searchId\fR +Returns 1 if there are any more elements left to be processed +in an array search, 0 if all elements have already been +returned. +\fISearchId\fR indicates which search on \fIarrayName\fR to +check, and must have been the return value from a previous +invocation of \fBarray startsearch\fR. +This option is particularly useful if an array has an element +with an empty name, since the return value from +\fBarray nextelement\fR won't indicate whether the search +has been completed. +.TP +\fBarray donesearch \fIarrayName searchId\fR +This command terminates an array search and destroys all the +state associated with that search. \fISearchId\fR indicates +which search on \fIarrayName\fR to destroy, and must have +been the return value from a previous invocation of +\fBarray startsearch\fR. Returns an empty string. +.TP +\fBarray exists \fIarrayName\fR +.VS +Returns 1 if \fIarrayName\fR is an array variable, 0 if there +is no variable by that name or if it is a scalar variable. +.VE +.TP +\fBarray get \fIarrayName\fR ?\fIpattern\fR? +.VS +Returns a list containing pairs of elements. The first +element in each pair is the name of an element in \fIarrayName\fR +and the second element of each pair is the value of the +array element. The order of the pairs is undefined. +.VS +If \fIpattern\fR is not specified, then all of the elements of the +array are included in the result. +If \fIpattern\fR is specified, then only those elements whose names +match \fIpattern\fR (using the glob-style matching rules of +\fBstring match\fR) are included. +.VE +If \fIarrayName\fR isn't the name of an array variable, or if +the array contains no elements, then an empty list is returned. +.VE +.TP +\fBarray names \fIarrayName\fR ?\fIpattern\fR? +Returns a list containing the names of all of the elements in +.VS +the array that match \fIpattern\fR (using the glob-style matching +rules of \fBstring match\fR). +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. +.VE +.TP +\fBarray nextelement \fIarrayName searchId\fR +Returns the name of the next element in \fIarrayName\fR, or +an empty string if all elements of \fIarrayName\fR have +already been returned in this search. The \fIsearchId\fR +argument identifies the search, and must have +been the return value of an \fBarray startsearch\fR command. +Warning: if elements are added to or deleted from the array, +then all searches are automatically terminated just as if +\fBarray donesearch\fR had been invoked; this will cause +\fBarray nextelement\fR operations to fail for those searches. +.TP +\fBarray set \fIarrayName list\fR +.VS +Sets the values of one or more elements in \fIarrayName\fR. +\fIlist\fR must have a form like that returned by \fBarray get\fR, +consisting of an even number of elements. +Each odd-numbered element in \fIlist\fR is treated as an element +name within \fIarrayName\fR, and the following element in \fIlist\fR +is used as a new value for that array element. +.VE +.TP +\fBarray size \fIarrayName\fR +Returns a decimal string giving the number of elements in the +array. +.VS +If \fIarrayName\fR isn't the name of an array then 0 is returned. +.VE +.TP +\fBarray startsearch \fIarrayName\fR +This command initializes an element-by-element search through the +array given by \fIarrayName\fR, such that invocations of the +\fBarray nextelement\fR command will return the names of the +individual elements in the array. +When the search has been completed, the \fBarray donesearch\fR +command should be invoked. +The return value is a +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. + +.SH KEYWORDS +array, element names, search diff --git a/contrib/tcl/doc/bgerror.n b/contrib/tcl/doc/bgerror.n new file mode 100644 index 0000000..6875bcf --- /dev/null +++ b/contrib/tcl/doc/bgerror.n @@ -0,0 +1,67 @@ +'\" +'\" 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. +'\" +'\" SCCS: @(#) bgerror.n 1.3 96/03/25 20:10:12 +'\" +.so man.macros +.TH bgerror n 7.5 Tcl "Tcl Built-In Commands" +.BS +'\" Note: do not modify the .SH NAME line immediately below! +.SH NAME +bgerror \- Command invoked to process background errors +.SH SYNOPSIS +\fBbgerror \fImessage\fR +.BE + +.SH DESCRIPTION +.PP +The \fBbgerror\fR command doesn't exist as built-in part of Tcl. Instead, +individual applications or users can define a \fBbgerror\fR +command (e.g. as a Tcl procedure) if they wish to handle background +errors. +.PP +A background error is one that occurs in an event handler or some +other command that didn't originate with the application. +For example, if an error occurs while executing a command specified +with the \fBafter\fR command, then it is a background error. +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. +.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. +.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. +.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. +.PP +Tcl has no default implementation for \fBbgerror\fR. +However, in applications using Tk there will be a default +\fBbgerror\fR procedure that posts a dialog box containing +the error message and offers the user a chance to see a stack +trace showing where the error occurred. + +.SH KEYWORDS +background error, reporting diff --git a/contrib/tcl/doc/break.n b/contrib/tcl/doc/break.n new file mode 100644 index 0000000..6b3a47b --- /dev/null +++ b/contrib/tcl/doc/break.n @@ -0,0 +1,34 @@ +'\" +'\" 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: @(#) break.n 1.6 96/03/25 20:10:27 +'\" +.so man.macros +.TH break n "" Tcl "Tcl Built-In Commands" +.BS +'\" Note: do not modify the .SH NAME line immediately below! +.SH NAME +break \- Abort looping command +.SH SYNOPSIS +\fBbreak\fR +.BE + +.SH DESCRIPTION +.PP +This command is typically invoked inside the body of a looping command +such as \fBfor\fR or \fBforeach\fR or \fBwhile\fR. +It returns a TCL_BREAK code, which causes a break exception +to occur. +The exception causes the current script to be aborted +out to the the innermost containing loop command, which then +aborts its execution and returns normally. +Break exceptions are also handled in a few other situations, such +as the \fBcatch\fR command, Tk event bindings, and the outermost +scripts of procedure bodies. + +.SH KEYWORDS +abort, break, loop diff --git a/contrib/tcl/doc/case.n b/contrib/tcl/doc/case.n new file mode 100644 index 0000000..d375288 --- /dev/null +++ b/contrib/tcl/doc/case.n @@ -0,0 +1,59 @@ +'\" +'\" Copyright (c) 1993 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: @(#) case.n 1.8 96/03/25 20:10:49 +'\" +.so man.macros +.TH case n 7.0 Tcl "Tcl Built-In Commands" +.BS +'\" Note: do not modify the .SH NAME line immediately below! +.SH NAME +case \- Evaluate one of several scripts, depending on a given value +.SH SYNOPSIS +\fBcase\fI string \fR?\fBin\fR? \fIpatList body \fR?\fIpatList body \fR...? +.sp +\fBcase\fI string \fR?\fBin\fR? {\fIpatList body \fR?\fIpatList body \fR...?} +.BE + +.SH DESCRIPTION +.PP +\fINote: the \fBcase\fI command is obsolete and is supported only +for backward compatibility. At some point in the future it may be +removed entirely. You should use the \fBswitch\fI command instead.\fR +.PP +The \fBcase\fR command matches \fIstring\fR against each of +the \fIpatList\fR arguments in order. +Each \fIpatList\fR argument is a list of one or +more patterns. If any of these patterns matches \fIstring\fR then +\fBcase\fR evaluates the following \fIbody\fR argument +by passing it recursively to the Tcl interpreter and returns the result +of that evaluation. +Each \fIpatList\fR argument consists of a single +pattern or list of patterns. Each pattern may contain any of the wild-cards +described under \fBstring match\fR. If a \fIpatList\fR +argument is \fBdefault\fR, the corresponding body will be evaluated +if no \fIpatList\fR matches \fIstring\fR. If no \fIpatList\fR argument +matches \fIstring\fR and no default is given, then the \fBcase\fR +command returns an empty string. +.PP +Two syntaxes are provided for the \fIpatList\fR and \fIbody\fR arguments. +The first uses a separate argument for each of the patterns and commands; +this form is convenient if substitutions are desired on some of the +patterns or commands. +The second form places all of the patterns and commands together into +a single argument; the argument must have proper list structure, with +the elements of the list being the patterns and commands. +The second form makes it easy to construct multi-line case commands, +since the braces around the whole list make it unnecessary to include a +backslash at the end of each line. +Since the \fIpatList\fR arguments are in braces in the second form, +no command or variable substitutions are performed on them; this makes +the behavior of the second form different than the first form in some +cases. + +.SH KEYWORDS +case, match, regular expression diff --git a/contrib/tcl/doc/catch.n b/contrib/tcl/doc/catch.n new file mode 100644 index 0000000..8aff166 --- /dev/null +++ b/contrib/tcl/doc/catch.n @@ -0,0 +1,40 @@ +'\" +'\" 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: @(#) catch.n 1.6 96/03/25 20:11:08 +'\" +.so man.macros +.TH catch n "" Tcl "Tcl Built-In Commands" +.BS +'\" Note: do not modify the .SH NAME line immediately below! +.SH NAME +catch \- Evaluate script and trap exceptional returns +.SH SYNOPSIS +\fBcatch\fI script \fR?\fIvarName\fR? +.BE + +.SH DESCRIPTION +.PP +The \fBcatch\fR command may be used to prevent errors from aborting +command interpretation. \fBCatch\fR calls the Tcl interpreter recursively +to execute \fIscript\fR, and always returns a TCL_OK code, regardless of +any errors that might occur while executing \fIscript\fR. The return +value from \fBcatch\fR is a decimal string giving the +code returned by the Tcl interpreter after executing \fIscript\fR. +This will be \fB0\fR (TCL_OK) if there were no errors in \fIscript\fR; +otherwise +it will have a non-zero value corresponding to one of the exceptional +return codes (see tcl.h for the definitions of code values). If the +\fIvarName\fR argument is given, then it gives the name of a variable; +\fBcatch\fR will set the variable to the string returned +from \fIscript\fR (either a result or an error message). +.PP +Note that \fBcatch\fR catches all exceptions, including those +generated by \fBbreak\fR and \fBcontinue\fR as well as errors. + +.SH KEYWORDS +catch, error diff --git a/contrib/tcl/doc/cd.n b/contrib/tcl/doc/cd.n new file mode 100644 index 0000000..6925a87 --- /dev/null +++ b/contrib/tcl/doc/cd.n @@ -0,0 +1,28 @@ +'\" +'\" Copyright (c) 1993 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: @(#) cd.n 1.6 96/03/28 08:40:52 +'\" +.so man.macros +.TH cd n "" Tcl "Tcl Built-In Commands" +.BS +'\" Note: do not modify the .SH NAME line immediately below! +.SH NAME +cd \- Change working directory +.SH SYNOPSIS +\fBcd \fR?\fIdirName\fR? +.BE + +.SH DESCRIPTION +.PP +Change the current working directory to \fIdirName\fR, or to the +home directory (as specified in the HOME environment variable) if +\fIdirName\fR is not given. +Returns an empty string. + +.SH KEYWORDS +working directory diff --git a/contrib/tcl/doc/clock.n b/contrib/tcl/doc/clock.n new file mode 100644 index 0000000..fc8e482 --- /dev/null +++ b/contrib/tcl/doc/clock.n @@ -0,0 +1,176 @@ +'\" +'\" Copyright (c) 1992-1995 Karl Lehenbauer and Mark Diekhans. +'\" Copyright (c) 1995-1996 Sun Microsystems, Inc. +'\" +'\" This documentation is derived from the time and date facilities of +'\" TclX, by Mark Diekhans and Karl Lehenbauer. +'\" +'\" See the file "license.terms" for information on usage and redistribution +'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. +'\" +'\" SCCS: @(#) clock.n 1.12 96/04/16 08:20:08 +'\" +.so man.macros +.TH clock n 7.4 Tcl "Tcl Built-In Commands" +.BS +'\" Note: do not modify the .SH NAME line immediately below! +.SH NAME +clock \- Obtain and manipulate time +.SH SYNOPSIS +\fBclock \fIoption\fR ?\fIarg arg ...\fR? +.BE + +.SH DESCRIPTION +.PP +This command performs one of several operations that may obtain +or manipulate strings or values that represent some notion of +time. The \fIoption\fR argument determines what action is carried +out by the command. The legal \fIoptions\fR (which may be +abbreviated) are: +.TP +\fBclock clicks\fR +Return a high-resolution time value as a system-dependent integer +value. The unit of the value is system-dependent but should be the +highest resolution clock available on the system such as a CPU cycle +counter. This value should only be used for the relative measurement +of elapsed time. +.TP +\fBclock format \fIclockValue\fR ?\fB\-format \fIstring\fR? ?\fB\-gmt \fIboolean\fR? +Converts an integer time value, typically returned by +\fBclock seconds\fR, \fBclock scan\fR, or the \fBatime\fR, \fBmtime\fR, +or \fBctime\fR options of the \fBfile\fR command, to human-readable +form. If the \fB\-format\fR argument is present the next argument is a +string that describes how the date and time are to be formatted. +Field descriptors consist of a \fB%\fR followed by a field +descriptor character. All other characters are copied into the result. +Valid field descriptors are: +.RS +.IP \fB%%\fR +Insert a %. +.IP \fB%a\fR +Abbreviated weekday name. (Mon, Tue, etc.) +.IP \fB%A\fR +Full weekday name. (Monday, Tuesday, etc.) +.IP \fB%b\fR +Abbreviated month name. (Jan, Feb, etc.) +.IP \fB%B\fR +Full month name. +.IP \fB%d\fR +Day of month (01 - 31). +.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%H\fR +Hour (00 - 23). +.IP \fB%I\fR +Hour (00 - 12). +.IP \fB%j\fR +Day number of year (001 - 366). +.IP \fB%m\fR +Month number (01 - 12). +.IP \fB%M\fR +Minute (00 - 59). +.IP \fB%n\fR +Insert a newline. +.IP \fB%p\fR +AM or PM. +.IP \fB%r\fR +Time as %I:%M:%S %p. +.IP \fB%R\fR +Time as %H:%M. +.IP \fB%S\fR +Seconds (00 - 59). +.IP \fB%t\fR +Insert a tab. +.IP \fB%T\fR +Time as %H:%M:%S. +.IP \fB%U\fR +Week number of year (01 - 52), Sunday is the first day of the week. +.IP \fB%w\fR +Weekday number (Sunday = 0). +.IP \fB%W\fR +Week number of year (01 - 52), Monday is the first day of the week. +.IP \fB%x\fR +Local specific date format. +.IP \fB%X\fR +Local specific time format. +.IP \fB%y\fR +Year within century (00 - 99). +.IP \fB%Y\fR +Year as ccyy (e.g. 1990) +.IP \fB%Z\fR +Time zone name. +.RE +.sp +.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 +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 +environment. +.RE +.TP +\fBclock scan \fIdateString\fR ?\fB\-base \fIclockVal\fR? ?\fB\-gmt \fIboolean\fR? +Convert \fIdateString\fR to an integer clock value (see \fBclock seconds\fR). +This command can parse and convert virtually any standard date and/or time +string, which can include standard time zone mnemonics. If only a time is +specified, the current date is assumed. If the string does not contain a +time zone mnemonic, the local time zone is assumed, unless the \fB\-gmt\fR +argument is true, in which case the clock value is calculated assuming +that the specified time is relative to Greenwich Mean Time. +.sp +If the \fB\-base\fR flag is specified, the next argument should contain +an integer clock value. Only the date in this value is used, not the +time. This is useful for determining the time on a specific day or +doing other date-relative conversions. +.sp +The \fIdateString\fR consists of zero or more specifications of the +following form: +.RS +.TP +\fItime\fR +A time of day, which is of the form: \fIhh\fR?\fI:mm\fR?\fI:ss\fR?? +?\fImeridian\fR? ?\fIzone\fR? or \fIhhmm \fR?\fImeridian\fR? +?\fIzone\fR?. If no meridian is specified, \fIhh\fR is interpreted on +a 24-hour clock. +.TP +\fIdate\fR +A specific month and day with optional year. The +acceptable formats are \fImm/dd\fR?\fI/yy\fR?, \fImonthname dd\fR +?, \fIyy\fR?, \fIdd monthname \fR?\fIyy\fR? and \fIday, dd monthname +yy\fR. The default year is the current year. If the year is less +then 100, then 1900 is added to it. +.TP +\fIrelative time\fR +A specification relative to the current time. The format is \fInumber +unit\fR acceptable units are \fByear\fR, \fBfortnight\fR, \fBmonth\fR, \fBweek\fR, \fBday\fR, +\fBhour\fR, \fBminute\fR (or \fBmin\fR), and \fBsecond\fR (or \fBsec\fR). The +unit can be specified as a singular or plural, as in \fB3 weeks\fR. +These modifiers may also be specified: +\fBtomorrow\fR, \fByesterday\fR, \fBtoday\fR, \fBnow\fR, +\fBlast\fR, \fBthis\fR, \fBnext\fR, \fBago\fR. +.RE +.sp +.RS +The actual date is calculated according to the following steps. +First, any absolute date and/or time is processed and converted. +Using that time as the base, day-of-week specifications are added. +Next, relative specifications are used. If a date or day is +specified, and no absolute or relative time is given, midnight is +used. Finally, a correction is applied so that the correct hour of +the day is produced after allowing for daylight savings time +differences. +.RE +.TP +\fBclock seconds\fR +Return the current date and time as a system-dependent integer value. The +unit of the value is seconds, allowing it to be used for relative time +calculations. The value is usually defined as total elapsed time from +an ``epoch''. You shouldn't assume the value of the epoch. + +.SH KEYWORDS +clock, date, time diff --git a/contrib/tcl/doc/close.n b/contrib/tcl/doc/close.n new file mode 100644 index 0000000..0ed5a1f --- /dev/null +++ b/contrib/tcl/doc/close.n @@ -0,0 +1,59 @@ +'\" +'\" Copyright (c) 1993 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: @(#) close.n 1.10 96/02/15 20:01:34 +'\" +.so man.macros +.TH close n 7.5 Tcl "Tcl Built-In Commands" +.BS +'\" Note: do not modify the .SH NAME line immediately below! +.SH NAME +close \- Close an open channel. +.SH SYNOPSIS +\fBclose \fIchannelId\fR +.BE + +.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. +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. +.VS br +.PP +If the channel is blocking, the command does not return until all output +is flushed. +If the channel is nonblocking and there is unflushed output, the +channel remains open and the command +returns immediately; output will be flushed in the background and the +channel will be closed when all the flushing is complete. +.VE +.PP +If \fIchannelId\fR is a blocking channel for a command pipeline then +\fBclose\fR waits for the child processes to complete. +.VS br +.PP +If the channel is shared between interpreters, then \fBclose\fR +makes \fIchannelId\fR unavailable in the invoking interpreter but has no +other effect until all of the sharing interpreters have closed the +channel. +When the last interpreter in which the channel is registered invokes +\fBclose\fR, the cleanup actions described above occur. See the +\fBinterp\fR command for a description of channel sharing. +.PP +Channels are automatically closed when an interpreter is destroyed and +when the process exits. Channels are switched to blocking mode, to ensure +that all output is correctly flushed before the process exits. +.VE +.PP +The command returns an empty string, and may generate an error if +an error occurs while flushing output. + +.SH KEYWORDS +blocking, channel, close, nonblocking diff --git a/contrib/tcl/doc/concat.n b/contrib/tcl/doc/concat.n new file mode 100644 index 0000000..f248335 --- /dev/null +++ b/contrib/tcl/doc/concat.n @@ -0,0 +1,44 @@ +'\" +'\" Copyright (c) 1993 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: @(#) concat.n 1.7 96/03/25 20:11:56 +'\" +.so man.macros +.TH concat n "" Tcl "Tcl Built-In Commands" +.BS +'\" Note: do not modify the .SH NAME line immediately below! +.SH NAME +concat \- Join lists together +.SH SYNOPSIS +.VS +\fBconcat\fI \fR?\fIarg arg ...\fR? +.VE +.BE + +.SH DESCRIPTION +.PP +This command treats each argument as a list and concatenates 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 +.CS +\fBconcat a b {c d e} {f {g h}}\fR +.CE +will return +.CS +\fBa b c d e f {g h}\fR +.CE +as its result. +.PP +.VS +If no \fIarg\fRs are supplied, the result is an empty string. +.VE + +.SH KEYWORDS +concatenate, join, lists diff --git a/contrib/tcl/doc/continue.n b/contrib/tcl/doc/continue.n new file mode 100644 index 0000000..75434a8 --- /dev/null +++ b/contrib/tcl/doc/continue.n @@ -0,0 +1,34 @@ +'\" +'\" 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: @(#) continue.n 1.6 96/03/25 20:12:09 +'\" +.so man.macros +.TH continue n "" Tcl "Tcl Built-In Commands" +.BS +'\" Note: do not modify the .SH NAME line immediately below! +.SH NAME +continue \- Skip to the next iteration of a loop +.SH SYNOPSIS +\fBcontinue\fR +.BE + +.SH DESCRIPTION +.PP +This command is typically invoked inside the body of a looping command +such as \fBfor\fR or \fBforeach\fR or \fBwhile\fR. +It returns a TCL_CONTINUE code, which causes a continue exception +to occur. +The exception causes the current script to be aborted +out to the the innermost containing loop command, which then +continues with the next iteration of the loop. +Catch exceptions are also handled in a few other situations, such +as the \fBcatch\fR command and the outermost scripts of procedure +bodies. + +.SH KEYWORDS +continue, iteration, loop diff --git a/contrib/tcl/doc/eof.n b/contrib/tcl/doc/eof.n new file mode 100644 index 0000000..71de06a --- /dev/null +++ b/contrib/tcl/doc/eof.n @@ -0,0 +1,27 @@ +'\" +'\" Copyright (c) 1993 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: @(#) eof.n 1.8 96/02/15 20:01:59 +'\" +.so man.macros +.TH eof n 7.5 Tcl "Tcl Built-In Commands" +.BS +'\" Note: do not modify the .SH NAME line immediately below! +.SH NAME +eof \- Check for end of file condition on channel +.SH SYNOPSIS +\fBeof \fIchannelId\fR +.BE + +.SH DESCRIPTION +.PP +Returns 1 if an end of file condition occurred during the most +recent input operation on \fIchannelId\fR (such as \fBgets\fR), +0 otherwise. + +.SH KEYWORDS +channel, end of file diff --git a/contrib/tcl/doc/error.n b/contrib/tcl/doc/error.n new file mode 100644 index 0000000..6be285b --- /dev/null +++ b/contrib/tcl/doc/error.n @@ -0,0 +1,58 @@ +'\" +'\" Copyright (c) 1993 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: @(#) error.n 1.7 96/03/25 20:12:35 +'\" +.so man.macros +.TH error n "" Tcl "Tcl Built-In Commands" +.BS +'\" Note: do not modify the .SH NAME line immediately below! +.SH NAME +error \- Generate an error +.SH SYNOPSIS +\fBerror \fImessage\fR ?\fIinfo\fR? ?\fIcode\fR? +.BE + +.SH DESCRIPTION +.PP +Returns a TCL_ERROR code, which causes command interpretation to be +unwound. \fIMessage\fR is a string that is returned to the application +to indicate what went wrong. +.PP +If the \fIinfo\fR argument is provided and is non-empty, +it is used to initialize the global variable \fBerrorInfo\fR. +\fBerrorInfo\fR is used to accumulate a stack trace of what +was in progress when an error occurred; as nested commands unwind, +the Tcl interpreter adds information to \fBerrorInfo\fR. If the +\fIinfo\fR argument is present, it is used to initialize +\fBerrorInfo\fR and the first increment of unwind information +will not be added by the Tcl interpreter. In other +words, the command containing the \fBerror\fR command will not appear +in \fBerrorInfo\fR; in its place will be \fIinfo\fR. +This feature is most useful in conjunction with the \fBcatch\fR command: +if a caught error cannot be handled successfully, \fIinfo\fR can be used +to return a stack trace reflecting the original point of occurrence +of the error: +.CS +\fBcatch {...} errMsg +set savedInfo $errorInfo +\&... +error $errMsg $savedInfo\fR +.CE +.PP +If the \fIcode\fR argument is present, then its value is stored +in the \fBerrorCode\fR global variable. This variable is intended +to hold a machine-readable description of the error in cases where +such information is available; see the \fBtclvars\fR manual +page for information on the proper format for the variable. +If the \fIcode\fR argument is not +present, then \fBerrorCode\fR is automatically reset to +``NONE'' by the Tcl interpreter as part of processing the +error generated by the command. + +.SH KEYWORDS +error, errorCode, errorInfo diff --git a/contrib/tcl/doc/eval.n b/contrib/tcl/doc/eval.n new file mode 100644 index 0000000..8ea7ae3 --- /dev/null +++ b/contrib/tcl/doc/eval.n @@ -0,0 +1,30 @@ +'\" +'\" Copyright (c) 1993 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: @(#) eval.n 1.5 96/03/25 20:12:53 +'\" +.so man.macros +.TH eval n "" Tcl "Tcl Built-In Commands" +.BS +'\" Note: do not modify the .SH NAME line immediately below! +.SH NAME +eval \- Evaluate a Tcl script +.SH SYNOPSIS +\fBeval \fIarg \fR?\fIarg ...\fR? +.BE + +.SH DESCRIPTION +.PP +\fBEval\fR takes one or more arguments, which together comprise a Tcl +script containing one or more commands. +\fBEval\fR concatenates all its arguments in the same +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). + +.SH KEYWORDS +concatenate, evaluate, script diff --git a/contrib/tcl/doc/exec.n b/contrib/tcl/doc/exec.n new file mode 100644 index 0000000..6b731e2 --- /dev/null +++ b/contrib/tcl/doc/exec.n @@ -0,0 +1,185 @@ +'\" +'\" Copyright (c) 1993 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: @(#) exec.n 1.12 96/03/25 20:13:20 +'\" +.so man.macros +.TH exec n 7.0 Tcl "Tcl Built-In Commands" +.BS +'\" Note: do not modify the .SH NAME line immediately below! +.SH NAME +exec \- Invoke subprocess(es) +.SH SYNOPSIS +\fBexec \fR?\fIswitches\fR? \fIarg \fR?\fIarg ...\fR? +.BE + +.SH DESCRIPTION +.PP +This command treats its arguments as the specification +of one or more subprocesses to execute. +The arguments take the form of a standard shell pipeline +where each \fIarg\fR becomes one word of a command, and +each distinct command becomes a subprocess. +.PP +If the initial arguments to \fBexec\fR start with \fB\-\fR then +.VS +they are treated as command-line switches and are not part +of the pipeline specification. The following switches are +currently supported: +.TP 13 +\fB\-keepnewline\fR +Retains a trailing newline in the pipeline's output. +Normally a trailing newline will be deleted. +.TP 13 +\fB\-\|\-\fR +Marks the end of switches. The argument following this one will +be treated as the first \fIarg\fR even if it starts with a \fB\-\fR. +.VE +.PP +If an \fIarg\fR (or pair of \fIarg\fR's) has one of the forms +described below then it is used by \fBexec\fR to control the +flow of input and output among the subprocess(es). +Such arguments will not be passed to the subprocess(es). In forms +.VS +such as ``< \fIfileName\fR'' \fIfileName\fR may either be in a +separate argument from ``<'' or in the same argument with no +intervening space (i.e. ``<\fIfileName\fR''). +.VE +.TP 15 +| +Separates distinct commands in the pipeline. The standard output +of the preceding command will be piped into the standard input +of the next command. +.TP 15 +|& +Separates distinct commands in the pipeline. Both standard output +and standard error of the preceding command will be piped into +the standard input of the next command. +This form of redirection overrides forms such as 2> and >&. +.TP 15 +<\0\fIfileName\fR +The file named by \fIfileName\fR is opened and used as the standard +input for the first command in the pipeline. +.TP 15 +<@\0\fIfileId\fR +.VS +\fIFileId\fR must be the identifier for an open file, such as the return +value from a previous call to \fBopen\fR. +It is used as the standard input for the first command in the pipeline. +\fIFileId\fR must have been opened for reading. +.VE +.TP 15 +<<\0\fIvalue\fR +\fIValue\fR is passed to the first command as its standard input. +.TP 15 +>\0\fIfileName\fR +Standard output from the last command is redirected to the file named +\fIfileName\fR, overwriting its previous contents. +.TP 15 +2>\0\fIfileName\fR +.VS +Standard error from all commands in the pipeline is redirected to the +file named \fIfileName\fR, overwriting its previous contents. +.TP 15 +>&\0\fIfileName\fR +Both standard output from the last command and standard error from all +commands are redirected to the file named \fIfileName\fR, overwriting +its previous contents. +.VE +.TP 15 +>>\0\fIfileName\fR +Standard output from the last command is +redirected to the file named \fIfileName\fR, appending to it rather +than overwriting it. +.TP 15 +2>>\0\fIfileName\fR +.VS +Standard error from all commands in the pipeline is +redirected to the file named \fIfileName\fR, appending to it rather +than overwriting it. +.TP 15 +>>&\0\fIfileName\fR +Both standard output from the last command and standard error from +all commands are redirected to the file named \fIfileName\fR, +appending to it rather than overwriting it. +.TP 15 +>@\0\fIfileId\fR +\fIFileId\fR must be the identifier for an open file, such as the return +value from a previous call to \fBopen\fR. +Standard output from the last command is redirected to \fIfileId\fR's +file, which must have been opened for writing. +.TP 15 +2>@\0\fIfileId\fR +\fIFileId\fR must be the identifier for an open file, such as the return +value from a previous call to \fBopen\fR. +Standard error from all commands in the pipeline is +redirected to \fIfileId\fR's file. +The file must have been opened for writing. +.TP 15 +>&@\0\fIfileId\fR +\fIFileId\fR must be the identifier for an open file, such as the return +value from a previous call to \fBopen\fR. +Both standard output from the last command and standard error from +all commands are redirected to \fIfileId\fR's file. +The file must have been opened for writing. +.VE +.PP +If standard output has not been redirected then the \fBexec\fR +command returns the standard output from the last command +in the pipeline. +If any of the commands in the pipeline exit abnormally or +are killed or suspended, then \fBexec\fR will return an error +and the error message will include the pipeline's output followed by +error messages describing the abnormal terminations; the +\fBerrorCode\fR variable will contain additional information +about the last abnormal termination encountered. +If any of the commands writes to its standard error file and that +standard error isn't redirected, +then \fBexec\fR will return an error; the error message +will include the pipeline's standard output, followed by messages +about abnormal terminations (if any), followed by the standard error +output. +.PP +If the last character of the result or error message +is a newline then that character is normally deleted +from the result or error message. +This is consistent with other Tcl return values, which don't +normally end with newlines. +.VS +However, if \fB\-keepnewline\fR is specified then the trailing +newline is retained. +.VE +.PP +If standard input isn't redirected with ``<'' or ``<<'' +or ``<@'' then the standard input for the first command in the +pipeline is taken from the application's current standard input. +.PP +If the last \fIarg\fR is ``&'' then the pipeline will be +executed in background. +.VS +In this case the \fBexec\fR command will return a list whose +elements are the process identifiers for all of the subprocesses +in the pipeline. +.VE +The standard output from the last command in the pipeline will +go to the application's standard output if it hasn't been +redirected, and error output from all of +the commands in the pipeline will go to the application's +standard error file unless redirected. +.PP +The first word in each command is taken as the command name; +tilde-substitution is performed on it, and if the result contains +no slashes then the directories +in the PATH environment variable are searched for +an executable by the given name. +If the name contains a slash then it must refer to an executable +reachable from the current directory. +No ``glob'' expansion or other shell-like substitutions +are performed on the arguments to commands. + +.SH KEYWORDS +execute, pipeline, redirection, subprocess diff --git a/contrib/tcl/doc/exit.n b/contrib/tcl/doc/exit.n new file mode 100644 index 0000000..2dfffb4 --- /dev/null +++ b/contrib/tcl/doc/exit.n @@ -0,0 +1,28 @@ +'\" +'\" Copyright (c) 1993 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: @(#) exit.n 1.6 96/03/25 20:13:32 +'\" +.so man.macros +.TH exit n "" Tcl "Tcl Built-In Commands" +.BS +'\" Note: do not modify the .SH NAME line immediately below! +.SH NAME +exit \- End the application +.SH SYNOPSIS +\fBexit \fR?\fIreturnCode\fR? +.BE + +.SH DESCRIPTION +.PP +Terminate the process, returning \fIreturnCode\fR to the +system as the exit status. +If \fIreturnCode\fR isn't specified then it defaults +to 0. + +.SH KEYWORDS +exit, process diff --git a/contrib/tcl/doc/expr.n b/contrib/tcl/doc/expr.n new file mode 100644 index 0000000..e8a80e9 --- /dev/null +++ b/contrib/tcl/doc/expr.n @@ -0,0 +1,299 @@ +'\" +'\" Copyright (c) 1993 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: @(#) expr.n 1.17 96/03/14 10:54:40 +'\" +.so man.macros +.TH expr n 7.4 Tcl "Tcl Built-In Commands" +.BS +'\" Note: do not modify the .SH NAME line immediately below! +.SH NAME +expr \- Evaluate an expression +.SH SYNOPSIS +\fBexpr \fIarg \fR?\fIarg arg ...\fR? +.BE + +.SH DESCRIPTION +.PP +.VS +Concatenates \fIarg\fR's (adding separator spaces between them), +evaluates the result as a Tcl expression, and returns the value. +.VE +The operators permitted in Tcl expressions are a subset of +the operators permitted in C expressions, and they have the +same meaning and precedence as the corresponding C operators. +Expressions almost always yield numeric results +(integer or floating-point values). +For example, the expression +.CS +\fBexpr 8.2 + 6\fR +.CE +evaluates to 14.2. +Tcl expressions differ from C expressions in the way that +operands are specified. Also, Tcl expressions support +non-numeric operands and string comparisons. +.SH OPERANDS +.PP +A Tcl expression consists of a combination of operands, operators, +and parentheses. +White space may be used between the operands and operators and +parentheses; it is ignored by the expression processor. +Where possible, operands are interpreted as integer values. +Integer values may be specified in decimal (the normal case), in octal (if the +first character of the operand is \fB0\fR), or in hexadecimal (if the first +two characters of the operand are \fB0x\fR). +If an operand does not have one of the integer formats given +above, then it is treated as a floating-point number if that is +possible. Floating-point numbers may be specified in any of the +ways accepted by an ANSI-compliant C compiler (except that the +``f'', ``F'', ``l'', and ``L'' suffixes will not be permitted in +most installations). For example, all of the +following are valid floating-point numbers: 2.1, 3., 6e4, 7.91e+16. +If no numeric interpretation is possible, then an operand is left +as a string (and only a limited set of operators may be applied to +it). +.PP +Operands may be specified in any of the following ways: +.IP [1] +As an numeric value, either integer or floating-point. +.IP [2] +As a Tcl variable, using standard \fB$\fR notation. +The variable's value will be used as the operand. +.IP [3] +As a string enclosed in double-quotes. +The expression parser will perform backslash, variable, and +command substitutions on the information between the quotes, +and use the resulting value as the operand +.IP [4] +As a string enclosed in braces. +The characters between the open brace and matching close brace +will be used as the operand without any substitutions. +.IP [5] +As a Tcl command enclosed in brackets. +The command will be executed and its result will be used as +the operand. +.IP [6] +.VS +As a mathematical function whose arguments have any of the above +forms for operands, such as ``\fBsin($x)\fR''. See below for a list of defined +functions. +.VE +.LP +Where substitutions occur above (e.g. inside quoted strings), they +are performed by the expression processor. +However, an additional layer of substitution may already have +been performed by the command parser before the expression +processor was called. +As discussed below, it is usually best to enclose expressions +in braces to prevent the command parser from performing substitutions +on the contents. +.PP +For some examples of simple expressions, suppose the variable +\fBa\fR has the value 3 and +the variable \fBb\fR has the value 6. +Then the command on the left side of each of the lines below +will produce the value on the right side of the line: +.CS +.ta 6c +\fBexpr 3.1 + $a 6.1 +expr 2 + "$a.$b" 5.6 +expr 4*[llength "6 2"] 8 +expr {{word one} < "word $a"} 0\fR +.CE +.SH OPERATORS +.PP +The valid operators are listed below, grouped in decreasing order +of precedence: +.TP 20 +\fB\-\0\0+\0\0~\0\0!\fR +.VS +Unary minus, unary plus, bit-wise NOT, logical NOT. None of these operands +.VE +may be applied to string operands, and bit-wise NOT may be +applied only to integers. +.TP 20 +\fB*\0\0/\0\0%\fR +Multiply, divide, remainder. None of these operands may be +applied to string operands, and remainder may be applied only +to integers. +.VS +The remainder will always have the same sign as the divisor and +an absolute value smaller than the divisor. +.VE +.TP 20 +\fB+\0\0\-\fR +Add and subtract. Valid for any numeric operands. +.TP 20 +\fB<<\0\0>>\fR +Left and right shift. Valid for integer operands only. +A right shift always propagates the sign bit. +.TP 20 +\fB<\0\0>\0\0<=\0\0>=\fR +Boolean less, greater, less than or equal, and greater than or equal. +Each operator produces 1 if the condition is true, 0 otherwise. +These operators may be applied to strings as well as numeric operands, +in which case string comparison is used. +.TP 20 +\fB==\0\0!=\fR +Boolean equal and not equal. Each operator produces a zero/one result. +Valid for all operand types. +.TP 20 +\fB&\fR +Bit-wise AND. Valid for integer operands only. +.TP 20 +\fB^\fR +Bit-wise exclusive OR. Valid for integer operands only. +.TP 20 +\fB|\fR +Bit-wise OR. Valid for integer operands only. +.TP 20 +\fB&&\fR +Logical AND. Produces a 1 result if both operands are non-zero, 0 otherwise. +Valid for numeric operands only (integers or floating-point). +.TP 20 +\fB||\fR +Logical OR. Produces a 0 result if both operands are zero, 1 otherwise. +Valid for numeric operands only (integers or floating-point). +.TP 20 +\fIx\fB?\fIy\fB:\fIz\fR +If-then-else, as in C. If \fIx\fR +evaluates to non-zero, then the result is the value of \fIy\fR. +Otherwise the result is the value of \fIz\fR. +The \fIx\fR operand must have a numeric value. +.LP +See the C manual for more details on the results +produced by each operator. +All of the binary operators group left-to-right within the same +precedence level. For example, the command +.CS +\fBexpr 4*2 < 7\fR +.CE +returns 0. +.PP +The \fB&&\fR, \fB||\fR, and \fB?:\fR operators have ``lazy +evaluation'', just as in C, +which means that operands are not evaluated if they are +not needed to determine the outcome. For example, in the command +.CS +\fBexpr {$v ? [a] : [b]}\fR +.CE +only one of \fB[a]\fR or \fB[b]\fR will actually be evaluated, +depending on the value of \fB$v\fR. Note, however, that this is +only true if the entire expression is enclosed in braces; otherwise +the Tcl parser will evaluate both \fB[a]\fR and \fB[b]\fR before +invoking the \fBexpr\fR command. +.SH "MATH FUNCTIONS" +.PP +.VS +Tcl supports the following mathematical functions in expressions: +.DS +.ta 3c 6c 9c +\fBacos\fR \fBcos\fR \fBhypot\fR \fBsinh\fR +\fBasin\fR \fBcosh\fR \fBlog\fR \fBsqrt\fR +\fBatan\fR \fBexp\fR \fBlog10\fR \fBtan\fR +\fBatan2\fR \fBfloor\fR \fBpow\fR \fBtanh\fR +\fBceil\fR \fBfmod\fR \fBsin\fR +.DE +Each of these functions invokes the math library function of the same +name; see the manual entries for the library functions for details +on what they do. Tcl also implements the following functions for +conversion between integers and floating-point numbers: +.TP +\fBabs(\fIarg\fB)\fR +Returns the absolute value of \fIarg\fR. \fIArg\fR may be either +integer or floating-point, and the result is returned in the same form. +.TP +\fBdouble(\fIarg\fB)\fR +If \fIarg\fR is a floating value, returns \fIarg\fR, otherwise converts +\fIarg\fR to floating and returns the converted value. +.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. +.TP +\fBround(\fIarg\fB)\fR +If \fIarg\fR is an integer value, returns \fIarg\fR, otherwise converts +\fIarg\fR to integer by rounding and returns the converted value. +.PP +In addition to these predefined functions, applications may +define additional functions using \fBTcl_CreateMathFunc\fR(). +.VE +.SH "TYPES, OVERFLOW, AND PRECISION" +.PP +All internal computations involving integers are done with the C type +\fIlong\fR, and all internal computations involving floating-point are +done with the C type \fIdouble\fR. +When converting a string to floating-point, exponent overflow is +detected and results in a Tcl error. +For conversion to integer from string, detection of overflow depends +on the behavior of some routines in the local C library, so it should +be regarded as unreliable. +In any case, integer overflow and underflow are generally not detected +reliably for intermediate results. Floating-point overflow and underflow +are detected to the degree supported by the hardware, which is generally +pretty reliable. +.PP +Conversion among internal representations for integer, floating-point, +and string operands is done automatically as needed. +For arithmetic computations, integers are used until some +floating-point number is introduced, after which floating-point is used. +For example, +.CS +\fBexpr 5 / 4\fR +.CE +returns 1, while +.CS +\fBexpr 5 / 4.0\fR +\fBexpr 5 / ( [string length "abcd"] + 0.0 )\fR +.CE +both return 1.25. +.VS +Floating-point values are always returned with a ``.'' +or an ``e'' so that they will not look like integer values. For +example, +.CS +\fBexpr 20.0/5.0\fR +.CE +returns ``4.0'', not ``4''. The global variable \fBtcl_precision\fR +determines the the number of significant digits that are retained +when floating values are converted to strings (except that trailing +zeroes are omitted). If \fBtcl_precision\fR +is unset then 6 digits of precision are used. +To retain all of the significant bits of an IEEE floating-point +number set \fBtcl_precision\fR to 17; if a value is converted to +string with 17 digits of precision and then converted back to binary +for some later calculation, the resulting binary value is guaranteed +to be identical to the original one. +.VE + +.SH "STRING OPERATIONS" +.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. +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 +\fB%d\fR for integers and \fB%g\fR for floating-point values. +For example, the commands +.CS +\fBexpr {"0x03" > "2"}\fR +\fBexpr {"0y" < "0x12"}\fR +.CE +both return 1. The first comparison is done using integer +comparison, and the second is done using string comparison after +the second operand is converted to the string ``18''. +.VS +Because of Tcl's tendency to treat values as numbers whenever +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 the +\fBstring compare\fR command instead. +.VE + +.SH KEYWORDS +arithmetic, boolean, compare, expression diff --git a/contrib/tcl/doc/fblocked.n b/contrib/tcl/doc/fblocked.n new file mode 100644 index 0000000..3184e47 --- /dev/null +++ b/contrib/tcl/doc/fblocked.n @@ -0,0 +1,32 @@ +'\" +'\" Copyright (c) 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: @(#) fblocked.n 1.6 96/02/23 13:46:30 +.so man.macros +.TH fblocked n 7.5 Tcl "Tcl Built-In Commands" +.BS +'\" Note: do not modify the .SH NAME line immediately below! +.SH NAME +fblocked \- Test whether the last input operation exhausted all available input +.SH SYNOPSIS +\fBfblocked \fIchannelId\fR +.BE + +.SH DESCRIPTION +.PP +The \fBfblocked\fR command returns 1 if the most recent input operation +on \fIchannelId\fR returned less information than requested because all +available input was exhausted. +For example, if \fBgets\fR is invoked when there are only three +characters available for input and no end-of-line sequence, \fBgets\fR +returns an empty string and a subsequent call to \fBfblocked\fR will +return 1. +.PP +.SH "SEE ALSO" +gets(n), read(n) + +.SH KEYWORDS +blocking, nonblocking diff --git a/contrib/tcl/doc/fconfigure.n b/contrib/tcl/doc/fconfigure.n new file mode 100644 index 0000000..1c187ac --- /dev/null +++ b/contrib/tcl/doc/fconfigure.n @@ -0,0 +1,178 @@ +'\" +'\" Copyright (c) 1995-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: @(#) fconfigure.n 1.23 96/04/16 08:20:07 +'\" +.so man.macros +.TH fconfigure n 7.5 Tcl "Tcl Built-In Commands" +.BS +'\" Note: do not modify the .SH NAME line immediately below! +.SH NAME +fconfigure \- Set and get options on a channel +.SH SYNOPSIS +.nf +\fBfconfigure \fIchannelId\fR +\fBfconfigure \fIchannelId\fR \fIname\fR +\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. +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 +the current value of the given option. +If one or more pairs of \fIname\fR and \fIvalue\fR are supplied, the +command sets each of the named options to the corresponding \fIvalue\fR; +in this case the return value is an empty string. +.PP +The options described below are supported for all channels. In addition, +each channel type may add options that only it supports. See the manual +entry for the command that creates each type of channels for the options +that that specific type of channel supports. For example, see the manual +entry for the \fBsocket\fR command for its additional options. +.TP +\fB\-blocking\fR \fIboolean\fR +The \fB\-blocking\fR option determines whether I/O operations on the +channel can cause the process to block indefinitely. +The value of the option must be a proper boolean value. +Channels are normally in blocking mode; if a channel is placed into +nonblocking mode it will affect the operation of the \fBgets\fR, +\fBread\fR, \fBputs\fR, \fBflush\fR, and \fBclose\fR commands; +see the documentation for those commands for details. +For nonblocking mode to work correctly, the application must be +using the Tcl event loop (e.g. by calling \fBTcl_DoOneEvent\fR or +invoking the \fBvwait\fR command). +.TP +\fB\-buffering\fR \fInewValue\fR +If \fInewValue\fR is \fBfull\fR then the I/O system will buffer output +until its internal buffer is full or until the \fBflush\fR command is +invoked. If \fInewValue\fR is \fBline\fR, then the I/O system will +automatically flush output for the channel whenever a newline character +is output. If \fInewValue\fR is \fBnone\fR, the I/O system will flush +automatically after every output operation. +The default is for \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. +.TP +\fB\-buffersize\fR \fInewSize\fR +\fINewvalue\fR must be an integer; its value is used to set the size of +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. +.TP +\fB\-eofchar\fR \fIchar\fR +.TP +\fB\-eofchar\fR \fB{\fIinChar outChar\fB}\fR +This option supports DOS file systems that use Control-z (\ex1a) as +an end of file marker. +If \fIchar\fR is not an empty string, then this character signals +end of file when it is encountered during input. +For output, the end of file character is output when +the channel is closed. +If \fIchar\fR is the empty string, then there is no special +end of file character marker. +For read-write channels, a two-element list specifies +the end of file marker for input and output, respectively. +As a convenience, when setting the end-of-file character +for a read-write channel +you can specify a single value that will apply to both reading and writing. +When querying the end-of-file character of a read-write channel, +a two-element list will always be returned. +The default value for \fB\-eofchar\fR is the empty string in all +cases except for files under Windows. In that case the \fB\-eofchar\fR +is Control-z (\ex1a) for reading and the empty string for writing. +.TP +\fB\-translation\fR \fImode\fR +.TP +\fB\-translation\fR \fB{\fIinMode outMode\fB}\fR +In Tcl scripts the end of a line is always represented using a +single newline character (\en). +However, in actual files and devices the end of a line may be +represented differently on different platforms, or even for +different devices on the same platform. For example, under UNIX +newlines are used in files, whereas carriage-return-linefeed +sequences are normally used in network connections. +On input (i.e., with \fBgets\fP and \fBread\fP) +the Tcl I/O system automatically translates the external end-of-line +representation into newline characters. +Upon output (i.e., with \fBputs\fP), +the I/O system translates newlines to the external +end-of-line representation. +The default translation mode, \fBauto\fP, handles all the common +cases automatically, but the \fB\-translation\fR option provides +explicit control over the end of line translations. +.RS +.PP +The value associated with \fB\-translation\fR is a single item for +read-only and write-only channels. +The value is a two-element list for read-write channels; +the read translation mode is the first element of the list, +and the write translation mode is the second element. +As a convenience, when setting the translation mode for a read-write channel +you can specify a single value that will apply to both reading and writing. +When querying the translation mode of a read-write channel, +a two-element list will always be returned. +The following values are currently supported: +.TP +\fBauto\fR +As the input translation mode, \fBauto\fR treats any of newline (\fBlf\fP), +carriage return (\fBcr\fP), or carriage return followed by a newline (\fBcrlf\fP) +as the end of line representation. The end of line representation can +even change from line-to-line, and all cases are translated to a newline. +As the output translation mode, \fBauto\fR chooses a platform specific +representation; for sockets on all platforms Tcl +chooses \fBcrlf\fR, for all Unix flavors, it chooses \fBlf\fR, for the +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. +.TP +\fBbinary\fR +No end-of-line translations are performed. This is nearly identical to +\fBlf\fP mode, except that in addition \fBbinary\fP mode also sets the +end of file character to the empty string, which disables it. +See the description of +\fB\-eofchar\fP for more information. +.TP +\fBcr\fR +The end of a line in the underlying file or device is represented +by a single carriage return character. +As the input translation mode, \fBcr\fP mode converts carriage returns +to newline characters. +As the output translation mode, \fBcr\fP mode +translates newline characters to carriage returns. +This mode is typically used on Macintosh platforms. +.TP +\fBcrlf\fR +The end of a line in the underlying file or device is represented +by a carriage return character followed by a linefeed character. +As the input translation mode, \fBcrlf\fP mode converts +carriage-return-linefeed sequences +to newline characters. +As the output translation mode, \fBcrlf\fP mode +translates newline characters to +carriage-return-linefeed sequences. +This mode is typically used on Windows platforms and for network +connections. +.TP +\fBlf\fR +The end of a line in the underlying file or device is represented +by a single newline (linefeed) character. +In this mode no translations occur during either input or output. +This mode is typically used on UNIX platforms. +.RE +.PP + +.SH "SEE ALSO" +close(n), flush(n), gets(n), puts(n), read(n), socket(n) + +.SH KEYWORDS +blocking, buffering, carriage return, end of line, flushing, linemode, +newline, nonblocking, platform, translation diff --git a/contrib/tcl/doc/file.n b/contrib/tcl/doc/file.n new file mode 100644 index 0000000..1451fc3 --- /dev/null +++ b/contrib/tcl/doc/file.n @@ -0,0 +1,217 @@ +'\" +'\" Copyright (c) 1993 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: @(#) file.n 1.13 96/04/11 17:03:13 +'\" +.so man.macros +.TH file n 7.5 Tcl "Tcl Built-In Commands" +.BS +'\" Note: do not modify the .SH NAME line immediately below! +.SH NAME +file \- Manipulate file names and attributes +.SH SYNOPSIS +\fBfile \fIoption\fR \fIname\fR ?\fIarg arg ...\fR? +.BE + +.SH DESCRIPTION +.PP +.VS +This command provides several operations on a file's name or attributes. +\fIName\fR is the name of a file; +if it starts with a tilde, then tilde substitution is done before +executing the command (see the manual entry for \fBfilename\fR +for details). +.VE +\fIOption\fR indicates what to do with the file name. Any unique +abbreviation for \fIoption\fR is acceptable. The valid options are: +.TP +\fBfile atime \fIname\fR +Returns a decimal string giving the time at which file \fIname\fR +was last accessed. The time is measured in the standard POSIX +fashion as seconds from a fixed starting time (often January 1, 1970). +If the file doesn't exist or its access time cannot be queried then an +error is generated. +.TP +\fBfile dirname \fIname\fR +.VS +Returns a name comprised of all of the path components in \fIname\fR +excluding the last element. If \fIname\fR is a relative file name and +only contains one path element, then returns ``\fB.\fR'' (or ``\fB:\fR'' +on the Macintosh). If \fIname\fR refers to a root directory, then the +root directory is returned. For example, +.RS +.CS +\fBfile dirname c:/\fR +.CE +returns \fBc:/\fR. +.PP +Note that tilde substitution will only be +performed if it is necessary to complete the command. For example, +.CS +\fBfile dirname ~/src/foo.c\fR +.CE +returns \fB~/src\fR, whereas +.CS +\fBfile dirname ~\fR +.CE +returns \fB/home\fR (or something similar). +.RE +.VE +.TP +\fBfile executable \fIname\fR +Returns \fB1\fR if file \fIname\fR is executable by +the current user, \fB0\fR otherwise. +Under UNIX this command uses the real user and group identifiers, +not the effective ones. +.TP +\fBfile exists \fIname\fR +Returns \fB1\fR if file \fIname\fR exists and the current user has +search privileges for the directories leading to it, \fB0\fR otherwise. +.TP +\fBfile extension \fIname\fR +Returns all of the characters in \fIname\fR after and including the +last dot in the last element of \fIname\fR. If there is no dot in +the last element of \fIname\fR then returns +the empty string. +.TP +\fBfile isdirectory \fIname\fR +Returns \fB1\fR if file \fIname\fR is a directory, +\fB0\fR otherwise. +.TP +\fBfile isfile \fIname\fR +Returns \fB1\fR if file \fIname\fR is a regular file, +\fB0\fR otherwise. +.VS br +.TP +\fBfile join \fIname\fR ?\fIname ...\fR? +Takes one or more file names and combines them, using the correct +path separator for the current platform. If a particular \fIname\fR is +relative, then it will be joined to the previous file name argument. +Otherwise, any earlier arguments will be discarded, and joining will +proceed from the current argument. For example, +.RS +.CS +\fBfile join a b /foo bar\fR +.CE +returns \fB/foo/bar\fR. +.PP +Note that any of the names can contain separators, and that the result +is always canonical for the current platform: \fB/\fR for Unix and +Windows, and \fB:\fR for Macintosh. +.RE +.VE +.TP +\fBfile lstat \fIname varName\fR +Same as \fBstat\fR option (see below) except uses the \fIlstat\fR +kernel call instead of \fIstat\fR. This means that if \fIname\fR +refers to a symbolic link the information returned in \fIvarName\fR +is for the link rather than the file it refers to. On systems that +don't support symbolic links this option behaves exactly the same +as the \fBstat\fR option. +.TP +\fBfile mtime \fIname\fR +Returns a decimal string giving the time at which file \fIname\fR +was last modified. The time is measured in the standard POSIX +fashion as seconds from a fixed starting time (often January 1, 1970). +If the file doesn't exist or its modified time cannot be queried then an +error is generated. +.TP +\fBfile owned \fIname\fR +Returns \fB1\fR if file \fIname\fR is owned by the current user, +\fB0\fR otherwise. +.VS br +.TP +\fBfile pathtype \fIname\fR +Returns one of \fBabsolute\fR, \fBrelative\fR, \fBvolumerelative\fR. If +\fIname\fR refers to a specific file on a specific volume, the path type +will be \fBabsolute\fR. If \fIname\fR refers to a file relative to the +current working directory, then the path type will be \fBrelative\fR. If +\fIname\fR refers to a file relative to the current working directory on +a specified volume, or to a specific file on the current working volume, then +the file type is \fBvolumerelative\fR. +.VE +.TP +\fBfile readable \fIname\fR +Returns \fB1\fR if file \fIname\fR is readable by +the current user, \fB0\fR otherwise. +Under UNIX this command uses the real user and group identifiers, +not the effective ones. +.TP +\fBfile readlink \fIname\fR +Returns the value of the symbolic link given by \fIname\fR (i.e. the +name 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. +.TP +\fBfile rootname \fIname\fR +Returns all of the characters in \fIname\fR up to but not including +the 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 size \fIname\fR +Returns a decimal string giving the size of file \fIname\fR in bytes. +If the file doesn't exist or its size cannot be queried then an +error is generated. +.VS br +.TP +\fBfile split \fIname\fR +Returns a list whose elements are the path components in \fIname\fR. The +first element of the list will have the same path type as \fIname\fR. +All other elements will be relative. Path separators will be discarded +unless they are needed ensure that an element is unambiguously relative. +For example, under Unix +.RS +.CS +\fBfile split /foo/~bar/baz\fR +.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 +substitution. +.RE +.VE +.TP +\fBfile stat \fIname varName\fR +Invokes the \fBstat\fR kernel call on \fIname\fR, and uses the +variable given by \fIvarName\fR to hold information returned from +the kernel call. +\fIVarName\fR is treated as an array variable, +and the following elements of that variable are set: \fBatime\fR, +\fBctime\fR, \fBdev\fR, \fBgid\fR, \fBino\fR, \fBmode\fR, \fBmtime\fR, +\fBnlink\fR, \fBsize\fR, \fBtype\fR, \fBuid\fR. +Each element except \fBtype\fR is a decimal string with the value of +the corresponding field from the \fBstat\fR return structure; see the +manual entry for \fBstat\fR for details on the meanings of the values. +The \fBtype\fR element gives the type of the file in the same form +returned by the command \fBfile type\fR. +This command returns an empty string. +.TP +\fBfile tail \fIname\fR +.VS +Returns all of the characters in \fIname\fR after the last directory +separator. If \fIname\fR contains no separators then returns +\fIname\fR. +.VE +.TP +\fBfile type \fIname\fR +Returns a string giving the type of file \fIname\fR, which will be +one of \fBfile\fR, \fBdirectory\fR, \fBcharacterSpecial\fR, +\fBblockSpecial\fR, \fBfifo\fR, \fBlink\fR, or \fBsocket\fR. +.TP +\fBfile writable \fIname\fR +Returns \fB1\fR if file \fIname\fR is writable by +the current user, \fB0\fR otherwise. +Under UNIX this command uses the real user and group identifiers, +not the effective ones. + +.VS +.SH "SEE ALSO" +filename +.VE + +.SH KEYWORDS +attributes, directory, file, name, stat diff --git a/contrib/tcl/doc/fileevent.n b/contrib/tcl/doc/fileevent.n new file mode 100644 index 0000000..daff74e --- /dev/null +++ b/contrib/tcl/doc/fileevent.n @@ -0,0 +1,109 @@ +'\" +'\" Copyright (c) 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: @(#) fileevent.n 1.6 96/02/23 13:46:29 +'\" +.so man.macros +.TH fileevent n 7.5 Tcl "Tcl Built-In Commands" +.BS +'\" Note: do not modify the .SH NAME line immediately below! +.SH NAME +fileevent \- Execute a script when a channel becomes readable or writable +.SH SYNOPSIS +\fBfileevent \fIchannelId \fBreadable \fR?\fIscript\fR? +.sp +\fBfileevent \fIchannelId \fBwritable \fR?\fIscript\fR? +.BE + +.SH DESCRIPTION +.PP +This command is used to create \fIfile event handlers\fR. A file event +handler is a binding between a channel and a script, such that the script +is evaluated whenever the channel becomes readable or writable. File event +handlers are most commonly used to allow data to be received from another +process on an event-driven basis, so that the receiver can continue to +interact with the user while waiting for the data to arrive. If an +application invokes \fBgets\fR or \fBread\fR on a blocking channel when +there is no input data available, the process will block; until the input +data arrives, it will not be able to service other events, so it will +appear to the user to ``freeze up''. With \fBfileevent\fR, the process can +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. +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 +second argument to \fBfileevent\fR). +In this case \fBfileevent\fR returns an empty string. +The \fBreadable\fR and \fBwritable\fR event handlers for a file +are independent, and may be created and deleted separately. +However, there may be at most one \fBreadable\fR and one \fBwritable\fR +handler for a file at a given time in a given interpreter. +If \fBfileevent\fR is called when the specified handler already +exists in the invoking interpreter, the new script replaces the old one. +.PP +If the \fIscript\fR argument is not specified, \fBfileevent\fR +returns the current script for \fIchannelId\fR, or an empty string +if there is none. +If the \fIscript\fR argument is specified as an empty string +then the event handler is deleted, so that no script will be invoked. +A file event handler is also deleted automatically whenever +its channel is closed or its interpreter is deleted. +.PP +A channel is considered to be readable if there is unread data +available on the underlying device. +A channel is also considered to be readable if there is unread +data in an input buffer, except in the special case where the +most recent attempt to read from the channel was a \fBgets\fR +call that could not find a complete line in the input buffer. +This feature allows a file to be read a line at a time in nonblocking mode +using events. +A channel is also considered to be readable if an end of file or +error condition is present on the underlying file or device. +It is important for \fIscript\fR to check for these conditions +and handle them appropriately; for example, if there is no special +check for end of file, an infinite loop may occur where \fIscript\fR +reads no data, returns, and is immediately invoked again. +.PP +A channel is considered to be writable if at least one byte of data +can be written to the underlying file or device without blocking, +or if an error condition is present on the underlying file or device. +.PP +Event-driven I/O works best for channels that have been +placed into nonblocking mode with the \fBfconfigure\fR command. +In blocking mode, a \fBputs\fR command may block if you give it +more data than the underlying file or device can accept, and a +\fBgets\fR or \fBread\fR command will block if you attempt to read +more data than is ready; no events will be processed while the +commands block. +In nonblocking mode \fBputs\fR, \fBread\fR, and \fBgets\fR never block. +See the documentation for the individual commands for information +on how they handle blocking and nonblocking channels. +.PP +The script for a file event is executed at global level (outside the +context of any Tcl procedure) in the interpreter in which the +\fBfileevent\fR command was invoked. +If an error occurs while executing the script then the +\fBbgerror\fR mechanism is used to report the error. +In addition, the file event handler is deleted if it ever returns +an error; this is done in order to prevent infinite loops due to +buggy handlers. + +.SH CREDITS +.PP +\fBfileevent\fR is based on the \fBaddinput\fR command created +by Mark Diekhans. + +.SH "SEE ALSO" +bgerror, fconfigure, gets, puts, read + +.SH KEYWORDS +asynchronous I/O, blocking, channel, event handler, nonblocking, readable, +script, writable. diff --git a/contrib/tcl/doc/filename.n b/contrib/tcl/doc/filename.n new file mode 100644 index 0000000..e1f38ae --- /dev/null +++ b/contrib/tcl/doc/filename.n @@ -0,0 +1,197 @@ +'\" +'\" Copyright (c) 1995-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: @(#) filename.n 1.7 96/04/11 17:03:14 +'\" +.so man.macros +.TH filename n 7.5 Tcl "Tcl Built-In Commands" +.BS +'\" Note: do not modify the .SH NAME line immediately below! +.SH NAME +filename \- File name conventions supported by Tcl commands +.BE +.SH INTRODUCTION +.PP +All Tcl commands and C procedures that take file names as arguments +expect the file names to be in one of three forms, depending on the +current platform. On each platform, Tcl supports file names in the +standard forms(s) for that platform. In addition, on all platforms, +Tcl supports a Unix-like syntax intended to provide a convenient way +of constructing simple file names. However, scripts that are intended +to be portable should not assume a particular form for file names. +Instead, portable scripts must use the \fBfile split\fR and \fBfile +join\fR commands to manipulate file names (see the \fBfile\fR manual +entry for more details). + +.SH PATH TYPES +.PP +File names are grouped into three general types based on the starting point +for the path used to specify the file: absolute, relative, and +volume-relative. Absolute names are completely qualified, giving a path to +the file relative to a particular volume and the root directory on that +volume. Relative names are unqualified, giving a path to the file relative +to the current working directory. Volume-relative names are partially +qualified, either giving the path relative to the root directory on the +current volume, or relative to the current directory of the specified +volume. The \fBfile pathtype\fR command can be used to determine the +type of a given path. + +.SH PATH SYNTAX +.PP +The rules for native names depend on the value reported in the Tcl +array element \fBtcl_platform(platform)\fR: +.TP 10 +\fBmac\fR +On Apple Macintosh systems, Tcl supports two forms of path names. The +normal Mac style names use colons as path separators. Paths may be +relative or absolute, and file names may contain any character other +than colon. A leading colon causes the rest of the path to be +interpreted relative to the current directory. If a path contains a +colon that is not at the beginning, then the path is interpreted as an +absolute path. Sequences of two or more colons anywhere in the path +are used to construct relative paths where \fB::\fR refers to the +parent of the current directory, \fB:::\fR refers to the parent of the +parent, and so forth. +.RS +.PP +In addition to Macintosh style names, Tcl also supports a subset of +Unix-like names. If a path contains no colons, then it is interpreted +like a Unix path. Slash is used as the path separator. The file name +\fB\&.\fR refers to the current directory, and \fB\&..\fR refers to the +parent of the current directory. However, some names like \fB/\fR or +\fB/..\fR have no mapping, and are interpreted as Macintosh names. In +general, commands that generate file names will return Macintosh style +names, but commands that accept file names will take both Macintosh +and Unix-style names. +.PP +The following examples illustrate various forms of path names: +.TP 15 +\fB:\fR +Relative path to the current folder. +.TP 15 +\fBMyFile\fR +Relative path to a file named \fBMyFile\fR in the current folder. +.TP 15 +\fBMyDisk:MyFile\fR +Absolute path to a file named \fBMyFile\fR on the device named \fBMyDisk\fR. +.TP 15 +\fB:MyDir:MyFile\fR +Relative path to a file name \fBMyFile\fR in a folder named +\fBMyDir\fR in the current folder. +.TP 15 +\fB::MyFile\fR +Relative path to a file named \fBMyFile\fR in the folder above the +current folder. +.TP 15 +\fB:::MyFile\fR +Relative path to a file named \fBMyFile\fR in the folder two levels above the +current folder. +.TP 15 +\fB/MyDisk/MyFile\fR +Absolute path to a file named \fBMyFile\fR on the device named +\fBMyDisk\fR. +.TP 15 +\fB\&../MyFile\fR +Relative path to a file named \fBMyFile\fR in the folder above the +current folder. +.RE +.TP +\fBunix\fR +On Unix platforms, Tcl uses path names where the components are +separated by slashes. Path names may be relative or absolute, and +file names may contain any character other than slash. The file names +\fB\&.\fR and \fB\&..\fR are special and refer to the current directory +and the parent of the current directory respectively. Multiple +adjacent slash characters are interpreted as a single separator. +The following examples illustrate various forms of path names: +.RS +.TP 15 +\fB/\fR +Absolute path to the root directory. +.TP 15 +\fB/etc/passwd\fR +Absolute path to the file named \fBpasswd\fR in the directory +\fBetc\fR in the root directory. +.TP 15 +\fB\&.\fR +Relative path to the current directory. +.TP 15 +\fBfoo\fR +Relative path to the file \fBfoo\fR in the current directory. +.TP 15 +\fBfoo/bar\fR +Relative path to the file \fBbar\fR in the directory \fBfoo\fR in the +current directory. +.TP 15 +\fB\&../foo\fR +Relative path to the file \fBfoo\fR in the directory above the current +directory. +.RE +.TP +\fBwindows\fR +On Microsoft Windows platforms, Tcl supports both drive-relative and UNC +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, +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: +.RS +.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. +.TP 15 +\fBc:foo\fR +Volume-relative path to a file \fBfoo\fR in the current directory on drive +\fBc\fR. +.TP 15 +\fBc:/foo\fR +Absolute path to a file \fBfoo\fR in the root directory of drive +\fBc\fR. +.TP 15 +\fBfoo\ebar\fR +Relative path to a file \fBbar\fR in the \fBfoo\fR directory in the current +directory on the current volume. +.TP 15 +\fB\&\efoo\fR +Volume-relative path to a file \fBfoo\fR in the root directory of the current +volume. +.RE + +.SH TILDE SUBSTITUTION +.PP +In addition to the file name rules described above, Tcl also supports +\fIcsh\fR-style tilde substitution. If a file name starts with a +tilde, then the file name will be interpreted as if the first element +is replaced with the location of the home directory for the given +user. If the tilde is followed immediately by a separator, then the +\fB$HOME\fR environment variable is substituted. Otherwise the +characters between the tilde and the next separator are taken as a +user name, which is used to retrieve the user's home directory for +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. + +.SH PORTABILITY ISSUES +.PP +Not all file systems are case sensitive, so scripts should avoid code +that depends on the case of characters in a file name. In addition, +the character sets allowed on different devices may differ, so scripts +should choose file names that do not contain special characters like: +\fB<>:"/\e|\fR. The safest approach is to use names consisting of +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. + +.SH KEYWORDS +current directory, absolute file name, relative file name, +volume-relative file name, portability diff --git a/contrib/tcl/doc/flush.n b/contrib/tcl/doc/flush.n new file mode 100644 index 0000000..4a224a8 --- /dev/null +++ b/contrib/tcl/doc/flush.n @@ -0,0 +1,37 @@ +'\" +'\" Copyright (c) 1993 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: @(#) flush.n 1.9 96/02/15 20:02:05 +'\" +.so man.macros +.TH flush n 7.5 Tcl "Tcl Built-In Commands" +.BS +'\" Note: do not modify the .SH NAME line immediately below! +.SH NAME +flush \- Flush buffered output for a channel +.SH SYNOPSIS +\fBflush \fIchannelId\fR +.BE + +.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. +.VS +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 +flushed; the remainder will be flushed in the background as fast as the +underlying file or device is able to absorb it. +.VE + +.SH "SEE ALSO" +open(n), socket(n) + +.SH KEYWORDS +blocking, buffer, channel, flush, nonblocking, output diff --git a/contrib/tcl/doc/for.n b/contrib/tcl/doc/for.n new file mode 100644 index 0000000..11e5d01 --- /dev/null +++ b/contrib/tcl/doc/for.n @@ -0,0 +1,44 @@ +'\" +'\" Copyright (c) 1993 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: @(#) for.n 1.5 96/03/25 20:15:01 +'\" +.so man.macros +.TH for n "" Tcl "Tcl Built-In Commands" +.BS +'\" Note: do not modify the .SH NAME line immediately below! +.SH NAME +for \- ``For'' loop +.SH SYNOPSIS +\fBfor \fIstart test next body\fR +.BE + +.SH DESCRIPTION +.PP +\fBFor\fR is a looping command, similar in structure to the C +\fBfor\fR statement. The \fIstart\fR, \fInext\fR, and +\fIbody\fR arguments must be Tcl command strings, and \fItest\fR +is an expression string. +The \fBfor\fR command first invokes the Tcl interpreter to +execute \fIstart\fR. Then it repeatedly evaluates \fItest\fR as +an expression; if the result is non-zero it invokes the Tcl +interpreter on \fIbody\fR, then invokes the Tcl interpreter on \fInext\fR, +then repeats the loop. The command terminates when \fItest\fR evaluates +to 0. If a \fBcontinue\fR command is invoked within \fIbody\fR then +any remaining commands in the current execution of \fIbody\fR are skipped; +processing continues by invoking the Tcl interpreter on \fInext\fR, then +evaluating \fItest\fR, and so on. If a \fBbreak\fR command is invoked +within \fIbody\fR +or \fInext\fR, +then the \fBfor\fR command will +return immediately. +The operation of \fBbreak\fR and \fBcontinue\fR are similar to the +corresponding statements in C. +\fBFor\fR returns an empty string. + +.SH KEYWORDS +for, iteration, looping diff --git a/contrib/tcl/doc/foreach.n b/contrib/tcl/doc/foreach.n new file mode 100644 index 0000000..0dec2a5 --- /dev/null +++ b/contrib/tcl/doc/foreach.n @@ -0,0 +1,86 @@ +'\" +'\" Copyright (c) 1993 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: @(#) foreach.n 1.6 96/03/25 20:15:14 +'\" +.so man.macros +.TH foreach n "" Tcl "Tcl Built-In Commands" +.BS +'\" Note: do not modify the .SH NAME line immediately below! +.SH NAME +foreach \- Iterate over all elements in one or more lists +.SH SYNOPSIS +\fBforeach \fIvarname list body\fR +.br +\fBforeach \fIvarlist1 list1\fR ?\fIvarlist2 list2 ...\fR? \fIbody\fR +.BE + +.SH DESCRIPTION +.PP +The \fBforeach\fR command implements a loop where the loop +variable(s) take on values from one or more lists. +In the simplest case there is one loop variable, \fIvarname\fR, +and one list, \fIlist\fR, that is a list of values to assign to \fIvarname\fR. +The \fIbody\fR argument is a Tcl script. +For each element of \fIlist\fR (in order +from first to last), \fBforeach\fR assigns the contents of the +element to \fIvarname\fR as if the \fBlindex\fR command had been used +to extract the element, then calls the Tcl interpreter to execute +\fIbody\fR. +.PP +In the general case there can be more than one value list +(e.g., \fIlist1\fR and \fIlist2\fR), +and each value list can be associated with a list of loop variables +(e.g., \fIvarlist1\fR and \fIvarlist2\fR). +During each iteration of the loop +the variables of each \fIvarlist\fP are assigned +consecutive values from the corresponding \fIlist\fP. +Values in each \fIlist\fP are used in order from first to last, +and each value is used exactly once. +The total number of loop iterations is large enough to use +up all the values from all the value lists. +If a value list does not contain enough +elements for each of its loop variables in each iteration, +empty values are used for the missing elements. +.PP +The \fBbreak\fR and \fBcontinue\fR statements may be +invoked inside \fIbody\fR, with the same effect as in the \fBfor\fR +command. \fBForeach\fR returns an empty string. +.SH EXAMPLES +.PP +The following loop uses i and j as loop variables to iterate over +pairs of elements of a single list. +.DS +set x {} +foreach {i j} {a b c d e f} { + lappend x $j $i +} +# The value of x is "b a d c f e" +# There are 3 iterations of the loop. +.DE +.PP +The next loop uses i and j to iterate over two lists in parallel. +.DS +set x {} +foreach i {a b c} j {d e f g} { + lappend x $i $j +} +# The value of x is "a d b e c f {} g" +# There are 4 iterations of the loop. +.DE +.PP +The two forms are combined in the following example. +.DS +set x {} +foreach i {a b c} {j k} {d e f g} { + lappend x $i $j $k +} +# The value of x is "a d e b f g c {} {}" +# There are 3 iterations of the loop. +.DE +.SH KEYWORDS +foreach, iteration, list, looping diff --git a/contrib/tcl/doc/format.n b/contrib/tcl/doc/format.n new file mode 100644 index 0000000..a207fa3 --- /dev/null +++ b/contrib/tcl/doc/format.n @@ -0,0 +1,220 @@ +'\" +'\" Copyright (c) 1993 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: @(#) format.n 1.10 96/03/25 20:15:25 +'\" +.so man.macros +.TH format n "" Tcl "Tcl Built-In Commands" +.BS +'\" Note: do not modify the .SH NAME line immediately below! +.SH NAME +format \- Format a string in the style of sprintf +.SH SYNOPSIS +\fBformat \fIformatString \fR?\fIarg arg ...\fR? +.BE + +.SH INTRODUCTION +.PP +This command generates a formatted string in the same way as the +ANSI C \fBsprintf\fR procedure (it uses \fBsprintf\fR in its +implementation). +\fIFormatString\fR indicates how to format the result, using +\fB%\fR conversion specifiers as in \fBsprintf\fR, and the additional +arguments, if any, provide values to be substituted into the result. +The return value from \fBformat\fR is the formatted string. + +.SH "DETAILS ON FORMATTING" +.PP +The command operates by scanning \fIformatString\fR from left to right. +Each character from the format string is appended to the result +string unless it is a percent sign. +If the character is a \fB%\fR then it is not copied to the result string. +Instead, the characters following the \fB%\fR character are treated as +a conversion specifier. +The conversion specifier controls the conversion of the next successive +\fIarg\fR to a particular format and the result is appended to +the result string in place of the conversion specifier. +If there are multiple conversion specifiers in the format string, +then each one controls the conversion of one additional \fIarg\fR. +The \fBformat\fR command must be given enough \fIarg\fRs to meet the needs +of all of the conversion specifiers in \fIformatString\fR. +.PP +Each conversion specifier may contain up to six different parts: +.VS +an XPG3 position specifier, +.VE +a set of flags, a minimum field width, a precision, a length modifier, +and a conversion character. +Any of these fields may be omitted except for the conversion character. +The fields that are present must appear in the order given above. +The paragraphs below discuss each of these fields in turn. +.PP +.VS +If the \fB%\fR is followed by a decimal number and a \fB$\fR, as in +``\fB%2$d\fR'', then the value to convert is not taken from the +next sequential argument. +Instead, it is taken from the argument indicated by the number, +where 1 corresponds to the first \fIarg\fR. +If the conversion specifier requires multiple arguments because +of \fB*\fR characters in the specifier then +successive arguments are used, starting with the argument +given by the number. +This follows the XPG3 conventions for positional specifiers. +If there are any positional specifiers in \fIformatString\fR +then all of the specifiers must be positional. +.VE +.PP +The second portion of a conversion specifier may contain any of the +following flag characters, in any order: +.TP 10 +\fB\-\fR +Specifies that the converted argument should be left-justified +in its field (numbers are normally right-justified with leading +spaces if needed). +.TP 10 +\fB+\fR +Specifies that a number should always be printed with a sign, +even if positive. +.TP 10 +\fIspace\fR +Specifies that a space should be added to the beginning of the +number if the first character isn't a sign. +.TP 10 +\fB0\fR +Specifies that the number should be padded on the left with +zeroes instead of spaces. +.TP 10 +\fB#\fR +Requests an alternate output form. For \fBo\fR and \fBO\fR +conversions it guarantees that the first digit is always \fB0\fR. +For \fBx\fR or \fBX\fR conversions, \fB0x\fR or \fB0X\fR (respectively) +will be added to the beginning of the result unless it is zero. +For all floating-point conversions (\fBe\fR, \fBE\fR, \fBf\fR, +\fBg\fR, and \fBG\fR) it guarantees that the result always +has a decimal point. +For \fBg\fR and \fBG\fR conversions it specifies that +trailing zeroes should not be removed. +.PP +The third portion of a conversion specifier is a number giving a +minimum field width for this conversion. +It is typically used to make columns line up in tabular printouts. +If the converted argument contains fewer characters than the +minimum field width then it will be padded so that it is as wide +as the minimum field width. +Padding normally occurs by adding extra spaces on the left of the +converted argument, but the \fB0\fR and \fB\-\fR flags +may be used to specify padding with zeroes on the left or with +spaces on the right, respectively. +If the minimum field width is specified as \fB*\fR rather than +a number, then the next argument to the \fBformat\fR command +determines the minimum field width; it must be a numeric string. +.PP +The fourth portion of a conversion specifier is a precision, +which consists of a period followed by a number. +The number is used in different ways for different conversions. +For \fBe\fR, \fBE\fR, and \fBf\fR conversions it specifies the number +of digits to appear to the right of the decimal point. +For \fBg\fR and \fBG\fR conversions it specifies the total number +of digits to appear, including those on both sides of the decimal +point (however, trailing zeroes after the decimal point will still +be omitted unless the \fB#\fR flag has been specified). +For integer conversions, it specifies a minimum number of digits +to print (leading zeroes will be added if necessary). +For \fBs\fR conversions it specifies the maximum number of characters to be +printed; if the string is longer than this then the trailing characters will be dropped. +If the precision is specified with \fB*\fR rather than a number +then the next argument to the \fBformat\fR command determines the precision; +it must be a numeric string. +.PP +The fifth part of a conversion specifier is a length modifier, +which must be \fBh\fR or \fBl\fR. +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. +.PP +The last thing in a conversion specifier is an alphabetic character +that determines what kind of conversion to perform. +The following conversion characters are currently supported: +.TP 10 +\fBd\fR +Convert integer to signed decimal string. +.TP 10 +\fBu\fR +Convert integer to unsigned decimal string. +.TP 10 +\fBi\fR +Convert integer to signed decimal string; the integer may either be +in decimal, in octal (with a leading \fB0\fR) or in hexadecimal +(with a leading \fB0x\fR). +.TP 10 +\fBo\fR +Convert integer to unsigned octal string. +.TP 10 +\fBx\fR or \fBX\fR +Convert integer to unsigned hexadecimal string, using digits +``0123456789abcdef'' for \fBx\fR and ``0123456789ABCDEF'' for \fBX\fR). +.TP 10 +\fBc\fR +Convert integer to the 8-bit character it represents. +.TP 10 +\fBs\fR +No conversion; just insert string. +.TP 10 +\fBf\fR +Convert floating-point number to signed decimal string of +the form \fIxx.yyy\fR, where the number of \fIy\fR's is determined by +the precision (default: 6). +If the precision is 0 then no decimal point is output. +.TP 10 +\fBe\fR or \fBe\fR +Convert floating-point number to scientific notation in the +form \fIx.yyy\fBe\(+-\fIzz\fR, where the number of \fIy\fR's is determined +by the precision (default: 6). +If the precision is 0 then no decimal point is output. +If the \fBE\fR form is used then \fBE\fR is +printed instead of \fBe\fR. +.TP 10 +\fBg\fR or \fBG\fR +If the exponent is less than \-4 or greater than or equal to the +precision, then convert floating-point number as for \fB%e\fR or +\fB%E\fR. +Otherwise convert as for \fB%f\fR. +Trailing zeroes and a trailing decimal point are omitted. +.TP 10 +\fB%\fR +No conversion: just insert \fB%\fR. +.LP +For the numerical conversions the argument being converted must +be an integer or floating-point string; format converts the argument +to binary and then converts it back to a string according to +the conversion specifier. + +.SH "DIFFERENCES FROM ANSI SPRINTF" +.PP +.VS +The behavior of the format command is the same as the +ANSI C \fBsprintf\fR procedure except for the following +differences: +.IP [1] +\fB%p\fR and \fB%n\fR specifiers are not currently supported. +.VE +.IP [2] +For \fB%c\fR conversions the argument must be a decimal string, +which will then be converted to the corresponding character value. +.IP [3] +.VS +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). +If the \fBh\fR modifier is specified then integer values are truncated +to \fBshort\fR before conversion. +.VE + +.SH KEYWORDS +conversion specifier, format, sprintf, string, substitution diff --git a/contrib/tcl/doc/gets.n b/contrib/tcl/doc/gets.n new file mode 100644 index 0000000..175a831 --- /dev/null +++ b/contrib/tcl/doc/gets.n @@ -0,0 +1,52 @@ +'\" +'\" Copyright (c) 1993 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: @(#) gets.n 1.12 96/02/15 20:02:08 +'\" +.so man.macros +.TH gets n 7.5 Tcl "Tcl Built-In Commands" +.BS +'\" Note: do not modify the .SH NAME line immediately below! +.SH NAME +gets \- Read a line from a channel +.SH SYNOPSIS +\fBgets \fIchannelId\fR ?\fIvarName\fR? +.BE + +.SH DESCRIPTION +.PP +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). +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 +that name and the return value is a count of the number of characters +returned. +.PP +.VS +If end of file occurs while scanning for an end of +line, the command returns whatever input is available up to the end of file. +If \fIchannelId\fR is in nonblocking mode and there is not a full +line of input available, the command returns an empty string and +does not consume any input. +If \fIvarName\fR is specified and an empty string is returned in +\fIvarName\fR because of end-of-file or because of insufficient +data in nonblocking mode, then the return count is -1. +Note that if \fIvarName\fR is not specified then the end-of-file +and no-full-line-available cases can +produce the same results as if there were an input line consisting +only of the end-of-line character(s). +The \fBeof\fR and \fBfblocked\fR commands can be used to distinguish +these three cases. +.VE + +.SH "SEE ALSO" +eof(n), fblocked(n) + +.SH KEYWORDS +blocking, channel, end of file, end of line, line, nonblocking, read diff --git a/contrib/tcl/doc/glob.n b/contrib/tcl/doc/glob.n new file mode 100644 index 0000000..11c6cc7 --- /dev/null +++ b/contrib/tcl/doc/glob.n @@ -0,0 +1,88 @@ +'\" +'\" Copyright (c) 1993 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: @(#) glob.n 1.10 96/03/25 20:15:48 +'\" +.so man.macros +.TH glob n 7.5 Tcl "Tcl Built-In Commands" +.BS +'\" Note: do not modify the .SH NAME line immediately below! +.SH NAME +glob \- Return names of files that match patterns +.SH SYNOPSIS +\fBglob \fR?\fIswitches\fR? \fIpattern \fR?\fIpattern ...\fR? +.BE + +.SH DESCRIPTION +.PP +This command performs file name ``globbing'' in a fashion similar to +the csh shell. It returns a list of the files whose names match any +of the \fIpattern\fR arguments. +.LP +If the initial arguments to \fBglob\fR start with \fB\-\fR then +.VS +they are treated as switches. The following switches are +currently supported: +.TP 15 +\fB\-nocomplain\fR +Allows an empty list to be returned without error; without this +switch an error is returned if the result list would be empty. +.TP 15 +\fB\-\|\-\fR +Marks the end of switches. The argument following this one will +be treated as a \fIpattern\fR even if it starts with a \fB\-\fR. +.VE +.PP +The \fIpattern\fR arguments may contain any of the following +special characters: +.TP 10 +\fB?\fR +Matches any single character. +.TP 10 +\fB*\fR +Matches any sequence of zero or more characters. +.TP 10 +\fB[\fIchars\fB]\fR +Matches any single character in \fIchars\fR. 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. +.TP 10 +\fB\e\fIx\fR +Matches the character \fIx\fR. +.TP 10 +\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. +In addition, all ``/'' characters must be matched explicitly. +.LP +If the first character in a \fIpattern\fR is ``~'' then it refers +to the home directory for the user whose name follows the ``~''. +If the ``~'' is followed immediately by ``/'' then the value of +the HOME environment variable is used. +.LP +The \fBglob\fR command differs from csh globbing in two ways. +First, it does not sort its result list (use the \fBlsort\fR +command if you want the list sorted). +.VS +Second, \fBglob\fR only returns the names of files that actually +exist; in csh no check for existence is made unless a pattern +contains a ?, *, or [] construct. + +.SH PORTABILITY ISSUES +.PP +Unlike other Tcl commands that will accept both network and native +style names (see the \fBfilename\fR manual entry for details on how +native and network names are specified), the \fBglob\fR command only +accepts native names. Also, for Windows UNC names, the servername and +sharename components of the path may not contain ?, *, or [] +constructs. +.VE + +.SH KEYWORDS +exist, file, glob, pattern diff --git a/contrib/tcl/doc/global.n b/contrib/tcl/doc/global.n new file mode 100644 index 0000000..17ac62f --- /dev/null +++ b/contrib/tcl/doc/global.n @@ -0,0 +1,30 @@ +'\" +'\" Copyright (c) 1993 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: @(#) global.n 1.5 96/03/25 20:16:10 +'\" +.so man.macros +.TH global n "" Tcl "Tcl Built-In Commands" +.BS +'\" Note: do not modify the .SH NAME line immediately below! +.SH NAME +global \- Access global variables +.SH SYNOPSIS +\fBglobal \fIvarname \fR?\fIvarname ...\fR? +.BE + +.SH DESCRIPTION +.PP +This command is ignored unless a Tcl procedure is being interpreted. +If so then it declares the given \fIvarname\fR's to be global variables +rather than local ones. For the duration of the current procedure +(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. + +.SH KEYWORDS +global, procedure, variable diff --git a/contrib/tcl/doc/history.n b/contrib/tcl/doc/history.n new file mode 100644 index 0000000..a93e2fd --- /dev/null +++ b/contrib/tcl/doc/history.n @@ -0,0 +1,168 @@ +'\" +'\" Copyright (c) 1993 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: @(#) history.n 1.6 96/03/25 20:16:25 +'\" +.so man.macros +.TH history n "" Tcl "Tcl Built-In Commands" +.BS +'\" Note: do not modify the .SH NAME line immediately below! +.SH NAME +history \- Manipulate the history list +.SH SYNOPSIS +\fBhistory \fR?\fIoption\fR? ?\fIarg arg ...\fR? +.BE + +.SH DESCRIPTION +.PP +The \fBhistory\fR command performs one of several operations related to +recently-executed commands recorded in a history list. Each of +these recorded commands is referred to as an ``event''. When +specifying an event to the \fBhistory\fR command, the following +forms may be used: +.IP [1] +A number: if positive, it refers to the event with +that number (all events are numbered starting at 1). If the number +is negative, it selects an event relative to the current event +(\fB\-1\fR refers to the previous event, \fB\-2\fR to the one before that, and +so on). +.IP [2] +A string: selects the most recent event that matches the string. +An event is considered to match the string either if the string is +the same as the first characters of the event, or if the string +matches the event in the sense of the \fBstring match\fR command. +.PP +The \fBhistory\fR command can take any of the following forms: +.TP +\fBhistory\fR +Same +as \fBhistory info\fR, described below. +.TP +\fBhistory add\fI command \fR?\fBexec\fR? +Adds the \fIcommand\fR argument to the history list as a new event. If +\fBexec\fR is specified (or abbreviated) then the command is also +executed and its result is returned. If \fBexec\fR isn't specified +then an empty string is returned as result. +.TP +\fBhistory change\fI newValue\fR ?\fIevent\fR? +Replaces the value recorded for an event with \fInewValue\fR. \fIEvent\fR +specifies the event to replace, and +defaults to the \fIcurrent\fR event (not event \fB\-1\fR). This command +is intended for use in commands that implement new forms of history +substitution and wish to replace the current event (which invokes the +substitution) with the command created through substitution. The return +value is an empty string. +.TP +\fBhistory event\fR ?\fIevent\fR? +Returns the value of the event given by \fIevent\fR. \fIEvent\fR +defaults to \fB\-1\fR. This command causes history revision to occur: +see below for details. +.TP +\fBhistory info \fR?\fIcount\fR? +Returns a formatted string (intended for humans to read) giving +the event number and contents for each of the events in the history +list except the current event. If \fIcount\fR is specified +then only the most recent \fIcount\fR events are returned. +.TP +\fBhistory keep \fIcount\fR +This command may be used to change the size of the history list to +\fIcount\fR events. Initially, 20 events are retained in the history +list. This command returns an empty string. +.TP +\fBhistory nextid\fR +Returns the number of the next event to be recorded +in the history list. It is useful for things like printing the +event number in command-line prompts. +.TP +\fBhistory redo \fR?\fIevent\fR? +Re-executes the command indicated by \fIevent\fR and return its result. +\fIEvent\fR defaults to \fB\-1\fR. This command results in history +revision: see below for details. +.TP +\fBhistory substitute \fIold new \fR?\fIevent\fR? +Retrieves the command given by \fIevent\fR +(\fB\-1\fR by default), replace any occurrences of \fIold\fR by +\fInew\fR in the command (only simple character equality is supported; +no wild cards), execute the resulting command, and return the result +of that execution. This command results in history +revision: see below for details. +.TP +\fBhistory words \fIselector\fR ?\fIevent\fR? +Retrieves from the command given by \fIevent\fR (\fB\-1\fR by default) +the words given by \fIselector\fR, and return those words in a string +separated by spaces. The \fBselector\fR argument has three forms. +If it is a single number then it selects the word given by that +number (\fB0\fR for the command name, \fB1\fR for its first argument, +and so on). If it consists of two numbers separated by a dash, +then it selects all the arguments between those two. Otherwise +\fBselector\fR is treated as a pattern; all words matching that +pattern (in the sense of \fBstring match\fR) are returned. In +the numeric forms \fB$\fR may be used +to select the last word of a command. +For example, suppose the most recent command in the history list is +.RS +.CS +\fBformat {%s is %d years old} Alice [expr $ageInMonths/12]\fR +.CE +Below are some history commands and the results they would produce: +.DS +.ta 4c +.fi +.UL Command " " +.UL Result +.nf + +\fBhistory words $ [expr $ageInMonths/12]\fR +\fBhistory words 1-2 {%s is %d years old} Alice\fR +\fBhistory words *a*o* {%s is %d years old} [expr $ageInMonths/12]\fR +.DE +\fBHistory words\fR results in history revision: see below for details. +.RE +.SH "HISTORY REVISION" +.PP +The history options \fBevent\fR, \fBredo\fR, \fBsubstitute\fR, +and \fBwords\fR result in ``history revision''. +When one of these options is invoked then the current event +is modified to eliminate the history command and replace it with +the result of the history command. +For example, suppose that the most recent command in the history +list is +.CS +\fBset a [expr $b+2]\fR +.CE +and suppose that the next command invoked is one of the ones on +the left side of the table below. The command actually recorded in +the history event will be the corresponding one on the right side +of the table. +.ne 1.5c +.DS +.ta 4c +.fi +.UL "Command Typed" " " +.UL "Command Recorded" +.nf + +\fBhistory redo set a [expr $b+2]\fR +\fBhistory s a b set b [expr $b+2]\fR +\fBset c [history w 2] set c [expr $b+2]\fR +.DE +History revision is needed because event specifiers like \fB\-1\fR +are only valid at a particular time: once more events have been +added to the history list a different event specifier would be +needed. +History revision occurs even when \fBhistory\fR is invoked +indirectly from the current event (e.g. a user types a command +that invokes a Tcl procedure that invokes \fBhistory\fR): the +top-level command whose execution eventually resulted in a +\fBhistory\fR command is replaced. +If you wish to invoke commands like \fBhistory words\fR without +history revision, you can use \fBhistory event\fR to save the +current history event and then use \fBhistory change\fR to +restore it later. + +.SH KEYWORDS +event, history, record, revision diff --git a/contrib/tcl/doc/if.n b/contrib/tcl/doc/if.n new file mode 100644 index 0000000..f76d8d9 --- /dev/null +++ b/contrib/tcl/doc/if.n @@ -0,0 +1,45 @@ +'\" +'\" Copyright (c) 1993 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: @(#) if.n 1.6 96/03/25 20:16:42 +'\" +.so man.macros +.TH if n "" Tcl "Tcl Built-In Commands" +.BS +'\" Note: do not modify the .SH NAME line immediately below! +.SH NAME +if \- Execute scripts conditionally +.SH SYNOPSIS +\fBif \fIexpr1 \fR?\fBthen\fR? \fIbody1 \fBelseif \fIexpr2 \fR?\fBthen\fR? \fIbody2\fR \fBelseif\fR ... ?\fBelse\fR? ?\fIbodyN\fR? +.BE + +.SH DESCRIPTION +.PP +The \fIif\fR command evaluates \fIexpr1\fR as an expression (in the +same way that \fBexpr\fR evaluates its argument). The value of the +expression must be a boolean +.VS +(a numeric value, where 0 is false and +anything is true, or a string value such as \fBtrue\fR or \fByes\fR +for true and \fBfalse\fR or \fBno\fR for false); +.VE +if it is true then \fIbody1\fR is executed by passing it to the +Tcl interpreter. +Otherwise \fIexpr2\fR is evaluated as an expression and if it is true +then \fBbody2\fR is executed, and so on. +If none of the expressions evaluates to true then \fIbodyN\fR is +executed. +The \fBthen\fR and \fBelse\fR arguments are optional +``noise words'' to make the command easier to read. +There may be any number of \fBelseif\fR clauses, including zero. +\fIBodyN\fR may also be omitted as long as \fBelse\fR is omitted too. +The return value from the command is the result of the body script +that was executed, or an empty string +if none of the expressions was non-zero and there was no \fIbodyN\fR. + +.SH KEYWORDS +boolean, conditional, else, false, if, true diff --git a/contrib/tcl/doc/incr.n b/contrib/tcl/doc/incr.n new file mode 100644 index 0000000..cfd76b8 --- /dev/null +++ b/contrib/tcl/doc/incr.n @@ -0,0 +1,31 @@ +'\" +'\" Copyright (c) 1993 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: @(#) incr.n 1.5 96/03/25 20:16:58 +'\" +.so man.macros +.TH incr n "" Tcl "Tcl Built-In Commands" +.BS +'\" Note: do not modify the .SH NAME line immediately below! +.SH NAME +incr \- Increment the value of a variable +.SH SYNOPSIS +\fBincr \fIvarName \fR?\fIincrement\fR? +.BE + +.SH DESCRIPTION +.PP +Increments the value stored in the variable whose name is \fIvarName\fR. +The value of the variable must be an integer. +If \fIincrement\fR is supplied then its value (which must be an +integer) is added to the value of variable \fIvarName\fR; otherwise +1 is added to \fIvarName\fR. +The new value is stored as a decimal string in variable \fIvarName\fR +and also returned as result. + +.SH KEYWORDS +add, increment, variable, value diff --git a/contrib/tcl/doc/info.n b/contrib/tcl/doc/info.n new file mode 100644 index 0000000..10fb1aa --- /dev/null +++ b/contrib/tcl/doc/info.n @@ -0,0 +1,168 @@ +'\" +'\" Copyright (c) 1993 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: @(#) info.n 1.12 96/03/25 20:17:12 +'\" +.so man.macros +.TH info n 7.5 Tcl "Tcl Built-In Commands" +.BS +'\" Note: do not modify the .SH NAME line immediately below! +.SH NAME +info \- Return information about the state of the Tcl interpreter +.SH SYNOPSIS +\fBinfo \fIoption \fR?\fIarg arg ...\fR? +.BE + +.SH DESCRIPTION +.PP +This command provides information about various internals of the Tcl +interpreter. +The legal \fIoption\fR's (which may be abbreviated) are: +.TP +\fBinfo args \fIprocname\fR +Returns a list containing the names of the arguments to procedure +\fIprocname\fR, in order. \fIProcname\fR must be the name of a +Tcl command procedure. +.TP +\fBinfo body \fIprocname\fR +Returns the body of procedure \fIprocname\fR. \fIProcname\fR must be +the name of a Tcl command procedure. +.TP +\fBinfo cmdcount\fR +Returns a count of the total number of commands that have been invoked +in this interpreter. +.TP +\fBinfo commands \fR?\fIpattern\fR? +If \fIpattern\fR isn't specified, returns a list of names of all the +Tcl commands, including both the built-in commands written in C and +the command procedures defined using the \fBproc\fR command. +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. +.TP +\fBinfo complete \fIcommand\fR +Returns 1 if \fIcommand\fR is a complete Tcl command in the sense of +having no unclosed quotes, braces, brackets or array element names, +If the command doesn't appear to be complete then 0 is returned. +This command is typically used in line-oriented input environments +to allow users to type in commands that span multiple lines; if the +command isn't complete, the script can delay evaluating it until additional +lines have been typed to complete the command. +.TP +\fBinfo default \fIprocname arg varname\fR +\fIProcname\fR must be the name of a Tcl command procedure and \fIarg\fR +must be the name of an argument to that procedure. If \fIarg\fR +doesn't have a default value then the command returns \fB0\fR. +Otherwise it returns \fB1\fR and places the default value of \fIarg\fR +into variable \fIvarname\fR. +.TP +\fBinfo exists \fIvarName\fR +Returns \fB1\fR if the variable named \fIvarName\fR exists in the +current context (either as a global or local variable), returns \fB0\fR +otherwise. +.TP +\fBinfo globals \fR?\fIpattern\fR? +If \fIpattern\fR isn't specified, returns a list of all the names +of currently-defined global variables. +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. +.VS br +.TP +\fBinfo hostname\fR +Returns the name of the computer on which this invocation is being +executed. +.VE +.TP +\fBinfo level\fR ?\fInumber\fR? +If \fInumber\fR is not specified, this command returns a number +giving the stack level of the invoking procedure, or 0 if the +command is invoked at top-level. If \fInumber\fR is specified, +then the result is a list consisting of the name and arguments for the +procedure call at level \fInumber\fR on the stack. If \fInumber\fR +is positive then it selects a particular stack level (1 refers +to the top-most active procedure, 2 to the procedure it called, and +so on); otherwise it gives a level relative to the current level +(0 refers to the current procedure, -1 to its caller, and so on). +See the \fBuplevel\fR command for more information on what stack +levels mean. +.TP +\fBinfo library\fR +Returns the name of the library directory in which standard Tcl +scripts are stored. +.VS +This is actually the value of the \fBtcl_library\fR +variable and may be changed by setting \fBtcl_library\fR. +See the \fBtclvars\fR manual entry for more information. +.TP +\fBinfo loaded \fR?\fIinterp\fR? +Returns a list describing all of the packages that have been loaded into +\fIinterp\fR with the \fBload\fR command. +Each list element is a sub-list with two elements consisting of the +name of the file from which the package was loaded and the name of +the package. +For statically-loaded packages the file name will be an empty string. +\fIInterp\fR defaults to the current interpreter. +.VE +.TP +\fBinfo locals \fR?\fIpattern\fR? +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. +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. +.VS br +.TP +\fBinfo nameofexecutable\fR +Returns the full path name of the binary file from which the application +was invoked. If Tcl was unable to identify the file, then an empty +string is returned. +.TP +\fBinfo patchlevel\fR +Returns the value of the global variable \fBtcl_patchLevel\fR; see +the \fBtclvars\fR manual entry for more information. +.VE +.TP +\fBinfo procs \fR?\fIpattern\fR? +If \fIpattern\fR isn't specified, returns a list of all the +names of Tcl command procedures. +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. +.TP +\fBinfo script\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. +.VS br +.TP +\fBinfo sharedlibextension\fR +Returns the extension used on this platform for the names of files +containing shared libraries (for example, \fB.so\fR under Solaris). +If shared libraries aren't supported on this platform then an empty +string is returned. +.TP +\fBinfo tclversion\fR +Returns the value of the global variable \fBtcl_version\fR; see +the \fBtclvars\fR manual entry for more information. +.VE +.TP +\fBinfo vars\fR ?\fIpattern\fR? +If \fIpattern\fR isn't specified, +returns a list of all the names of currently-visible variables, including +both locals and currently-visible globals. +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. + +.SH KEYWORDS +command, information, interpreter, level, procedure, variable diff --git a/contrib/tcl/doc/interp.n b/contrib/tcl/doc/interp.n new file mode 100644 index 0000000..d07c3a9 --- /dev/null +++ b/contrib/tcl/doc/interp.n @@ -0,0 +1,347 @@ +'\" +'\" Copyright (c) 1995-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: @(#) interp.n 1.15 96/03/25 20:17:28 +'\" +.so man.macros +.TH interp n 7.5 Tcl "Tcl Built-In Commands" +.BS +'\" Note: do not modify the .SH NAME line immediately below! +.SH NAME +interp \- Create and manipulate Tcl interpreters +.SH SYNOPSIS +\fBinterp \fIoption \fR?\fIarg arg ...\fR? +.BE +.SH DESCRIPTION +.PP +This command makes it possible to create one or more new Tcl +interpreters that co-exist with the creating interpreter in the +same application. The creating interpreter is called the \fImaster\fR +and the new interpreter is called a \fIslave\fR. +A master can create any number of slaves, and each slave can +itself create additional slaves for which it is master, resulting +in a hierarchy of interpreters. +.PP +Each interpreter is independent from the others: it has its own name +space for commands, procedures, and global variables. +A master interpreter may create connections between its slaves and +itself using a mechanism called an \fIalias\fR. An \fIalias\fR is +a command in a slave interpreter which, when invoked, causes a +command to be invoked in its master interpreter or in another slave +interpreter. The only other connections between interpreters are +through environment variables (the \fBenv\fR variable), which are +normally shared among all interpreters in the application. Note that the +name space for files (such as the names returned by the \fBopen\fR command) +is no longer shared between interpreters. Explicit commands are provided to +share files and to transfer references to open files from one interpreter +to another. +.PP +The \fBinterp\fR command also provides support for \fIsafe\fR +interpreters. A safe interpreter is a slave whose functions have +been greatly restricted, so that it is safe to execute untrusted +scripts without fear of them damaging other interpreters or the +application's environment. For example, all IO channel creation commands +and subprocess creation commands are removed from safe interpreters. +See SAFE INTERPRETERS below for more information on what features +are present in a safe interpreter. The alias mechanism can be +used for protected communication (analogous to a kernel call) +between a slave interpreter and its master. +.PP +A qualified interpreter name is a proper Tcl lists containing a subset of its +ancestors in the interpreter hierarchy, terminated by the string naming the +interpreter in its immediate master. Interpreter names are relative to the +interpreter in which they are used. For example, if \fIa\fR is a slave of +the current interpreter and it has a slave \fIa1\fR, which in turn has a +slave \fIa11\fR, the qualified name of \fIa11\fR in \fIa\fR is the list +\fI{a1 a11}\fR. +.PP +The \fBinterp\fR command, described below, accepts qualified interpreter +names as arguments; the interpreter in which the command is being evaluated +can always be referred to as \fI{}\fR (the empty list or string). Note that +it is impossible to refer to a master (ancestor) interpreter by name in a +slave interpreter except through aliases. Also, there is no global name by +which one can refer to the first interpreter created in an application. +Both restrictions are motivated by safety concerns. +.PP +The \fBinterp\fR command is used to create, delete, and manipulate +slave interpreters. It can have any of several forms, depending on +the \fIoption\fR argument: +.TP +\fBinterp \fBalias \fIsrcPath \fIsrcCmd\fR +Returns a Tcl list whose elements are the \fItargetCmd\fR and +\fIarg\fRs associated with the alias named \fIsrcCmd\fR +(all of these are the values specified when the alias was +created; it is possible that the actual source command in the +slave is different from \fIsrcCmd\fR if it was renamed). +.TP +\fBinterp \fBalias \fIsrcPath \fIsrcCmd\fR \fB{}\fR +Deletes the alias for \fIsrcCmd\fR in the slave interpreter identified by +\fIsrcPath\fR. +\fIsrcCmd\fR refers to the name under which the alias +was created; if the source command has been renamed, the renamed +command will be deleted. +.TP +\fBinterp \fBalias \fIsrcPath \fIsrcCmd\fR \fItargetPath \fItargetCmd \fR?\fIarg arg ...\fR? +This command creates an alias between one slave and another (see the +\fBalias\fR slave command below for creating aliases between a slave +and its master). In this command, either of the slave interpreters +may be anywhere in the hierarchy of interpreters under the interpreter +invoking the command. +\fISrcPath\fR and \fIsrcCmd\fR identify the source of the alias. +\fISrcPath\fR is a Tcl list whose elements select a particular +interpreter. For example, ``\fBa b\fR'' identifies an interpreter +\fBb\fR, which is a slave of interpreter \fBa\fR, which is a slave +of the invoking interpreter. An empty list specifies the interpreter +invoking the command. \fIsrcCmd\fR gives the name of a new +command, which will be created in the source interpreter. +\fITargetPath\fR and \fItargetCmd\fR specify a target interpreter +and command, and the \fIarg\fR arguments, if any, specify additional +arguments to \fItargetCmd\fR which are prepended to any arguments specified +in the invocation of \fIsrcCmd\fR. +\fITargetCmd\fR may be undefined at the time of this call, or it may +already exist; it is not created by this command. +The alias arranges for the given target command to be invoked +in the target interpreter whenever the given source command is +invoked in the source interpreter. See ALIAS INVOCATION below for +more details. +.TP +\fBinterp \fBaliases \fR?\fIpath\fR? +This command returns a Tcl list of the names of all the source commands for +aliases defined in the interpreter identified by \fIpath\fR. +.TP +\fBinterp \fBcreate \fR?\fB\-safe\fR? ?\fB\-\|\-\fR? ?\fIpath\fR? +Creates a slave interpreter identified by \fIpath\fR and a new command, +called a \fIslave command\fR. The name of the slave command is the last +component of \fIpath\fR. The new slave interpreter and the slave command +are created in the interpreter identified by the path obtained by removing +the last component from \fIpath\fR. For example, if \fIpath is ``\fBa b +c\fR'' then a new slave interpreter and slave command named ``\fBc\fR'' are +created in the interpreter identified by the path ``\fBa b\fR''. +The slave command may be used to manipulate the new interpreter as +described below. If \fIpath\fR is omitted, Tcl creates a unique name of the +form \fBinterp\fIx\fR, where \fIx\fR is an integer, and uses it for the +interpreter and the slave command. If the \fB\-safe\fR switch is specified +(or if the master interpreter is a safe interpreter), the new slave +interpreter will be created as a safe interpreter with limited +functionality; otherwise the slave will include the full set of Tcl +built-in commands and variables. The \fB\-\|\-\fR switch can be used to +mark the end of switches; it may be needed if \fIpath\fR is an unusual +value such as \fB\-safe\fR. The result of the command is the name of the +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. +.TP +\fBinterp \fBdelete \fR?\fIpath ...?\fR +Deletes zero or more interpreters given by the optional \fIpath\fR +arguments, and for each interpreter, it also deletes its slaves. The +command also deletes the slave command for each interpreter deleted. +For each \fIpath\fR argument, if no interpreter by that name +exists, the command raises an error. +.TP +\fBinterp \fBeval \fIpath arg \fR?\fIarg ...\fR? +This command concatenates all of the \fIarg\fR arguments in the same +fashion as the \fBconcat\fR command, then evaluates the resulting string as +a Tcl script in the slave interpreter identified by \fIpath\fR. The result +of this evaluation (including error information such as the \fBerrorInfo\fR +and \fBerrorCode\fR variables, if an error occurs) is returned to the +invoking interpreter. +.TP +\fBinterp \fBexists \fIpath\fR +Returns \fB1\fR if a slave interpreter by the specified \fIpath\fR +exists in this master, \fB0\fR otherwise. If \fIpath\fR is omitted, the +invoking interpreter is used. +.TP +\fBinterp \fBissafe\fR ?\fIpath\fR? +Returns \fB1\fR if the interpreter identified by the specified \fIpath\fR +is safe, \fB0\fR otherwise. +.TP +\fBinterp \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 +identified by \fIdestPath\fR. Both interpreters have the same permissions +on the IO channel. +Both interpreters must close it to close the underlying IO channel; IO +channels accessible in an interpreter are automatically closed when an +interpreter is destroyed. +.TP +\fBinterp \fBslaves\fR ?\fIpath\fR? +Returns a Tcl list of the names of all the slave interpreters associated +with the interpreter identified by \fIpath\fR. If \fIpath\fR is omitted, +the invoking interpreter is used. +.TP +\fBinterp \fBtarget \fIpath alias\fR +Returns a Tcl list describing the target interpreter for an alias. The +alias is specified with an interpreter path and source command name, just +as in \fBinterp alias\fR above. The name of the target interpreter is +returned as an interpreter path, relative to the invoking interpreter. +If the target interpreter for the alias is the invoking interpreter then an +empty list is returned. If the target interpreter for the alias is not the +invoking interpreter or one of its descendants then an error is generated. +The target command does not have to be defined at the time of this invocation. +.TP +\fBinterp \fBtransfer\fR \fIsrcPath channelId destPath\fR +Causes the IO channel identified by \fIchannelId\fR to become available in +the interpreter identified by \fIdestPath\fR and unavailable in the +interpreter identified by \fIsrcPath\fR. +.SH "SLAVE COMMAND" +.PP +For each slave interpreter created with the \fBinterp\fR command, a +new Tcl command is created in the master interpreter with the same +name as the new interpreter. This command may be used to invoke +various operations on the interpreter. It has the following +general form: +.CS +\fIslave command \fR?\fIarg arg ...\fR? +.CE +\fISlave\fR is the name of the interpreter, and \fIcommand\fR +and the \fIarg\fRs determine the exact behavior of the command. +The valid forms of this command are: +.TP +\fIslave \fBaliases\fR +Returns a Tcl list whose elements are the names of all the +aliases in \fIslave\fR. The names returned are the \fIsrcCmd\fR +values used when the aliases were created (which may not be the same +as the current names of the commands, if they have been +renamed). +.TP +\fIslave \fBalias \fIsrcCmd\fR +Returns a Tcl list whose elements are the \fItargetCmd\fR and +\fIarg\fRs associated with the alias named \fIsrcCmd\fR +(all of these are the values specified when the alias was +created; it is possible that the actual source command in the +slave is different from \fIsrcCmd\fR if it was renamed). +.TP +\fIslave \fBalias \fIsrcCmd \fB{}\fR +Deletes the alias for \fIsrcCmd\fR in the slave interpreter. +\fIsrcCmd\fR refers to the name under which the alias +was created; if the source command has been renamed, the renamed +command will be deleted. +.TP +\fIslave \fBalias \fIsrcCmd targetCmd \fR?\fIarg ..\fR? +Creates an alias such that whenever \fIsrcCmd\fR is invoked +in \fIslave\fR, \fItargetCmd\fR is invoked in the master. +The \fIarg\fR arguments will be passed to \fItargetCmd\fR as additional +arguments, prepended before any arguments passed in the invocation of +\fIsrcCmd\fR. +See ALIAS INVOCATION below for details. +.TP +\fIslave \fBeval \fIarg \fR?\fIarg ..\fR? +This command concatenates all of the \fIarg\fR arguments in +the same fashion as the \fBconcat\fR command, then evaluates +the resulting string as a Tcl script in \fIslave\fR. +The result of this evaluation (including error information +such as the \fBerrorInfo\fR and \fBerrorCode\fR variables, if an +error occurs) is returned to the invoking interpreter. +.TP +\fIslave \fBissafe\fR +Returns \fB1\fR if the slave interpreter is safe, \fB0\fR otherwise. + +.SH "ALIAS INVOCATION" +.PP +The alias mechanism has been carefully designed so that it can +be used safely when an untrusted script is executing +in a safe slave and the target of the alias is a trusted +master. The most important thing in guaranteeing safety is to +ensure that information passed from the slave to the master is +never evaluated or substituted in the master; if this were to +occur, it would enable an evil script in the slave to invoke +arbitrary functions in the master, which would compromise security. +.PP +When the source for an alias is invoked in the slave interpreter, the +usual Tcl substitutions are performed when parsing that command. +These substitutions are carried out in the source interpreter just +as they would be for any other command invoked in that interpreter. +The command procedure for the source command takes its arguments +and merges them with the \fItargetCmd\fR and \fIarg\fRs for the +alias to create a new array of arguments. If the words +of \fIsrcCmd\fR were ``\fIsrcCmd arg1 arg2 ... argN\fR'', +the new set of words will be +``\fItargetCmd arg arg ... arg arg1 arg2 ... argN\fR'', +where \fItargetCmd\fR and \fIarg\fRs are the values supplied when the +alias was created. \fITargetCmd\fR is then used to locate a command +procedure in the target interpreter, and that command procedure +is invoked with the new set of arguments. An error occurs if +there is no command named \fItargetCmd\fR in the target interpreter. +No additional substitutions are performed on the words: the +target command procedure is invoked directly, without +going through the normal Tcl evaluation mechanism. +Substitutions are thus performed on each word exactly once: +\fItargetCmd\fR and \fIargs\fR were substituted when parsing the command +that created the alias, and \fIarg1 - argN\fR are substituted when +the alias's source command is parsed in the source interpreter. +.PP +When writing the \fItargetCmd\fRs for aliases in safe interpreters, +it is very important that the arguments to that command never be +evaluated or substituted, since this would provide an escape +mechanism whereby the slave interpreter could execute arbitrary +code in the master. This in turn would compromise the security +of the system. + +.SH "SAFE INTERPRETERS" +.PP +A safe interpreter is one with restricted functionality, so that +is safe to execute an arbitrary script from your worst enemy without +fear of that script damaging the enclosing application or the rest +of your computing environment. In order to make an interpreter +safe, certain commands and variables are removed from the interpreter. +For example, commands to create files on disk are removed, and the +\fBexec\fR command is removed, since it could be used to cause damage +through subprocesses. +Limited access to these facilities can be provided, by creating +aliases to the master interpreter which check their arguments carefully +and provide restricted access to a safe subset of facilities. +For example, file creation might be allowed in a particular subdirectory +and subprocess invocation might be allowed for a carefully selected and +fixed set of programs. +.PP +A safe interpreter is created by specifying the \fB\-safe\fR switch +to the \fBinterp create\fR command. Furthermore, any slave created +by a safe interpreter will also be safe. +.PP +A safe interpreter is created with exactly the following set of +built-in commands: +.DS +.ta 1.2i 2.4i 3.6i +\fBappend array break case +catch clock close concat +continue eof error eval +expr fblocked flush for +foreach format gets global +history if incr info +interp join lappend lindex +list llength lrange lreplace +pid proc puts read +regexp regsub rename return +scan set seek split +string switch tell trace\fR +.DE +All commands not on this list are removed from the interpreter by +the \fBinterp create\fR command. Of course, the missing commands +can be recreated later as Tcl procedures or aliases. +.PP +In addition, the \fBenv\fR variable is not present in a safe interpreter, +so it cannot share environment variables with other interpreters. The +\fBenv\fR variable poses a security risk, because users can store +sensitive information in an environment variable. For example, the PGP +manual recommends storing the PGP private key protection password in +the environment variable \fIPGPPASS\fR. Making this variable available +to untrusted code executing in a safe interpreter would incur a +security risk. +.PP +If extensions are loaded into a safe interpreter, they may also restrict +their own functionality to eliminate unsafe commands. The management of +extensions for safety will be explained in the manual entries for the +\fBpackage\fR and \fBload\fR Tcl commands. +.SH CREDITS +.PP +This mechanism is based on the Safe-Tcl prototype implemented +by Nathaniel Borenstein and Marshall Rose. + +.SH "SEE ALSO" +load(n), package(n) Tcl_CreateSlave(3) + +.SH KEYWORDS +alias, master interpreter, safe interpreter, slave interpreter diff --git a/contrib/tcl/doc/join.n b/contrib/tcl/doc/join.n new file mode 100644 index 0000000..7e662cf --- /dev/null +++ b/contrib/tcl/doc/join.n @@ -0,0 +1,29 @@ +'\" +'\" Copyright (c) 1993 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: @(#) join.n 1.5 96/03/25 20:17:46 +'\" +.so man.macros +.TH join n "" Tcl "Tcl Built-In Commands" +.BS +'\" Note: do not modify the .SH NAME line immediately below! +.SH NAME +join \- Create a string by joining together list elements +.SH SYNOPSIS +\fBjoin \fIlist \fR?\fIjoinString\fR? +.BE + +.SH DESCRIPTION +.PP +The \fIlist\fR argument must be a valid Tcl list. +This command returns the string +formed by joining all of the elements of \fIlist\fR together with +\fIjoinString\fR separating each adjacent pair of elements. +The \fIjoinString\fR argument defaults to a space character. + +.SH KEYWORDS +element, join, list, separator diff --git a/contrib/tcl/doc/lappend.n b/contrib/tcl/doc/lappend.n new file mode 100644 index 0000000..a0c3b54 --- /dev/null +++ b/contrib/tcl/doc/lappend.n @@ -0,0 +1,35 @@ +'\" +'\" Copyright (c) 1993 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: @(#) lappend.n 1.6 96/03/25 20:18:03 +'\" +.so man.macros +.TH lappend n "" Tcl "Tcl Built-In Commands" +.BS +'\" Note: do not modify the .SH NAME line immediately below! +.SH NAME +lappend \- Append list elements onto a variable +.SH SYNOPSIS +\fBlappend \fIvarName \fR?\fIvalue value value ...\fR? +.BE + +.SH DESCRIPTION +.PP +This command treats the variable given by \fIvarName\fR as a list +and appends each of the \fIvalue\fR arguments to that list as a separate +element, with spaces between elements. +If \fIvarName\fR doesn't exist, it is created as a list with elements +given by the \fIvalue\fR arguments. +\fBLappend\fR is similar to \fBappend\fR except that the \fIvalue\fRs +are appended as list elements rather than raw text. +This command provides a relatively efficient way to build up +large lists. For example, ``\fBlappend a $b\fR'' is much +more efficient than ``\fBset a [concat $a [list $b]]\fR'' when +\fB$a\fR is long. + +.SH KEYWORDS +append, element, list, variable diff --git a/contrib/tcl/doc/library.n b/contrib/tcl/doc/library.n new file mode 100644 index 0000000..232c799 --- /dev/null +++ b/contrib/tcl/doc/library.n @@ -0,0 +1,188 @@ +'\" +'\" Copyright (c) 1991-1993 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: @(#) library.n 1.20 96/03/25 20:18:29 +.so man.macros +.TH library n "" Tcl "Tcl Built-In Commands" +.BS +.SH NAME +library \- standard library of Tcl procedures +.SH SYNOPSIS +.nf +\fBauto_execok \fIcmd\fR +\fBauto_load \fIcmd\fR +\fBauto_mkindex \fIdir pattern pattern ...\fR +\fBauto_reset\fR +\fBparray \fIarrayName\fR +.BE + +.SH INTRODUCTION +.PP +Tcl includes a library of Tcl procedures for commonly-needed functions. +The procedures defined in the Tcl library are generic ones suitable +for use by many different applications. +The location of the Tcl library is returned by the \fBinfo library\fR +command. +In addition to the Tcl library, each application will normally have +its own library of support procedures as well; the location of this +library is normally given by the value of the \fB$\fIapp\fB_library\fR +global variable, where \fIapp\fR is the name of the application. +For example, the location of the Tk library is kept in the variable +\fB$tk_library\fR. +.PP +To access the procedures in the Tcl library, an application should +source the file \fBinit.tcl\fR in the library, for example with +the Tcl command +.CS +\fBsource [info library]/init.tcl\fR +.CE +If the library procedure \fBTcl_Init\fR is invoked from an application's +\fBTcl_AppInit\fR procedure, this happens automatically. +The code in \fBinit.tcl\fR will define the \fBunknown\fR procedure +and arrange for the other procedures to be loaded on-demand using +the auto-load mechanism defined below. + +.SH "COMMAND PROCEDURES" +.PP +The following procedures are provided in the Tcl library: +.TP +\fBauto_execok \fIcmd\fR +Determines whether there is an executable file by the name \fIcmd\fR. +This command examines the directories in the current search path +(given by the PATH environment variable) to see if there is an +executable file named \fIcmd\fR in any of those directories. +If so, it returns 1; if not it returns 0. \fBAuto_exec\fR +remembers information about previous searches in an array +named \fBauto_execs\fR; this avoids the path search in +future calls for the same \fIcmd\fR. The command \fBauto_reset\fR +may be used to force \fBauto_execok\fR to forget its cached +information. +.TP +\fBauto_load \fIcmd\fR +This command attempts to load the definition for a Tcl command named +\fIcmd\fR. +To do this, it searches an \fIauto-load path\fR, which is a list of +one or more directories. +The auto-load path is given by the global variable \fB$auto_path\fR +if it exists. +If there is no \fB$auto_path\fR variable, then the TCLLIBPATH environment +variable is used, if it exists. +Otherwise the auto-load path consists of just the Tcl library directory. +Within each directory in the auto-load path there must be a file +\fBtclIndex\fR that describes one +.VS +or more commands defined in that directory +and a script to evaluate to load each of the commands. +The \fBtclIndex\fR file should be generated with the +\fBauto_mkindex\fR command. +If \fIcmd\fR is found in an index file, then the appropriate +script is evaluated to create the command. +.VE +The \fBauto_load\fR command returns 1 if \fIcmd\fR was successfully +created. +The command returns 0 if there was no index entry for \fIcmd\fR +or if the script didn't actually define \fIcmd\fR (e.g. because +index information is out of date). +If an error occurs while processing the script, then that error +is returned. +\fBAuto_load\fR only reads the index information once and saves it +in the array \fBauto_index\fR; future calls to \fBauto_load\fR +check for \fIcmd\fR in the array rather than re-reading the index +files. +The cached index information may be deleted with the command +\fBauto_reset\fR. +This will force the next \fBauto_load\fR command to reload the +index database from disk. +.TP +\fBauto_mkindex \fIdir pattern pattern ...\fR +.VS +Generates an index suitable for use by \fBauto_load\fR. +The command searches \fIdir\fR for all files whose names match +any of the \fIpattern\fR arguments +.VE +(matching is done with the \fBglob\fR command), +generates an index of all the Tcl command +procedures defined in all the matching files, and stores the +index information in a file named \fBtclIndex\fR in \fIdir\fR. +If no pattern is given a pattern of \fB*.tcl\fR will be assumed. +For example, the command +.RS +.CS +\fBauto_mkindex foo *.tcl\fR +.CE +.LP +will read all the \fB.tcl\fR files in subdirectory \fBfoo\fR +and generate a new index file \fBfoo/tclIndex\fR. +.PP +\fBAuto_mkindex\fR parses the Tcl scripts in a relatively +unsophisticated way: if any line contains the word \fBproc\fR +as its first characters then it is assumed to be a procedure +definition and the next word of the line is taken as the +procedure's name. +Procedure definitions that don't appear in this way (e.g. they +have spaces before the \fBproc\fR) will not be indexed. +.RE +.TP +\fBauto_reset\fR +Destroys all the information cached by \fBauto_execok\fR and +\fBauto_load\fR. +This information will be re-read from disk the next time it is +needed. +\fBAuto_reset\fR also deletes any procedures listed in the auto-load +index, so that fresh copies of them will be loaded the next time +that they're used. +.TP +\fBparray \fIarrayName\fR +Prints on standard output the names and values of all the elements +in the array \fIarrayName\fR. +\fBArrayName\fR must be an array accessible to the caller of \fBparray\fR. +It may be either local or global. + +.SH "VARIABLES" +.PP +The following global variables are defined or used by the procedures in +the Tcl library: +.TP +\fBauto_execs\fR +Used by \fBauto_execok\fR to record information about whether +particular commands exist as executable files. +.TP +\fBauto_index\fR +Used by \fBauto_load\fR to save the index information read from +disk. +.TP +\fBauto_noexec\fR +If set to any value, then \fBunknown\fR will not attempt to auto-exec +any commands. +.TP +\fBauto_noload\fR +If set to any value, then \fBunknown\fR will not attempt to auto-load +any commands. +.TP +\fBauto_path\fR +If set, then it must contain a valid Tcl list giving directories to +search during auto-load operations. +.TP +\fBenv(TCL_LIBRARY)\fR +If set, then it specifies the location of the directory containing +library scripts (the value of this variable will be returned by +the command \fBinfo library\fR). If this variable isn't set then +a default value is used. +.TP +\fBenv(TCLLIBPATH)\fR +If set, then it must contain a valid Tcl list giving directories to +search during auto-load operations. +This variable is only used if \fBauto_path\fR is not defined. +.TP +\fBunknown_active\fR +This variable is set by \fBunknown\fR to indicate that it is active. +It is used to detect errors where \fBunknown\fR recurses on itself +infinitely. +The variable is unset before \fBunknown\fR returns. + +.SH KEYWORDS +auto-exec, auto-load, library, unknown diff --git a/contrib/tcl/doc/license.terms b/contrib/tcl/doc/license.terms new file mode 100644 index 0000000..3dcd816 --- /dev/null +++ b/contrib/tcl/doc/license.terms @@ -0,0 +1,32 @@ +This software is copyrighted by the Regents of the University of +California, Sun Microsystems, Inc., 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. + +RESTRICTED RIGHTS: Use, duplication or disclosure by the government +is subject to the restrictions as set forth in subparagraph (c) (1) (ii) +of the Rights in Technical Data and Computer Software Clause as DFARS +252.227-7013 and FAR 52.227-19. diff --git a/contrib/tcl/doc/lindex.n b/contrib/tcl/doc/lindex.n new file mode 100644 index 0000000..794d128 --- /dev/null +++ b/contrib/tcl/doc/lindex.n @@ -0,0 +1,37 @@ +'\" +'\" Copyright (c) 1993 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: @(#) lindex.n 1.7 96/03/25 20:18:43 +'\" +.so man.macros +.TH lindex n 7.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 +.BE + +.SH DESCRIPTION +.PP +This command treats \fIlist\fR as a Tcl list and returns the +\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 +concerning braces and quotes and backslashes as the Tcl command +interpreter; however, variable +substitution and command substitution do not occur. +If \fIindex\fR is negative or greater than or equal to the number +of elements in \fIvalue\fR, then an empty +string is returned. +.VS +If \fIindex\fR has the value \fBend\fR, it refers to the last element +in the list. +.VE + +.SH KEYWORDS +element, index, list diff --git a/contrib/tcl/doc/linsert.n b/contrib/tcl/doc/linsert.n new file mode 100644 index 0000000..17c7538 --- /dev/null +++ b/contrib/tcl/doc/linsert.n @@ -0,0 +1,35 @@ +'\" +'\" Copyright (c) 1993 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: @(#) linsert.n 1.7 96/03/25 20:18:57 +'\" +.so man.macros +.TH linsert n 7.4 Tcl "Tcl Built-In Commands" +.BS +'\" Note: do not modify the .SH NAME line immediately below! +.SH NAME +linsert \- Insert elements into a list +.SH SYNOPSIS +\fBlinsert \fIlist index element \fR?\fIelement element ...\fR? +.BE + +.SH DESCRIPTION +.PP +This command produces a new list from \fIlist\fR by inserting all +of the \fIelement\fR arguments just before the \fIindex\fRth +element of \fIlist\fR. Each \fIelement\fR argument will become +a separate element of the new list. If \fIindex\fR is less than +or equal to zero, then the new elements are inserted at the +beginning of the list. If \fIindex\fR +.VS +has the value \fBend\fR, +.VE +or if it is greater than or equal to the number of elements in the list, +then the new elements are appended to the list. + +.SH KEYWORDS +element, insert, list diff --git a/contrib/tcl/doc/list.n b/contrib/tcl/doc/list.n new file mode 100644 index 0000000..f89b203 --- /dev/null +++ b/contrib/tcl/doc/list.n @@ -0,0 +1,49 @@ +'\" +'\" Copyright (c) 1993 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: @(#) list.n 1.8 96/03/25 20:19:13 +'\" +.so man.macros +.TH list n "" Tcl "Tcl Built-In Commands" +.BS +'\" Note: do not modify the .SH NAME line immediately below! +.SH NAME +list \- Create a list +.SH SYNOPSIS +.VS +\fBlist \fR?\fIarg arg ...\fR? +.VE +.BE + +.SH DESCRIPTION +.PP +This command returns a list comprised of all the \fIarg\fRs, +.VS +or an empty string if no \fIarg\fRs are specified. +.VE +Braces and backslashes get added as necessary, so that the \fBindex\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 +its arguments. \fBList\fR produces slightly different results than +\fBconcat\fR: \fBconcat\fR removes one level of grouping before forming +the list, while \fBlist\fR works directly from the original arguments. +For example, the command +.CS +\fBlist a b {c d e} {f {g h}}\fR +.CE +will return +.CS +\fBa b {c d e} {f {g h}}\fR +.CE +while \fBconcat\fR with the same arguments will return +.CS +\fBa b c d e f {g h}\fR +.CE + +.SH KEYWORDS +element, list diff --git a/contrib/tcl/doc/llength.n b/contrib/tcl/doc/llength.n new file mode 100644 index 0000000..874a965 --- /dev/null +++ b/contrib/tcl/doc/llength.n @@ -0,0 +1,26 @@ +'\" +'\" Copyright (c) 1993 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: @(#) llength.n 1.5 96/03/25 20:19:25 +'\" +.so man.macros +.TH llength n "" Tcl "Tcl Built-In Commands" +.BS +'\" Note: do not modify the .SH NAME line immediately below! +.SH NAME +llength \- Count the number of elements in a list +.SH SYNOPSIS +\fBllength \fIlist\fR +.BE + +.SH DESCRIPTION +.PP +Treats \fIlist\fR as a list and returns a decimal string giving +the number of elements in it. + +.SH KEYWORDS +element, list, length diff --git a/contrib/tcl/doc/load.n b/contrib/tcl/doc/load.n new file mode 100644 index 0000000..73a3f16 --- /dev/null +++ b/contrib/tcl/doc/load.n @@ -0,0 +1,105 @@ +'\" +'\" Copyright (c) 1995-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: @(#) load.n 1.5 96/03/25 20:19:39 +'\" +.so man.macros +.TH load n 7.5 Tcl "Tcl Built-In Commands" +.BS +'\" Note: do not modify the .SH NAME line immediately below! +.SH NAME +load \- Load machine code and initialize new commands. +.SH SYNOPSIS +\fBload \fIfileName\fR +.br +\fBload \fIfileName packageName\fR +.br +\fBload \fIfileName packageName interp\fR +.BE + +.SH DESCRIPTION +.PP +This command loads binary code from a file into the +application's address space and calls an initialization procedure +in the package to incorporate it into an interpreter. \fIfileName\fR +is the name of the file containing the code; its exact form varies +from system to system but on most systems it is a shared library, +such as a \fB.so\fR file under Solaris or a DLL under Windows. +\fIpackageName\fR is the name of the package, and is used to +compute the name of an initialization procedure. +\fIinterp\fR is the path name of the interpreter into which to load +the package (see the \fBinterp\fR manual entry for details); +if \fIinterp\fR is omitted, it defaults to the +interpreter in which the \fBload\fR command was invoked. +.PP +Once the file has been loaded into the application's address space, +one of two initialization procedures will be invoked in the new code. +Typically the initialization procedure will add new commands to a +Tcl interpreter. +The name of the initialization procedure is determined by +\fIpackageName\fR and whether or not the target interpreter +is a safe one. For normal interpreters the name of the initialization +procedure will have the form \fIpkg\fB_Init\fR, where \fIpkg\fR +is the same as \fIpackageName\fR except that the first letter is +converted to upper case and all other letters +are converted to lower case. For example, if \fIpackageName\fR is +\fBfoo\fR or \fBFOo\fR, the initialization procedure's name will +be \fBFoo_Init\fR. +.PP +If the target interpreter is a safe interpreter, then the name +of the initialization procedure will be \fIpkg\fB_SafeInit\fR +instead of \fIpkg\fB_Init\fR. +.PP +The initialization procedure must match the following prototype: +.CS +typedef int Tcl_PackageInitProc(Tcl_Interp *\fIinterp\fR); +.CE +The \fIinterp\fR argument identifies the interpreter in which the +package is to be loaded. The initialization procedure must return +\fBTCL_OK\fR or \fBTCL_ERROR\fR to indicate whether or not it completed +successfully; in the event of an error it should set \fIinterp->result\fR +to point to an error message. The result of the \fBload\fR command +will be the result returned by the initialization procedure. +.PP +The actual loading of a file will only be done once for each \fIfileName\fR +in an application. If a given \fIfileName\fR is loaded into multiple +interpreters, then the first \fBload\fR will load the code and +call the initialization procedure; subsequent \fBload\fRs will +call the initialization procedure without loading the code again. +It is not possible to unload or reload a package. +.PP +The \fBload\fR command also supports packages that are statically +linked with the application, if those packages have been registered +by calling the \fBTcl_StaticPackage\fR procedure. +If \fIfileName\fR is an empty string, then \fIpackageName\fR must +be specified and it must give the name of a statically loaded +package. +The appropriate initialization procedure for that package will then +be invoked to incorporate the package into the target interpreter. +.PP +If \fIpackageName\fR is omitted or specified as an empty string, +Tcl tries to guess the name of the package. +This may be done differently on different platforms. +The default guess, which is used on most UNIX platforms, is to +take the last element of \fIfileName\fR, strip off the first +three characters if they are \fBlib\fR, and use any following +alphabetic characters as the module name. +For example, the command \fBload libxyz4.2.so\fR uses the module +name \fBxyz\fR and the command \fBload bin/last.so {}\fR uses the +module name \fBlast\fR. + +.SH BUGS +.PP +If the same file is \fBload\fRed by different \fIfileName\fRs, it will +be loaded into the process's address space multiple times. The +behavior of this varies from system to system (some systems may +detect the redundant loads, others may not). + +.SH "SEE ALSO" +\fBinfo sharedlibextension\fR, Tcl_StaticPackage + +.SH KEYWORDS +binary code, loading, shared library diff --git a/contrib/tcl/doc/lrange.n b/contrib/tcl/doc/lrange.n new file mode 100644 index 0000000..1dbc012 --- /dev/null +++ b/contrib/tcl/doc/lrange.n @@ -0,0 +1,41 @@ +'\" +'\" Copyright (c) 1993 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: @(#) lrange.n 1.8 96/03/25 20:19:51 +'\" +.so man.macros +.TH lrange n 7.4 Tcl "Tcl Built-In Commands" +.BS +'\" Note: do not modify the .SH NAME line immediately below! +.SH NAME +lrange \- Return one or more adjacent elements from a list +.SH SYNOPSIS +\fBlrange \fIlist first last\fR +.BE + +.SH DESCRIPTION +.PP +\fIList\fR must be a valid Tcl list. This command will +return a new list consisting of elements +\fIfirst\fR through \fIlast\fR, inclusive. +.VS +\fIFirst\fR or \fIlast\fR +.VE +may be \fBend\fR (or any abbreviation of it) to refer to the last +element of the list. +If \fIfirst\fR is less than zero, it is treated as if it were zero. +If \fIlast\fR is greater than or equal to the number of elements +in the list, then it is treated as if it were \fBend\fR. +If \fIfirst\fR is greater than \fIlast\fR then an empty string +is returned. +Note: ``\fBlrange \fIlist first first\fR'' does not always produce the +same result as ``\fBlindex \fIlist first\fR'' (although it often does +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 KEYWORDS +element, list, range, sublist diff --git a/contrib/tcl/doc/lreplace.n b/contrib/tcl/doc/lreplace.n new file mode 100644 index 0000000..6ee6664 --- /dev/null +++ b/contrib/tcl/doc/lreplace.n @@ -0,0 +1,45 @@ +'\" +'\" Copyright (c) 1993 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: @(#) lreplace.n 1.8 96/03/25 20:20:05 +'\" +.so man.macros +.TH lreplace n 7.4 Tcl "Tcl Built-In Commands" +.BS +'\" Note: do not modify the .SH NAME line immediately below! +.SH NAME +lreplace \- Replace elements in a list with new elements +.SH SYNOPSIS +\fBlreplace \fIlist first last \fR?\fIelement element ...\fR? +.BE + +.SH DESCRIPTION +.PP +\fBLreplace\fR returns a new list formed by replacing one or more elements of +\fIlist\fR with the \fIelement\fR arguments. +\fIFirst\fR gives the index in \fIlist\fR of the first element +to be replaced (0 refers to the first element). +If \fIfirst\fR is less than zero then it refers to the first +element of \fIlist\fR; the element indicated by \fIfirst\fR +must exist in the list. +\fILast\fR gives the index in \fIlist\fR of the last element +to be replaced. +.VS +If \fIlast\fR is less than \fIfirst\fR then no elements are deleted; +the new elements are simply inserted before \fIfirst\fR. +\fIFirst\fR or \fIlast\fR may be \fBend\fR +.VE +(or any abbreviation of it) to refer to the last element of the list. +The \fIelement\fR arguments specify zero or more new arguments to +be added to the list in place of those that were deleted. +Each \fIelement\fR argument will become a separate element of +the list. +If no \fIelement\fR arguments are specified, then the elements +between \fIfirst\fR and \fIlast\fR are simply deleted. + +.SH KEYWORDS +element, list, replace diff --git a/contrib/tcl/doc/lsearch.n b/contrib/tcl/doc/lsearch.n new file mode 100644 index 0000000..a411c96 --- /dev/null +++ b/contrib/tcl/doc/lsearch.n @@ -0,0 +1,47 @@ +'\" +'\" Copyright (c) 1993 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: @(#) lsearch.n 1.6 96/03/25 20:20:16 +'\" +.so man.macros +.TH lsearch n 7.0 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 +.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. +.VS +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: +.TP +\fB\-exact\fR +The list element must contain exactly the same string as \fIpattern\fR. +.TP +\fB\-glob\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\-regexp\fR +\fIPattern\fR is treated as a regular expression and matched against +each list element using the same rules as the \fBregexp\fR command. +.PP +If \fImode\fR is omitted then it defaults to \fB\-glob\fR. +.VE + +.SH KEYWORDS +list, match, pattern, regular expression, search, string diff --git a/contrib/tcl/doc/lsort.n b/contrib/tcl/doc/lsort.n new file mode 100644 index 0000000..e6cf40f --- /dev/null +++ b/contrib/tcl/doc/lsort.n @@ -0,0 +1,59 @@ +'\" +'\" Copyright (c) 1993 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: @(#) lsort.n 1.6 96/03/25 20:20:27 +'\" +.so man.macros +.TH lsort n 7.0 Tcl "Tcl Built-In Commands" +.BS +'\" Note: do not modify the .SH NAME line immediately below! +.SH NAME +lsort \- Sort the elements of a list +.SH SYNOPSIS +\fBlsort \fR?\fIswitches\fR? \fIlist\fR +.BE + +.SH DESCRIPTION +.PP +This command sorts the elements of \fIlist\fR, returning a new +list in sorted order. By default ASCII sorting is used with +the result returned in increasing order. +.VS +However, any of the +following switches may be specified before \fIlist\fR to +control the sorting process (unique abbreviations are accepted): +.TP 20 +\fB\-ascii\fR +Use string comparison with ASCII collation order. This is +the default. +.TP 20 +\fB\-integer\fR +Convert list elements to integers and use integer comparison. +.TP 20 +\fB\-real\fR +Convert list elements to floating-point values and use floating +comparison. +.TP 20 +\fB\-command\0\fIcommand\fR +Use \fIcommand\fR as a comparison command. +To compare two elements, evaluate a Tcl script consisting of +\fIcommand\fR with the two elements appended as additional +arguments. The script should return an integer less than, +equal to, or greater than zero if the first element is to +be considered less than, equal to, or greater than the second, +respectively. +.TP 20 +\fB\-increasing\fR +Sort the list in increasing order (``smallest'' items first). +This is the default. +.TP 20 +\fB\-decreasing\fR +Sort the list in decreasing order (``largest'' items first). +.VE + +.SH KEYWORDS +element, list, order, sort diff --git a/contrib/tcl/doc/man.macros b/contrib/tcl/doc/man.macros new file mode 100644 index 0000000..67e6012 --- /dev/null +++ b/contrib/tcl/doc/man.macros @@ -0,0 +1,234 @@ +'\" The definitions below are for supplemental macros used in Tcl/Tk +'\" manual entries. +'\" +'\" .AP type name in/out ?indent? +'\" Start paragraph describing an argument to a library procedure. +'\" type is type of argument (int, etc.), in/out is either "in", "out", +'\" or "in/out" to describe whether procedure reads or modifies arg, +'\" and indent is equivalent to second arg of .IP (shouldn't ever be +'\" needed; use .AS below instead) +'\" +'\" .AS ?type? ?name? +'\" Give maximum sizes of arguments for setting tab stops. Type and +'\" name are examples of largest possible arguments that will be passed +'\" to .AP later. If args are omitted, default tab stops are used. +'\" +'\" .BS +'\" Start box enclosure. From here until next .BE, everything will be +'\" enclosed in one large box. +'\" +'\" .BE +'\" End of box enclosure. +'\" +'\" .CS +'\" Begin code excerpt. +'\" +'\" .CE +'\" End code excerpt. +'\" +'\" .VS ?br? +'\" Begin vertical sidebar, for use in marking newly-changed parts +'\" of man pages. If an argument is present, then a line break is +'\" forced before starting the sidebar. +'\" +'\" .VE +'\" End of vertical sidebar. +'\" +'\" .DS +'\" Begin an indented unfilled display. +'\" +'\" .DE +'\" End of indented unfilled display. +'\" +'\" .SO +'\" Start of list of standard options for a Tk widget. The +'\" options follow on successive lines, in four columns separated +'\" by tabs. +'\" +'\" .SE +'\" End of list of standard options for a Tk widget. +'\" +'\" .OP cmdName dbName dbClass +'\" Start of description of a specific option. cmdName gives the +'\" option's name as specified in the class command, dbName gives +'\" the option's name in the option database, and dbClass gives +'\" the option's class in the option database. +'\" +'\" .UL arg1 arg2 +'\" Print arg1 underlined, then print arg2 normally. +'\" +'\" SCCS: @(#) man.macros 1.8 96/02/15 20:02:24 +'\" +'\" # Set up traps and other miscellaneous stuff for Tcl/Tk man pages. +.if t .wh -1.3i ^B +.nr ^l \n(.l +.ad b +'\" # Start an argument description +.de AP +.ie !"\\$4"" .TP \\$4 +.el \{\ +. ie !"\\$2"" .TP \\n()Cu +. el .TP 15 +.\} +.ie !"\\$3"" \{\ +.ta \\n()Au \\n()Bu +\&\\$1 \\fI\\$2\\fP (\\$3) +.\".b +.\} +.el \{\ +.br +.ie !"\\$2"" \{\ +\&\\$1 \\fI\\$2\\fP +.\} +.el \{\ +\&\\fI\\$1\\fP +.\} +.\} +.. +'\" # define tabbing values for .AP +.de AS +.nr )A 10n +.if !"\\$1"" .nr )A \\w'\\$1'u+3n +.nr )B \\n()Au+15n +.\" +.if !"\\$2"" .nr )B \\w'\\$2'u+\\n()Au+3n +.nr )C \\n()Bu+\\w'(in/out)'u+2n +.. +.AS Tcl_Interp Tcl_CreateInterp in/out +'\" # BS - start boxed text +'\" # ^y = starting y location +'\" # ^b = 1 +.de BS +.br +.mk ^y +.nr ^b 1u +.if n .nf +.if n .ti 0 +.if n \l'\\n(.lu\(ul' +.if n .fi +.. +'\" # BE - end boxed text (draw box now) +.de BE +.nf +.ti 0 +.mk ^t +.ie n \l'\\n(^lu\(ul' +.el \{\ +.\" Draw four-sided box normally, but don't draw top of +.\" box if the box started on an earlier page. +.ie !\\n(^b-1 \{\ +\h'-1.5n'\L'|\\n(^yu-1v'\l'\\n(^lu+3n\(ul'\L'\\n(^tu+1v-\\n(^yu'\l'|0u-1.5n\(ul' +.\} +.el \}\ +\h'-1.5n'\L'|\\n(^yu-1v'\h'\\n(^lu+3n'\L'\\n(^tu+1v-\\n(^yu'\l'|0u-1.5n\(ul' +.\} +.\} +.fi +.br +.nr ^b 0 +.. +'\" # VS - start vertical sidebar +'\" # ^Y = starting y location +'\" # ^v = 1 (for troff; for nroff this doesn't matter) +.de VS +.if !"\\$1"" .br +.mk ^Y +.ie n 'mc \s12\(br\s0 +.el .nr ^v 1u +.. +'\" # VE - end of vertical sidebar +.de VE +.ie n 'mc +.el \{\ +.ev 2 +.nf +.ti 0 +.mk ^t +\h'|\\n(^lu+3n'\L'|\\n(^Yu-1v\(bv'\v'\\n(^tu+1v-\\n(^Yu'\h'-|\\n(^lu+3n' +.sp -1 +.fi +.ev +.\} +.nr ^v 0 +.. +'\" # Special macro to handle page bottom: finish off current +'\" # box/sidebar if in box/sidebar mode, then invoked standard +'\" # page bottom macro. +.de ^B +.ev 2 +'ti 0 +'nf +.mk ^t +.if \\n(^b \{\ +.\" Draw three-sided box if this is the box's first page, +.\" draw two sides but no top otherwise. +.ie !\\n(^b-1 \h'-1.5n'\L'|\\n(^yu-1v'\l'\\n(^lu+3n\(ul'\L'\\n(^tu+1v-\\n(^yu'\h'|0u'\c +.el \h'-1.5n'\L'|\\n(^yu-1v'\h'\\n(^lu+3n'\L'\\n(^tu+1v-\\n(^yu'\h'|0u'\c +.\} +.if \\n(^v \{\ +.nr ^x \\n(^tu+1v-\\n(^Yu +\kx\h'-\\nxu'\h'|\\n(^lu+3n'\ky\L'-\\n(^xu'\v'\\n(^xu'\h'|0u'\c +.\} +.bp +'fi +.ev +.if \\n(^b \{\ +.mk ^y +.nr ^b 2 +.\} +.if \\n(^v \{\ +.mk ^Y +.\} +.. +'\" # DS - begin display +.de DS +.RS +.nf +.sp +.. +'\" # DE - end display +.de DE +.fi +.RE +.sp +.. +'\" # SO - start of list of standard options +.de SO +.SH "STANDARD OPTIONS" +.LP +.nf +.ta 4c 8c 12c +.ft B +.. +'\" # SE - end of list of standard options +.de SE +.fi +.ft R +.LP +See the \\fBoptions\\fR manual entry for details on the standard options. +.. +'\" # OP - start of full description for a single option +.de OP +.LP +.nf +.ta 4c +Command-Line Name: \\fB\\$1\\fR +Database Name: \\fB\\$2\\fR +Database Class: \\fB\\$3\\fR +.fi +.IP +.. +'\" # CS - begin code excerpt +.de CS +.RS +.nf +.ta .25i .5i .75i 1i +.. +'\" # CE - end code excerpt +.de CE +.fi +.RE +.. +.de UL +\\$1\l'|0\(ul'\\$2 +.. diff --git a/contrib/tcl/doc/open.n b/contrib/tcl/doc/open.n new file mode 100644 index 0000000..8e6f1d3 --- /dev/null +++ b/contrib/tcl/doc/open.n @@ -0,0 +1,131 @@ +'\" +'\" Copyright (c) 1993 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: @(#) open.n 1.11 96/02/15 20:02:25 +'\" +.so man.macros +.TH open n 7.5 Tcl "Tcl Built-In Commands" +.BS +'\" Note: do not modify the .SH NAME line immediately below! +.SH NAME +open \- Open a file-based or command pipeline channel +.SH SYNOPSIS +.sp +\fBopen \fIfileName\fR +.br +\fBopen \fIfileName access\fR +.br +\fBopen \fIfileName access permissions\fR +.BE + +.SH DESCRIPTION +.PP +This command opens a file or command pipeline and returns a 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 +the command opens a file: +\fIfileName\fR gives the name of the file to open, and it must conform to the +conventions described in the \fBfilename\fR manual entry. +.PP +The \fIaccess\fR argument, if present, indicates the way in which the file +(or command pipeline) is to be accessed. +In the first form \fIaccess\fR may have any of the following values: +.TP 15 +\fBr\fR +Open the file for reading only; the file must already exist. This is the +default value if \fIaccess\fR is not specified. +.TP 15 +\fBr+\fR +Open the file for both reading and writing; the file must +already exist. +.TP 15 +\fBw\fR +Open the file for writing only. Truncate it if it exists. If it doesn't +exist, create a new file. +.TP 15 +\fBw+\fR +Open the file for reading and writing. Truncate it if it exists. +If it doesn't exist, create a new file. +.TP 15 +\fBa\fR +Open the file for writing only. The file must already exist, and the file +is positioned so that new data is appended to the file. +.TP 15 +\fBa+\fR +Open the file for reading and writing. If the file doesn't exist, +create a new empty file. +Set the initial access position to the end of the file. +.PP +In the second form, \fIaccess\fR consists of a list of any of the +following flags, all of which have the standard POSIX meanings. +One of the flags must be either \fBRDONLY\fR, \fBWRONLY\fR or \fBRDWR\fR. +.TP 15 +\fBRDONLY\fR +Open the file for reading only. +.TP 15 +\fBWRONLY\fR +Open the file for writing only. +.TP 15 +\fBRDWR\fR +Open the file for both reading and writing. +.TP 15 +\fBAPPEND\fR +Set the file pointer to the end of the file prior to each write. +.TP 15 +\fBCREAT\fR +Create the file if it doesn't already exist (without this flag it +is an error for the file not to exist). +.TP 15 +\fBEXCL\fR +If \fBCREAT\fR is also specified, an error is returned if the +file already exists. +.TP 15 +\fBNOCTTY\fR +If the file is a terminal device, this flag prevents the file from +becoming the controlling terminal of the process. +.TP 15 +\fBNONBLOCK\fR +.VS +Prevents the process from blocking while opening the file, and +possibly in subsequent I/O operations. The exact behavior of +this flag is system- and device-dependent; its use is discouraged +(it is better to use the \fBfconfigure\fR command to put a file +in nonblocking mode). +For details refer to your system documentation on the \fBopen\fR system +call's \fBO_NONBLOCK\fR flag. +.VE +.TP 15 +\fBTRUNC\fR +If the file exists it is truncated to zero length. +.PP +If a new file is created as part of opening it, \fIpermissions\fR +(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. +.SH "COMMAND PIPELINES" +.PP +If the first character of \fIfileName\fR is ``|'' then the +remaining characters of \fIfileName\fR are treated as a list of arguments +that describe a command pipeline to invoke, in the same style as the +arguments for \fBexec\fR. +In this case, the channel identifier returned by \fBopen\fR may be used +to write to the command's input pipe or read from its output pipe, +depending on the value of \fIaccess\fR. +If write-only access is used (e.g. \fIaccess\fR is \fBw\fR), then +standard output for the pipeline is directed to the current standard +output unless overridden by the command. +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. + +.SH "SEE ALSO" +close(n), filename(n), gets(n), read(n), puts(n) + +.SH KEYWORDS +access mode, append, create, file, non-blocking, open, permissions, +pipeline, process diff --git a/contrib/tcl/doc/package.n b/contrib/tcl/doc/package.n new file mode 100644 index 0000000..b485caa --- /dev/null +++ b/contrib/tcl/doc/package.n @@ -0,0 +1,188 @@ +'\" +'\" Copyright (c) 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: @(#) package.n 1.5 96/03/18 14:17:31 +'\" +.so man.macros +.TH package n 7.5 Tcl "Tcl Built-In Commands" +.BS +'\" Note: do not modify the .SH NAME line immediately below! +.SH NAME +package \- Facilities for package loading and version control +.SH SYNOPSIS +.nf +\fBpackage forget \fIpackage\fR +\fBpackage ifneeded \fIpackage version\fR ?\fIscript\fR? +\fBpackage names\fR +\fBpackage provide \fIpackage \fR?\fIversion\fR? +\fBpackage require \fR?\fB\-exact\fR? \fIpackage \fR?\fIversion\fR? +\fBpackage unknown \fR?\fIcommand\fR? +\fBpackage vcompare \fIversion1 version2\fR +\fBpackage versions \fIpackage\fR +\fBpackage vsatisfies \fIversion1 version2\fR +.fi +.BE + +.SH DESCRIPTION +.PP +This command keeps a simple database of the packages available for +use by the current interpreter and how to load them into the +interpreter. +It supports multiple versions of each package and arranges +for the correct version of a package to be loaded based on what +is needed by the application. +This command also detects and reports version clashes. +Typically, only the \fBpackage require\fR and \fBpackage provide\fR +commands are invoked in normal Tcl scripts; the other commands are used +primarily by system scripts that maintain the package database. +.PP +The behavior of the \fBpackage\fR command is determined by its first argument. +The following forms are permitted: +.TP +\fBpackage forget \fIpackage\fR +Removes all information about \fIpackage\fR from this interpreter, +including information provided by both \fBpackage ifneeded\fR and +\fBpackage provide\fR. +.TP +\fBpackage ifneeded \fIpackage version\fR ?\fIscript\fR? +This command typically appears only in system configuration +scripts to set up the package database. +It indicates that a particular version of +a particular package is available if needed, and that the package +can be added to the interpreter by executing \fIscript\fR. +The script is saved in a database for use by subsequent +\fBpackage require\fR commands; typically, \fIscript\fR +sets up auto-loading for the commands in the package (or calls +\fBload\fR and/or \fBsource\fR directly), then invokes +\fBpackage provide\fR to indicate that the package is present. +There may be information in the database for several different +versions of a single package. +If the database already contains information for \fIpackage\fR +and \fIversion\fR, the new \fIscript\fR replaces the existing +one. +If the \fIscript\fR argument is omitted, the current script for +version \fIversion\fR of package \fIpackage\fR is returned, +or an empty string if no \fBpackage ifneeded\fR command has +been invoked for this \fIpackage\fR and \fIversion\fR. +.TP +\fBpackage names\fR +Returns a list of the names of all packages in the +interpreter for which a version has been provided (via +\fBpackage provide\fR) or for which a \fBpackage ifneeded\fR +script is available. +The order of elements in the list is arbitrary. +.TP +\fBpackage provide \fIpackage \fR?\fIversion\fR? +This command is invoked to indicate that version \fIversion\fR +of package \fIpackage\fR is now present in the interpreter. +It is typically invoked once as part of an \fBifneeded\fR script, +and again by the package itself when it is finally loaded. +An error occurs if a different version of \fIpackage\fR has been +provided by a previous \fBpackage provide\fR command. +If the \fIversion\fR argument is omitted, then the command +returns the version number that is currently provided, or an +empty string if no \fBpackage provide\fR command has been +invoked for \fIpackage\fR in this interpreter. +.TP +\fBpackage require \fR?\fB\-exact\fR? \fIpackage \fR?\fIversion\fR? +This command is typically invoked by Tcl code that wishes to use +a particular version of a particular package. The arguments +indicate which package is wanted, and the command ensures that +a suitable version of the package is loaded into the interpreter. +If the command succeeds, it returns the version number that is +loaded; otherwise it generates an error. +If both the \fB\-exact\fR +switch and the \fIversion\fR argument are specified then only the +given version is acceptable. If \fB\-exact\fR is omitted but +\fIversion\fR is specified, then versions later than \fIversion\fR +are also acceptable as long as they have the same major version +number as \fIversion\fR. +If both \fB\-exact\fR and \fIversion\fR are omitted then any +version whatsoever is acceptable. +If a version of \fIpackage\fR has already been provided (by invoking +the \fBpackage provide\fR command), then its version number must +satisfy the criteria given by \fB\-exact\fR and \fIversion\fR and +the command returns immediately. +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; +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 +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 +package, then the command returns an error. +.TP +\fBpackage unknown \fR?\fIcommand\fR? +This command supplies a ``last resort'' command to invoke during +\fBpackage require\fR if no suitable version of a package can be found +in the \fBpackage ifneeded\fR database. +If the \fIcommand\fR argument is supplied, it contains the first part +of a command; when the command is invoked during a \fBpackage require\fR +command, Tcl appends two additional arguments giving the desired package +name and version. +For example, if \fIcommand\fR is \fBfoo bar\fR and later the command +\fBpackage require test 2.4\fR is invoked, then Tcl will execute +the command \fBfoo bar test 2.4\fR to load the package. +If no version number is supplied to the \fBpackage require\fR command, +then the version argument for the invoked command will be an empty string. +If the \fBpackage unknown\fR command is invoked without a \fIcommand\fR +argument, then the current \fBpackage unknown\fR script is returned, +or an empty string if there is none. +If \fIcommand\fR is specified as an empty string, then the current +\fBpackage unknown\fR script is removed, if there is one. +.TP +\fBpackage vcompare \fIversion1 version2\fR +Compares the two version numbers given by \fIversion1\fR and \fIversion2\fR. +Returns -1 if \fIversion1\fR is an earlier version than \fIversion2\fR, +0 if they are equal, and 1 if \fIversion1\fR is later than \fBversion2\fR. +.TP +\fBpackage versions \fIpackage\fR +Returns a list of all the version numbers of \fIpackage\fR +for which information has been provided by \fBpackage ifneeded\fR +commands. +.TP +\fBpackage vsatisfies \fIversion1 version2\fR +Returns 1 if scripts written for \fIversion2\fR will work unchanged +with \fIversion1\fR (i.e. \fIversion1\fR is equal to or greater +than \fIversion2\fR and they both have the same major version +number), 0 otherwise. + +.SH "VERSION NUMBERS" +.PP +Version numbers consist of one or more decimal numbers separated +by dots, such as 2 or 1.162 or 3.1.13.1. +The first number is called the major version number. +Larger numbers correspond to later versions of a package, with +leftmost numbers having greater significance. +For example, version 2.1 is later than 1.3 and version +3.4.6 is later than 3.3.5. +Missing fields are equivalent to zeroes: version 1.3 is the +same as version 1.3.0 and 1.3.0.0, so it is earlier than 1.3.1 or 1.3.0.2. +A later version number is assumed to be upwards compatible with +an earlier version number as long as both versions have the same +major version number. +For example, Tcl scripts written for version 2.3 of a package should +work unchanged under versions 2.3.2, 2.4, and 2.5.1. +Changes in the major version number signify incompatible changes: +if code is written to use version 2.1 of a package, it is not guaranteed +to work unmodified with either version 1.7.3 or version 3.1. + +.SH "PACKAGE INDICES" +.PP +The recommended way to use packages in Tcl is to invoke \fBpackage require\fR +and \fBpackage provide\fR commands in scripts, and use the procedure +\fBpkg_mkIndex\fR to create package index files. +Once you've done this, packages will be loaded automatically +in response to \fBpackage require\fR commands. +See the documentation for \fBpkg_mkIndex\fR for details. + +.SH KEYWORDS +package, version diff --git a/contrib/tcl/doc/pid.n b/contrib/tcl/doc/pid.n new file mode 100644 index 0000000..2db8b32 --- /dev/null +++ b/contrib/tcl/doc/pid.n @@ -0,0 +1,34 @@ +'\" +'\" Copyright (c) 1993 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: @(#) pid.n 1.5 96/03/25 20:20:57 +'\" +.so man.macros +.TH pid n 7.0 Tcl "Tcl Built-In Commands" +.BS +'\" Note: do not modify the .SH NAME line immediately below! +.SH NAME +pid \- Retrieve process id(s) +.SH SYNOPSIS +\fBpid \fR?\fIfileId\fR? +.BE + +.SH DESCRIPTION +.PP +If the \fIfileId\fR argument is given then it should normally +refer to a process pipeline created with the \fBopen\fR command. +In this case the \fBpid\fR command will return a list whose elements +are the process identifiers of all the processes in the pipeline, +in order. +The list will be empty if \fIfileId\fR refers to an open file +that isn't a process pipeline. +If no \fIfileId\fR argument is given then \fBpid\fR returns the process +identifier of the current process. +All process identifiers are returned as decimal strings. + +.SH KEYWORDS +file, pipeline, process identifier diff --git a/contrib/tcl/doc/pkgMkIndex.n b/contrib/tcl/doc/pkgMkIndex.n new file mode 100644 index 0000000..251c033 --- /dev/null +++ b/contrib/tcl/doc/pkgMkIndex.n @@ -0,0 +1,115 @@ +'\" +'\" Copyright (c) 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: @(#) pkgMkIndex.n 1.2 96/02/15 20:03:23 +'\" +.so man.macros +.TH pkg_mkIndex n 7.5 Tcl "Tcl Built-In Commands" +.BS +'\" Note: do not modify the .SH NAME line immediately below! +.SH NAME +pkg_mkIndex \- Build an index for automatic loading of packages +.SH SYNOPSIS +.nf +\fBpkg_mkIndex \fIdir \fIpattern \fR?\fIpattern pattern ...\fR? +.fi +.BE + +.SH DESCRIPTION +.PP +\fBPkg_mkIndex\fR is a utility procedure that is part of the standard +Tcl library. +It is used to create index files that allow packages to be loaded +automatically when \fBpackage require\fR commands are executed. +To use \fBpkg_mkIndex\fR, follow these steps: +.IP [1] +Create the package(s). +Each package may consist of one or more Tcl script files or binary files. +Binary files must be suitable for loading with the \fBload\fR command +with a single argument; for example, if the file is \fBtest.so\fR it must +be possible to load this file with the command \fBload test.so\fR. +Each script file must contain a \fBpackage provide\fR command to declare +the package and version number, and each binary file must contain +a call to \fBTcl_PkgProvide\fR. +.IP [2] +Create the index by invoking \fBpkg_mkIndex\fR. +The \fIdir\fR argument gives the name of a directory and each +\fIpattern\fR argument is a \fBglob\fR-style pattern that selects +script or binary files in \fIdir\fR. +\fBPkg_mkIndex\fR will create a file \fBpkgIndex.tcl\fR in \fIdir\fR +with package information about all the files given by the \fIpattern\fR +arguments. +It does this by loading each file and seeing what packages +and new commands appear (this is why it is essential to have +\fBpackage provide\fR commands or \fBTcl_PkgProvide\fR calls +in the files, as described above). +.IP [3] +Make sure that the directory is in the \fBauto_path\fR global variable. +\fBAuto_path\fR contains a list of directories that are searched +by both the auto-loader and the package loader. +If you want access to files described by a \fBpkgIndex.tcl\fR file +in a directory, that directory must be present in \fBauto_path\fR. +You can add the directory to \fBauto_path\fR explicitly in your +application, or you can add the directory to your \fBTCLLIBPATH\fR +environment variable: if this environment variable is present, +Tcl initializes \fBauto_path\fR from it during application startup. +.IP [4] +Once the above steps have been taken, all you need to do to use a +package is to invoke \fBpackage require\fR. +For example, if versions 2.1, 2.3, and 3.1 of package \fBTest\fR +have been indexed by \fBpkg_mkIndex\fR, the command +\fBpackage require Test\fR will make vesion 3.1 available +and the command \fBpackage require \-exact Test 2.1\fR will +make version 2.1 available. +There may be many versions of a package in the various index files +in \fBauto_path\fR, but only one will actually be loaded in a given +interpreter, based on the first call to \fBpackage require\fR. +Different versions of a package may be loaded in different +interpreters. + +.SH "PACKAGES AND THE AUTO-LOADER" +.PP +The package management facilities overlap somewhat with the auto-loader, +in that both arrange for files to be loaded on-demand. +However, package management is a higher-level mechanism that uses +the auto-loader for the last step in the loading process. +It is generally better to index a package with \fBpkg_mkIndex\fR +rather than \fBauto_mkindex\fR because the package mechanism provides +version control: several versions of a package can be made available +in the index files, with different applications using different +versions based on \fBpackage require\fR commands. +In contrast, \fBauto_mkindex\fR does not understand versions so +it can only handle a single version of each package. +It is probably not a good idea to index a given package with both +\fBpkg_mkIndex\fR and \fBauto_mkindex\fR. +If you use \fBpkg_mkIndex\fR to index a package, its commands cannot +be invoked until \fBpackage require\fR has been used to select a +version; in contrast, packages indexed with \fBauto_mkindex\fR +can be used immediately since there is no version control. + +.SH "HOW IT WORKS" +.PP +\fBPkg_mkIndex\fR depends on the \fBpackage unknown\fR command, +the \fBpackage ifneeded\fR command, and the auto-loader. +The first time a \fBpackage require\fR command is invoked, +the \fBpackage unknown\fR script is invoked. +This is set by Tcl initialization to a script that +evaluates all of the \fBpkgIndex.tcl\fR files in the +\fBauto_path\fR. +The \fBpkgIndex.tcl\fR files contain \fBpackage ifneeded\fR +commands for each version of each available package; these commands +invoke \fBpackage provide\fR commands to announce the +availability of the package, and they setup auto-loader +information to load the files of the package. +A given file of a given version of a given package isn't +actually loaded until the first time one of its commands +is invoked. +Thus, after invoking \fBpackage require\fR you won't see +the package's commands in the interpreter, but you will be able +to invoke the commands and they will be auto-loaded. + +.SH KEYWORDS +auto-load, index, package, version diff --git a/contrib/tcl/doc/proc.n b/contrib/tcl/doc/proc.n new file mode 100644 index 0000000..85ee2da --- /dev/null +++ b/contrib/tcl/doc/proc.n @@ -0,0 +1,67 @@ +'\" +'\" Copyright (c) 1993 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: @(#) proc.n 1.5 96/03/25 20:21:12 +'\" +.so man.macros +.TH proc n "" Tcl "Tcl Built-In Commands" +.BS +'\" Note: do not modify the .SH NAME line immediately below! +.SH NAME +proc \- Create a Tcl procedure +.SH SYNOPSIS +\fBproc \fIname args body\fR +.BE + +.SH DESCRIPTION +.PP +The \fBproc\fR command creates a new Tcl procedure named +\fIname\fR, replacing +any existing command or procedure there may have been by that name. +Whenever the new command is invoked, the contents of \fIbody\fR will +be executed by the Tcl interpreter. +\fIArgs\fR specifies the formal arguments to the +procedure. It consists of a list, possibly empty, each of whose +elements specifies +one argument. Each argument specifier is also a list with either +one or two fields. If there is only a single field in the specifier +then it is the name of the argument; if there are two fields, then +the first is the argument name and the second is its default value. +.PP +When \fIname\fR is invoked a local variable +will be created for each of the formal arguments to the procedure; its +value will be the value of corresponding argument in the invoking command +or the argument's default value. +Arguments with default values need not be +specified in a procedure invocation. However, there must be enough +actual arguments for all the +formal arguments that don't have defaults, and there must not be any extra +actual arguments. There is one special case to permit procedures with +variable numbers of arguments. If the last formal argument has the name +\fBargs\fR, then a call to the procedure may contain more actual arguments +than the procedure has formals. In this case, all of the actual arguments +starting at the one that would be assigned to \fBargs\fR are combined into +a list (as if the \fBlist\fR command had been used); this combined value +is assigned to the local variable \fBargs\fR. +.PP +When \fIbody\fR is being executed, variable names normally refer to +local variables, which are created automatically when referenced and +deleted when the procedure returns. One local variable is automatically +created for each of the procedure's arguments. +Global variables can only be accessed by invoking +the \fBglobal\fR command or the \fBupvar\fR command. +.PP +The \fBproc\fR command returns an empty string. When a procedure is +invoked, the procedure's return value is the value specified in a +\fBreturn\fR command. If the procedure doesn't execute an explicit +\fBreturn\fR, then its return value is the value of the last command +executed in the procedure's body. +If an error occurs while executing the procedure +body, then the procedure-as-a-whole will return that same error. + +.SH KEYWORDS +argument, procedure diff --git a/contrib/tcl/doc/puts.n b/contrib/tcl/doc/puts.n new file mode 100644 index 0000000..61599c1 --- /dev/null +++ b/contrib/tcl/doc/puts.n @@ -0,0 +1,73 @@ +'\" +'\" Copyright (c) 1993 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: @(#) puts.n 1.10 96/02/15 20:02:28 +'\" +.so man.macros +.TH puts n 7.5 Tcl "Tcl Built-In Commands" +.BS +'\" Note: do not modify the .SH NAME line immediately below! +.SH NAME +puts \- Write to a channel +.SH SYNOPSIS +\fBputs \fR?\fB\-nonewline\fR? ?\fIchannelId\fR? \fIstring\fR +.BE + +.SH DESCRIPTION +.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 +\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. +.PP +.VS +Newline characters in the output are translated by \fBputs\fR to +platform-specific end-of-line sequences according to the current +value of the \fB\-translation\fR option for the channel (for example, +on PCs newlines are normally replaced with carriage-return-linefeed +sequences; on Macintoshes newlines are normally replaced with +carriage-returns). +See the \fBfconfigure\fR manual entry for a discussion of end-of-line +translations. +.VE +.PP +Tcl buffers output internally, so characters written with \fBputs\fR +may not appear immediately on the output file or device; Tcl will +normally delay output until the buffer is full or the channel is +closed. +You can force output to appear immediately with the \fBflush\fR +command. +.PP +.VS +When the output buffer fills up, the \fBputs\fR command will normally +block until all the buffered data has been accepted for output by the +operating system. +If \fIchannelId\fR is in nonblocking mode then the \fBputs\fR command +will not block even if the operating system cannot accept the data. +Instead, Tcl continues to buffer the data and writes it in the +background as fast as the underlying file or device can accept it. +The application must use the Tcl event loop for nonblocking output +to work; otherwise Tcl never finds out that the file or device is +ready for more output data. +It is possible for an arbitrarily large amount of data to be +buffered for a channel in nonblocking mode, which could consume a +large amount of memory. +To avoid wasting memory, nonblocking I/O should normally +be used in an event-driven fashion with the \fBfileevent\fR command +(don't invoke \fBputs\fR unless you have recently been notified +via a file event that the channel is ready for more output data). +.VE + +.SH "SEE ALSO" +fileevent(n) + +.SH KEYWORDS +channel, newline, output, write diff --git a/contrib/tcl/doc/pwd.n b/contrib/tcl/doc/pwd.n new file mode 100644 index 0000000..adc8811 --- /dev/null +++ b/contrib/tcl/doc/pwd.n @@ -0,0 +1,25 @@ +'\" +'\" Copyright (c) 1993 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: @(#) pwd.n 1.5 96/03/25 20:21:30 +'\" +.so man.macros +.TH pwd n "" Tcl "Tcl Built-In Commands" +.BS +'\" Note: do not modify the .SH NAME line immediately below! +.SH NAME +pwd \- Return the current working directory +.SH SYNOPSIS +\fBpwd\fR +.BE + +.SH DESCRIPTION +.PP +Returns the path name of the current working directory. + +.SH KEYWORDS +working directory diff --git a/contrib/tcl/doc/read.n b/contrib/tcl/doc/read.n new file mode 100644 index 0000000..c56d8db --- /dev/null +++ b/contrib/tcl/doc/read.n @@ -0,0 +1,52 @@ +'\" +'\" Copyright (c) 1993 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: @(#) read.n 1.14 96/02/15 20:02:29 +'\" +.so man.macros +.TH read n 7.5 Tcl "Tcl Built-In Commands" +.BS +'\" Note: do not modify the .SH NAME line immediately below! +.SH NAME +read \- Read from a channel +.SH SYNOPSIS +\fBread \fR?\fB\-nonewline\fR? \fIchannelId\fR +.sp +\fBread \fIchannelId numBytes\fR +.BE + +.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. +In the second form, the extra argument specifies how many bytes to +read. Exactly that many bytes will be read and returned, unless +there are fewer than \fInumBytes\fR left in the file; in this case +all the remaining bytes are returned. +.PP +.VS +If \fIchannelId\fR is in nonblocking mode, the command may not read +as many bytes as requested: once all available input has been read, +the command will return the data that is available rather than blocking +for more input. +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 +for the channel. +See the manual entry for \fBfconfigure\fR for details on the +\fB\-translation\fR option. +.VE + +.SH "SEE ALSO" +eof(n), fblocked(n), fconfigure(n) + +.SH KEYWORDS +blocking, channel, end of line, end of file, nonblocking, read, translation diff --git a/contrib/tcl/doc/regexp.n b/contrib/tcl/doc/regexp.n new file mode 100644 index 0000000..f4e3fab --- /dev/null +++ b/contrib/tcl/doc/regexp.n @@ -0,0 +1,147 @@ +'\" +'\" Copyright (c) 1993 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: @(#) regexp.n 1.11 96/03/25 20:21:48 +'\" +.so man.macros +.TH regexp n "" Tcl "Tcl Built-In Commands" +.BS +'\" Note: do not modify the .SH NAME line immediately below! +.SH NAME +regexp \- Match a regular expression against a string +.SH SYNOPSIS +\fBregexp \fR?\fIswitches\fR? \fIexp string \fR?\fImatchVar\fR? ?\fIsubMatchVar subMatchVar ...\fR? +.BE + +.SH DESCRIPTION +.PP +Determines whether the regular expression \fIexp\fR matches part or +all of \fIstring\fR and returns 1 if it does, 0 if it doesn't. +.LP +If additional arguments are specified after \fIstring\fR then they +are treated as the names of variables in which to return +information about which part(s) of \fIstring\fR matched \fIexp\fR. +\fIMatchVar\fR will be set to the range of \fIstring\fR that +matched all of \fIexp\fR. The first \fIsubMatchVar\fR will contain +the characters in \fIstring\fR that matched the leftmost parenthesized +subexpression within \fIexp\fR, the next \fIsubMatchVar\fR will +contain the characters that matched the next parenthesized +subexpression to the right in \fIexp\fR, and so on. +.LP +If the initial arguments to \fBregexp\fR start with \fB\-\fR then +.VS +they are treated as switches. The following switches are +currently supported: +.TP 10 +\fB\-nocase\fR +Causes upper-case characters in \fIstring\fR to be treated as +lower case during the matching process. +.TP 10 +\fB\-indices\fR +Changes what is stored in the \fIsubMatchVar\fRs. +Instead of storing the matching characters from \fBstring\fR, +each variable +will contain a list of two decimal strings giving the indices +in \fIstring\fR of the first and last characters in the matching +range of characters. +.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. +.VE +.LP +If there are more \fIsubMatchVar\fR's than parenthesized +subexpressions within \fIexp\fR, or if a particular subexpression +in \fIexp\fR doesn't match the string (e.g. because it was in a +portion of the expression that wasn't matched), then the corresponding +\fIsubMatchVar\fR will be set to ``\fB\-1 \-1\fR'' if \fB\-indices\fR +has been specified or to an empty string otherwise. + +.SH "REGULAR EXPRESSIONS" +.PP +Regular expressions are implemented using Henry Spencer's package +(thanks, Henry!), +and much of the description of regular expressions below is copied verbatim +from his manual entry. +.PP +A regular expression is zero or more \fIbranches\fR, separated by ``|''. +It matches anything that matches one of the branches. +.PP +A branch is zero or more \fIpieces\fR, concatenated. +It matches a match for the first, followed by a match for the second, etc. +.PP +A piece is an \fIatom\fR possibly followed by ``*'', ``+'', or ``?''. +An atom followed by ``*'' matches a sequence of 0 or more matches of the atom. +An atom followed by ``+'' matches a sequence of 1 or more matches of the atom. +An atom followed by ``?'' matches a match of the atom, or the null string. +.PP +An atom is a regular expression in parentheses (matching a match for the +regular expression), a \fIrange\fR (see below), ``.'' +(matching any single character), ``^'' (matching the null string at the +beginning of the input string), ``$'' (matching the null string at the +end of the input string), a ``\e'' followed by a single character (matching +that character), or a single character with no other significance +(matching that character). +.PP +A \fIrange\fR is a sequence of characters enclosed in ``[]''. +It normally matches any single character from the sequence. +If the sequence begins with ``^'', +it matches any single character \fInot\fR from the rest of the sequence. +If two characters in the sequence are separated by ``\-'', this is shorthand +for the full list of ASCII characters between them +(e.g. ``[0-9]'' matches any decimal digit). +To include a literal ``]'' in the sequence, make it the first character +(following a possible ``^''). +To include a literal ``\-'', make it the first or last character. + +.SH "CHOOSING AMONG ALTERNATIVE MATCHES" +.PP +In general there may be more than one way to match a regular expression +to an input string. For example, consider the command +.CS +\fBregexp (a*)b* aabaaabb x y\fR +.CE +Considering only the rules given so far, \fBx\fR and \fBy\fR could +end up with the values \fBaabb\fR and \fBaa\fR, \fBaaab\fR and \fBaaa\fR, +\fBab\fR and \fBa\fR, or any of several other combinations. +To resolve this potential ambiguity \fBregexp\fR chooses among +alternatives using the rule ``first then longest''. +In other words, it considers the possible matches in order working +from left to right across the input string and the pattern, and it +attempts to match longer pieces of the input string before shorter +ones. More specifically, the following rules apply in decreasing +order of priority: +.IP [1] +If a regular expression could match two different parts of an input string +then it will match the one that begins earliest. +.IP [2] +If a regular expression contains \fB|\fR operators then the leftmost +matching sub-expression is chosen. +.IP [3] +In \fB*\fR, \fB+\fR, and \fB?\fR constructs, longer matches are chosen +in preference to shorter ones. +.IP [4] +In sequences of expression components the components are considered +from left to right. +.LP +In the example from above, \fB(a*)b*\fR matches \fBaab\fR: the \fB(a*)\fR +portion of the pattern is matched first and it consumes the leading +\fBaa\fR; then the \fBb*\fR portion of the pattern consumes the +next \fBb\fR. Or, consider the following example: +.CS +\fBregexp (ab|a)(b*)c abc x y z\fR +.CE +After this command \fBx\fR will be \fBabc\fR, \fBy\fR will be +\fBab\fR, and \fBz\fR will be an empty string. +Rule 4 specifies that \fB(ab|a)\fR gets first shot at the input +string and Rule 2 specifies that the \fBab\fR sub-expression +is checked before the \fBa\fR sub-expression. +Thus the \fBb\fR has already been claimed before the \fB(b*)\fR +component is checked and \fB(b*)\fR must match an empty string. + +.SH KEYWORDS +match, regular expression, string diff --git a/contrib/tcl/doc/regsub.n b/contrib/tcl/doc/regsub.n new file mode 100644 index 0000000..efa7b74 --- /dev/null +++ b/contrib/tcl/doc/regsub.n @@ -0,0 +1,78 @@ +'\" +'\" Copyright (c) 1993 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: @(#) regsub.n 1.8 96/03/25 20:22:01 +'\" +.so man.macros +.TH regsub n 7.4 Tcl "Tcl Built-In Commands" +.BS +'\" Note: do not modify the .SH NAME line immediately below! +.SH NAME +regsub \- Perform substitutions based on regular expression pattern matching +.SH SYNOPSIS +\fBregsub \fR?\fIswitches\fR? \fIexp string subSpec varName\fR +.BE + +.SH DESCRIPTION +.PP +This command matches the regular expression \fIexp\fR against +\fIstring\fR, +.VS +and it copies \fIstring\fR to the variable whose name is +given by \fIvarName\fR. +If there is a match, then while copying \fIstring\fR to \fIvarName\fR +the portion of \fIstring\fR that +.VE +matched \fIexp\fR is replaced with \fIsubSpec\fR. +If \fIsubSpec\fR contains a ``&'' or ``\e0'', then it is replaced +in the substitution with the portion of \fIstring\fR that +matched \fIexp\fR. +If \fIsubSpec\fR contains a ``\e\fIn\fR'', where \fIn\fR is a digit +between 1 and 9, then it is replaced in the substitution with +the portion of \fIstring\fR that matched the \fIn\fR-th +parenthesized subexpression of \fIexp\fR. +Additional backslashes may be used in \fIsubSpec\fR to prevent special +interpretation of ``&'' or ``\e0'' or ``\e\fIn\fR'' or +backslash. +The use of backslashes in \fIsubSpec\fR tends to interact badly +with the Tcl parser's use of backslashes, so it's generally +safest to enclose \fIsubSpec\fR in braces if it includes +backslashes. +.LP +If the initial arguments to \fBregexp\fR start with \fB\-\fR then +.VS +they are treated as switches. The following switches are +currently supported: +.TP 10 +\fB\-all\fR +All ranges in \fIstring\fR that match \fIexp\fR are found and +substitution is performed for each of these ranges. +Without this switch only the first +matching range is found and substituted. +If \fB\-all\fR is specified, then ``&'' and ``\e\fIn\fR'' +sequences are handled for each substitution using the information +from the corresponding match. +.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. +.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. +.VE +.PP +.VS +The command returns a count of the number of matching ranges that +were found and replaced. +.VE +See the manual entry for \fBregexp\fR for details on the interpretation +of regular expressions. + +.SH KEYWORDS +match, pattern, regular expression, substitute diff --git a/contrib/tcl/doc/rename.n b/contrib/tcl/doc/rename.n new file mode 100644 index 0000000..a3e185d --- /dev/null +++ b/contrib/tcl/doc/rename.n @@ -0,0 +1,28 @@ +'\" +'\" Copyright (c) 1993 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: @(#) rename.n 1.5 96/03/25 20:22:11 +'\" +.so man.macros +.TH rename n "" Tcl "Tcl Built-In Commands" +.BS +'\" Note: do not modify the .SH NAME line immediately below! +.SH NAME +rename \- Rename or delete a command +.SH SYNOPSIS +\fBrename \fIoldName newName\fR +.BE + +.SH DESCRIPTION +.PP +Rename the command that used to be called \fIoldName\fR so that it +is now called \fInewName\fR. If \fInewName\fR is an empty string +then \fIoldName\fR is deleted. The \fBrename\fR command +returns an empty string as result. + +.SH KEYWORDS +command, delete, rename diff --git a/contrib/tcl/doc/return.n b/contrib/tcl/doc/return.n new file mode 100644 index 0000000..e2c0d5d --- /dev/null +++ b/contrib/tcl/doc/return.n @@ -0,0 +1,91 @@ +'\" +'\" Copyright (c) 1993 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: @(#) return.n 1.12 96/03/25 20:22:26 +'\" +.so man.macros +.TH return n 7.0 Tcl "Tcl Built-In Commands" +.BS +'\" Note: do not modify the .SH NAME line immediately below! +.SH NAME +return \- Return from a procedure +.SH SYNOPSIS +\fBreturn \fR?\fB\-code \fIcode\fR? ?\fB\-errorinfo \fIinfo\fR? ?\fB\-errorcode\fI code\fR? ?\fIstring\fR? +.BE + +.SH DESCRIPTION +.PP +Return immediately from the current procedure +(or top-level command or \fBsource\fR command), +with \fIstring\fR as the return value. If \fIstring\fR is not specified then +an empty string will be returned as result. + +.SH "EXCEPTIONAL RETURNS" +.PP +In the usual case where the \fB\-code\fR option isn't +.VS +specified the procedure will return normally (its completion +code will be TCL_OK). +However, the \fB\-code\fR option may be used to generate an +exceptional return from the procedure. +\fICode\fR may have any of the following values: +.TP 10 +\fBok\fR +Normal return: same as if the option is omitted. +.TP 10 +\fBerror\fR +Error return: same as if the \fBerror\fR command were used to +terminate the procedure, except for handling of \fBerrorInfo\fR +and \fBerrorCode\fR variables (see below). +.TP 10 +\fBreturn\fR +The current procedure will return with a completion code of +TCL_RETURN, so that the procedure that invoked it will return +also. +.TP 10 +\fBbreak\fR +The current procedure will return with a completion code of +TCL_BREAK, which will terminate the innermost nested loop in +the code that invoked the current procedure. +.TP 10 +\fBcontinue\fR +The current procedure will return with a completion code of +TCL_CONTINUE, which will terminate the current iteration of +the innermost nested loop in the code that invoked the current +procedure. +.TP 10 +\fIvalue\fR +\fIValue\fR must be an integer; it will be returned as the +completion code for the current procedure. +.LP +The \fB\-code\fR option is rarely used. +It is provided so that procedures that implement +new control structures can reflect exceptional conditions back to +their callers. +.PP +Two additional options, \fB\-errorinfo\fR and \fB\-errorcode\fR, +may be used to provide additional information during error +returns. +These options are ignored unless \fIcode\fR is \fBerror\fR. +.PP +The \fB\-errorinfo\fR option specifies an initial stack +trace for the \fBerrorInfo\fR variable; if it is not specified then +the stack trace left in \fBerrorInfo\fR will include the call to +the procedure and higher levels on the stack but it will not include +any information about the context of the error within the procedure. +Typically the \fIinfo\fR value is supplied from the value left +in \fBerrorInfo\fR after a \fBcatch\fR command trapped an error within +the procedure. +.PP +If the \fB\-errorcode\fR option is specified then \fIcode\fR provides +a value for the \fBerrorCode\fR variable. +If the option is not specified then \fBerrorCode\fR will +default to \fBNONE\fR. +.VE + +.SH KEYWORDS +break, continue, error, procedure, return diff --git a/contrib/tcl/doc/scan.n b/contrib/tcl/doc/scan.n new file mode 100644 index 0000000..bdc3230 --- /dev/null +++ b/contrib/tcl/doc/scan.n @@ -0,0 +1,140 @@ +'\" +'\" Copyright (c) 1993 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: @(#) scan.n 1.11 96/03/25 20:22:44 +'\" +.so man.macros +.TH scan n "" Tcl "Tcl Built-In Commands" +.BS +'\" Note: do not modify the .SH NAME line immediately below! +.SH NAME +scan \- Parse string using conversion specifiers in the style of sscanf +.SH SYNOPSIS +\fBscan \fIstring format varName \fR?\fIvarName ...\fR? +.BE + +.SH INTRODUCTION +.PP +This command parses fields from an input string in the same fashion +as the ANSI C \fBsscanf\fR procedure and returns a count of the number +.VS +of conversions performed, or -1 if the end of the input string is +reached before any conversions have been performed. +.VE +\fIString\fR gives the input to be parsed and \fIformat\fR indicates +how to parse it, using \fB%\fR 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. + +.SH "DETAILS ON SCANNING" +.PP +\fBScan\fR operates by scanning \fIstring\fR and \fIformatString\fR together. +If the next character in \fIformatString\fR is a blank or tab then it +matches any number of white space characters in \fIstring\fR (including +zero). +Otherwise, if it isn't a \fB%\fR character then it +must match the next character of \fIstring\fR. +When a \fB%\fR is encountered in \fIformatString\fR, it indicates +the start of a conversion specifier. +A conversion specifier contains three fields after the \fB%\fR: +a \fB*\fR, which indicates that the converted value is to be discarded +instead of assigned to a variable; a number indicating a maximum field +width; and a conversion character. +All of these fields are optional except for the conversion character. +.PP +When \fBscan\fR finds a conversion specifier in \fIformatString\fR, it +first skips any white-space characters in \fIstring\fR. +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. +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. +.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. +.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. +.TP 10 +\fBc\fR +A single character is read in and its binary value is stored in +the variable as a decimal string. +Initial white space is not skipped in this case, so the input +field may be a white-space character. +This conversion is different from the ANSI standard in that the +input field always consists of a single character and no field +width may be specified. +.TP 10 +\fBs\fR +The input field consists of all the characters up to the next +white-space character; the characters are copied to the variable. +.TP 10 +\fBe\fR or \fBf\fR or \fBg\fR +The input field must be a floating-point number consisting +of an optional sign, a string of decimal digits possibly +containing a decimal point, and an optional exponent consisting +of an \fBe\fR or \fBE\fR followed by an optional sign and a string of +decimal digits. +It is read in and stored in the variable as a floating-point string. +.TP 10 +\fB[\fIchars\fB]\fR +The input field consists of any number of characters in +\fIchars\fR. +The matching string is stored in the variable. +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. +.TP 10 +\fB[^\fIchars\fB]\fR +The input field consists of any number of characters not in +\fIchars\fR. +The matching string is stored in the variable. +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. +.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. +as many decimal digits as possible for \fB%d\fR, as +many octal digits as possible for \fB%o\fR, and so on). +The input field for a given conversion terminates either when a +white-space character is encountered or when the maximum field +width has been reached, whichever comes first. +If a \fB*\fR is present in the conversion specifier +then no variable is assigned and the next scan argument is not consumed. + +.SH "DIFFERENCES FROM ANSI SSCANF" +.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: +.IP [1] +.VS +\fB%p\fR and \fB%n\fR conversion specifiers are not currently +supported. +.VE +.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] +.VS +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). +.VE + +.SH KEYWORDS +conversion specifier, parse, scan diff --git a/contrib/tcl/doc/seek.n b/contrib/tcl/doc/seek.n new file mode 100644 index 0000000..d31cf15 --- /dev/null +++ b/contrib/tcl/doc/seek.n @@ -0,0 +1,58 @@ +'\" +'\" Copyright (c) 1993 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: @(#) seek.n 1.9 96/02/15 20:02:34 +'\" +.so man.macros +.TH seek n 7.5 Tcl "Tcl Built-In Commands" +.BS +'\" Note: do not modify the .SH NAME line immediately below! +.SH NAME +seek \- Change the access position for an open channel +.SH SYNOPSIS +\fBseek \fIchannelId offset \fR?\fIorigin\fR? +.BE + +.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. +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 +negative) and \fIorigin\fR must be one of the following: +.TP 10 +\fBstart\fR +The new access position will be \fIoffset\fR bytes from the start +of the underlying file or device. +.TP 10 +\fBcurrent\fR +The new access position will be \fIoffset\fR bytes from the current +access position; a negative \fIoffset\fR moves the access position +backwards in the underlying file or device. +.TP 10 +\fBend\fR +The new access position will be \fIoffset\fR bytes from the end of +the file or device. A negative \fIoffset\fR places the access position +before the end of file, and a positive \fIoffset\fR places the access +position after the end of file. +.LP +The \fIorigin\fR argument defaults to \fBstart\fR. +.PP +The command flushes all buffered output for the channel before the command +returns, +.VS +even if the channel is in nonblocking mode. +.VE +It also discards any buffered and unread input. +This command returns an empty string. +An error occurs if this command is applied to channels whose underlying +file or device does not support seeking. + +.SH KEYWORDS +access position, file, seek diff --git a/contrib/tcl/doc/set.n b/contrib/tcl/doc/set.n new file mode 100644 index 0000000..84f63ee --- /dev/null +++ b/contrib/tcl/doc/set.n @@ -0,0 +1,38 @@ +'\" +'\" Copyright (c) 1993 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: @(#) set.n 1.5 96/03/25 20:23:07 +'\" +.so man.macros +.TH set n "" Tcl "Tcl Built-In Commands" +.BS +'\" Note: do not modify the .SH NAME line immediately below! +.SH NAME +set \- Read and write variables +.SH SYNOPSIS +\fBset \fIvarName \fR?\fIvalue\fR? +.BE + +.SH DESCRIPTION +.PP +Returns the value of variable \fIvarName\fR. +If \fIvalue\fR is specified, then set +the value of \fIvarName\fR to \fIvalue\fR, creating a new variable +if one doesn't already exist, and return its value. +If \fIvarName\fR contains an open parenthesis and ends with a +close parenthesis, then it refers to an array element: the characters +before the first open parenthesis are the name of the array, and the characters +between the parentheses are the index within the array. +Otherwise \fIvarName\fR refers to a scalar variable. +If no procedure is active, then \fIvarName\fR refers to a global +variable. +If a procedure is active, then \fIvarName\fR refers to a parameter +or local variable of the procedure unless the \fIglobal\fR command +has been invoked to declare \fIvarName\fR to be global. + +.SH KEYWORDS +read, write, variable diff --git a/contrib/tcl/doc/socket.n b/contrib/tcl/doc/socket.n new file mode 100644 index 0000000..1377497 --- /dev/null +++ b/contrib/tcl/doc/socket.n @@ -0,0 +1,125 @@ +'\" +'\" Copyright (c) 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: @(#) socket.n 1.13 96/04/05 12:05:26 +.so man.macros +.TH socket n 7.5 Tcl "Tcl Built-In Commands" +.BS +'\" Note: do not modify the .SH NAME line immediately below! +.SH NAME +socket \- Open a TCP network connection +.SH SYNOPSIS +.sp +\fBsocket \fR?\fIoptions\fR? \fIhost port\fR +.sp +\fBsocket \fB\-server \fIcommand\fR ?\fIoptions\fR? \fIport\fR +.BE + +.SH DESCRIPTION +.PP +This command opens a network socket and returns a channel +identifier that may be used in future invocations of commands like +\fBread\fR, \fBputs\fR and \fBflush\fR. +At present only the TCP network protocol is supported; future +releases may include support for additional protocols. +The \fBsocket\fR command may be used to open either the client or +server side of a connection, depending on whether the \fB\-server\fR +switch is specified. + +.SH "CLIENT SOCKETS" +.PP +If the \fB\-server\fR option is not specified, then the client side of a +connection is opened and the command returns a channel identifier +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 +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. +.PP +The following options may also be present before \fIhost\fR +to specify additional information about the connection: +.TP +\fB\-myaddr\fI addr\fR +\fIAddr\fR gives the domain-style name or numerical IP address of +the client-side network interface to use for the connection. +This option may be useful if the client machine has multiple network +interfaces. If the option is omitted then the client-side interface +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 +side of the connection. If this option is omitted, the client's +port number will be chosen at random by the system software. +.TP +\fB\-async\fR +The \fB\-async\fR option will cause the client socket to be connected +asynchronously. This means that the socket will be created immediately but +may not yet be connected to the server, when the call to \fBsocket\fR +returns. When a \fBgets\fR or \fBflush\fR is done on the socket before the +connection attempt succeeds or fails, if the socket is in blocking mode, the +operation will wait until the connection is completed or fails. If the +socket is in nonblocking mode and a \fBgets\fR or \fBflush\fR is done on +the socket before the connection attempt succeeds or fails, the operation +returns immediately and \fBfblocked\fR on the socket returns 1. + +.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. +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 +with three additional arguments: the name of the new channel, the +address, in network address notation, of the client's host, and +the client's port number. +.PP +The following additional option may also be specified before \fIhost\fR: +.TP +\fB\-myaddr\fI addr\fR +\fIAddr\fR gives the domain-style name or numerical IP address of +the server-side network interface to use for the connection. +This option may be useful if the server machine has multiple network +interfaces. If the option is omitted then the server socket is bound +to the special address INADDR_ANY so that it can accept connections from +any interface. +.PP +Server channels cannot be used for input or output; their sole use is to +accept new client connections. The channels created for each incoming +client connection are opened for input and output. Closing the server +channel shuts down the server so that no new connections will be +accepted; however, existing connections will be unaffected. +.PP +Server sockets depend on the Tcl event mechanism to find out when +new connections are opened. If the application doesn't enter the +event loop, for example by invoking the \fBvwait\fR command or +calling the C procedure \fBTcl_DoOneEvent\fR, then no connections +will be accepted. + +.SH CONFIGURATION OPTIONS +The \fBfconfigure\fR command can be used to query several readonly +configuration options for socket channels: +.TP +\fB\-sockname\fR +This option returns a list of three elements, the address, the host name +and the port number for the socket. If the host name cannot be computed, +the second element is identical to the address, the first element of the +list. +.TP +\fB\-peername\fR +This option is not supported by server sockets. For client and accepted +sockets, this option returns a list of three elements; these are the +address, the host name and the port to which the peer socket is connected +or bound. If the host name cannot be computed, the second element of the +list is identical to the address, its first element. +.PP + +.SH "SEE ALSO" +flush(n), open(n), read(n) + +.SH KEYWORDS +bind, channel, connection, domain name, host, network address, socket, tcp diff --git a/contrib/tcl/doc/source.n b/contrib/tcl/doc/source.n new file mode 100644 index 0000000..4b153b9 --- /dev/null +++ b/contrib/tcl/doc/source.n @@ -0,0 +1,44 @@ +'\" +'\" Copyright (c) 1993 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: @(#) source.n 1.7 96/04/15 13:07:38 +'\" +.so man.macros +.TH source n "" Tcl "Tcl Built-In Commands" +.BS +'\" Note: do not modify the .SH NAME line immediately below! +.SH NAME +source \- Evaluate a file or resource as a Tcl script +.SH SYNOPSIS +\fBsource \fIfileName\fR +.sp +\fBsource \fB\-rsrc \fIresourceName \fR?\fIfileName\fR? +.sp +\fBsource \fB\-rsrcid \fIresourceId \fR?\fIfileName\fR? +.BE + +.SH DESCRIPTION +.PP +This command takes the contents of the specified file or resource +and passes it to the Tcl interpreter as a text script. The return +value from \fBsource\fR is the return value of the last command +executed in the script. If an error occurs in evaluating the contents +of the script then the \fBsource\fR command will return that error. +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. + +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 +what \fBTEXT\fR resource to source by either name or id. By default Tcl +searches all open resource files, which include the current +application and any loaded C extensions. Alternatively, you may +specify the \fIfileName\fR where the \fBTEXT\fR resource can be found. + +.SH KEYWORDS +file, script diff --git a/contrib/tcl/doc/split.n b/contrib/tcl/doc/split.n new file mode 100644 index 0000000..eff0058 --- /dev/null +++ b/contrib/tcl/doc/split.n @@ -0,0 +1,44 @@ +'\" +'\" Copyright (c) 1993 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: @(#) split.n 1.6 96/03/25 20:23:53 +'\" +.so man.macros +.TH split n "" Tcl "Tcl Built-In Commands" +.BS +'\" Note: do not modify the .SH NAME line immediately below! +.SH NAME +split \- Split a string into a proper Tcl list +.SH SYNOPSIS +\fBsplit \fIstring \fR?\fIsplitChars\fR? +.BE + +.SH DESCRIPTION +.PP +Returns a list created by splitting \fIstring\fR at each character +that is in the \fIsplitChars\fR argument. +Each element of the result list will consist of the +characters from \fIstring\fR that lie between instances of the +characters in \fIsplitChars\fR. +Empty list elements will be generated if \fIstring\fR contains +adjacent characters in \fIsplitChars\fR, or if the first or last +character of \fIstring\fR is in \fIsplitChars\fR. +If \fIsplitChars\fR is an empty string then each character of +\fIstring\fR becomes a separate element of the result list. +\fISplitChars\fR defaults to the standard white-space characters. +For example, +.CS +\fBsplit "comp.unix.misc" .\fR +.CE +returns \fB"comp unix misc"\fR and +.CS +\fBsplit "Hello world" {}\fR +.CE +returns \fB"H e l l o { } w o r l d"\fR. + +.SH KEYWORDS +list, split, string diff --git a/contrib/tcl/doc/string.n b/contrib/tcl/doc/string.n new file mode 100644 index 0000000..bed040d --- /dev/null +++ b/contrib/tcl/doc/string.n @@ -0,0 +1,132 @@ +'\" +'\" Copyright (c) 1993 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: @(#) string.n 1.7 96/03/25 20:24:06 +'\" +.so man.macros +.TH string n 7.4 Tcl "Tcl Built-In Commands" +.BS +'\" Note: do not modify the .SH NAME line immediately below! +.SH NAME +string \- Manipulate strings +.SH SYNOPSIS +\fBstring \fIoption arg \fR?\fIarg ...?\fR +.BE + +.SH DESCRIPTION +.PP +Performs one of several string operations, depending on \fIoption\fR. +The legal \fIoption\fRs (which may be abbreviated) are: +.TP +\fBstring compare \fIstring1 string2\fR +Perform a character-by-character comparison of strings \fIstring1\fR and +\fIstring2\fR in the same way as the C \fBstrcmp\fR procedure. Return +\-1, 0, or 1, depending on whether \fIstring1\fR is lexicographically +less than, equal to, or greater than \fIstring2\fR. +.TP +\fBstring first \fIstring1 string2\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 first such match within \fIstring2\fR. If not +found, return \-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. +If \fIcharIndex\fR is less than 0 or greater than +or equal to the length of the string then an empty string is +returned. +.TP +\fBstring last \fIstring1 string2\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. +.TP +\fBstring length \fIstring\fR +Returns a decimal string giving the number of characters in \fIstring\fR. +.TP +\fBstring match \fIpattern\fR \fIstring\fR +See if \fIpattern\fR matches \fIstring\fR; return 1 if it does, 0 +if it doesn't. Matching is done in a fashion similar to that +used by the C-shell. 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. +.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. +.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. +.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 +first character of the string. \fILast\fR may be \fBend\fR (or any +abbreviation of it) to refer to the last character of the string. +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 tolower \fIstring\fR +Returns a value equal to \fIstring\fR except that all upper case +letters have been converted to lower case. +.TP +\fBstring toupper \fIstring\fR +Returns a value equal to \fIstring\fR except that all lower case +letters have been converted to upper case. +.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). +.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). +.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). +.TP +\fBstring wordend \fIstring index\fR +.VS +Returns the index of the character just after the last one in the +word containing character \fIindex\fR of \fIstring\fR. +A word is considered to be any contiguous range of alphanumeric +or underscore characters, or any single character other than these. +.TP +\fBstring wordstart \fIstring index\fR +Returns the index of the first character in the +word containing character \fIindex\fR of \fIstring\fR. +A word is considered to be any contiguous range of alphanumeric +or underscore characters, or any single character other than these. +.VE + +.SH KEYWORDS +case conversion, compare, index, match, pattern, string, word diff --git a/contrib/tcl/doc/subst.n b/contrib/tcl/doc/subst.n new file mode 100644 index 0000000..7a19b91 --- /dev/null +++ b/contrib/tcl/doc/subst.n @@ -0,0 +1,48 @@ +'\" +'\" Copyright (c) 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: @(#) subst.n 1.9 96/03/25 20:24:17 +'\" +.so man.macros +.TH subst n 7.4 Tcl "Tcl Built-In Commands" +.BS +'\" Note: do not modify the .SH NAME line immediately below! +.SH NAME +subst \- Perform backslash, command, and variable substitutions +.SH SYNOPSIS +\fBsubst \fR?\fB\-nobackslashes\fR? ?\fB\-nocommands\fR? ?\fB\-novariables\fR? \fIstring\fR +.BE + +.SH DESCRIPTION +.PP +This command performs variable substitutions, command substitutions, +and backslash substitutions on its \fIstring\fR argument and +returns the fully-substituted result. +The substitutions are performed in exactly the same way as for +Tcl commands. +As a result, the \fIstring\fR argument is actually substituted twice, +once by the Tcl parser in the usual fashion for Tcl commands, and +again by the \fIsubst\fR command. +.PP +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 +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 +.CS +\fBset a 44 +subst {xyz {$a}}\fR +.CE +returns ``\fBxyz {44}\fR'', not ``\fBxyz {$a}\fR''. + +.SH KEYWORDS +backslash substitution, command substitution, variable substitution diff --git a/contrib/tcl/doc/switch.n b/contrib/tcl/doc/switch.n new file mode 100644 index 0000000..f92540d --- /dev/null +++ b/contrib/tcl/doc/switch.n @@ -0,0 +1,107 @@ +'\" +'\" Copyright (c) 1993 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: @(#) switch.n 1.8 96/03/25 20:24:31 +'\" +.so man.macros +.TH switch n 7.0 Tcl "Tcl Built-In Commands" +.BS +'\" Note: do not modify the .SH NAME line immediately below! +.SH NAME +switch \- Evaluate one of several scripts, depending on a given value +.SH SYNOPSIS +\fBswitch\fI \fR?\fIoptions\fR?\fI string \fIpattern body \fR?\fIpattern body \fR...? +.sp +\fBswitch\fI \fR?\fIoptions\fR?\fI string \fR{\fIpattern body \fR?\fIpattern body \fR...?} +.BE + +.SH DESCRIPTION +.PP +The \fBswitch\fR command matches its \fIstring\fR argument against each of +the \fIpattern\fR arguments in order. +As soon as it finds a \fIpattern\fR that matches \fIstring\fR it +evaluates the following \fIbody\fR argument by passing it recursively +to the Tcl interpreter and returns the result of that evaluation. +If the last \fIpattern\fR argument is \fBdefault\fR then it matches +anything. +If no \fIpattern\fR argument +matches \fIstring\fR and no default is given, then the \fBswitch\fR +command returns an empty string. +.PP +If the initial arguments to \fBswitch\fR start with \fB\-\fR then +they are treated as options. The following options are +currently supported: +.TP 10 +\fB\-exact\fR +Use exact matching when comparing \fIstring\fR to a pattern. This +is the default. +.TP 10 +\fB\-glob\fR +When matching \fIstring\fR to the patterns, use glob-style matching +(i.e. the same as implemented by the \fBstring match\fR command). +.TP 10 +\fB\-regexp\fR +When matching \fIstring\fR to the patterns, use regular +expression matching +(i.e. the same as implemented by the \fBregexp\fR command). +.TP 10 +\fB\-\|\-\fR +Marks the end of options. The argument following this one will +be treated as \fIstring\fR even if it starts with a \fB\-\fR. +.PP +Two syntaxes are provided for the \fIpattern\fR and \fIbody\fR arguments. +The first uses a separate argument for each of the patterns and commands; +this form is convenient if substitutions are desired on some of the +patterns or commands. +The second form places all of the patterns and commands together into +a single argument; the argument must have proper list structure, with +the elements of the list being the patterns and commands. +The second form makes it easy to construct multi-line switch commands, +since the braces around the whole list make it unnecessary to include a +backslash at the end of each line. +Since the \fIpattern\fR arguments are in braces in the second form, +no command or variable substitutions are performed on them; this makes +the behavior of the second form different than the first form in some +cases. +.PP +If a \fIbody\fR is specified as ``\fB\-\fR'' it means that the \fIbody\fR +for the next pattern should also be used as the body for this +pattern (if the next pattern also has a body of ``\fB\-\fR'' +then the body after that is used, and so on). +This feature makes it possible to share a single \fIbody\fR among +several patterns. +.PP +Below are some examples of \fBswitch\fR commands: +.CS +\fBswitch\0abc\0a\0\-\0b\0{format 1}\0abc\0{format 2}\0default\0{format 3}\fR +.CE +will return \fB2\fR, +.CS +\fBswitch\0\-regexp\0aaab { + ^a.*b$\0\- + b\0{format 1} + a*\0{format 2} + default\0{format 3} +}\fR +.CE +will return \fB1\fR, and +.CS +\fBswitch\0xyz { + a + \- + b + {format 1} + a* + {format 2} + default + {format 3} +}\fR +.CE +will return \fB3\fR. + +.SH KEYWORDS +switch, match, regular expression diff --git a/contrib/tcl/doc/tclsh.1 b/contrib/tcl/doc/tclsh.1 new file mode 100644 index 0000000..228a9a4 --- /dev/null +++ b/contrib/tcl/doc/tclsh.1 @@ -0,0 +1,120 @@ +'\" +'\" Copyright (c) 1993 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: @(#) tclsh.1 1.12 96/03/25 20:25:06 +'\" +.so man.macros +.TH tclsh 1 "" Tcl "Tcl Applications" +.BS +'\" Note: do not modify the .SH NAME line immediately below! +.SH NAME +tclsh \- Simple shell containing Tcl interpreter +.SH SYNOPSIS +\fBtclsh\fR ?\fIfileName arg arg ...\fR? +.BE + +.SH DESCRIPTION +.PP +\fBTclsh\fR is a shell-like application that reads Tcl commands +from its standard input or from a file and evaluates them. +If invoked with no arguments then it runs interactively, reading +Tcl commands from standard input and printing command results and +error messages to standard output. +It runs until the \fBexit\fR command is invoked or until it +reaches end-of-file on its standard input. +If there exists a file \fB.tclshrc\fR in the home directory of +the user, \fBtclsh\fR evaluates the file as a Tcl script +just before reading the first command from standard input. + +.SH "SCRIPT FILES" +.PP +If \fBtclsh\fR is invoked with arguments then the first argument +is the name of a script file and any additional arguments +are made available to the script as variables (see below). +Instead of reading commands from standard input \fBtclsh\fR will +read Tcl commands from the named file; \fBtclsh\fR will exit +when it reaches the end of the file. +There is no automatic evaluation of \fB.tclshrc\fR in this +case, but the script file can always \fBsource\fR it if desired. +.PP +If you create a Tcl script in a file whose first line is +.CS +\fB#!/usr/local/bin/tclsh\fR +.CE +then you can invoke the script file directly from your shell if +you mark the file as executable. +This assumes that \fBtclsh\fR has been installed in the default +location in /usr/local/bin; if it's installed somewhere else +then you'll have to modify the above line to match. +.VS +Many UNIX systems do not allow the \fB#!\fR line to exceed about +30 characters in length, so be sure that the \fBtclsh\fR +executable can be accessed with a short file name. +.PP +An even better approach is to start your script files with the +following three lines: +.CS +\fB#!/bin/sh +# the next line restarts using tclsh \e +exec tclsh "$0" "$@"\fR +.CE +This approach has three advantages over the approach in the previous +paragraph. First, the location of the \fBtclsh\fR binary doesn't have +to be hard-wired into the script: it can be anywhere in your shell +search path. Second, it gets around the 30-character file name limit +in the previous approach. +Third, this approach will work even if \fBtclsh\fR is +itself a shell script (this is done on some systems in order to +handle multiple architectures or operating systems: the \fBtclsh\fR +script selects one of several binaries to run). The three lines +cause both \fBsh\fR and \fBtclsh\fR to process the script, but the +\fBexec\fR is only executed by \fBsh\fR. +\fBsh\fR processes the script first; it treats the second +line as a comment and executes the third line. +The \fBexec\fR statement cause the shell to stop processing and +instead to start up \fBtclsh\fR to reprocess the entire script. +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. +.VE + +.SH "VARIABLES" +.PP +\fBTclsh\fR sets the following Tcl variables: +.TP 15 +\fBargc\fR +Contains a count of the number of \fIarg\fR arguments (0 if none), +not including the name of the script file. +.TP 15 +\fBargv\fR +Contains a Tcl list whose elements are the \fIarg\fR arguments, +in order, or an empty string if there are no \fIarg\fR arguments. +.TP 15 +\fBargv0\fR +Contains \fIfileName\fR if it was specified. +Otherwise, contains the name by which \fBtclsh\fR was invoked. +.TP 15 +\fBtcl_interactive\fR +Contains 1 if \fBtclsh\fR is running interactively (no +\fIfileName\fR was specified and standard input is a terminal-like +device), 0 otherwise. + +.SH PROMPTS +.PP +When \fBtclsh\fR is invoked interactively it normally prompts for each +command with ``\fB% \fR''. You can change the prompt by setting the +variables \fBtcl_prompt1\fR and \fBtcl_prompt2\fR. If variable +\fBtcl_prompt1\fR exists then it must consist of a Tcl script +to output a prompt; instead of outputting a prompt \fBtclsh\fR +will evaluate the script in \fBtcl_prompt1\fR. +The variable \fBtcl_prompt2\fR is used in a similar way when +a newline is typed but the current command isn't yet complete; +if \fBtcl_prompt2\fR isn't set then no prompt is output for +incomplete commands. + +.SH KEYWORDS +argument, interpreter, prompt, script file, shell diff --git a/contrib/tcl/doc/tclvars.n b/contrib/tcl/doc/tclvars.n new file mode 100644 index 0000000..47f1b15 --- /dev/null +++ b/contrib/tcl/doc/tclvars.n @@ -0,0 +1,220 @@ +'\" +'\" Copyright (c) 1993 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: @(#) tclvars.n 1.15 96/04/12 08:28:20 +'\" +.so man.macros +.TH tclvars n 7.5 Tcl "Tcl Built-In Commands" +.BS +'\" Note: do not modify the .SH NAME line immediately below! +.SH NAME +tclvars \- Variables used by Tcl +.BE + +.SH DESCRIPTION +.PP +The following global variables are created and managed automatically +by the Tcl library. Except where noted below, these variables should +normally be treated as read-only by application-specific code and by users. +.TP +\fBenv\fR +This variable is maintained by Tcl as an array +whose elements are the environment variables for the process. +Reading an element will return the value of the corresponding +environment variable. +Setting an element of the array will modify the corresponding +environment variable or create a new one if it doesn't already +exist. +Unsetting an element of \fBenv\fR will remove the corresponding +environment variable. +Changes to the \fBenv\fR array will affect the environment +passed to children by commands like \fBexec\fR. +If the entire \fBenv\fR array is unset then Tcl will stop +monitoring \fBenv\fR accesses and will not update environment +variables. +.TP +\fBerrorCode\fR +After an error has occurred, this variable will be set to hold +additional information about the error in a form that is easy +to process with programs. +\fBerrorCode\fR consists of a Tcl list with one or more elements. +The first element of the list identifies a general class of +errors, and determines the format of the rest of the list. +The following formats for \fBerrorCode\fR are used by the +Tcl core; individual applications may define additional formats. +.RS +.TP +\fBARITH\fI code msg\fR +.VS +This format is used when an arithmetic error occurs (e.g. an attempt +to divide by zero in the \fBexpr\fR command). +\fICode\fR identifies the precise error and \fImsg\fR provides a +human-readable description of the error. \fICode\fR will be either +DIVZERO (for an attempt to divide by zero), +DOMAIN (if an argument is outside the domain of a function, such as acos(\-3)), +IOVERFLOW (for integer overflow), +OVERFLOW (for a floating-point overflow), +or UNKNOWN (if the cause of the error cannot be determined). +.VE +.TP +\fBCHILDKILLED\fI pid sigName msg\fR +This format is used when a child process has been killed because of +a signal. The second element of \fBerrorCode\fR will be the +process's identifier (in decimal). +The third element will be the symbolic name of the signal that caused +the process to terminate; it will be one of the names from the +include file signal.h, such as \fBSIGPIPE\fR. +The fourth element will be a short human-readable message +describing the signal, such as ``write on pipe with no readers'' +for \fBSIGPIPE\fR. +.TP +\fBCHILDSTATUS\fI pid code\fR +This format is used when a child process has exited with a non-zero +exit status. The second element of \fBerrorCode\fR will be the +process's identifier (in decimal) and the third element will be the exit +code returned by the process (also in decimal). +.TP +\fBCHILDSUSP\fI pid sigName msg\fR +This format is used when a child process has been suspended because +of a signal. +The second element of \fBerrorCode\fR will be the process's identifier, +in decimal. +The third element will be the symbolic name of the signal that caused +the process to suspend; this will be one of the names from the +include file signal.h, such as \fBSIGTTIN\fR. +The fourth element will be a short human-readable message +describing the signal, such as ``background tty read'' +for \fBSIGTTIN\fR. +.TP +\fBNONE\fR +This format is used for errors where no additional information is +available for an error besides the message returned with the +error. In these cases \fBerrorCode\fR will consist of a list +containing a single element whose contents are \fBNONE\fR. +.TP +\fBPOSIX \fIerrName msg\fR +.VS +If the first element of \fBerrorCode\fR is \fBPOSIX\fR, then +the error occurred during a POSIX kernel call. +.VE +The second element of the list will contain the symbolic name +of the error that occurred, such as \fBENOENT\fR; this will +be one of the values defined in the include file errno.h. +The third element of the list will be a human-readable +message corresponding to \fIerrName\fR, such as +``no such file or directory'' for the \fBENOENT\fR case. +.PP +To set \fBerrorCode\fR, applications should use library +procedures such as \fBTcl_SetErrorCode\fR and +.VS +\fBTcl_PosixError\fR, +.VE +or they may invoke the \fBerror\fR command. +If one of these methods hasn't been used, then the Tcl +interpreter will reset the variable to \fBNONE\fR after +the next error. +.RE +.TP +\fBerrorInfo\fR +After an error has occurred, this string will contain one or more lines +identifying the Tcl commands and procedures that were being executed +when the most recent error occurred. +Its contents take the form of a stack trace showing the various +nested Tcl commands that had been invoked at the time of the error. +.TP +\fBtcl_library\fR +.VS +This variable holds the network name of a directory containing the +system library of Tcl scripts, such as those used for auto-loading. +The value of this variable is returned by the \fBinfo library\fR command. +See the \fBlibrary\fR manual entry for details of the facilities +rovided by the Tcl script library. +Normally each application or package will have its own application-specific +script library in addition to the Tcl script library; +each application should set a global variable with a name like +\fB$\fIapp\fB_library\fR (where \fIapp\fR is the application's name) +to hold the network file name for that application's library directory. +The initial value of \fBtcl_library\fR is set when an interpreter +is created by searching several different directories until one is +found that contains an appropriate Tcl startup script. +If the \fBTCL_LIBRARY\fR environment variable exists, then +the directory it names is checked first. +If \fBTCL_LIBRARY\fR isn't set or doesn't refer to an appropriate +directory, then Tcl checks several other directories based on a +compiled-in default location, the location of the binary containing +the application, and the current working directory. +.VE +.TP +\fBtcl_patchLevel\fR +When an interpreter is created Tcl initializes this variable to +hold a string giving the current patch level for Tcl, such as +\fB7.3p2\fR for Tcl 7.3 with the first two official patches, or +\fB7.4b4\fR for the fourth beta release of Tcl 7.4. +The value of this variable is returned by the \fBinfo patchlevel\fR +command. +.VS br +.TP +\fBtcl_platform\fR +This is an associative array whose elements contain information about +the platform on which the application is running, such as the name of +the operating system, its current release number, and the machine's +instruction set. The elements listed below will always +be defined, but they may have empty strings as values if Tcl couldn't +retrieve any relevant information. In addition, extensions +and applications may add additional values to the array. The +predefined elements are: +.RS +.TP +\fBmachine\fR +The instruction set executed by this machine, such as +\fBPPC\fR, \fB68k\fR, or \fBsun4m\fR. On UNIX machines, this +is the value returned by \fBuname -m\fR. +.TP +\fBos\fR +The name of the operating system running on this machine, such +as \fBWin95\fR, \fBMacOS\fR, or \fBSunOS\fR. On UNIX machines, +this is the value returned by \fBuname -s\fR. +.TP +\fBosVersion\fR +The version number for the operating system running on this machine. +On UNIX machines, this is the value returned by \fBuname -r\fR. +.TP +\fBplatform\fR +Either \fBwindows\fR, \fBmacintosh\fR, or \fBunix\fR. This identifies the +general operating environment of the machine. +.RE +.VE +.TP +\fBtcl_precision\fR +If this variable is set, it must contain a decimal number giving the +number of significant digits to include when converting floating-point +values to strings. +If this variable is not set then 6 digits are included. +17 digits is ``perfect'' for IEEE floating-point in that it allows +double-precision values to be converted to strings and back to +binary with no loss of precision. +.VS br +.TP +\fBtcl_rcFileName\fR +This variable is used during initialization to indicate the name of a +user-specific startup file. If it is set by application-specific +initialization, then the Tcl startup code will check for the existence +of this file and \fBsource\fR it if it exists. For example, for \fBwish\fR +the variable is set to \fB~/.wishrc\fR. +.VE +.TP +\fBtcl_version\fR +When an interpreter is created Tcl initializes this variable to +hold the version number for this version of Tcl in the form \fIx.y\fR. +Changes to \fIx\fR represent major changes with probable +incompatibilities and changes to \fIy\fR represent small enhancements and +bug fixes that retain backward compatibility. +The value of this variable is returned by the \fBinfo tclversion\fR +command. + +.SH KEYWORDS +arithmetic, error, environment, POSIX, precision, subprocess, variables diff --git a/contrib/tcl/doc/tell.n b/contrib/tcl/doc/tell.n new file mode 100644 index 0000000..9edf7d2 --- /dev/null +++ b/contrib/tcl/doc/tell.n @@ -0,0 +1,30 @@ +'\" +'\" Copyright (c) 1993 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: @(#) tell.n 1.8 96/02/15 20:02:42 +'\" +.so man.macros +.TH tell n 7.5 Tcl "Tcl Built-In Commands" +.BS +'\" Note: do not modify the .SH NAME line immediately below! +.SH NAME +tell \- Return current access position for an open channel +.SH SYNOPSIS +\fBtell \fIchannelId\fR +.BE + +.SH DESCRIPTION +.PP +Returns a decimal string giving the current access position in +\fIchannelId\fR. +.VS +The value returned is -1 for channels that do not support +seeking. +.VE + +.SH KEYWORDS +access position, channel, seeking diff --git a/contrib/tcl/doc/time.n b/contrib/tcl/doc/time.n new file mode 100644 index 0000000..19b99fb --- /dev/null +++ b/contrib/tcl/doc/time.n @@ -0,0 +1,33 @@ +'\" +'\" Copyright (c) 1993 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: @(#) time.n 1.6 96/03/25 20:25:30 +'\" +.so man.macros +.TH time n "" Tcl "Tcl Built-In Commands" +.BS +'\" Note: do not modify the .SH NAME line immediately below! +.SH NAME +time \- Time the execution of a script +.SH SYNOPSIS +\fBtime \fIscript\fR ?\fIcount\fR? +.BE + +.SH DESCRIPTION +.PP +This command will call the Tcl interpreter \fIcount\fR +times to evaluate \fIscript\fR (or once if \fIcount\fR isn't +specified). It will then return a string of the form +.CS +\fB503 microseconds per iteration\fR +.CE +which indicates the average amount of time required per iteration, +in microseconds. +Time is measured in elapsed time, not CPU time. + +.SH KEYWORDS +script, time diff --git a/contrib/tcl/doc/trace.n b/contrib/tcl/doc/trace.n new file mode 100644 index 0000000..7832d2f --- /dev/null +++ b/contrib/tcl/doc/trace.n @@ -0,0 +1,164 @@ +'\" +'\" Copyright (c) 1993 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: @(#) trace.n 1.11 96/03/25 20:25:42 +'\" +.so man.macros +.TH trace n "" Tcl "Tcl Built-In Commands" +.BS +'\" Note: do not modify the .SH NAME line immediately below! +.SH NAME +trace \- Monitor variable accesses +.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: +.TP +\fBtrace variable \fIname 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 +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 +\fIcommand\fR is invoked whenever any element of the array is +manipulated. +.RS +.PP +\fIOps\fR indicates which operations are of interest, and consists of +one or more of the following letters: +.TP +\fBr\fR +Invoke \fIcommand\fR whenever the variable is read. +.TP +\fBw\fR +Invoke \fIcommand\fR whenever the variable is written. +.TP +\fBu\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 +are unset). Variables are also unset when interpreters are +deleted, but traces will not be invoked because there is no +interpreter in which to execute them. +.PP +When the trace triggers, three arguments are appended to +\fIcommand\fR so that the actual command is as follows: +.CS +\fIcommand name1 name2 op\fR +.CE +\fIName1\fR and \fIname2\fR give the name(s) for the variable +being accessed: if the variable is a scalar then \fIname1\fR +gives the variable's name and \fIname2\fR is an empty string; +if the variable is an array element then \fIname1\fR gives the +name of the array and name2 gives the index into the array; +if an entire array is being deleted and the trace was registered +on the overall array, rather than a single element, then \fIname1\fR +gives the array name and \fIname2\fR is an empty string. +\fIName1\fR and \fIname2\fR are not necessarily the same as the +name used in the \fBtrace variable\fR command: the \fBupvar\fR +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 +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 +.VS +the same error message returned by the trace command +.VE +(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. +.VS +However, if \fIcommand\fR unsets the variable then unset traces +will be invoked. +.VE +.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. +.VS +Any errors in unset traces are ignored. +.VE +.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. +.PP +This command returns an empty string. +.RE +.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. + +.SH KEYWORDS +read, variable, write, trace, unset diff --git a/contrib/tcl/doc/unknown.n b/contrib/tcl/doc/unknown.n new file mode 100644 index 0000000..6f2fd65 --- /dev/null +++ b/contrib/tcl/doc/unknown.n @@ -0,0 +1,75 @@ +'\" +'\" Copyright (c) 1993 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: @(#) unknown.n 1.7 96/03/25 20:26:05 +'\" +.so man.macros +.TH unknown n "" Tcl "Tcl Built-In Commands" +.BS +'\" Note: do not modify the .SH NAME line immediately below! +.SH NAME +unknown \- Handle attempts to use non-existent commands +.SH SYNOPSIS +\fBunknown \fIcmdName \fR?\fIarg arg ...\fR? +.BE + +.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. +.PP +If the Tcl interpreter encounters a command name for which there +is not a defined command, then Tcl checks for the existence of +a command named \fBunknown\fR. +If there is no such command, then the interpreter returns an +error. +If the \fBunknown\fR command exists, then it is invoked with +arguments consisting of the fully-substituted name and arguments +for the original non-existent command. +The \fBunknown\fR command typically does things like searching +through library directories for a command procedure with the name +\fIcmdName\fR, or expanding abbreviated command names to full-length, +or automatically executing unknown commands as sub-processes. +In some cases (such as expanding abbreviations) \fBunknown\fR will +change the original command slightly and then (re-)execute it. +The result of the \fBunknown\fR command is used as the result for +the original non-existent command. +.PP +The default implementation of \fBunknown\fR behaves as follows. +It first calls the \fBauto_load\fR library procedure to load the command. +If this succeeds, then it executes the original command with its +original arguments. +If the auto-load fails then \fBunknown\fR calls \fBauto_execok\fR +to see if there is an executable file by the name \fIcmd\fR. +If so, it invokes the Tcl \fBexec\fR command +with \fIcmd\fR and all the \fIargs\fR as arguments. +If \fIcmd\fR can't be auto-executed, \fBunknown\fR checks to +see if the command was invoked at top-level and outside of any +script. If so, then \fBunknown\fR takes takes two additional steps. +First, it sees if \fIcmd\fR has one of the following three forms: +\fB!!\fR, \fB!\fIevent\fR, or \fB^\fIold\fB^\fInew\fR?\fB^\fR?. +If so, then \fBunknown\fR carries out history substitution +in the same way that \fBcsh\fR would for these constructs. +Finally, \fBunknown\fR checks to see if \fIcmd\fR is +a unique abbreviation for an existing Tcl command. +If so, it expands the command name and executes the command with +the original arguments. +If none of the above efforts has been able to execute +the command, \fBunknown\fR generates an error return. +If the global variable \fBauto_noload\fR is defined, then the auto-load +step is skipped. +If the global variable \fBauto_noexec\fR is defined then the +auto-exec step is skipped. +Under normal circumstances the return value from \fBunknown\fR +is the return value from the command that was eventually +executed. + +.SH KEYWORDS +error, non-existent command diff --git a/contrib/tcl/doc/unset.n b/contrib/tcl/doc/unset.n new file mode 100644 index 0000000..6073256 --- /dev/null +++ b/contrib/tcl/doc/unset.n @@ -0,0 +1,34 @@ +'\" +'\" Copyright (c) 1993 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: @(#) unset.n 1.5 96/03/25 20:26:21 +'\" +.so man.macros +.TH unset n "" 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? +.BE + +.SH DESCRIPTION +.PP +This command removes one or more variables. +Each \fIname\fR is a variable name, specified in any of the +ways acceptable to the \fBset\fR command. +If a \fIname\fR refers to an element of an array then that +element is removed without affecting the rest of the array. +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. + +.SH KEYWORDS +remove, variable diff --git a/contrib/tcl/doc/update.n b/contrib/tcl/doc/update.n new file mode 100644 index 0000000..522b176 --- /dev/null +++ b/contrib/tcl/doc/update.n @@ -0,0 +1,48 @@ +'\" +'\" Copyright (c) 1990-1992 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: @(#) update.n 1.3 96/03/25 20:26:34 +'\" +.so man.macros +.TH update n 7.5 Tcl "Tcl Built-In Commands" +.BS +'\" Note: do not modify the .SH NAME line immediately below! +.SH NAME +update \- Process pending events and idle callbacks +.SH SYNOPSIS +\fBupdate\fR ?\fBidletasks\fR? +.BE + +.SH DESCRIPTION +.PP +This command is used to bring the application ``up to date'' +by entering the event loop repeated until all pending events +(including idle callbacks) have been processed. +.PP +If the \fBidletasks\fR keyword is specified as an argument to the +command, then no new events or errors are processed; only idle +callbacks are invoked. +This causes operations that are normally deferred, such as display +updates and window layout calculations, to be performed immediately. +.PP +The \fBupdate idletasks\fR command is useful in scripts where +changes have been made to the application's state and you want those +changes to appear on the display immediately, rather than waiting +for the script to complete. Most display updates are performed as +idle callbacks, so \fBupdate idletasks\fR will cause them to run. +However, there are some kinds of updates that only happen in +response to events, such as those triggered by window size changes; +these updates will not occur in \fBupdate idletasks\fR. +.PP +The \fBupdate\fR command with no options is useful in scripts where +you are performing a long-running computation but you still want +the application to respond to events such as user interactions; if +you occasionally call \fBupdate\fR then user input will be processed +during the next call to \fBupdate\fR. + +.SH KEYWORDS +event, flush, handler, idle, update diff --git a/contrib/tcl/doc/uplevel.n b/contrib/tcl/doc/uplevel.n new file mode 100644 index 0000000..574900e --- /dev/null +++ b/contrib/tcl/doc/uplevel.n @@ -0,0 +1,66 @@ +'\" +'\" Copyright (c) 1993 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: @(#) uplevel.n 1.7 96/03/25 20:26:46 +'\" +.so man.macros +.TH uplevel n "" Tcl "Tcl Built-In Commands" +.BS +'\" Note: do not modify the .SH NAME line immediately below! +.SH NAME +uplevel \- Execute a script in a different stack frame +.SH SYNOPSIS +\fBuplevel \fR?\fIlevel\fR?\fI arg \fR?\fIarg ...\fR? +.BE + +.SH DESCRIPTION +.PP +All of the \fIarg\fR arguments are concatenated as if they had +been passed to \fBconcat\fR; the result is then evaluated in the +variable context indicated by \fIlevel\fR. \fBUplevel\fR returns +the result of that evaluation. +.PP +If \fIlevel\fR is an integer then +it gives a distance (up the procedure calling stack) to move before +executing the command. If \fIlevel\fR consists of \fB#\fR followed by +a number then the number gives an absolute level number. If \fIlevel\fR +is omitted then it defaults to \fB1\fR. \fILevel\fR cannot be +defaulted if the first \fIcommand\fR argument starts with a digit or \fB#\fR. +.PP +For example, suppose that procedure \fBa\fR was invoked +from top-level, and that it called \fBb\fR, and that \fBb\fR called \fBc\fR. +Suppose that \fBc\fR invokes the \fBuplevel\fR command. If \fIlevel\fR +is \fB1\fR or \fB#2\fR or omitted, then the command will be executed +in the variable context of \fBb\fR. If \fIlevel\fR is \fB2\fR or \fB#1\fR +then the command will be executed in the variable context of \fBa\fR. +If \fIlevel\fR is \fB3\fR or \fB#0\fR then the command will be executed +at top-level (only global variables will be visible). +.PP +The \fBuplevel\fR command causes the invoking procedure to disappear +from the procedure calling stack while the command is being executed. +In the above example, suppose \fBc\fR invokes the command +.CS +\fBuplevel 1 {set x 43; d}\fR +.CE +where \fBd\fR is another Tcl procedure. The \fBset\fR command will +modify the variable \fBx\fR in \fBb\fR's context, and \fBd\fR will execute +at level 3, as if called from \fBb\fR. If it in turn executes +the command +.CS +\fBuplevel {set x 42}\fR +.CE +then the \fBset\fR command will modify the same variable \fBx\fR in \fBb\fR's +context: the procedure \fBc\fR does not appear to be on the call stack +when \fBd\fR is executing. The command ``\fBinfo level\fR'' may +be used to obtain the level of the current procedure. +.PP +\fBUplevel\fR makes it possible to implement new control +constructs as Tcl procedures (for example, \fBuplevel\fR could +be used to implement the \fBwhile\fR construct as a Tcl procedure). + +.SH KEYWORDS +context, stack frame, variables diff --git a/contrib/tcl/doc/upvar.n b/contrib/tcl/doc/upvar.n new file mode 100644 index 0000000..37baf4c --- /dev/null +++ b/contrib/tcl/doc/upvar.n @@ -0,0 +1,80 @@ +'\" +'\" Copyright (c) 1993 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: @(#) upvar.n 1.14 96/03/25 20:27:03 +'\" +.so man.macros +.TH upvar n "" Tcl "Tcl Built-In Commands" +.BS +'\" Note: do not modify the .SH NAME line immediately below! +.SH NAME +upvar \- Create link to variable in a different stack frame +.SH SYNOPSIS +\fBupvar \fR?\fIlevel\fR? \fIotherVar myVar \fR?\fIotherVar myVar \fR...? +.BE + +.SH DESCRIPTION +.PP +This command arranges for one or more local variables in the current +procedure to refer to variables in an enclosing procedure call or +to global variables. +\fILevel\fR may have any of the forms permitted for the \fBuplevel\fR +command, and may be omitted if the first letter of the first \fIotherVar\fR +isn't \fB#\fR or a digit (it defaults to \fB1\fR). +For each \fIotherVar\fR argument, \fBupvar\fR makes the variable +by that name in the procedure frame given by \fIlevel\fR (or at +global level, if \fIlevel\fR is \fB#0\fR) accessible +in the current procedure by the name given in the corresponding +\fImyVar\fR argument. +The variable named by \fIotherVar\fR need not exist at the time of the +call; it will be created the first time \fImyVar\fR is referenced, just like +an ordinary variable. There must not exist a variable by the +name \fImyVar\fR at the time \fBupvar\fR is invoked. +.VS +\fIMyVar\fR is always treated as the name of a variable, not an +array element. Even if the name looks like an array element, +such as \fBa(b)\fR, a regular variable is created. +\fIOtherVar\fR may refer to a scalar variable, an array, +or an array element. +.VE +\fBUpvar\fR returns an empty string. +.PP +The \fBupvar\fR command simplifies the implementation of call-by-name +procedure calling and also makes it easier to build new control constructs +as Tcl procedures. +For example, consider the following procedure: +.CS +\fBproc add2 name { + upvar $name x + set x [expr $x+2] +}\fR +.CE +\fBAdd2\fR is invoked with an argument giving the name of a variable, +and it adds two to the value of that variable. +Although \fBadd2\fR could have been implemented using \fBuplevel\fR +instead of \fBupvar\fR, \fBupvar\fR makes it simpler for \fBadd2\fR +to access the variable in the caller's procedure frame. +.PP +.VS +If an upvar variable is unset (e.g. \fBx\fR in \fBadd2\fR above), the +\fBunset\fR operation affects the variable it is linked to, not the +upvar variable. There is no way to unset an upvar variable except +by exiting the procedure in which it is defined. However, it is +possible to retarget an upvar variable by executing another \fBupvar\fR +command. + +.SH BUGS +.PP +If \fIotherVar\fR refers to an element of an array, then variable +traces set for the entire array will not be invoked when \fImyVar\fR +is accessed (but traces on the particular element will still be +invoked). In particular, if the array is \fBenv\fR, then changes +made to \fImyVar\fR will not be passed to subprocesses correctly. +.VE + +.SH KEYWORDS +context, frame, global, level, procedure, variable diff --git a/contrib/tcl/doc/vwait.n b/contrib/tcl/doc/vwait.n new file mode 100644 index 0000000..868f5dc --- /dev/null +++ b/contrib/tcl/doc/vwait.n @@ -0,0 +1,38 @@ +'\" +'\" Copyright (c) 1995-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: @(#) vwait.n 1.3 96/03/25 20:27:21 +'\" +.so man.macros +.TH vwait n 7.5 Tcl "Tcl Built-In Commands" +.BS +'\" Note: do not modify the .SH NAME line immediately below! +.SH NAME +vwait \- Process events until a variable is written +.SH SYNOPSIS +\fBvwait\fR ?\fIvarName\fR? +.BE + +.SH DESCRIPTION +.PP +This command enters the Tcl event loop to process events, blocking +the application if no events are ready. It continues processing +events until some event handler sets the value of variable +\fIvarName\fR. Once \fIvarName\fR has been set, the \fBvwait\fR +command will return as soon as the event handler that modified +\fIvarName\fR completes. +.PP +In some cases the \fBvwait\fR command may not return immediately +after \fIvarName\fR is set. This can happen if the event handler +that sets \fIvarName\fR does not complete immediately. For example, +if an event handler sets \fIvarName\fR and then itself calls +\fBvwait\fR to wait for a different variable, then it may not return +for a long time. During this time the top-level \fBvwait\fR is +blocked waiting for the event handler to complete, so it cannot +return either. + +.SH KEYWORDS +event, variable, wait diff --git a/contrib/tcl/doc/while.n b/contrib/tcl/doc/while.n new file mode 100644 index 0000000..8703684 --- /dev/null +++ b/contrib/tcl/doc/while.n @@ -0,0 +1,37 @@ +'\" +'\" Copyright (c) 1993 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: @(#) while.n 1.6 96/03/25 20:27:35 +'\" +.so man.macros +.TH while n "" Tcl "Tcl Built-In Commands" +.BS +'\" Note: do not modify the .SH NAME line immediately below! +.SH NAME +while \- Execute script repeatedly as long as a condition is met +.SH SYNOPSIS +\fBwhile \fItest body\fR +.BE + +.SH DESCRIPTION +.PP +The \fIwhile\fR command evaluates \fItest\fR as an expression +(in the same way that \fBexpr\fR evaluates its argument). +The value of the expression must a proper boolean +value; if it is a true value +then \fIbody\fR is executed by passing it to the Tcl interpreter. +Once \fIbody\fR has been executed then \fItest\fR is evaluated +again, and the process repeats until eventually \fItest\fR +evaluates to a false boolean value. \fBContinue\fR +commands may be executed inside \fIbody\fR to terminate the current +iteration of the loop, and \fBbreak\fR +commands may be executed inside \fIbody\fR to cause immediate +termination of the \fBwhile\fR command. The \fBwhile\fR command +always returns an empty string. + +.SH KEYWORDS +boolean value, loop, test, while diff --git a/contrib/tcl/generic/README b/contrib/tcl/generic/README new file mode 100644 index 0000000..4b3aa4f --- /dev/null +++ b/contrib/tcl/generic/README @@ -0,0 +1,5 @@ +This directory contains Tcl source files that work on all the platforms +where Tcl runs (e.g. UNIX, PCs, and Macintoshes). Platform-specific +sources are in the directories ../unix, ../win, and ../mac. + +SCCS ID: @(#) README 1.1 95/09/11 14:02:13 diff --git a/contrib/tcl/generic/panic.c b/contrib/tcl/generic/panic.c new file mode 100644 index 0000000..4ad98fd --- /dev/null +++ b/contrib/tcl/generic/panic.c @@ -0,0 +1,92 @@ +/* + * 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. + * + * SCCS: @(#) panic.c 1.11 96/02/15 11:50:29 + */ + +#include <stdio.h> +#ifdef NO_STDLIB_H +# include "../compat/stdlib.h" +#else +# include <stdlib.h> +#endif + +#include "tcl.h" + +/* + * The panicProc variable contains a pointer to an application + * specific panic procedure. + */ + +void (*panicProc) _ANSI_ARGS_(TCL_VARARGS(char *,format)) = NULL; + + + +/* + *---------------------------------------------------------------------- + * + * 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; +} + +/* + *---------------------------------------------------------------------- + * + * 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(); + } +} diff --git a/contrib/tcl/generic/patchlevel.h b/contrib/tcl/generic/patchlevel.h new file mode 100644 index 0000000..2482cd3 --- /dev/null +++ b/contrib/tcl/generic/patchlevel.h @@ -0,0 +1,23 @@ +/* + * 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" diff --git a/contrib/tcl/generic/regexp.c b/contrib/tcl/generic/regexp.c new file mode 100644 index 0000000..52e5a51 --- /dev/null +++ b/contrib/tcl/generic/regexp.c @@ -0,0 +1,1335 @@ +/* + * 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. *** + * + * SCCS: @(#) regexp.c 1.12 96/04/02 13:54:57 + */ + +#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 == '^') { /* 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 */ + break; + case '?': + case '+': + case '*': + FAIL("?+* follows nothing"); + /* NOTREACHED */ + break; + 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); + /* 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 + +/* + *---------------------------------------------------------------------- + * + * 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; +} diff --git a/contrib/tcl/generic/tcl.h b/contrib/tcl/generic/tcl.h new file mode 100644 index 0000000..b37665f --- /dev/null +++ b/contrib/tcl/generic/tcl.h @@ -0,0 +1,1047 @@ +/* + * tcl.h -- + * + * This header file describes the externally-visible facilities + * of the Tcl interpreter. + * + * Copyright (c) 1987-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: @(#) tcl.h 1.266 96/04/10 11:25:19 + */ + +#ifndef _TCL +#define _TCL + +/* + * The following definitions set up the proper options for Windows + * compilers. We use this method because there is no autoconf equivalent. + */ + +#if defined(_WIN32) && !defined(__WIN32__) +# define __WIN32__ +#endif + +#ifdef __WIN32__ +# undef USE_PROTOTYPE +# undef HAS_STDARG +# define USE_PROTOTYPE +# define HAS_STDARG +#endif + +#ifndef BUFSIZ +#include <stdio.h> +#endif + +#define TCL_VERSION "7.5" +#define TCL_MAJOR_VERSION 7 +#define TCL_MINOR_VERSION 5 + +/* + * Definitions that allow Tcl functions with variable numbers of + * arguments to be used with either varargs.h or stdarg.h. TCL_VARARGS + * is used in procedure prototypes. TCL_VARARGS_DEF is used to declare + * the arguments in a function definiton: it takes the type and name of + * the first argument and supplies the appropriate argument declaration + * 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) +# 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 +# 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_START(type, name, list) \ + (va_start(list), va_arg(list, type)) +#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 + +#if ((defined(__STDC__) || defined(SABER)) && !defined(NO_PROTOTYPE)) || defined(__cplusplus) || defined(USE_PROTOTYPE) +# define _USING_PROTOTYPES_ 1 +# define _ANSI_ARGS_(x) x +# define CONST const +#else +# define _ANSI_ARGS_(x) () +# define CONST +#endif + +#ifdef __cplusplus +# define EXTERN extern "C" +#else +# define EXTERN extern +#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 + */ +#ifndef VOID +#define VOID void +typedef char CHAR; +typedef short SHORT; +typedef long LONG; +#endif +#endif /* __WIN32__ */ + +/* + * Miscellaneous declarations. + */ + +#ifndef NULL +#define NULL 0 +#endif + +#ifndef _CLIENTDATA +# if defined(__STDC__) || defined(__cplusplus) + typedef void *ClientData; +# else + typedef int *ClientData; +# endif /* __STDC__ */ +#define _CLIENTDATA +#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 for returning string values. + * Note: any change to the Tcl_Interp definition below must be mirrored + * in the "real" definition in tclInt.h. + */ + +typedef struct Tcl_Interp{ + char *result; /* Points to result string returned by last + * command. */ + void (*freeProc) _ANSI_ARGS_((char *blockPtr)); + /* Zero means result is statically allocated. + * TCL_DYNAMIC means result was allocated with + * ckalloc and should be freed with ckfree. + * Other values give address of procedure + * to invoke to free the result. Must be + * freed by Tcl_Eval before executing next + * command. */ + int errorLine; /* When TCL_ERROR is returned, this gives + * the line number within the command where + * the error occurred (1 means first line). */ +} Tcl_Interp; + +typedef struct Tcl_AsyncHandler_ *Tcl_AsyncHandler; +typedef struct Tcl_Command_ *Tcl_Command; +typedef struct Tcl_Event Tcl_Event; +typedef struct Tcl_File_ *Tcl_File; +typedef struct Tcl_Channel_ *Tcl_Channel; +typedef struct Tcl_RegExp_ *Tcl_RegExp; +typedef struct Tcl_TimerToken_ *Tcl_TimerToken; +typedef struct Tcl_Trace_ *Tcl_Trace; + +/* + * When a TCL command returns, the string pointer interp->result points to + * a string containing return information from the command. In addition, + * the command procedure returns an integer value, which is one of the + * following: + * + * TCL_OK Command completed normally; interp->result contains + * the command's result. + * TCL_ERROR The command couldn't be completed successfully; + * interp->result describes what went wrong. + * TCL_RETURN The command requests that the current procedure + * return; interp->result contains the procedure's + * return value. + * TCL_BREAK The command requests that the innermost loop + * be exited; interp->result is meaningless. + * TCL_CONTINUE Go on to the next iteration of the current loop; + * interp->result is meaningless. + */ + +#define TCL_OK 0 +#define TCL_ERROR 1 +#define TCL_RETURN 2 +#define TCL_BREAK 3 +#define TCL_CONTINUE 4 + +#define TCL_RESULT_SIZE 200 + +/* + * Argument descriptors for math function callbacks in expressions: + */ + +typedef enum {TCL_INT, TCL_DOUBLE, TCL_EITHER} 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. */ +} Tcl_Value; + +/* + * Procedure types defined by Tcl: + */ + +typedef int (Tcl_AppInitProc) _ANSI_ARGS_((Tcl_Interp *interp)); +typedef int (Tcl_AsyncProc) _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int code)); +typedef void (Tcl_ChannelProc) _ANSI_ARGS_((ClientData clientData, int mask)); +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[])); +typedef void (Tcl_CmdTraceProc) _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int level, char *command, Tcl_CmdProc *proc, + ClientData cmdClientData, int argc, char *argv[])); +typedef int (Tcl_EventProc) _ANSI_ARGS_((Tcl_Event *evPtr, int flags)); +typedef void (Tcl_EventCheckProc) _ANSI_ARGS_((ClientData clientData, + int flags)); +typedef int (Tcl_EventDeleteProc) _ANSI_ARGS_((Tcl_Event *evPtr, + ClientData clientData)); +typedef void (Tcl_EventSetupProc) _ANSI_ARGS_((ClientData clientData, + int flags)); +typedef void (Tcl_ExitProc) _ANSI_ARGS_((ClientData clientData)); +typedef void (Tcl_FileProc) _ANSI_ARGS_((ClientData clientData, int mask)); +typedef void (Tcl_FileFreeProc) _ANSI_ARGS_((ClientData clientData)); +typedef void (Tcl_FreeProc) _ANSI_ARGS_((char *blockPtr)); +typedef void (Tcl_IdleProc) _ANSI_ARGS_((ClientData clientData)); +typedef void (Tcl_InterpDeleteProc) _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp)); +typedef int (Tcl_MathProc) _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, Tcl_Value *args, Tcl_Value *resultPtr)); +typedef int (Tcl_PackageInitProc) _ANSI_ARGS_((Tcl_Interp *interp)); +typedef void (Tcl_TcpAcceptProc) _ANSI_ARGS_((ClientData callbackData, + Tcl_Channel chan, char *address, int port)); +typedef void (Tcl_TimerProc) _ANSI_ARGS_((ClientData clientData)); +typedef char *(Tcl_VarTraceProc) _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, char *part1, char *part2, int flags)); + +/* + * The structure returned by Tcl_GetCmdInfo and passed into + * Tcl_SetCmdInfo: + */ + +typedef struct Tcl_CmdInfo { + Tcl_CmdProc *proc; /* Procedure to implement command. */ + ClientData clientData; /* ClientData passed to proc. */ + Tcl_CmdDeleteProc *deleteProc; /* Procedure to call when command + * is deleted. */ + ClientData deleteData; /* Value to pass to deleteProc (usually + * the same as clientData). */ +} Tcl_CmdInfo; + +/* + * 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. + */ + +#define TCL_DSTRING_STATIC_SIZE 200 +typedef struct Tcl_DString { + char *string; /* Points to beginning of string: either + * staticSpace below or a malloc'ed array. */ + int length; /* Number of non-NULL characters in the + * string. */ + int spaceAvl; /* Total number of bytes available for the + * string and its terminating NULL char. */ + char staticSpace[TCL_DSTRING_STATIC_SIZE]; + /* Space to use in common case where string + * is small. */ +} Tcl_DString; + +#define Tcl_DStringLength(dsPtr) ((dsPtr)->length) +#define Tcl_DStringValue(dsPtr) ((dsPtr)->string) +#define Tcl_DStringTrunc Tcl_DStringSetLength + +/* + * Definitions for the maximum number of digits of precision that may + * be specified in the "tcl_precision" variable, and the number of + * characters of buffer space required by Tcl_PrintDouble. + */ + +#define TCL_MAX_PREC 17 +#define TCL_DOUBLE_SPACE (TCL_MAX_PREC+10) + +/* + * Flag that may be passed to Tcl_ConvertElement to force it not to + * 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 values passed to Tcl_RecordAndEval. + * 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 + +/* + * 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_APPEND_VALUE 2 +#define TCL_LIST_ELEMENT 4 +#define TCL_TRACE_READS 0x10 +#define TCL_TRACE_WRITES 0x20 +#define TCL_TRACE_UNSETS 0x40 +#define TCL_TRACE_DESTROYED 0x80 +#define TCL_INTERP_DESTROYED 0x100 +#define TCL_LEAVE_ERR_MSG 0x200 + +/* + * 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_READ_ONLY 0x80 + +/* + * 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__) + +EXTERN int Tcl_DumpActiveMemory _ANSI_ARGS_((char *fileName)); +EXTERN void Tcl_ValidateAllMemory _ANSI_ARGS_((char *file, + int line)); + +#else + +# define ckalloc(x) malloc(x) +# define ckfree(x) free(x) +# define ckrealloc(x,y) realloc(x,y) + +# define Tcl_DumpActiveMemory(x) +# define Tcl_ValidateAllMemory(x,y) + +#endif /* TCL_MEM_DEBUG */ + +/* + * Macro to free result of interpreter. + */ + +#define Tcl_FreeResult(interp) \ + if ((interp)->freeProc != 0) { \ + if (((interp)->freeProc == TCL_DYNAMIC) \ + || ((interp)->freeProc == (Tcl_FreeProc *) free)) { \ + ckfree((interp)->result); \ + } else { \ + (*(interp)->freeProc)((interp)->result); \ + } \ + (interp)->freeProc = 0; \ + } + +/* + * 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. + */ + +#ifdef __cplusplus +struct Tcl_HashTable; +#endif + +/* + * Structure definition for an entry in a hash table. No-one outside + * Tcl should access any of these fields directly; use the macros + * defined below. + */ + +typedef struct Tcl_HashEntry { + struct 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 + * first entry in this entry's chain: + * used for deleting the entry. */ + ClientData clientData; /* Application stores something here + * with Tcl_SetHashValue. */ + union { /* Key has one of these forms: */ + char *oneWordValue; /* One-word value for key. */ + int words[1]; /* Multiple integer words for key. + * The actual size will be as large + * as necessary for this table's + * keys. */ + char string[4]; /* String for key. The actual size + * will be as large as needed to hold + * the key. */ + } key; /* MUST BE LAST FIELD IN RECORD!! */ +} Tcl_HashEntry; + +/* + * Structure definition for a hash table. Must be in tcl.h so clients + * can allocate space for these structures, but clients should never + * access any fields in this structure. + */ + +#define TCL_SMALL_HASH_TABLE 4 +typedef struct Tcl_HashTable { + Tcl_HashEntry **buckets; /* Pointer to bucket array. Each + * element points to first entry in + * bucket's hash chain, or NULL. */ + Tcl_HashEntry *staticBuckets[TCL_SMALL_HASH_TABLE]; + /* Bucket array used for small tables + * (to avoid mallocs and frees). */ + int numBuckets; /* Total number of buckets allocated + * at **bucketPtr. */ + int numEntries; /* Total number of entries present + * in table. */ + int rebuildSize; /* Enlarge table when numEntries gets + * to be this large. */ + int downShift; /* Shift count used in hashing + * function. Designed to use high- + * order bits of randomized keys. */ + 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. + */ + Tcl_HashEntry *(*findProc) _ANSI_ARGS_((struct Tcl_HashTable *tablePtr, + char *key)); + Tcl_HashEntry *(*createProc) _ANSI_ARGS_((struct Tcl_HashTable *tablePtr, + char *key, int *newPtr)); +} Tcl_HashTable; + +/* + * Structure definition for information used to keep track of searches + * through hash tables: + */ + +typedef struct Tcl_HashSearch { + Tcl_HashTable *tablePtr; /* Table being searched. */ + int nextIndex; /* Index of next bucket to be + * enumerated after present one. */ + Tcl_HashEntry *nextEntryPtr; /* Next entry to be enumerated in the + * the current bucket. */ +} Tcl_HashSearch; + +/* + * Acceptable key types for hash tables: + */ + +#define TCL_STRING_KEYS 0 +#define TCL_ONE_WORD_KEYS 1 + +/* + * 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)) + +/* + * Macros to use for clients to use to invoke find and create procedures + * for hash tables: + */ + +#define Tcl_FindHashEntry(tablePtr, key) \ + (*((tablePtr)->findProc))(tablePtr, key) +#define Tcl_CreateHashEntry(tablePtr, key, newPtr) \ + (*((tablePtr)->createProc))(tablePtr, key, newPtr) + +/* + * 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) +#define TCL_TIMER_EVENTS (1<<4) +#define TCL_IDLE_EVENTS (1<<5) /* WAS 0x10 ???? */ +#define TCL_ALL_EVENTS (~TCL_DONT_WAIT) + +/* + * The following structure defines a generic event for the Tcl event + * system. These are the things that are queued in calls to Tcl_QueueEvent + * and serviced later by Tcl_DoOneEvent. There can be many different + * kinds of events with different fields, corresponding to window events, + * timer events, etc. The structure for a particular event consists of + * 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 Tk_QueueEvent: + */ + +typedef enum { + TCL_QUEUE_TAIL, TCL_QUEUE_HEAD, TCL_QUEUE_MARK +} Tcl_QueuePosition; + +/* + * 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. */ +} Tcl_Time; + +/* + * 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) + +/* + * Flag values to pass to Tcl_OpenCommandChannel to indicate the + * 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) +#define TCL_ENFORCE_MODE (1<<4) + +/* + * Typedefs for the various operations in a channel type: + */ + +typedef int (Tcl_DriverBlockModeProc) _ANSI_ARGS_((ClientData instanceData, + Tcl_File inFile, Tcl_File outFile, int mode)); +typedef int (Tcl_DriverCloseProc) _ANSI_ARGS_((ClientData instanceData, + Tcl_Interp *interp, Tcl_File inFile, Tcl_File outFile)); +typedef int (Tcl_DriverInputProc) _ANSI_ARGS_((ClientData instanceData, + Tcl_File inFile, char *buf, int toRead, + int *errorCodePtr)); +typedef int (Tcl_DriverOutputProc) _ANSI_ARGS_((ClientData instanceData, + Tcl_File outFile, char *buf, int toWrite, + int *errorCodePtr)); +typedef int (Tcl_DriverSeekProc) _ANSI_ARGS_((ClientData instanceData, + Tcl_File inFile, Tcl_File outFile, long offset, int mode, + int *errorCodePtr)); +typedef int (Tcl_DriverSetOptionProc) _ANSI_ARGS_(( + ClientData instanceData, Tcl_Interp *interp, + char *optionName, char *value)); +typedef int (Tcl_DriverGetOptionProc) _ANSI_ARGS_(( + ClientData instanceData, char *optionName, + Tcl_DString *dsPtr)); + +/* + * 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 collects together in one place all the functions that are + * part of the specific channel type. + */ + +typedef struct Tcl_ChannelType { + char *typeName; /* The name of the channel type in Tcl + * commands. This storage is owned by + * channel type. */ + Tcl_DriverBlockModeProc *blockModeProc; + /* Set blocking mode for the + * raw channel. May be NULL. */ + Tcl_DriverCloseProc *closeProc; /* Procedure to call to close + * the channel. */ + Tcl_DriverInputProc *inputProc; /* Procedure to call for input + * on channel. */ + Tcl_DriverOutputProc *outputProc; /* Procedure to call for output + * on channel. */ + Tcl_DriverSeekProc *seekProc; /* Procedure to call to seek + * on the channel. May be NULL. */ + Tcl_DriverSetOptionProc *setOptionProc; + /* Set an option on a channel. */ + Tcl_DriverGetOptionProc *getOptionProc; + /* Get an option from a channel. */ +} Tcl_ChannelType; + +/* + * The following flags determine whether the blockModeProc above should + * 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 + * mode. */ + +/* + * Types for file handles: + */ + +#define TCL_UNIX_FD 1 +#define TCL_MAC_FILE 2 +#define TCL_MAC_SOCKET 3 +#define TCL_WIN_PIPE 4 +#define TCL_WIN_FILE 5 +#define TCL_WIN_SOCKET 6 +#define TCL_WIN_CONSOLE 7 + +/* + * 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 interface is exported for backwards compatibility, but + * is only implemented on Unix. Portable applications should use + * Tcl_OpenCommandChannel, instead. + */ + +EXTERN int Tcl_CreatePipeline _ANSI_ARGS_((Tcl_Interp *interp, + int argc, char **argv, int **pidArrayPtr, + int *inPipePtr, int *outPipePtr, + int *errFilePtr)); + +/* + * Exported Tcl procedures: + */ + +EXTERN void Tcl_AddErrorInfo _ANSI_ARGS_((Tcl_Interp *interp, + char *message)); +EXTERN void Tcl_AllowExceptions _ANSI_ARGS_((Tcl_Interp *interp)); +EXTERN void Tcl_AppendElement _ANSI_ARGS_((Tcl_Interp *interp, + char *string)); +EXTERN void Tcl_AppendResult _ANSI_ARGS_( + TCL_VARARGS(Tcl_Interp *,interp)); +EXTERN int Tcl_AppInit _ANSI_ARGS_((Tcl_Interp *interp)); +EXTERN Tcl_AsyncHandler Tcl_AsyncCreate _ANSI_ARGS_((Tcl_AsyncProc *proc, + ClientData clientData)); +EXTERN void Tcl_AsyncDelete _ANSI_ARGS_((Tcl_AsyncHandler async)); +EXTERN int Tcl_AsyncInvoke _ANSI_ARGS_((Tcl_Interp *interp, + int code)); +EXTERN void Tcl_AsyncMark _ANSI_ARGS_((Tcl_AsyncHandler async)); +EXTERN int Tcl_AsyncReady _ANSI_ARGS_((void)); +EXTERN void Tcl_BackgroundError _ANSI_ARGS_((Tcl_Interp *interp)); +EXTERN char Tcl_Backslash _ANSI_ARGS_((char *src, + int *readPtr)); +EXTERN void Tcl_CallWhenDeleted _ANSI_ARGS_((Tcl_Interp *interp, + Tcl_InterpDeleteProc *proc, + ClientData clientData)); +EXTERN void Tcl_CancelIdleCall _ANSI_ARGS_((Tcl_IdleProc *idleProc, + ClientData clientData)); +EXTERN VOID * Tcl_Ckalloc _ANSI_ARGS_((unsigned int size)); +EXTERN void Tcl_Ckfree _ANSI_ARGS_((char *ptr)); +EXTERN int Tcl_Close _ANSI_ARGS_((Tcl_Interp *interp, + Tcl_Channel chan)); +EXTERN int Tcl_CommandComplete _ANSI_ARGS_((char *cmd)); +EXTERN char * Tcl_Concat _ANSI_ARGS_((int argc, char **argv)); +EXTERN int Tcl_ConvertElement _ANSI_ARGS_((char *src, + char *dst, int flags)); +EXTERN int Tcl_CreateAlias _ANSI_ARGS_((Tcl_Interp *slave, + char *slaveCmd, Tcl_Interp *target, + char *targetCmd, int argc, char **argv)); +EXTERN Tcl_Channel Tcl_CreateChannel _ANSI_ARGS_(( + Tcl_ChannelType *typePtr, char *chanName, + Tcl_File inFile, Tcl_File outFile, + ClientData instanceData)); +EXTERN void Tcl_CreateChannelHandler _ANSI_ARGS_(( + Tcl_Channel chan, int mask, + Tcl_ChannelProc *proc, ClientData clientData)); +EXTERN void Tcl_CreateCloseHandler _ANSI_ARGS_(( + Tcl_Channel chan, Tcl_CloseProc *proc, + ClientData clientData)); +EXTERN Tcl_Command Tcl_CreateCommand _ANSI_ARGS_((Tcl_Interp *interp, + char *cmdName, Tcl_CmdProc *proc, + ClientData clientData, + Tcl_CmdDeleteProc *deleteProc)); +EXTERN void Tcl_CreateEventSource _ANSI_ARGS_(( + Tcl_EventSetupProc *setupProc, Tcl_EventCheckProc + *checkProc, ClientData clientData)); +EXTERN void Tcl_CreateExitHandler _ANSI_ARGS_((Tcl_ExitProc *proc, + ClientData clientData)); +EXTERN void Tcl_CreateFileHandler _ANSI_ARGS_(( + Tcl_File file, int mask, Tcl_FileProc *proc, + ClientData clientData)); +EXTERN Tcl_Interp * Tcl_CreateInterp _ANSI_ARGS_((void)); +EXTERN void Tcl_CreateMathFunc _ANSI_ARGS_((Tcl_Interp *interp, + char *name, int numArgs, Tcl_ValueType *argTypes, + Tcl_MathProc *proc, ClientData clientData)); +EXTERN void Tcl_CreateModalTimeout _ANSI_ARGS_((int milliseconds, + Tcl_TimerProc *proc, ClientData clientData)); +EXTERN Tcl_Interp *Tcl_CreateSlave _ANSI_ARGS_((Tcl_Interp *interp, + char *slaveName, int isSafe)); +EXTERN Tcl_TimerToken Tcl_CreateTimerHandler _ANSI_ARGS_((int milliseconds, + Tcl_TimerProc *proc, ClientData clientData)); +EXTERN Tcl_Trace Tcl_CreateTrace _ANSI_ARGS_((Tcl_Interp *interp, + int level, Tcl_CmdTraceProc *proc, + ClientData clientData)); +EXTERN char * Tcl_DbCkalloc _ANSI_ARGS_((unsigned int size, + char *file, int line)); +EXTERN int Tcl_DbCkfree _ANSI_ARGS_((char *ptr, + char *file, int line)); +EXTERN char * Tcl_DbCkrealloc _ANSI_ARGS_((char *ptr, + unsigned int size, char *file, int line)); +EXTERN void Tcl_DeleteAssocData _ANSI_ARGS_((Tcl_Interp *interp, + char *name)); +EXTERN int Tcl_DeleteCommand _ANSI_ARGS_((Tcl_Interp *interp, + char *cmdName)); +EXTERN void Tcl_DeleteChannelHandler _ANSI_ARGS_(( + Tcl_Channel chan, Tcl_ChannelProc *proc, + ClientData clientData)); +EXTERN void Tcl_DeleteCloseHandler _ANSI_ARGS_(( + Tcl_Channel chan, Tcl_CloseProc *proc, + ClientData clientData)); +EXTERN void Tcl_DeleteEventSource _ANSI_ARGS_(( + Tcl_EventSetupProc *setupProc, + Tcl_EventCheckProc *checkProc, + ClientData clientData)); +EXTERN void Tcl_DeleteEvents _ANSI_ARGS_(( + Tcl_EventDeleteProc *proc, + ClientData clientData)); +EXTERN void Tcl_DeleteExitHandler _ANSI_ARGS_((Tcl_ExitProc *proc, + ClientData clientData)); +EXTERN void Tcl_DeleteFileHandler _ANSI_ARGS_(( + Tcl_File file)); +EXTERN void Tcl_DeleteHashEntry _ANSI_ARGS_(( + Tcl_HashEntry *entryPtr)); +EXTERN void Tcl_DeleteHashTable _ANSI_ARGS_(( + Tcl_HashTable *tablePtr)); +EXTERN void Tcl_DeleteInterp _ANSI_ARGS_((Tcl_Interp *interp)); +EXTERN void Tcl_DeleteModalTimeout _ANSI_ARGS_(( + Tcl_TimerProc *proc, ClientData clientData)); +EXTERN void Tcl_DeleteTimerHandler _ANSI_ARGS_(( + Tcl_TimerToken token)); +EXTERN void Tcl_DeleteTrace _ANSI_ARGS_((Tcl_Interp *interp, + Tcl_Trace trace)); +EXTERN void Tcl_DetachPids _ANSI_ARGS_((int numPids, int *pidPtr)); +EXTERN void Tcl_DontCallWhenDeleted _ANSI_ARGS_(( + Tcl_Interp *interp, Tcl_InterpDeleteProc *proc, + ClientData clientData)); +EXTERN int Tcl_DoOneEvent _ANSI_ARGS_((int flags)); +EXTERN void Tcl_DoWhenIdle _ANSI_ARGS_((Tcl_IdleProc *proc, + ClientData clientData)); +EXTERN char * Tcl_DStringAppend _ANSI_ARGS_((Tcl_DString *dsPtr, + char *string, int length)); +EXTERN char * Tcl_DStringAppendElement _ANSI_ARGS_(( + Tcl_DString *dsPtr, char *string)); +EXTERN void Tcl_DStringEndSublist _ANSI_ARGS_((Tcl_DString *dsPtr)); +EXTERN void Tcl_DStringFree _ANSI_ARGS_((Tcl_DString *dsPtr)); +EXTERN void Tcl_DStringGetResult _ANSI_ARGS_((Tcl_Interp *interp, + Tcl_DString *dsPtr)); +EXTERN void Tcl_DStringInit _ANSI_ARGS_((Tcl_DString *dsPtr)); +EXTERN void Tcl_DStringResult _ANSI_ARGS_((Tcl_Interp *interp, + Tcl_DString *dsPtr)); +EXTERN void Tcl_DStringSetLength _ANSI_ARGS_((Tcl_DString *dsPtr, + int length)); +EXTERN void Tcl_DStringStartSublist _ANSI_ARGS_(( + Tcl_DString *dsPtr)); +EXTERN int Tcl_Eof _ANSI_ARGS_((Tcl_Channel chan)); +EXTERN char * Tcl_ErrnoId _ANSI_ARGS_((void)); +EXTERN char * Tcl_ErrnoMsg _ANSI_ARGS_((int err)); +EXTERN int Tcl_Eval _ANSI_ARGS_((Tcl_Interp *interp, char *cmd)); +EXTERN int Tcl_EvalFile _ANSI_ARGS_((Tcl_Interp *interp, + char *fileName)); +EXTERN void Tcl_EventuallyFree _ANSI_ARGS_((ClientData clientData, + Tcl_FreeProc *freeProc)); +EXTERN void Tcl_Exit _ANSI_ARGS_((int status)); +EXTERN int Tcl_ExprBoolean _ANSI_ARGS_((Tcl_Interp *interp, + char *string, int *ptr)); +EXTERN int Tcl_ExprDouble _ANSI_ARGS_((Tcl_Interp *interp, + char *string, double *ptr)); +EXTERN int Tcl_ExprLong _ANSI_ARGS_((Tcl_Interp *interp, + char *string, long *ptr)); +EXTERN int Tcl_ExprString _ANSI_ARGS_((Tcl_Interp *interp, + char *string)); +EXTERN int Tcl_FileReady _ANSI_ARGS_((Tcl_File file, + int mask)); +EXTERN void Tcl_FindExecutable _ANSI_ARGS_((char *argv0)); +EXTERN Tcl_HashEntry * Tcl_FirstHashEntry _ANSI_ARGS_(( + Tcl_HashTable *tablePtr, + Tcl_HashSearch *searchPtr)); +EXTERN int Tcl_Flush _ANSI_ARGS_((Tcl_Channel chan)); +EXTERN void Tcl_FreeFile _ANSI_ARGS_(( + Tcl_File file)); +EXTERN int Tcl_GetAlias _ANSI_ARGS_((Tcl_Interp *interp, + char *slaveCmd, Tcl_Interp **targetInterpPtr, + char **targetCmdPtr, int *argcPtr, + char ***argvPtr)); +EXTERN ClientData Tcl_GetAssocData _ANSI_ARGS_((Tcl_Interp *interp, + char *name, Tcl_InterpDeleteProc **procPtr)); +EXTERN int Tcl_GetBoolean _ANSI_ARGS_((Tcl_Interp *interp, + char *string, int *boolPtr)); +EXTERN Tcl_Channel Tcl_GetChannel _ANSI_ARGS_((Tcl_Interp *interp, + char *chanName, int *modePtr)); +EXTERN int Tcl_GetChannelBufferSize _ANSI_ARGS_(( + Tcl_Channel chan)); +EXTERN Tcl_File Tcl_GetChannelFile _ANSI_ARGS_((Tcl_Channel chan, + int direction)); +EXTERN ClientData Tcl_GetChannelInstanceData _ANSI_ARGS_(( + Tcl_Channel chan)); +EXTERN int Tcl_GetChannelOption _ANSI_ARGS_((Tcl_Channel chan, + char *optionName, Tcl_DString *dsPtr)); +EXTERN char * Tcl_GetChannelName _ANSI_ARGS_((Tcl_Channel chan)); +EXTERN Tcl_ChannelType * Tcl_GetChannelType _ANSI_ARGS_((Tcl_Channel chan)); +EXTERN int Tcl_GetCommandInfo _ANSI_ARGS_((Tcl_Interp *interp, + char *cmdName, Tcl_CmdInfo *infoPtr)); +EXTERN char * Tcl_GetCommandName _ANSI_ARGS_((Tcl_Interp *interp, + Tcl_Command command)); +EXTERN char * Tcl_GetCwd _ANSI_ARGS_((char *buf, int len)); +EXTERN int Tcl_GetDouble _ANSI_ARGS_((Tcl_Interp *interp, + char *string, double *doublePtr)); +EXTERN int Tcl_GetErrno _ANSI_ARGS_((void)); +EXTERN Tcl_File Tcl_GetFile _ANSI_ARGS_((ClientData fileData, + int type)); +EXTERN ClientData Tcl_GetFileInfo _ANSI_ARGS_((Tcl_File file, + int *typePtr)); +EXTERN char * Tcl_GetHostName _ANSI_ARGS_((void)); +EXTERN int Tcl_GetInt _ANSI_ARGS_((Tcl_Interp *interp, + char *string, int *intPtr)); +EXTERN int Tcl_GetInterpPath _ANSI_ARGS_((Tcl_Interp *askInterp, + Tcl_Interp *slaveInterp)); +EXTERN Tcl_Interp *Tcl_GetMaster _ANSI_ARGS_((Tcl_Interp *interp)); +EXTERN ClientData Tcl_GetNotifierData _ANSI_ARGS_((Tcl_File file, + Tcl_FileFreeProc **freeProcPtr)); +EXTERN int Tcl_GetOpenFile _ANSI_ARGS_((Tcl_Interp *interp, + char *string, int write, int checkUsage, + ClientData *filePtr)); +EXTERN Tcl_PathType Tcl_GetPathType _ANSI_ARGS_((char *path)); +EXTERN int Tcl_Gets _ANSI_ARGS_((Tcl_Channel chan, + Tcl_DString *dsPtr)); +EXTERN Tcl_Interp *Tcl_GetSlave _ANSI_ARGS_((Tcl_Interp *interp, + char *slaveName)); +EXTERN Tcl_Channel Tcl_GetStdChannel _ANSI_ARGS_((int type)); +EXTERN char * Tcl_GetVar _ANSI_ARGS_((Tcl_Interp *interp, + char *varName, int flags)); +EXTERN char * Tcl_GetVar2 _ANSI_ARGS_((Tcl_Interp *interp, + char *part1, char *part2, int flags)); +EXTERN int Tcl_GlobalEval _ANSI_ARGS_((Tcl_Interp *interp, + char *command)); +EXTERN char * Tcl_HashStats _ANSI_ARGS_((Tcl_HashTable *tablePtr)); +EXTERN int Tcl_Init _ANSI_ARGS_((Tcl_Interp *interp)); +EXTERN void Tcl_InitHashTable _ANSI_ARGS_((Tcl_HashTable *tablePtr, + int keyType)); +EXTERN void Tcl_InitMemory _ANSI_ARGS_((Tcl_Interp *interp)); +EXTERN int Tcl_InputBlocked _ANSI_ARGS_((Tcl_Channel chan)); +EXTERN int Tcl_InputBuffered _ANSI_ARGS_((Tcl_Channel chan)); +EXTERN int Tcl_InterpDeleted _ANSI_ARGS_((Tcl_Interp *interp)); +EXTERN int Tcl_IsSafe _ANSI_ARGS_((Tcl_Interp *interp)); +EXTERN char * Tcl_JoinPath _ANSI_ARGS_((int argc, char **argv, + Tcl_DString *resultPtr)); +EXTERN int Tcl_LinkVar _ANSI_ARGS_((Tcl_Interp *interp, + char *varName, char *addr, int type)); +EXTERN void Tcl_Main _ANSI_ARGS_((int argc, char **argv, + Tcl_AppInitProc *appInitProc)); +EXTERN Tcl_Channel Tcl_MakeFileChannel _ANSI_ARGS_((ClientData inFile, + ClientData outFile, int mode)); +EXTERN int Tcl_MakeSafe _ANSI_ARGS_((Tcl_Interp *interp)); +EXTERN Tcl_Channel Tcl_MakeTcpClientChannel _ANSI_ARGS_(( + ClientData tcpSocket)); +EXTERN char * Tcl_Merge _ANSI_ARGS_((int argc, char **argv)); +EXTERN Tcl_HashEntry * Tcl_NextHashEntry _ANSI_ARGS_(( + Tcl_HashSearch *searchPtr)); +EXTERN Tcl_Channel Tcl_OpenCommandChannel _ANSI_ARGS_(( + Tcl_Interp *interp, int argc, char **argv, + int flags)); +EXTERN Tcl_Channel Tcl_OpenFileChannel _ANSI_ARGS_((Tcl_Interp *interp, + char *fileName, char *modeString, + int permissions)); +EXTERN Tcl_Channel Tcl_OpenTcpClient _ANSI_ARGS_((Tcl_Interp *interp, + int port, char *address, char *myaddr, + int myport, int async)); +EXTERN Tcl_Channel Tcl_OpenTcpServer _ANSI_ARGS_((Tcl_Interp *interp, + int port, char *host, + Tcl_TcpAcceptProc *acceptProc, + ClientData callbackData)); +EXTERN char * Tcl_ParseVar _ANSI_ARGS_((Tcl_Interp *interp, + char *string, char **termPtr)); +EXTERN int Tcl_PkgProvide _ANSI_ARGS_((Tcl_Interp *interp, + char *name, char *version)); +EXTERN char * Tcl_PkgRequire _ANSI_ARGS_((Tcl_Interp *interp, + char *name, char *version, int exact)); +EXTERN char * Tcl_PosixError _ANSI_ARGS_((Tcl_Interp *interp)); +EXTERN void Tcl_Preserve _ANSI_ARGS_((ClientData data)); +EXTERN void Tcl_PrintDouble _ANSI_ARGS_((Tcl_Interp *interp, + double value, char *dst)); +EXTERN int Tcl_PutEnv _ANSI_ARGS_((CONST char *string)); +EXTERN void Tcl_QueueEvent _ANSI_ARGS_((Tcl_Event *evPtr, + Tcl_QueuePosition position)); +EXTERN int Tcl_Read _ANSI_ARGS_((Tcl_Channel chan, + char *bufPtr, int toRead)); +EXTERN void Tcl_ReapDetachedProcs _ANSI_ARGS_((void)); +EXTERN int Tcl_RecordAndEval _ANSI_ARGS_((Tcl_Interp *interp, + char *cmd, int flags)); +EXTERN Tcl_RegExp Tcl_RegExpCompile _ANSI_ARGS_((Tcl_Interp *interp, + char *string)); +EXTERN int Tcl_RegExpExec _ANSI_ARGS_((Tcl_Interp *interp, + Tcl_RegExp regexp, char *string, char *start)); +EXTERN int Tcl_RegExpMatch _ANSI_ARGS_((Tcl_Interp *interp, + char *string, char *pattern)); +EXTERN void Tcl_RegExpRange _ANSI_ARGS_((Tcl_RegExp regexp, + int index, char **startPtr, char **endPtr)); +EXTERN void Tcl_RegisterChannel _ANSI_ARGS_((Tcl_Interp *interp, + Tcl_Channel chan)); +EXTERN void Tcl_Release _ANSI_ARGS_((ClientData clientData)); +EXTERN void Tcl_ResetResult _ANSI_ARGS_((Tcl_Interp *interp)); +#define Tcl_Return Tcl_SetResult +EXTERN int Tcl_ScanElement _ANSI_ARGS_((char *string, + int *flagPtr)); +EXTERN int Tcl_Seek _ANSI_ARGS_((Tcl_Channel chan, + int offset, int mode)); +EXTERN void Tcl_SetAssocData _ANSI_ARGS_((Tcl_Interp *interp, + char *name, Tcl_InterpDeleteProc *proc, + ClientData clientData)); +EXTERN void Tcl_SetChannelBufferSize _ANSI_ARGS_(( + Tcl_Channel chan, int sz)); +EXTERN int Tcl_SetChannelOption _ANSI_ARGS_(( + Tcl_Interp *interp, Tcl_Channel chan, + char *optionName, char *newValue)); +EXTERN int Tcl_SetCommandInfo _ANSI_ARGS_((Tcl_Interp *interp, + char *cmdName, Tcl_CmdInfo *infoPtr)); +EXTERN void Tcl_SetErrno _ANSI_ARGS_((int errno)); +EXTERN void Tcl_SetErrorCode _ANSI_ARGS_( + TCL_VARARGS(Tcl_Interp *,interp)); +EXTERN void Tcl_SetMaxBlockTime _ANSI_ARGS_((Tcl_Time *timePtr)); +EXTERN void Tcl_SetNotifierData _ANSI_ARGS_((Tcl_File file, + Tcl_FileFreeProc *freeProcPtr, ClientData data)); +EXTERN void Tcl_SetPanicProc _ANSI_ARGS_((void (*proc) + _ANSI_ARGS_(TCL_VARARGS(char *, format)))); +EXTERN int Tcl_SetRecursionLimit _ANSI_ARGS_((Tcl_Interp *interp, + int depth)); +EXTERN void Tcl_SetResult _ANSI_ARGS_((Tcl_Interp *interp, + char *string, Tcl_FreeProc *freeProc)); +EXTERN void Tcl_SetStdChannel _ANSI_ARGS_((Tcl_Channel channel, + int type)); +EXTERN char * Tcl_SetVar _ANSI_ARGS_((Tcl_Interp *interp, + char *varName, char *newValue, int flags)); +EXTERN char * Tcl_SetVar2 _ANSI_ARGS_((Tcl_Interp *interp, + char *part1, char *part2, char *newValue, + int flags)); +EXTERN char * Tcl_SignalId _ANSI_ARGS_((int sig)); +EXTERN char * Tcl_SignalMsg _ANSI_ARGS_((int sig)); +EXTERN void Tcl_Sleep _ANSI_ARGS_((int ms)); +EXTERN int Tcl_SplitList _ANSI_ARGS_((Tcl_Interp *interp, + char *list, int *argcPtr, char ***argvPtr)); +EXTERN void Tcl_SplitPath _ANSI_ARGS_((char *path, + int *argcPtr, char ***argvPtr)); +EXTERN void Tcl_StaticPackage _ANSI_ARGS_((Tcl_Interp *interp, + char *pkgName, Tcl_PackageInitProc *initProc, + Tcl_PackageInitProc *safeInitProc)); +EXTERN int Tcl_StringMatch _ANSI_ARGS_((char *string, + char *pattern)); +EXTERN int Tcl_Tell _ANSI_ARGS_((Tcl_Channel chan)); +#define Tcl_TildeSubst Tcl_TranslateFileName +EXTERN int Tcl_TraceVar _ANSI_ARGS_((Tcl_Interp *interp, + char *varName, int flags, Tcl_VarTraceProc *proc, + ClientData clientData)); +EXTERN int Tcl_TraceVar2 _ANSI_ARGS_((Tcl_Interp *interp, + char *part1, char *part2, int flags, + Tcl_VarTraceProc *proc, ClientData clientData)); +EXTERN char * Tcl_TranslateFileName _ANSI_ARGS_((Tcl_Interp *interp, + char *name, Tcl_DString *bufferPtr)); +EXTERN void Tcl_UnlinkVar _ANSI_ARGS_((Tcl_Interp *interp, + char *varName)); +EXTERN int Tcl_UnregisterChannel _ANSI_ARGS_((Tcl_Interp *interp, + Tcl_Channel chan)); +EXTERN int Tcl_UnsetVar _ANSI_ARGS_((Tcl_Interp *interp, + char *varName, int flags)); +EXTERN int Tcl_UnsetVar2 _ANSI_ARGS_((Tcl_Interp *interp, + char *part1, char *part2, int flags)); +EXTERN void Tcl_UntraceVar _ANSI_ARGS_((Tcl_Interp *interp, + char *varName, int flags, Tcl_VarTraceProc *proc, + ClientData clientData)); +EXTERN void Tcl_UntraceVar2 _ANSI_ARGS_((Tcl_Interp *interp, + char *part1, char *part2, int flags, + Tcl_VarTraceProc *proc, ClientData clientData)); +EXTERN void Tcl_UpdateLinkedVar _ANSI_ARGS_((Tcl_Interp *interp, + char *varName)); +EXTERN int Tcl_UpVar _ANSI_ARGS_((Tcl_Interp *interp, + char *frameName, char *varName, + char *localName, int flags)); +EXTERN int Tcl_UpVar2 _ANSI_ARGS_((Tcl_Interp *interp, + char *frameName, char *part1, char *part2, + char *localName, int flags)); +EXTERN int Tcl_VarEval _ANSI_ARGS_( + TCL_VARARGS(Tcl_Interp *,interp)); +EXTERN ClientData Tcl_VarTraceInfo _ANSI_ARGS_((Tcl_Interp *interp, + char *varName, int flags, + Tcl_VarTraceProc *procPtr, + ClientData prevClientData)); +EXTERN ClientData Tcl_VarTraceInfo2 _ANSI_ARGS_((Tcl_Interp *interp, + char *part1, char *part2, int flags, + Tcl_VarTraceProc *procPtr, + ClientData prevClientData)); +EXTERN int Tcl_WaitForEvent _ANSI_ARGS_((Tcl_Time *timePtr)); +EXTERN int Tcl_WaitPid _ANSI_ARGS_((int pid, int *statPtr, + int options)); +EXTERN void Tcl_WatchFile _ANSI_ARGS_((Tcl_File file, + int mask)); +EXTERN int Tcl_Write _ANSI_ARGS_((Tcl_Channel chan, + char *s, int slen)); + +#endif /* _TCL */ diff --git a/contrib/tcl/generic/tclAsync.c b/contrib/tcl/generic/tclAsync.c new file mode 100644 index 0000000..905b664 --- /dev/null +++ b/contrib/tcl/generic/tclAsync.c @@ -0,0 +1,265 @@ +/* + * tclAsync.c -- + * + * This file provides low-level support needed to invoke signal + * handlers in a safe way. The code here doesn't actually handle + * signals, though. This code is based on proposals made by + * Mark Diekhans and Don Libes. + * + * 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: @(#) tclAsync.c 1.6 96/02/15 11:46:15 + */ + +#include "tclInt.h" + +/* + * One of the following structures exists for each asynchronous + * handler: + */ + +typedef struct AsyncHandler { + int ready; /* Non-zero means this handler should + * be invoked in the next call to + * Tcl_AsyncInvoke. */ + struct AsyncHandler *nextPtr; /* Next in list of all handlers for + * the process. */ + Tcl_AsyncProc *proc; /* Procedure to call when handler + * is invoked. */ + ClientData clientData; /* Value to pass to handler when it + * is invoked. */ +} 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. */ + +/* + * 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. + */ + +static int asyncReady = 0; + +/* + * 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 asyncActive = 0; + +/* + *---------------------------------------------------------------------- + * + * Tcl_AsyncCreate -- + * + * This procedure creates the data structures for an asynchronous + * handler, so that no memory has to be allocated when the handler + * is activated. + * + * Results: + * The return value is a token for the handler, which can be used + * to activate it later on. + * + * Side effects: + * Information about the handler is recorded. + * + *---------------------------------------------------------------------- + */ + +Tcl_AsyncHandler +Tcl_AsyncCreate(proc, clientData) + Tcl_AsyncProc *proc; /* Procedure to call when handler + * is invoked. */ + ClientData clientData; /* Argument to pass to handler. */ +{ + AsyncHandler *asyncPtr; + + asyncPtr = (AsyncHandler *) ckalloc(sizeof(AsyncHandler)); + asyncPtr->ready = 0; + asyncPtr->nextPtr = NULL; + asyncPtr->proc = proc; + asyncPtr->clientData = clientData; + if (firstHandler == NULL) { + firstHandler = asyncPtr; + } else { + lastHandler->nextPtr = asyncPtr; + } + lastHandler = asyncPtr; + return (Tcl_AsyncHandler) asyncPtr; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_AsyncMark -- + * + * This procedure is called to request that an asynchronous handler + * be invoked as soon as possible. It's typically called from + * an interrupt handler, where it isn't safe to do anything that + * depends on or modifies application state. + * + * Results: + * None. + * + * Side effects: + * The handler gets marked for invocation later. + * + *---------------------------------------------------------------------- + */ + +void +Tcl_AsyncMark(async) + Tcl_AsyncHandler async; /* Token for handler. */ +{ + ((AsyncHandler *) async)->ready = 1; + if (!asyncActive) { + asyncReady = 1; + } +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_AsyncInvoke -- + * + * This procedure is called at a "safe" time at background level + * to invoke any active asynchronous handlers. + * + * Results: + * The return value is a normal Tcl result, which is intended to + * replace the code argument as the current completion code for + * interp. + * + * Side effects: + * Depends on the handlers that are active. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_AsyncInvoke(interp, code) + Tcl_Interp *interp; /* If invoked from Tcl_Eval just after + * completing a command, points to + * interpreter. Otherwise it is + * NULL. */ + int code; /* If interp is non-NULL, this gives + * completion code from command that + * just completed. */ +{ + AsyncHandler *asyncPtr; + + if (asyncReady == 0) { + return code; + } + asyncReady = 0; + asyncActive = 1; + if (interp == NULL) { + code = 0; + } + + /* + * Make one or more passes over the list of handlers, invoking + * at most one handler in each pass. After invoking a handler, + * go back to the start of the list again so that (a) if a new + * higher-priority handler gets marked while executing a lower + * priority handler, we execute the higher-priority handler + * next, and (b) if a handler gets deleted during the execution + * of a handler, then the list structure may change so it isn't + * safe to continue down the list anyway. + */ + + while (1) { + for (asyncPtr = firstHandler; asyncPtr != NULL; + asyncPtr = asyncPtr->nextPtr) { + if (asyncPtr->ready) { + break; + } + } + if (asyncPtr == NULL) { + break; + } + asyncPtr->ready = 0; + code = (*asyncPtr->proc)(asyncPtr->clientData, interp, code); + } + asyncActive = 0; + return code; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_AsyncDelete -- + * + * Frees up all the state for an asynchronous handler. The handler + * should never be used again. + * + * Results: + * None. + * + * Side effects: + * The state associated with the handler is deleted. + * + *---------------------------------------------------------------------- + */ + +void +Tcl_AsyncDelete(async) + Tcl_AsyncHandler async; /* Token for handler to delete. */ +{ + AsyncHandler *asyncPtr = (AsyncHandler *) async; + AsyncHandler *prevPtr; + + if (firstHandler == asyncPtr) { + firstHandler = asyncPtr->nextPtr; + if (firstHandler == NULL) { + lastHandler = NULL; + } + } else { + prevPtr = firstHandler; + while (prevPtr->nextPtr != asyncPtr) { + prevPtr = prevPtr->nextPtr; + } + prevPtr->nextPtr = asyncPtr->nextPtr; + if (lastHandler == asyncPtr) { + lastHandler = prevPtr; + } + } + ckfree((char *) asyncPtr); +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_AsyncReady -- + * + * 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. + * + * Results: + * The return value is 1 whenever a handler is ready and is 0 + * when no handlers are ready. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_AsyncReady() +{ + return asyncReady; +} diff --git a/contrib/tcl/generic/tclBasic.c b/contrib/tcl/generic/tclBasic.c new file mode 100644 index 0000000..e081402 --- /dev/null +++ b/contrib/tcl/generic/tclBasic.c @@ -0,0 +1,1826 @@ +/* + * tclBasic.c -- + * + * Contains the basic facilities for TCL command interpretation, + * including interpreter creation and deletion, command creation + * and deletion, and command parsing and execution. + * + * Copyright (c) 1987-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: @(#) tclBasic.c 1.210 96/03/25 17:17:54 + */ + +#include "tclInt.h" +#ifndef TCL_GENERIC_ONLY +# include "tclPort.h" +#endif +#include "patchlevel.h" + +/* + * Static procedures in this file: + */ + +static void DeleteInterpProc _ANSI_ARGS_((Tcl_Interp *interp)); + +/* + * The following structure defines all of the commands in the Tcl core, + * and the C procedures that execute them. + */ + +typedef struct { + char *name; /* Name of command. */ + Tcl_CmdProc *proc; /* Procedure that executes command. */ +} CmdInfo; + +/* + * Built-in commands, and the procedures associated with them: + */ + +static CmdInfo builtInCmds[] = { + /* + * Commands in the generic core: + */ + + {"append", Tcl_AppendCmd}, + {"array", Tcl_ArrayCmd}, + {"break", Tcl_BreakCmd}, + {"case", Tcl_CaseCmd}, + {"catch", Tcl_CatchCmd}, + {"clock", Tcl_ClockCmd}, + {"concat", Tcl_ConcatCmd}, + {"continue", Tcl_ContinueCmd}, + {"error", Tcl_ErrorCmd}, + {"eval", Tcl_EvalCmd}, + {"exit", Tcl_ExitCmd}, + {"expr", Tcl_ExprCmd}, + {"fileevent", Tcl_FileEventCmd}, + {"for", Tcl_ForCmd}, + {"foreach", Tcl_ForeachCmd}, + {"format", Tcl_FormatCmd}, + {"global", Tcl_GlobalCmd}, + {"history", Tcl_HistoryCmd}, + {"if", Tcl_IfCmd}, + {"incr", Tcl_IncrCmd}, + {"info", Tcl_InfoCmd}, + {"interp", Tcl_InterpCmd}, + {"join", Tcl_JoinCmd}, + {"lappend", Tcl_LappendCmd}, + {"lindex", Tcl_LindexCmd}, + {"linsert", Tcl_LinsertCmd}, + {"list", Tcl_ListCmd}, + {"llength", Tcl_LlengthCmd}, + {"load", Tcl_LoadCmd}, + {"lrange", Tcl_LrangeCmd}, + {"lreplace", Tcl_LreplaceCmd}, + {"lsearch", Tcl_LsearchCmd}, + {"lsort", Tcl_LsortCmd}, + {"package", Tcl_PackageCmd}, + {"proc", Tcl_ProcCmd}, + {"regexp", Tcl_RegexpCmd}, + {"regsub", Tcl_RegsubCmd}, + {"rename", Tcl_RenameCmd}, + {"return", Tcl_ReturnCmd}, + {"scan", Tcl_ScanCmd}, + {"set", Tcl_SetCmd}, + {"split", Tcl_SplitCmd}, + {"string", Tcl_StringCmd}, + {"subst", Tcl_SubstCmd}, + {"switch", Tcl_SwitchCmd}, + {"trace", Tcl_TraceCmd}, + {"unset", Tcl_UnsetCmd}, + {"uplevel", Tcl_UplevelCmd}, + {"upvar", Tcl_UpvarCmd}, + {"while", Tcl_WhileCmd}, + + /* + * Commands in the UNIX core: + */ + +#ifndef TCL_GENERIC_ONLY + {"after", Tcl_AfterCmd}, + {"cd", Tcl_CdCmd}, + {"close", Tcl_CloseCmd}, + {"eof", Tcl_EofCmd}, + {"fblocked", Tcl_FblockedCmd}, + {"fconfigure", Tcl_FconfigureCmd}, + {"file", Tcl_FileCmd}, + {"flush", Tcl_FlushCmd}, + {"gets", Tcl_GetsCmd}, + {"glob", Tcl_GlobCmd}, + {"open", Tcl_OpenCmd}, + {"pid", Tcl_PidCmd}, + {"puts", Tcl_PutsCmd}, + {"pwd", Tcl_PwdCmd}, + {"read", Tcl_ReadCmd}, + {"seek", Tcl_SeekCmd}, + {"socket", Tcl_SocketCmd}, + {"tell", Tcl_TellCmd}, + {"time", Tcl_TimeCmd}, + {"update", Tcl_UpdateCmd}, + {"vwait", Tcl_VwaitCmd}, + {"unsupported0", TclUnsupported0Cmd}, + +#ifndef MAC_TCL + {"exec", Tcl_ExecCmd}, + {"source", Tcl_SourceCmd}, +#endif + +#ifdef MAC_TCL + {"beep", Tcl_MacBeepCmd}, + {"cp", Tcl_CpCmd}, + {"echo", Tcl_EchoCmd}, + {"ls", Tcl_LsCmd}, + {"mkdir", Tcl_MkdirCmd}, + {"mv", Tcl_MvCmd}, + {"rm", Tcl_RmCmd}, + {"rmdir", Tcl_RmdirCmd}, + {"source", Tcl_MacSourceCmd}, +#endif /* MAC_TCL */ + +#endif /* TCL_GENERIC_ONLY */ + {NULL, (Tcl_CmdProc *) NULL} +}; + +/* + *---------------------------------------------------------------------- + * + * Tcl_CreateInterp -- + * + * Create a new TCL command interpreter. + * + * Results: + * The return value is a token for the interpreter, which may be + * used in calls to procedures like Tcl_CreateCmd, Tcl_Eval, or + * Tcl_DeleteInterp. + * + * Side effects: + * The command interpreter is initialized with an empty variable + * table and the built-in commands. + * + *---------------------------------------------------------------------- + */ + +Tcl_Interp * +Tcl_CreateInterp() +{ + register Interp *iPtr; + register Command *cmdPtr; + register CmdInfo *cmdInfoPtr; + Tcl_Channel chan; + int i; + + iPtr = (Interp *) ckalloc(sizeof(Interp)); + iPtr->result = iPtr->resultSpace; + iPtr->freeProc = 0; + iPtr->errorLine = 0; + Tcl_InitHashTable(&iPtr->commandTable, TCL_STRING_KEYS); + Tcl_InitHashTable(&iPtr->mathFuncTable, TCL_STRING_KEYS); + Tcl_InitHashTable(&iPtr->globalTable, TCL_STRING_KEYS); + iPtr->numLevels = 0; + iPtr->maxNestingDepth = 1000; + iPtr->framePtr = NULL; + iPtr->varFramePtr = NULL; + iPtr->activeTracePtr = NULL; + iPtr->returnCode = TCL_OK; + iPtr->errorInfo = NULL; + iPtr->errorCode = NULL; + iPtr->numEvents = 0; + iPtr->events = NULL; + iPtr->curEvent = 0; + iPtr->curEventNum = 0; + iPtr->revPtr = NULL; + iPtr->historyFirst = NULL; + iPtr->revDisables = 1; + iPtr->evalFirst = iPtr->evalLast = NULL; + iPtr->appendResult = NULL; + iPtr->appendAvl = 0; + iPtr->appendUsed = 0; + for (i = 0; i < NUM_REGEXPS; i++) { + iPtr->patterns[i] = NULL; + iPtr->patLengths[i] = -1; + iPtr->regexps[i] = NULL; + } + Tcl_InitHashTable(&iPtr->packageTable, TCL_STRING_KEYS); + iPtr->packageUnknown = NULL; + strcpy(iPtr->pdFormat, DEFAULT_PD_FORMAT); + iPtr->pdPrec = DEFAULT_PD_PREC; + iPtr->cmdCount = 0; + iPtr->noEval = 0; + iPtr->evalFlags = 0; + iPtr->scriptFile = NULL; + iPtr->flags = 0; + iPtr->tracePtr = NULL; + iPtr->assocData = (Tcl_HashTable *) NULL; + iPtr->resultSpace[0] = 0; + + /* + * Create the built-in commands. Do it here, rather than calling + * Tcl_CreateCommand, because it's faster (there's no need to + * check for a pre-existing command by the same name). + */ + + for (cmdInfoPtr = builtInCmds; cmdInfoPtr->name != NULL; cmdInfoPtr++) { + int new; + Tcl_HashEntry *hPtr; + + hPtr = Tcl_CreateHashEntry(&iPtr->commandTable, + cmdInfoPtr->name, &new); + if (new) { + cmdPtr = (Command *) ckalloc(sizeof(Command)); + cmdPtr->hPtr = hPtr; + cmdPtr->proc = cmdInfoPtr->proc; + cmdPtr->clientData = (ClientData) NULL; + cmdPtr->deleteProc = NULL; + cmdPtr->deleteData = (ClientData) NULL; + cmdPtr->deleted = 0; + Tcl_SetHashValue(hPtr, cmdPtr); + } + } + +#ifndef TCL_GENERIC_ONLY + TclSetupEnv((Tcl_Interp *) iPtr); +#endif + + /* + * Do Safe-Tcl init stuff + */ + + (void) TclInterpInit((Tcl_Interp *)iPtr); + + /* + * Set up variables such as tcl_library and tcl_precision. + */ + + TclPlatformInit((Tcl_Interp *)iPtr); + Tcl_SetVar((Tcl_Interp *) iPtr, "tcl_patchLevel", TCL_PATCH_LEVEL, + TCL_GLOBAL_ONLY); + Tcl_SetVar((Tcl_Interp *) iPtr, "tcl_version", TCL_VERSION, + TCL_GLOBAL_ONLY); + Tcl_TraceVar2((Tcl_Interp *) iPtr, "tcl_precision", (char *) NULL, + TCL_GLOBAL_ONLY|TCL_TRACE_WRITES|TCL_TRACE_UNSETS, + TclPrecTraceProc, (ClientData) NULL); + + /* + * Register Tcl's version number. + */ + + Tcl_PkgProvide((Tcl_Interp *) iPtr, "Tcl", TCL_VERSION); + + /* + * Add the standard channels. + */ + + chan = Tcl_GetStdChannel(TCL_STDIN); + if (chan != (Tcl_Channel) NULL) { + Tcl_RegisterChannel((Tcl_Interp *) iPtr, chan); + } + chan = Tcl_GetStdChannel(TCL_STDOUT); + if (chan != (Tcl_Channel) NULL) { + Tcl_RegisterChannel((Tcl_Interp *) iPtr, chan); + } + chan = Tcl_GetStdChannel(TCL_STDERR); + if (chan != (Tcl_Channel) NULL) { + Tcl_RegisterChannel((Tcl_Interp *) iPtr, chan); + } + + return (Tcl_Interp *) iPtr; +} + +/* + *-------------------------------------------------------------- + * + * Tcl_CallWhenDeleted -- + * + * Arrange for a procedure to be called before a given + * interpreter is deleted. The procedure is called as soon + * as Tcl_DeleteInterp is called; if Tcl_CallWhenDeleted is + * called on an interpreter that has already been deleted, + * the procedure will be called when the last Tcl_Release is + * done on the interpreter. + * + * Results: + * None. + * + * Side effects: + * When Tcl_DeleteInterp is invoked to delete interp, + * proc will be invoked. See the manual entry for + * details. + * + *-------------------------------------------------------------- + */ + +void +Tcl_CallWhenDeleted(interp, proc, clientData) + Tcl_Interp *interp; /* Interpreter to watch. */ + Tcl_InterpDeleteProc *proc; /* Procedure to call when interpreter + * is about to be deleted. */ + ClientData clientData; /* One-word value to pass to proc. */ +{ + Interp *iPtr = (Interp *) interp; + static int assocDataCounter = 0; + int new; + char buffer[128]; + AssocData *dPtr = (AssocData *) ckalloc(sizeof(AssocData)); + Tcl_HashEntry *hPtr; + + sprintf(buffer, "Assoc Data Key #%d", assocDataCounter); + assocDataCounter++; + + if (iPtr->assocData == (Tcl_HashTable *) NULL) { + iPtr->assocData = (Tcl_HashTable *) ckalloc(sizeof(Tcl_HashTable)); + Tcl_InitHashTable(iPtr->assocData, TCL_STRING_KEYS); + } + hPtr = Tcl_CreateHashEntry(iPtr->assocData, buffer, &new); + dPtr->proc = proc; + dPtr->clientData = clientData; + Tcl_SetHashValue(hPtr, dPtr); +} + +/* + *-------------------------------------------------------------- + * + * Tcl_DontCallWhenDeleted -- + * + * Cancel the arrangement for a procedure to be called when + * a given interpreter is deleted. + * + * Results: + * None. + * + * Side effects: + * If proc and clientData were previously registered as a + * callback via Tcl_CallWhenDeleted, they are unregistered. + * If they weren't previously registered then nothing + * happens. + * + *-------------------------------------------------------------- + */ + +void +Tcl_DontCallWhenDeleted(interp, proc, clientData) + Tcl_Interp *interp; /* Interpreter to watch. */ + Tcl_InterpDeleteProc *proc; /* Procedure to call when interpreter + * is about to be deleted. */ + ClientData clientData; /* One-word value to pass to proc. */ +{ + Interp *iPtr = (Interp *) interp; + Tcl_HashTable *hTablePtr; + Tcl_HashSearch hSearch; + Tcl_HashEntry *hPtr; + AssocData *dPtr; + + hTablePtr = iPtr->assocData; + if (hTablePtr == (Tcl_HashTable *) NULL) { + return; + } + for (hPtr = Tcl_FirstHashEntry(hTablePtr, &hSearch); hPtr != NULL; + hPtr = Tcl_NextHashEntry(&hSearch)) { + dPtr = (AssocData *) Tcl_GetHashValue(hPtr); + if ((dPtr->proc == proc) && (dPtr->clientData == clientData)) { + ckfree((char *) dPtr); + Tcl_DeleteHashEntry(hPtr); + return; + } + } +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_SetAssocData -- + * + * Creates a named association between user-specified data, a delete + * function and this interpreter. If the association already exists + * the data is overwritten with the new data. The delete function will + * be invoked when the interpreter is deleted. + * + * Results: + * None. + * + * Side effects: + * Sets the associated data, creates the association if needed. + * + *---------------------------------------------------------------------- + */ + +void +Tcl_SetAssocData(interp, name, proc, clientData) + Tcl_Interp *interp; /* Interpreter to associate with. */ + 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. */ +{ + Interp *iPtr = (Interp *) interp; + AssocData *dPtr; + Tcl_HashEntry *hPtr; + int new; + + if (iPtr->assocData == (Tcl_HashTable *) NULL) { + iPtr->assocData = (Tcl_HashTable *) ckalloc(sizeof(Tcl_HashTable)); + Tcl_InitHashTable(iPtr->assocData, TCL_STRING_KEYS); + } + hPtr = Tcl_CreateHashEntry(iPtr->assocData, name, &new); + if (new == 0) { + dPtr = (AssocData *) Tcl_GetHashValue(hPtr); + } else { + dPtr = (AssocData *) ckalloc(sizeof(AssocData)); + } + dPtr->proc = proc; + dPtr->clientData = clientData; + + Tcl_SetHashValue(hPtr, dPtr); +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_DeleteAssocData -- + * + * Deletes a named association of user-specified data with + * the specified interpreter. + * + * Results: + * None. + * + * Side effects: + * Deletes the association. + * + *---------------------------------------------------------------------- + */ + +void +Tcl_DeleteAssocData(interp, name) + Tcl_Interp *interp; /* Interpreter to associate with. */ + char *name; /* Name of association. */ +{ + Interp *iPtr = (Interp *) interp; + AssocData *dPtr; + Tcl_HashEntry *hPtr; + + if (iPtr->assocData == (Tcl_HashTable *) NULL) { + return; + } + hPtr = Tcl_FindHashEntry(iPtr->assocData, name); + if (hPtr == (Tcl_HashEntry *) NULL) { + return; + } + dPtr = (AssocData *) Tcl_GetHashValue(hPtr); + if (dPtr->proc != NULL) { + (dPtr->proc) (dPtr->clientData, interp); + } + ckfree((char *) dPtr); + Tcl_DeleteHashEntry(hPtr); +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_GetAssocData -- + * + * Returns the client data associated with this name in the + * specified interpreter. + * + * Results: + * The client data in the AssocData record denoted by the named + * association, or NULL. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +ClientData +Tcl_GetAssocData(interp, name, procPtr) + Tcl_Interp *interp; /* Interpreter associated with. */ + char *name; /* Name of association. */ + Tcl_InterpDeleteProc **procPtr; /* Pointer to place to store address + * of current deletion callback. */ +{ + Interp *iPtr = (Interp *) interp; + AssocData *dPtr; + Tcl_HashEntry *hPtr; + + if (iPtr->assocData == (Tcl_HashTable *) NULL) { + return (ClientData) NULL; + } + hPtr = Tcl_FindHashEntry(iPtr->assocData, name); + if (hPtr == (Tcl_HashEntry *) NULL) { + return (ClientData) NULL; + } + dPtr = (AssocData *) Tcl_GetHashValue(hPtr); + if (procPtr != (Tcl_InterpDeleteProc **) NULL) { + *procPtr = dPtr->proc; + } + return dPtr->clientData; +} + +/* + *---------------------------------------------------------------------- + * + * DeleteInterpProc -- + * + * Helper procedure to delete an interpreter. This procedure is + * called when the last call to Tcl_Preserve on this interpreter + * is matched by a call to Tcl_Release. The procedure cleans up + * all resources used in the interpreter and calls all currently + * registered interpreter deletion callbacks. + * + * Results: + * None. + * + * Side effects: + * Whatever the interpreter deletion callbacks do. Frees resources + * used by the interpreter. + * + *---------------------------------------------------------------------- + */ + +static void +DeleteInterpProc(interp) + Tcl_Interp *interp; /* Interpreter to delete. */ +{ + Interp *iPtr = (Interp *) interp; + Tcl_HashEntry *hPtr; + Tcl_HashSearch search; + int i; + Tcl_HashTable *hTablePtr; + AssocData *dPtr; + + /* + * Punt if there is an error in the Tcl_Release/Tcl_Preserve matchup. + */ + + if (iPtr->numLevels > 0) { + panic("DeleteInterpProc called with active evals"); + } + + /* + * The interpreter should already be marked deleted; otherwise how + * did we get here? + */ + + if (!(iPtr->flags & DELETED)) { + panic("DeleteInterpProc called on interpreter not marked deleted"); + } + + /* + * First delete all the commands. There's a special hack here + * because "tkerror" is just a synonym for "bgerror" (they share + * a Command structure). Just delete the hash table entry for + * "tkerror" without invoking its callback or cleaning up its + * Command structure. + */ + + hPtr = Tcl_FindHashEntry(&iPtr->commandTable, "tkerror"); + if (hPtr != NULL) { + Tcl_DeleteHashEntry(hPtr); + } + for (hPtr = Tcl_FirstHashEntry(&iPtr->commandTable, &search); + hPtr != NULL; + hPtr = Tcl_FirstHashEntry(&iPtr->commandTable, &search)) { + Tcl_DeleteCommand(interp, + Tcl_GetHashKey(&iPtr->commandTable, hPtr)); + } + Tcl_DeleteHashTable(&iPtr->commandTable); + for (hPtr = Tcl_FirstHashEntry(&iPtr->mathFuncTable, &search); + hPtr != NULL; + hPtr = Tcl_NextHashEntry(&search)) { + ckfree((char *) Tcl_GetHashValue(hPtr)); + } + Tcl_DeleteHashTable(&iPtr->mathFuncTable); + + /* + * Invoke deletion callbacks; note that a callback can create new + * callbacks, so we iterate. + */ + + while (iPtr->assocData != (Tcl_HashTable *) NULL) { + hTablePtr = iPtr->assocData; + iPtr->assocData = (Tcl_HashTable *) NULL; + for (hPtr = Tcl_FirstHashEntry(hTablePtr, &search); + hPtr != NULL; + hPtr = Tcl_FirstHashEntry(hTablePtr, &search)) { + dPtr = (AssocData *) Tcl_GetHashValue(hPtr); + Tcl_DeleteHashEntry(hPtr); + if (dPtr->proc != NULL) { + (*dPtr->proc)(dPtr->clientData, interp); + } + ckfree((char *) dPtr); + } + Tcl_DeleteHashTable(hTablePtr); + ckfree((char *) hTablePtr); + } + + /* + * Delete all global variables: + */ + + TclDeleteVars(iPtr, &iPtr->globalTable); + + /* + * Free up the result *after* deleting variables, since variable + * deletion could have transferred ownership of the result string + * to Tcl. + */ + + Tcl_FreeResult(interp); + interp->result = NULL; + + if (iPtr->errorInfo != NULL) { + ckfree(iPtr->errorInfo); + iPtr->errorInfo = NULL; + } + if (iPtr->errorCode != NULL) { + ckfree(iPtr->errorCode); + iPtr->errorCode = NULL; + } + if (iPtr->events != NULL) { + int i; + + for (i = 0; i < iPtr->numEvents; i++) { + ckfree(iPtr->events[i].command); + } + ckfree((char *) iPtr->events); + iPtr->events = NULL; + } + while (iPtr->revPtr != NULL) { + HistoryRev *nextPtr = iPtr->revPtr->nextPtr; + + ckfree(iPtr->revPtr->newBytes); + ckfree((char *) iPtr->revPtr); + iPtr->revPtr = nextPtr; + } + if (iPtr->appendResult != NULL) { + ckfree(iPtr->appendResult); + iPtr->appendResult = NULL; + } + for (i = 0; i < NUM_REGEXPS; i++) { + if (iPtr->patterns[i] == NULL) { + break; + } + ckfree(iPtr->patterns[i]); + ckfree((char *) iPtr->regexps[i]); + iPtr->regexps[i] = NULL; + } + TclFreePackageInfo(iPtr); + while (iPtr->tracePtr != NULL) { + Trace *nextPtr = iPtr->tracePtr->nextPtr; + + ckfree((char *) iPtr->tracePtr); + iPtr->tracePtr = nextPtr; + } + + ckfree((char *) iPtr); +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_InterpDeleted -- + * + * Returns nonzero if the interpreter has been deleted with a call + * to Tcl_DeleteInterp. + * + * Results: + * Nonzero if the interpreter is deleted, zero otherwise. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_InterpDeleted(interp) + Tcl_Interp *interp; +{ + return (((Interp *) interp)->flags & DELETED) ? 1 : 0; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_DeleteInterp -- + * + * Ensures that the interpreter will be deleted eventually. If there + * are no Tcl_Preserve calls in effect for this interpreter, it is + * deleted immediately, otherwise the interpreter is deleted when + * the last Tcl_Preserve is matched by a call to Tcl_Release. In either + * case, the procedure runs the currently registered deletion callbacks. + * + * Results: + * None. + * + * Side effects: + * The interpreter is marked as deleted. The caller may still use it + * safely if there are calls to Tcl_Preserve in effect for the + * interpreter, but further calls to Tcl_Eval etc in this interpreter + * will fail. + * + *---------------------------------------------------------------------- + */ + +void +Tcl_DeleteInterp(interp) + Tcl_Interp *interp; /* Token for command interpreter (returned + * by a previous call to Tcl_CreateInterp). */ +{ + Interp *iPtr = (Interp *) interp; + + /* + * If the interpreter has already been marked deleted, just punt. + */ + + if (iPtr->flags & DELETED) { + return; + } + + /* + * Mark the interpreter as deleted. No further evals will be allowed. + */ + + iPtr->flags |= DELETED; + + /* + * Ensure that the interpreter is eventually deleted. + */ + + Tcl_EventuallyFree((ClientData) interp, + (Tcl_FreeProc *) DeleteInterpProc); +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_CreateCommand -- + * + * Define a new command in a command table. + * + * Results: + * The return value is a token for the command, which can + * be used in future calls to Tcl_NameOfCommand. + * + * Side effects: + * If a command named cmdName already exists for interp, it is + * deleted. In the future, when cmdName is seen as the name of + * a command by Tcl_Eval, proc will be called. When the command + * is deleted from the table, deleteProc will be called. See the + * manual entry for details on the calling sequence. + * + *---------------------------------------------------------------------- + */ + +Tcl_Command +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. */ + Tcl_CmdProc *proc; /* Command procedure to associate with + * cmdName. */ + ClientData clientData; /* Arbitrary one-word value to pass to proc. */ + Tcl_CmdDeleteProc *deleteProc; + /* If not NULL, gives a procedure to call when + * this command is deleted. */ +{ + Interp *iPtr = (Interp *) interp; + Command *cmdPtr; + Tcl_HashEntry *hPtr; + int new; + + /* + * The code below was added in 11/95 to preserve backwards compatibility + * when "tkerror" was renamed "bgerror": if anyone attempts to define + * "tkerror" as a command, it is actually created as "bgerror". This + * code should eventually be removed. + */ + + if ((cmdName[0] == 't') && (strcmp(cmdName, "tkerror") == 0)) { + cmdName = "bgerror"; + } + + if (iPtr->flags & DELETED) { + + /* + * The interpreter is being deleted. Don't create any new + * commands; it's not safe to muck with the interpreter anymore. + */ + + return (Tcl_Command) NULL; + } + hPtr = Tcl_CreateHashEntry(&iPtr->commandTable, cmdName, &new); + if (!new) { + /* + * Command already exists: delete the old one. + */ + + Tcl_DeleteCommand(interp, Tcl_GetHashKey(&iPtr->commandTable, hPtr)); + hPtr = Tcl_CreateHashEntry(&iPtr->commandTable, cmdName, &new); + if (!new) { + /* + * Drat. The stupid deletion callback recreated the command. + * Just throw away the new command (if we try to delete it again, + * we could get stuck in an infinite loop). + */ + + ckfree((char *) Tcl_GetHashValue(hPtr)); + } + } + cmdPtr = (Command *) ckalloc(sizeof(Command)); + Tcl_SetHashValue(hPtr, cmdPtr); + cmdPtr->hPtr = hPtr; + cmdPtr->proc = proc; + cmdPtr->clientData = clientData; + cmdPtr->deleteProc = deleteProc; + cmdPtr->deleteData = clientData; + cmdPtr->deleted = 0; + + /* + * The code below provides more backwards compatibility for the + * renaming of "tkerror" to "bgerror". Like the code above, this + * code should eventually become unnecessary. + */ + + if ((cmdName[0] == 'b') && (strcmp(cmdName, "bgerror") == 0)) { + /* + * We're currently creating the "bgerror" command; create + * a "tkerror" command that shares the same Command structure. + */ + + hPtr = Tcl_CreateHashEntry(&iPtr->commandTable, "tkerror", &new); + Tcl_SetHashValue(hPtr, cmdPtr); + } + return (Tcl_Command) cmdPtr; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_SetCommandInfo -- + * + * Modifies various information about a Tcl command. + * + * 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_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 store information about + * command. */ +{ + Tcl_HashEntry *hPtr; + Command *cmdPtr; + + hPtr = Tcl_FindHashEntry(&((Interp *) interp)->commandTable, cmdName); + if (hPtr == NULL) { + return 0; + } + cmdPtr = (Command *) Tcl_GetHashValue(hPtr); + cmdPtr->proc = infoPtr->proc; + cmdPtr->clientData = infoPtr->clientData; + cmdPtr->deleteProc = infoPtr->deleteProc; + cmdPtr->deleteData = infoPtr->deleteData; + return 1; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_GetCommandInfo -- + * + * Returns various information about a Tcl command. + * + * Results: + * If cmdName exists in interp, then *infoPtr is modified to + * hold information about cmdName and 1 is returned. If the + * command doesn't exist then 0 is returned and *infoPtr isn't + * modified. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_GetCommandInfo(interp, cmdName, infoPtr) + Tcl_Interp *interp; /* Interpreter in which to look + * for command. */ + char *cmdName; /* Name of desired command. */ + Tcl_CmdInfo *infoPtr; /* Where to store information about + * command. */ +{ + Tcl_HashEntry *hPtr; + Command *cmdPtr; + + hPtr = Tcl_FindHashEntry(&((Interp *) interp)->commandTable, cmdName); + if (hPtr == NULL) { + return 0; + } + cmdPtr = (Command *) Tcl_GetHashValue(hPtr); + infoPtr->proc = cmdPtr->proc; + infoPtr->clientData = cmdPtr->clientData; + infoPtr->deleteProc = cmdPtr->deleteProc; + infoPtr->deleteData = cmdPtr->deleteData; + return 1; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_GetCommandName -- + * + * Given a token returned by Tcl_CreateCommand, this procedure + * returns the current name of the command (which may have changed + * due to renaming). + * + * Results: + * The return value is the name of the given command. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +char * +Tcl_GetCommandName(interp, command) + Tcl_Interp *interp; /* Interpreter containing the command. */ + Tcl_Command command; /* Token for the command, returned by a + * previous call to Tcl_CreateCommand. + * The command must not have been deleted. */ +{ + Command *cmdPtr = (Command *) command; + Interp *iPtr = (Interp *) interp; + + if ((cmdPtr == NULL) || (cmdPtr->hPtr == NULL)) { + + /* + * This should only happen if command was "created" after the + * interpreter began to be deleted, so there isn't really any + * command. Just return an empty string. + */ + + return ""; + } + return Tcl_GetHashKey(&iPtr->commandTable, cmdPtr->hPtr); +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_DeleteCommand -- + * + * Remove the given command from the given interpreter. + * + * Results: + * 0 is returned if the command was deleted successfully. + * -1 is returned if there didn't exist a command by that + * name. + * + * Side effects: + * CmdName will no longer be recognized as a valid command for + * interp. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_DeleteCommand(interp, cmdName) + Tcl_Interp *interp; /* Token for command interpreter (returned + * by a previous call to Tcl_CreateInterp). */ + char *cmdName; /* Name of command to remove. */ +{ + Interp *iPtr = (Interp *) interp; + Tcl_HashEntry *hPtr, *tkErrorHPtr; + Command *cmdPtr; + + /* + * The code below was added in 11/95 to preserve backwards compatibility + * when "tkerror" was renamed "bgerror": if anyone attempts to delete + * "tkerror", delete both it and "bgerror". This code should + * eventually be removed. + */ + + if ((cmdName[0] == 't') && (strcmp(cmdName, "tkerror") == 0)) { + cmdName = "bgerror"; + } + hPtr = Tcl_FindHashEntry(&iPtr->commandTable, cmdName); + if (hPtr == NULL) { + return -1; + } + cmdPtr = (Command *) Tcl_GetHashValue(hPtr); + + /* + * The code here is tricky. We can't delete the hash table entry + * before invoking the deletion callback because there are cases + * where the deletion callback needs to invoke the command (e.g. + * object systems such as OTcl). However, this means that the + * callback could try to delete or rename the command. The deleted + * flag allows us to detect these cases and skip nested deletes. + */ + + if (cmdPtr->deleted) { + + /* + * Another deletion is already in progress. Remove the hash + * table entry now, but don't invoke a callback or free the + * command structure. + */ + + Tcl_DeleteHashEntry(cmdPtr->hPtr); + cmdPtr->hPtr = NULL; + return 0; + } + cmdPtr->deleted = 1; + if (cmdPtr->deleteProc != NULL) { + (*cmdPtr->deleteProc)(cmdPtr->deleteData); + } + + /* + * The code below provides more backwards compatibility for the + * renaming of "tkerror" to "bgerror". Like the code above, this + * code should eventually become unnecessary. + */ + + if ((cmdName[0] == 'b') && (strcmp(cmdName, "bgerror") == 0)) { + + /* + * When the "bgerror" command is deleted, delete "tkerror" + * as well. It shared the same Command structure as "bgerror", + * so all we have to do is throw away the hash table entry. + * NOTE: we have to be careful since tkerror may already have + * been deleted before bgerror. + */ + + tkErrorHPtr = Tcl_FindHashEntry(&iPtr->commandTable, "tkerror"); + if (tkErrorHPtr != (Tcl_HashEntry *) NULL) { + Tcl_DeleteHashEntry(tkErrorHPtr); + } + } + + /* + * Don't use hPtr to delete the hash entry here, because it's + * possible that the deletion callback renamed the command. + * Instead, use cmdPtr->hptr, and make sure that no-one else + * has already deleted the hash entry. + */ + + if (cmdPtr->hPtr != NULL) { + Tcl_DeleteHashEntry(cmdPtr->hPtr); + } + ckfree((char *) cmdPtr); + + return 0; +} + +/* + *----------------------------------------------------------------- + * + * Tcl_Eval -- + * + * Parse and execute a command in the Tcl language. + * + * Results: + * The return value is one of the return codes defined in tcl.hd + * (such as TCL_OK), and interp->result contains a string value + * to supplement the return code. The value of interp->result + * will persist only until the next call to Tcl_Eval: copy it or + * lose it! *TermPtr is filled in with the character just after + * the last one that was part of the command (usually a NULL + * character or a closing bracket). + * + * Side effects: + * Almost certainly; depends on the command. + * + *----------------------------------------------------------------- + */ + +int +Tcl_Eval(interp, cmd) + Tcl_Interp *interp; /* Token for command interpreter (returned + * by a previous call to Tcl_CreateInterp). */ + char *cmd; /* Pointer to TCL command to interpret. */ +{ + /* + * The storage immediately below is used to generate a copy + * of the command, after all argument substitutions. Pv will + * contain the argv values passed to the command procedure. + */ + +# define NUM_CHARS 200 + char copyStorage[NUM_CHARS]; + ParseValue pv; + char *oldBuffer; + + /* + * This procedure generates an (argv, argc) array for the command, + * It starts out with stack-allocated space but uses dynamically- + * allocated storage to increase it if needed. + */ + +# define NUM_ARGS 10 + char *(argStorage[NUM_ARGS]); + char **argv = argStorage; + int argc; + int argSize = NUM_ARGS; + + register char *src; /* Points to current character + * in cmd. */ + char termChar; /* Return when this character is found + * (either ']' or '\0'). Zero means + * that newlines terminate commands. */ + int flags; /* Interp->evalFlags value when the + * procedure was called. */ + int result; /* Return value. */ + register Interp *iPtr = (Interp *) interp; + Tcl_HashEntry *hPtr; + Command *cmdPtr; + char *termPtr; /* Contains character just after the + * last one in the command. */ + char *cmdStart; /* Points to first non-blank char. in + * command (used in calling trace + * procedures). */ + char *ellipsis = ""; /* Used in setting errorInfo variable; + * set to "..." to indicate that not + * all of offending command is included + * in errorInfo. "" means that the + * command is all there. */ + register Trace *tracePtr; + int oldCount = iPtr->cmdCount; /* Used to tell whether any commands + * at all were executed. */ + + /* + * Initialize the result to an empty string 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_FreeResult((Tcl_Interp *) iPtr); + iPtr->result = iPtr->resultSpace; + iPtr->resultSpace[0] = 0; + result = TCL_OK; + + /* + * Initialize the area in which command copies will be assembled. + */ + + pv.buffer = copyStorage; + pv.end = copyStorage + NUM_CHARS - 1; + pv.expandProc = TclExpandParseValue; + pv.clientData = (ClientData) NULL; + + src = cmd; + flags = iPtr->evalFlags; + iPtr->evalFlags = 0; + if (flags & TCL_BRACKET_TERM) { + termChar = ']'; + } else { + termChar = 0; + } + termPtr = src; + cmdStart = src; + + /* + * Check depth of nested calls to Tcl_Eval: if this gets too large, + * it's probably because of an infinite loop somewhere. + */ + + iPtr->numLevels++; + if (iPtr->numLevels > iPtr->maxNestingDepth) { + iPtr->numLevels--; + iPtr->result = "too many nested calls to Tcl_Eval (infinite loop?)"; + iPtr->termPtr = termPtr; + return TCL_ERROR; + } + + /* + * There can be many sub-commands (separated by semi-colons or + * newlines) in one command string. This outer loop iterates over + * individual commands. + */ + + while (*src != termChar) { + + /* + * If we have been deleted, return an error preventing further + * evals. + */ + + if (iPtr->flags & DELETED) { + Tcl_ResetResult(interp); + interp->result = "attempt to call eval in deleted interpreter"; + Tcl_SetErrorCode(interp, "CORE", "IDELETE", interp->result, + (char *) NULL); + iPtr->numLevels--; + return TCL_ERROR; + } + + iPtr->flags &= ~(ERR_IN_PROGRESS | ERROR_CODE_SET); + + /* + * Skim off leading white space and semi-colons, and skip + * comments. + */ + + while (1) { + register char c = *src; + + if ((CHAR_TYPE(c) != TCL_SPACE) && (c != ';') && (c != '\n')) { + break; + } + src += 1; + } + if (*src == '#') { + while (*src != 0) { + if (*src == '\\') { + int length; + Tcl_Backslash(src, &length); + src += length; + } else if (*src == '\n') { + src++; + termPtr = src; + break; + } else { + src++; + } + } + continue; + } + cmdStart = src; + + /* + * Parse the words of the command, generating the argc and + * argv for the command procedure. May have to call + * TclParseWords several times, expanding the argv array + * between calls. + */ + + pv.next = oldBuffer = pv.buffer; + argc = 0; + while (1) { + int newArgs, maxArgs; + char **newArgv; + int i; + + /* + * Note: the "- 2" below guarantees that we won't use the + * last two argv slots here. One is for a NULL pointer to + * mark the end of the list, and the other is to leave room + * for inserting the command name "unknown" as the first + * argument (see below). + */ + + maxArgs = argSize - argc - 2; + result = TclParseWords((Tcl_Interp *) iPtr, src, flags, + maxArgs, &termPtr, &newArgs, &argv[argc], &pv); + src = termPtr; + if (result != TCL_OK) { + ellipsis = "..."; + goto done; + } + + /* + * Careful! Buffer space may have gotten reallocated while + * parsing words. If this happened, be sure to update all + * of the older argv pointers to refer to the new space. + */ + + if (oldBuffer != pv.buffer) { + int i; + + for (i = 0; i < argc; i++) { + argv[i] = pv.buffer + (argv[i] - oldBuffer); + } + oldBuffer = pv.buffer; + } + argc += newArgs; + if (newArgs < maxArgs) { + argv[argc] = (char *) NULL; + break; + } + + /* + * Args didn't all fit in the current array. Make it bigger. + */ + + argSize *= 2; + newArgv = (char **) + ckalloc((unsigned) argSize * sizeof(char *)); + for (i = 0; i < argc; i++) { + newArgv[i] = argv[i]; + } + if (argv != argStorage) { + ckfree((char *) argv); + } + argv = newArgv; + } + + /* + * If this is an empty command (or if we're just parsing + * commands without evaluating them), then just skip to the + * next command. + */ + + if ((argc == 0) || iPtr->noEval) { + continue; + } + argv[argc] = NULL; + + /* + * Save information for the history module, if needed. + */ + + if (flags & TCL_RECORD_BOUNDS) { + iPtr->evalFirst = cmdStart; + iPtr->evalLast = src-1; + } + + /* + * Find the procedure to execute this command. If there isn't + * one, then see if there is a command "unknown". If so, + * invoke it instead, passing it the words of the original + * command as arguments. + */ + + hPtr = Tcl_FindHashEntry(&iPtr->commandTable, argv[0]); + if (hPtr == NULL) { + int i; + + hPtr = Tcl_FindHashEntry(&iPtr->commandTable, "unknown"); + if (hPtr == NULL) { + Tcl_ResetResult(interp); + Tcl_AppendResult(interp, "invalid command name \"", + argv[0], "\"", (char *) NULL); + result = TCL_ERROR; + goto done; + } + for (i = argc; i >= 0; i--) { + argv[i+1] = argv[i]; + } + argv[0] = "unknown"; + argc++; + } + cmdPtr = (Command *) Tcl_GetHashValue(hPtr); + + /* + * Call trace procedures, if any. + */ + + for (tracePtr = iPtr->tracePtr; tracePtr != NULL; + tracePtr = tracePtr->nextPtr) { + char saved; + + if (tracePtr->level < iPtr->numLevels) { + continue; + } + saved = *src; + *src = 0; + (*tracePtr->proc)(tracePtr->clientData, interp, iPtr->numLevels, + cmdStart, cmdPtr->proc, cmdPtr->clientData, argc, argv); + *src = saved; + } + + /* + * At long last, invoke the command procedure. Reset the + * result to its default empty value first (it could have + * gotten changed by earlier commands in the same command + * string). + */ + + iPtr->cmdCount++; + Tcl_FreeResult(iPtr); + iPtr->result = iPtr->resultSpace; + iPtr->resultSpace[0] = 0; + result = (*cmdPtr->proc)(cmdPtr->clientData, interp, argc, argv); + if (Tcl_AsyncReady()) { + result = Tcl_AsyncInvoke(interp, result); + } + if (result != TCL_OK) { + break; + } + } + + done: + + /* + * 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 (I'm not sure that loops like this are a good + * idea, * but...). + */ + + if ((oldCount == iPtr->cmdCount) && (Tcl_AsyncReady())) { + result = Tcl_AsyncInvoke(interp, result); + } + + /* + * Free up any extra resources that were allocated. + */ + + if (pv.buffer != copyStorage) { + ckfree((char *) pv.buffer); + } + if (argv != argStorage) { + ckfree((char *) argv); + } + iPtr->numLevels--; + if (iPtr->numLevels == 0) { + if (result == TCL_RETURN) { + result = TclUpdateReturnInfo(iPtr); + } + if ((result != TCL_OK) && (result != TCL_ERROR) + && !(flags & TCL_ALLOW_EXCEPTIONS)) { + Tcl_ResetResult(interp); + if (result == TCL_BREAK) { + iPtr->result = "invoked \"break\" outside of a loop"; + } else if (result == TCL_CONTINUE) { + iPtr->result = "invoked \"continue\" outside of a loop"; + } else { + iPtr->result = iPtr->resultSpace; + sprintf(iPtr->resultSpace, "command returned bad code: %d", + result); + } + result = TCL_ERROR; + } + } + + /* + * If an error occurred, record information about what was being + * executed when the error occurred. + */ + + if ((result == TCL_ERROR) && !(iPtr->flags & ERR_ALREADY_LOGGED)) { + int numChars; + register char *p; + + /* + * Compute the line number where the error occurred. + */ + + iPtr->errorLine = 1; + for (p = cmd; p != cmdStart; p++) { + if (*p == '\n') { + iPtr->errorLine++; + } + } + for ( ; isspace(UCHAR(*p)) || (*p == ';'); p++) { + if (*p == '\n') { + iPtr->errorLine++; + } + } + + /* + * Figure out how much of the command to print in the error + * message (up to a certain number of characters, or up to + * the first new-line). + */ + + numChars = src - cmdStart; + if (numChars > (NUM_CHARS-50)) { + numChars = NUM_CHARS-50; + ellipsis = " ..."; + } + + if (!(iPtr->flags & ERR_IN_PROGRESS)) { + sprintf(copyStorage, "\n while executing\n\"%.*s%s\"", + numChars, cmdStart, ellipsis); + } else { + sprintf(copyStorage, "\n invoked from within\n\"%.*s%s\"", + numChars, cmdStart, ellipsis); + } + Tcl_AddErrorInfo(interp, copyStorage); + iPtr->flags &= ~ERR_ALREADY_LOGGED; + } else { + iPtr->flags &= ~ERR_ALREADY_LOGGED; + } + iPtr->termPtr = termPtr; + return result; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_CreateTrace -- + * + * Arrange for a procedure to be called to trace command execution. + * + * Results: + * The return value is a token for the trace, which may be passed + * to Tcl_DeleteTrace to eliminate the trace. + * + * Side effects: + * 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, interp, level, command, cmdProc, cmdClientData, + * argc, argv) + * ClientData clientData; + * Tcl_Interp *interp; + * int level; + * char *command; + * int (*cmdProc)(); + * ClientData cmdClientData; + * int argc; + * char **argv; + * { + * } + * + * The clientData and interp arguments to proc will be the same + * as the corresponding arguments to this procedure. Level gives + * the nesting level of command interpretation for this interpreter + * (0 corresponds to top level). Command gives the ASCII text of + * the raw command, cmdProc and cmdClientData give the procedure that + * will be called to process the command and the ClientData value it + * will receive, and argc and argv give the arguments to the + * command, after any argument parsing and substitution. Proc + * does not return a value. + * + *---------------------------------------------------------------------- + */ + +Tcl_Trace +Tcl_CreateTrace(interp, level, proc, clientData) + Tcl_Interp *interp; /* Interpreter in which to create the trace. */ + int level; /* Only call proc for commands at nesting level + * <= level (1 => top level). */ + Tcl_CmdTraceProc *proc; /* Procedure to call before executing each + * command. */ + ClientData clientData; /* Arbitrary one-word value to pass to proc. */ +{ + register Trace *tracePtr; + register Interp *iPtr = (Interp *) interp; + + tracePtr = (Trace *) ckalloc(sizeof(Trace)); + tracePtr->level = level; + tracePtr->proc = proc; + tracePtr->clientData = clientData; + tracePtr->nextPtr = iPtr->tracePtr; + iPtr->tracePtr = tracePtr; + + return (Tcl_Trace) tracePtr; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_DeleteTrace -- + * + * Remove a trace. + * + * Results: + * None. + * + * Side effects: + * From now on there will be no more calls to the procedure given + * in trace. + * + *---------------------------------------------------------------------- + */ + +void +Tcl_DeleteTrace(interp, trace) + Tcl_Interp *interp; /* Interpreter that contains trace. */ + Tcl_Trace trace; /* Token for trace (returned previously by + * Tcl_CreateTrace). */ +{ + register Interp *iPtr = (Interp *) interp; + register Trace *tracePtr = (Trace *) trace; + register Trace *tracePtr2; + + 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); + return; + } + } + } +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_AddErrorInfo -- + * + * Add information to a message being accumulated that describes + * the current error. + * + * Results: + * None. + * + * Side effects: + * The contents of message are added to the "errorInfo" variable. + * If Tcl_Eval has been called since the current value of errorInfo + * was set, errorInfo is cleared before adding the new message. + * + *---------------------------------------------------------------------- + */ + +void +Tcl_AddErrorInfo(interp, message) + Tcl_Interp *interp; /* Interpreter to which error information + * pertains. */ + char *message; /* Message to record. */ +{ + register Interp *iPtr = (Interp *) interp; + + /* + * If an error is already being logged, then the new errorInfo + * is the concatenation of the old info and the new message. + * If this is the first piece of info for the error, then the + * new errorInfo is the concatenation of the message in + * interp->result and the new message. + */ + + if (!(iPtr->flags & ERR_IN_PROGRESS)) { + Tcl_SetVar2(interp, "errorInfo", (char *) NULL, interp->result, + TCL_GLOBAL_ONLY); + iPtr->flags |= ERR_IN_PROGRESS; + + /* + * If the errorCode variable wasn't set by the code that generated + * the error, set it to "NONE". + */ + + if (!(iPtr->flags & ERROR_CODE_SET)) { + (void) Tcl_SetVar2(interp, "errorCode", (char *) NULL, "NONE", + TCL_GLOBAL_ONLY); + } + } + Tcl_SetVar2(interp, "errorInfo", (char *) NULL, message, + TCL_GLOBAL_ONLY|TCL_APPEND_VALUE); +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_VarEval -- + * + * Given a variable number of string arguments, concatenate them + * all together and execute the result as a Tcl command. + * + * Results: + * A standard Tcl return result. An error message or other + * result may be left in interp->result. + * + * Side effects: + * Depends on what was done by the command. + * + *---------------------------------------------------------------------- + */ + /* VARARGS2 */ /* ARGSUSED */ +int +Tcl_VarEval TCL_VARARGS_DEF(Tcl_Interp *,arg1) +{ + va_list argList; + Tcl_DString buf; + char *string; + Tcl_Interp *interp; + int result; + + /* + * Copy the strings one after the other into a single larger + * string. Use stack-allocated space for small commands, but if + * the command gets too large than call ckalloc to create the + * space. + */ + + interp = TCL_VARARGS_START(Tcl_Interp *,arg1,argList); + Tcl_DStringInit(&buf); + while (1) { + string = va_arg(argList, char *); + if (string == NULL) { + break; + } + Tcl_DStringAppend(&buf, string, -1); + } + va_end(argList); + + result = Tcl_Eval(interp, Tcl_DStringValue(&buf)); + Tcl_DStringFree(&buf); + return result; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_GlobalEval -- + * + * Evaluate a command at global level in an interpreter. + * + * Results: + * A standard Tcl result is returned, and interp->result is + * modified accordingly. + * + * Side effects: + * The command string is executed in interp, and the execution + * is carried out in the variable context of global level (no + * procedures active), just as if an "uplevel #0" command were + * being executed. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_GlobalEval(interp, command) + Tcl_Interp *interp; /* Interpreter in which to evaluate command. */ + char *command; /* Command to evaluate. */ +{ + register Interp *iPtr = (Interp *) interp; + int result; + CallFrame *savedVarFramePtr; + + savedVarFramePtr = iPtr->varFramePtr; + iPtr->varFramePtr = NULL; + result = Tcl_Eval(interp, command); + iPtr->varFramePtr = savedVarFramePtr; + return result; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_SetRecursionLimit -- + * + * Set the maximum number of recursive calls that may be active + * for an interpreter at once. + * + * Results: + * The return value is the old limit on nesting for interp. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_SetRecursionLimit(interp, depth) + Tcl_Interp *interp; /* Interpreter whose nesting limit + * is to be set. */ + int depth; /* New value for maximimum depth. */ +{ + Interp *iPtr = (Interp *) interp; + int old; + + old = iPtr->maxNestingDepth; + if (depth > 0) { + iPtr->maxNestingDepth = depth; + } + return old; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_AllowExceptions -- + * + * Sets a flag in an interpreter so that exceptions can occur + * in the next call to Tcl_Eval without them being turned into + * errors. + * + * Results: + * None. + * + * Side effects: + * The TCL_ALLOW_EXCEPTIONS flag gets set in the interpreter's + * evalFlags structure. See the reference documentation for + * more details. + * + *---------------------------------------------------------------------- + */ + +void +Tcl_AllowExceptions(interp) + Tcl_Interp *interp; /* Interpreter in which to set flag. */ +{ + Interp *iPtr = (Interp *) interp; + + iPtr->evalFlags |= TCL_ALLOW_EXCEPTIONS; +} diff --git a/contrib/tcl/generic/tclCkalloc.c b/contrib/tcl/generic/tclCkalloc.c new file mode 100644 index 0000000..e8f3b37 --- /dev/null +++ b/contrib/tcl/generic/tclCkalloc.c @@ -0,0 +1,738 @@ +/* + * tclCkalloc.c -- + * + * Interface to malloc and free that provides support for debugging problems + * involving overwritten, double freeing memory and loss of memory. + * + * Copyright (c) 1991-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. + * + * This code contributed by Karl Lehenbauer and Mark Diekhans + * + * + * SCCS: @(#) tclCkalloc.c 1.17 96/03/14 13:05:56 + */ + +#include "tclInt.h" + +#define FALSE 0 +#define TRUE 1 + +#ifdef TCL_MEM_DEBUG +#ifndef TCL_GENERIC_ONLY +#include "tclPort.h" +#endif + +/* + * One of the following structures is allocated each time the + * "memory tag" command is invoked, to hold the current tag. + */ + +typedef struct MemTag { + int refCount; /* Number of mem_headers referencing + * this tag. */ + char string[4]; /* Actual size of string will be as + * large as needed for actual tag. This + * must be the last field in the structure. */ +} MemTag; + +#define TAG_SIZE(bytesInString) ((unsigned) sizeof(MemTag) + bytesInString - 3) + +static MemTag *curTagPtr = NULL;/* Tag to use in all future mem_headers + * (set by "memory tag" command). */ + +/* + * One of the following structures is allocated just before each + * dynamically allocated chunk of memory, both to record information + * about the chunk and to help detect chunk under-runs. + */ + +#define LOW_GUARD_SIZE (8 + (32 - (sizeof(long) + sizeof(int)))%8) +struct mem_header { + struct mem_header *flink; + struct mem_header *blink; + MemTag *tagPtr; /* Tag from "memory tag" command; may be + * NULL. */ + char *file; + long length; + int line; + unsigned char low_guard[LOW_GUARD_SIZE]; + /* Aligns body on 8-byte boundary, plus + * provides at least 8 additional guard bytes + * to detect underruns. */ + char body[1]; /* First byte of client's space. Actual + * size of this field will be larger than + * one. */ +}; + +static struct mem_header *allocHead = NULL; /* List of allocated structures */ + +#define GUARD_VALUE 0141 + +/* + * The following macro determines the amount of guard space *above* each + * chunk of memory. + */ + +#define HIGH_GUARD_SIZE 8 + +/* + * The following macro computes the offset of the "body" field within + * mem_header. It is used to get back to the header pointer from the + * body pointer that's used by clients. + */ + +#define BODY_OFFSET \ + ((unsigned long) (&((struct mem_header *) 0)->body)) + +static int total_mallocs = 0; +static int total_frees = 0; +static int current_bytes_malloced = 0; +static int maximum_bytes_malloced = 0; +static int current_malloc_packets = 0; +static int maximum_malloc_packets = 0; +static int break_on_malloc = 0; +static int trace_on_at_malloc = 0; +static int alloc_tracing = FALSE; +static int init_malloced_bodies = TRUE; +#ifdef MEM_VALIDATE + static int validate_memory = TRUE; +#else + static int validate_memory = FALSE; +#endif + +/* + * Prototypes for procedures defined in this file: + */ + +static int MemoryCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int argc, char **argv)); + +/* + *---------------------------------------------------------------------- + * + * dump_memory_info -- + * Display the global memory management statistics. + * + *---------------------------------------------------------------------- + */ +static void +dump_memory_info(outFile) + FILE *outFile; +{ + fprintf(outFile,"total mallocs %10d\n", + total_mallocs); + fprintf(outFile,"total frees %10d\n", + total_frees); + fprintf(outFile,"current packets allocated %10d\n", + current_malloc_packets); + fprintf(outFile,"current bytes allocated %10d\n", + current_bytes_malloced); + fprintf(outFile,"maximum packets allocated %10d\n", + maximum_malloc_packets); + fprintf(outFile,"maximum bytes allocated %10d\n", + maximum_bytes_malloced); +} + +/* + *---------------------------------------------------------------------- + * + * ValidateMemory -- + * Procedure to validate allocted memory guard zones. + * + *---------------------------------------------------------------------- + */ +static void +ValidateMemory (memHeaderP, file, line, nukeGuards) + struct mem_header *memHeaderP; + char *file; + int line; + int nukeGuards; +{ + unsigned char *hiPtr; + int idx; + int guard_failed = FALSE; + int byte; + + for (idx = 0; idx < LOW_GUARD_SIZE; idx++) { + byte = *(memHeaderP->low_guard + idx); + if (byte != GUARD_VALUE) { + guard_failed = TRUE; + fflush (stdout); + byte &= 0xff; + fprintf(stderr, "low guard byte %d is 0x%x \t%c\n", idx, byte, + (isprint(UCHAR(byte)) ? byte : ' ')); + } + } + if (guard_failed) { + dump_memory_info (stderr); + fprintf (stderr, "low guard failed at %lx, %s %d\n", + (long unsigned int) memHeaderP->body, file, line); + fflush (stderr); /* In case name pointer is bad. */ + fprintf (stderr, "%ld bytes allocated at (%s %d)\n", memHeaderP->length, + memHeaderP->file, memHeaderP->line); + panic ("Memory validation failure"); + } + + hiPtr = (unsigned char *)memHeaderP->body + memHeaderP->length; + for (idx = 0; idx < HIGH_GUARD_SIZE; idx++) { + byte = *(hiPtr + idx); + if (byte != GUARD_VALUE) { + guard_failed = TRUE; + fflush (stdout); + byte &= 0xff; + fprintf(stderr, "hi guard byte %d is 0x%x \t%c\n", idx, byte, + (isprint(UCHAR(byte)) ? byte : ' ')); + } + } + + if (guard_failed) { + dump_memory_info (stderr); + fprintf (stderr, "high guard failed at %lx, %s %d\n", + (long unsigned int) memHeaderP->body, file, line); + fflush (stderr); /* In case name pointer is bad. */ + fprintf (stderr, "%ld bytes allocated at (%s %d)\n", + memHeaderP->length, memHeaderP->file, + memHeaderP->line); + panic ("Memory validation failure"); + } + + if (nukeGuards) { + memset ((char *) memHeaderP->low_guard, 0, LOW_GUARD_SIZE); + memset ((char *) hiPtr, 0, HIGH_GUARD_SIZE); + } + +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_ValidateAllMemory -- + * Validates guard regions for all allocated memory. + * + *---------------------------------------------------------------------- + */ +void +Tcl_ValidateAllMemory (file, line) + char *file; + int line; +{ + struct mem_header *memScanP; + + for (memScanP = allocHead; memScanP != NULL; memScanP = memScanP->flink) + ValidateMemory (memScanP, file, line, FALSE); + +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_DumpActiveMemory -- + * Displays all allocated memory to stderr. + * + * Results: + * Return TCL_ERROR if an error accessing the file occures, `errno' + * will have the file error number left in it. + *---------------------------------------------------------------------- + */ +int +Tcl_DumpActiveMemory (fileName) + char *fileName; +{ + FILE *fileP; + struct mem_header *memScanP; + char *address; + + fileP = fopen(fileName, "w"); + if (fileP == NULL) + return TCL_ERROR; + + for (memScanP = allocHead; memScanP != NULL; memScanP = memScanP->flink) { + address = &memScanP->body [0]; + fprintf (fileP, "%8lx - %8lx %7ld @ %s %d %s", + (long unsigned int) address, + (long unsigned int) address + memScanP->length - 1, + memScanP->length, memScanP->file, memScanP->line, + (memScanP->tagPtr == NULL) ? "" : memScanP->tagPtr->string); + (void) fputc('\n', fileP); + } + fclose (fileP); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_DbCkalloc - debugging ckalloc + * + * Allocate the requested amount of space plus some extra for + * guard bands at both ends of the request, plus a size, panicing + * if there isn't enough space, then write in the guard bands + * and return the address of the space in the middle that the + * user asked for. + * + * The second and third arguments are file and line, these contain + * the filename and line number corresponding to the caller. + * These are sent by the ckalloc macro; it uses the preprocessor + * autodefines __FILE__ and __LINE__. + * + *---------------------------------------------------------------------- + */ +char * +Tcl_DbCkalloc(size, file, line) + unsigned int size; + char *file; + int line; +{ + struct mem_header *result; + + if (validate_memory) + Tcl_ValidateAllMemory (file, line); + + result = (struct mem_header *)malloc((unsigned)size + + sizeof(struct mem_header) + HIGH_GUARD_SIZE); + if (result == NULL) { + fflush(stdout); + dump_memory_info(stderr); + panic("unable to alloc %d bytes, %s line %d", size, file, + line); + } + + /* + * 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); + } + 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 %d %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; + + return result->body; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_DbCkfree - debugging ckfree + * + * Verify that the low and high guards are intact, and if so + * then free the buffer else panic. + * + * The guards are erased after being checked to catch duplicate + * frees. + * + * The second and third arguments are file and line, these contain + * the filename and line number corresponding to the caller. + * These are sent by the ckfree macro; it uses the preprocessor + * autodefines __FILE__ and __LINE__. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_DbCkfree(ptr, file, line) + char * ptr; + char *file; + int line; +{ + /* + * The following cast is *very* tricky. Must convert the pointer + * to an integer before doing arithmetic on it, because otherwise + * the arithmetic will be done differently (and incorrectly) on + * word-addressed machines such as Crays (will subtract only bytes, + * even though BODY_OFFSET is in words on these machines). + */ + + struct mem_header *memp = (struct mem_header *) + (((unsigned long) ptr) - BODY_OFFSET); + + if (alloc_tracing) + fprintf(stderr, "ckfree %lx %ld %s %d\n", + (long unsigned int) memp->body, memp->length, file, line); + + if (validate_memory) + Tcl_ValidateAllMemory (file, line); + + ValidateMemory (memp, file, line, TRUE); + if (init_malloced_bodies) { + memset((VOID *) ptr, GUARD_VALUE, (size_t) memp->length); + } + + total_frees++; + current_malloc_packets--; + current_bytes_malloced -= memp->length; + + if (memp->tagPtr != NULL) { + memp->tagPtr->refCount--; + if ((memp->tagPtr->refCount == 0) && (curTagPtr != memp->tagPtr)) { + free((char *) memp->tagPtr); + } + } + + /* + * Delink from allocated list + */ + if (memp->flink != NULL) + memp->flink->blink = memp->blink; + if (memp->blink != NULL) + memp->blink->flink = memp->flink; + if (allocHead == memp) + allocHead = memp->flink; + free((char *) memp); + return 0; +} + +/* + *-------------------------------------------------------------------- + * + * Tcl_DbCkrealloc - debugging ckrealloc + * + * Reallocate a chunk of memory by allocating a new one of the + * right size, copying the old data to the new location, and then + * freeing the old memory space, using all the memory checking + * features of this package. + * + *-------------------------------------------------------------------- + */ +char * +Tcl_DbCkrealloc(ptr, size, file, line) + char *ptr; + unsigned int size; + char *file; + int line; +{ + char *new; + unsigned int copySize; + + /* + * See comment from Tcl_DbCkfree before you change the following + * line. + */ + + struct mem_header *memp = (struct mem_header *) + (((unsigned long) ptr) - BODY_OFFSET); + + copySize = size; + if (copySize > memp->length) { + copySize = memp->length; + } + new = Tcl_DbCkalloc(size, file, line); + memcpy((VOID *) new, (VOID *) ptr, (size_t) copySize); + Tcl_DbCkfree(ptr, file, line); + return(new); +} + +/* + *---------------------------------------------------------------------- + * + * MemoryCmd -- + * Implements the TCL memory command: + * memory info + * memory display + * break_on_malloc count + * trace_on_at_malloc count + * trace on|off + * validate on|off + * + * Results: + * Standard TCL results. + * + *---------------------------------------------------------------------- + */ + /* ARGSUSED */ +static int +MemoryCmd (clientData, interp, argc, argv) + ClientData clientData; + Tcl_Interp *interp; + int argc; + char **argv; +{ + char *fileName; + Tcl_DString buffer; + int result; + + if (argc < 2) { + Tcl_AppendResult(interp, "wrong # args: should be \"", + argv[0], " option [args..]\"", (char *) NULL); + return TCL_ERROR; + } + + if (strcmp(argv[1],"active") == 0) { + if (argc != 3) { + Tcl_AppendResult(interp, "wrong # args: should be \"", + argv[0], " active file\"", (char *) NULL); + return TCL_ERROR; + } + fileName = Tcl_TranslateFileName(interp, argv[2], &buffer); + if (fileName == NULL) { + return TCL_ERROR; + } + result = Tcl_DumpActiveMemory (fileName); + Tcl_DStringFree(&buffer); + if (result != TCL_OK) { + Tcl_AppendResult(interp, "error accessing ", argv[2], + (char *) NULL); + return TCL_ERROR; + } + return TCL_OK; + } + if (strcmp(argv[1],"break_on_malloc") == 0) { + if (argc != 3) + goto argError; + if (Tcl_GetInt(interp, argv[2], &break_on_malloc) != TCL_OK) + return TCL_ERROR; + return TCL_OK; + } + if (strcmp(argv[1],"info") == 0) { + dump_memory_info(stdout); + return TCL_OK; + } + if (strcmp(argv[1],"init") == 0) { + if (argc != 3) + goto bad_suboption; + init_malloced_bodies = (strcmp(argv[2],"on") == 0); + return TCL_OK; + } + if (strcmp(argv[1],"tag") == 0) { + if (argc != 3) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " tag string\"", (char *) NULL); + return TCL_ERROR; + } + if ((curTagPtr != NULL) && (curTagPtr->refCount == 0)) { + free((char *) curTagPtr); + } + curTagPtr = (MemTag *) malloc(TAG_SIZE(strlen(argv[2]))); + curTagPtr->refCount = 0; + strcpy(curTagPtr->string, argv[2]); + return TCL_OK; + } + if (strcmp(argv[1],"trace") == 0) { + if (argc != 3) + goto bad_suboption; + alloc_tracing = (strcmp(argv[2],"on") == 0); + return TCL_OK; + } + + if (strcmp(argv[1],"trace_on_at_malloc") == 0) { + if (argc != 3) + goto argError; + if (Tcl_GetInt(interp, argv[2], &trace_on_at_malloc) != TCL_OK) + return TCL_ERROR; + return TCL_OK; + } + if (strcmp(argv[1],"validate") == 0) { + if (argc != 3) + goto bad_suboption; + validate_memory = (strcmp(argv[2],"on") == 0); + return TCL_OK; + } + + Tcl_AppendResult(interp, "bad option \"", argv[1], + "\": should be active, break_on_malloc, info, init, ", + "tag, trace, trace_on_at_malloc, or validate", (char *) NULL); + return TCL_ERROR; + +argError: + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " ", argv[1], " count\"", (char *) NULL); + return TCL_ERROR; + +bad_suboption: + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " ", argv[1], " on|off\"", (char *) NULL); + return TCL_ERROR; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_InitMemory -- + * Initialize the memory command. + * + *---------------------------------------------------------------------- + */ +void +Tcl_InitMemory(interp) + Tcl_Interp *interp; +{ +Tcl_CreateCommand (interp, "memory", MemoryCmd, (ClientData) NULL, + (Tcl_CmdDeleteProc *) NULL); +} + +#else + + +/* + *---------------------------------------------------------------------- + * + * Tcl_Ckalloc -- + * Interface to malloc when TCL_MEM_DEBUG is disabled. It does check + * that memory was actually allocated. + * + *---------------------------------------------------------------------- + */ +VOID * +Tcl_Ckalloc (size) + unsigned int size; +{ + char *result; + + result = malloc(size); + if (result == NULL) + panic("unable to alloc %d bytes", size); + return result; +} + + +char * +Tcl_DbCkalloc(size, file, line) + unsigned int size; + char *file; + int line; +{ + char *result; + + result = (char *) malloc(size); + + if (result == NULL) { + fflush(stdout); + panic("unable to alloc %d bytes, %s line %d", size, file, + line); + } + return result; +} + +char * +Tcl_DbCkrealloc(ptr, size, file, line) + char *ptr; + unsigned int size; + char *file; + int line; +{ + char *result; + + result = (char *) realloc(ptr, size); + + if (result == NULL) { + fflush(stdout); + panic("unable to realloc %d bytes, %s line %d", size, file, + line); + } + return result; +} +/* + *---------------------------------------------------------------------- + * + * TckCkfree -- + * Interface to free when TCL_MEM_DEBUG is disabled. Done here rather + * in the macro to keep some modules from being compiled with + * TCL_MEM_DEBUG enabled and some with it disabled. + * + *---------------------------------------------------------------------- + */ +void +Tcl_Ckfree (ptr) + char *ptr; +{ + free (ptr); +} + +int +Tcl_DbCkfree(ptr, file, line) + char * ptr; + char *file; + int line; +{ + free (ptr); + return 0; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_InitMemory -- + * Dummy initialization for memory command, which is only available + * if TCL_MEM_DEBUG is on. + * + *---------------------------------------------------------------------- + */ + /* ARGSUSED */ +void +Tcl_InitMemory(interp) + Tcl_Interp *interp; +{ +} + +#undef Tcl_DumpActiveMemory +#undef Tcl_ValidateAllMemory + +extern int Tcl_DumpActiveMemory _ANSI_ARGS_((char *fileName)); +extern void Tcl_ValidateAllMemory _ANSI_ARGS_((char *file, + int line)); + +int +Tcl_DumpActiveMemory (fileName) + char *fileName; +{ + return TCL_OK; +} + +void +Tcl_ValidateAllMemory (file, line) + char *file; + int line; +{ +} + +#endif diff --git a/contrib/tcl/generic/tclClock.c b/contrib/tcl/generic/tclClock.c new file mode 100644 index 0000000..3fb4abd --- /dev/null +++ b/contrib/tcl/generic/tclClock.c @@ -0,0 +1,353 @@ +/* + * tclClock.c -- + * + * Contains the time and date related commands. This code + * is derived from the time and date facilities of TclX, + * by Mark Diekhans and Karl Lehenbauer. + * + * Copyright 1991-1995 Karl Lehenbauer and Mark Diekhans. + * 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: @(#) tclClock.c 1.19 96/03/13 11:28:45 + */ + +#include "tcl.h" +#include "tclInt.h" +#include "tclPort.h" + +/* + * Function prototypes for local procedures in this file: + */ + +static int FormatClock _ANSI_ARGS_((Tcl_Interp *interp, + unsigned long clockVal, int useGMT, + char *format)); +static int ParseTime _ANSI_ARGS_((Tcl_Interp *interp, + char *string, unsigned long *timePtr)); + +/* + *----------------------------------------------------------------------------- + * + * Tcl_ClockCmd -- + * + * This procedure is invoked to process the "clock" 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_ClockCmd (dummy, interp, argc, argv) + ClientData dummy; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ + int c; + size_t length; + char **argPtr; + int useGMT = 0; + unsigned long clockVal; + + if (argc < 2) { + Tcl_AppendResult(interp, "wrong # args: should be \"", + argv[0], " option ?arg ...?\"", (char *) NULL); + return TCL_ERROR; + } + c = argv[1][0]; + length = strlen(argv[1]); + if ((c == 'c') && (strncmp(argv[1], "clicks", length) == 0)) { + if (argc != 2) { + Tcl_AppendResult(interp, "wrong # arguments: must be \"", + argv[0], " clicks\"", (char *) NULL); + return TCL_ERROR; + } + sprintf(interp->result, "%lu", TclGetClicks()); + return TCL_OK; + } else if ((c == 'f') && (strncmp(argv[1], "format", length) == 0)) { + char *format = "%a %b %d %X %Z %Y"; + + if ((argc < 3) || (argc > 7)) { + wrongFmtArgs: + Tcl_AppendResult(interp, "wrong # args: ", argv [0], + " format clockval ?-format string? ?-gmt boolean?", + (char *) NULL); + return TCL_ERROR; + } + + if (ParseTime(interp, argv[2], &clockVal) != TCL_OK) { + return TCL_ERROR; + } + + argPtr = argv+3; + argc -= 3; + while ((argc > 1) && (argPtr[0][0] == '-')) { + if (strcmp(argPtr[0], "-format") == 0) { + format = argPtr[1]; + } else if (strcmp(argPtr[0], "-gmt") == 0) { + if (Tcl_GetBoolean(interp, argPtr[1], &useGMT) != TCL_OK) { + return TCL_ERROR; + } + } else { + Tcl_AppendResult(interp, "bad option \"", argPtr[0], + "\": must be -format or -gmt", (char *) NULL); + return TCL_ERROR; + } + argPtr += 2; + argc -= 2; + } + if (argc != 0) { + goto wrongFmtArgs; + } + + return FormatClock(interp, clockVal, useGMT, format); + } else if ((c == 's') && (strncmp(argv[1], "scan", length) == 0)) { + unsigned long baseClock; + long zone; + char * baseStr = NULL; + + if ((argc < 3) || (argc > 7)) { + wrongScanArgs: + Tcl_AppendResult (interp, "wrong # args: ", argv [0], + " scan dateString ?-base clockValue? ?-gmt boolean?", + (char *) NULL); + return TCL_ERROR; + } + + argPtr = argv+3; + argc -= 3; + while ((argc > 1) && (argPtr[0][0] == '-')) { + if (strcmp(argPtr[0], "-base") == 0) { + baseStr = argPtr[1]; + } else if (strcmp(argPtr[0], "-gmt") == 0) { + if (Tcl_GetBoolean(interp, argPtr[1], &useGMT) != TCL_OK) { + return TCL_ERROR; + } + } else { + Tcl_AppendResult(interp, "bad option \"", argPtr[0], + "\": must be -base or -gmt", (char *) NULL); + return TCL_ERROR; + } + argPtr += 2; + argc -= 2; + } + if (argc != 0) { + goto wrongScanArgs; + } + + if (baseStr != NULL) { + if (ParseTime(interp, baseStr, &baseClock) != TCL_OK) + return TCL_ERROR; + } else { + baseClock = TclGetSeconds(); + } + + if (useGMT) { + zone = -50000; /* Force GMT */ + } else { + zone = TclGetTimeZone(baseClock); + } + + if (TclGetDate(argv[2], baseClock, zone, &clockVal) < 0) { + Tcl_AppendResult(interp, "unable to convert date-time string \"", + argv[2], "\"", (char *) NULL); + return TCL_ERROR; + } + + sprintf(interp->result, "%lu", (long) clockVal); + return TCL_OK; + } else if ((c == 's') && (strncmp(argv[1], "seconds", length) == 0)) { + if (argc != 2) { + Tcl_AppendResult(interp, "wrong # arguments: must be \"", + argv[0], " seconds\"", (char *) NULL); + return TCL_ERROR; + } + sprintf(interp->result, "%lu", TclGetSeconds()); + return TCL_OK; + } else { + Tcl_AppendResult(interp, "unknown option \"", argv[1], + "\": must be clicks, format, scan, or seconds", + (char *) NULL); + return TCL_ERROR; + } +} + +/* + *----------------------------------------------------------------------------- + * + * ParseTime -- + * + * Given a string, produce the corresponding time_t value. + * + * Results: + * The return value is normally TCL_OK; in this case *timePtr + * will be set to the integer value equivalent to string. If + * string is improperly formed then TCL_ERROR is returned and + * an error message will be left in interp->result. + * + * Side effects: + * None. + * + *----------------------------------------------------------------------------- + */ + +static int +ParseTime(interp, string, timePtr) + Tcl_Interp *interp; + char *string; + unsigned long *timePtr; +{ + char *end, *p; + unsigned long i; + + /* + * Since some strtoul functions don't detect negative numbers, check + * in advance. + */ + errno = 0; + for (p = (char *) string; isspace(UCHAR(*p)); p++) { + /* Empty loop body. */ + } + if (*p == '+') { + p++; + } + i = strtoul(p, &end, 0); + if (end == p) { + goto badTime; + } + if (errno == ERANGE) { + interp->result = "integer value too large to represent"; + Tcl_SetErrorCode(interp, "ARITH", "IOVERFLOW", + interp->result, (char *) NULL); + return TCL_ERROR; + } + while ((*end != '\0') && isspace(UCHAR(*end))) { + end++; + } + if (*end != '\0') { + goto badTime; + } + + *timePtr = (time_t) i; + if (*timePtr != i) { + goto badTime; + } + return TCL_OK; + + badTime: + Tcl_AppendResult (interp, "expected unsigned time but got \"", + string, "\"", (char *) NULL); + return TCL_ERROR; +} + +/* + *----------------------------------------------------------------------------- + * + * FormatClock -- + * + * Formats a time value based on seconds into a human readable + * string. + * + * Results: + * Standard Tcl result. + * + * Side effects: + * None. + * + *----------------------------------------------------------------------------- + */ + +static int +FormatClock(interp, clockVal, useGMT, format) + Tcl_Interp *interp; /* Current interpreter. */ + unsigned long clockVal; /* Time in seconds. */ + int useGMT; /* Boolean */ + char *format; /* Format string */ +{ + struct tm *timeDataPtr; + Tcl_DString buffer; + int bufSize; +#ifdef TCL_USE_TIMEZONE_VAR + int savedTimeZone; + char *savedTZEnv; +#endif + +#ifdef HAVE_TZSET + /* + * Some systems forgot to call tzset in localtime, make sure its done. + */ + static int calledTzset = 0; + + if (!calledTzset) { + tzset(); + calledTzset = 1; + } +#endif + +#ifdef TCL_USE_TIMEZONE_VAR + /* + * This is a horrible kludge for systems not having the timezone in + * struct tm. No matter what was specified, they use the global time + * zone. (Thanks Solaris). + */ + if (useGMT) { + char *varValue; + + varValue = Tcl_GetVar2(interp, "env", "TZ", TCL_GLOBAL_ONLY); + if (varValue != NULL) { + savedTZEnv = strcpy(ckalloc(strlen(varValue) + 1), varValue); + } else { + savedTZEnv = NULL; + } + Tcl_SetVar2(interp, "env", "TZ", "GMT", TCL_GLOBAL_ONLY); + savedTimeZone = timezone; + timezone = 0; + tzset(); + } +#endif + + if (useGMT) { + timeDataPtr = gmtime((time_t *) &clockVal); + } else { + timeDataPtr = localtime((time_t *) &clockVal); + } + + /* + * Format the time, increasing the buffer size until strftime succeeds. + */ + bufSize = TCL_DSTRING_STATIC_SIZE - 1; + Tcl_DStringInit(&buffer); + Tcl_DStringSetLength(&buffer, bufSize); + + while (strftime(buffer.string, (unsigned int) bufSize, format, + timeDataPtr) == 0) { + bufSize *= 2; + Tcl_DStringSetLength(&buffer, bufSize); + } + +#ifdef TCL_USE_TIMEZONE_VAR + if (useGMT) { + if (savedTZEnv != NULL) { + Tcl_SetVar2(interp, "env", "TZ", savedTZEnv, TCL_GLOBAL_ONLY); + ckfree(savedTZEnv); + } else { + Tcl_UnsetVar2(interp, "env", "TZ", TCL_GLOBAL_ONLY); + } + timezone = savedTimeZone; + tzset(); + } +#endif + + Tcl_DStringResult(interp, &buffer); + return TCL_OK; +} + diff --git a/contrib/tcl/generic/tclCmdAH.c b/contrib/tcl/generic/tclCmdAH.c new file mode 100644 index 0000000..526a111 --- /dev/null +++ b/contrib/tcl/generic/tclCmdAH.c @@ -0,0 +1,1678 @@ +/* + * tclCmdAH.c -- + * + * This file contains the top-level command routines for most of + * the Tcl built-in commands whose names begin with the letters + * A to H. + * + * Copyright (c) 1987-1993 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: @(#) tclCmdAH.c 1.107 96/04/09 17:14:39 + */ + +#include "tclInt.h" +#include "tclPort.h" + +/* + * Prototypes for local procedures defined in this file: + */ + +static char * GetTypeFromMode _ANSI_ARGS_((int mode)); +static int StoreStatData _ANSI_ARGS_((Tcl_Interp *interp, + char *varName, struct stat *statPtr)); + +/* + *---------------------------------------------------------------------- + * + * Tcl_BreakCmd -- + * + * This procedure is invoked to process the "break" Tcl command. + * See the user documentation for details on what it does. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * See the user documentation. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +int +Tcl_BreakCmd(dummy, interp, argc, argv) + ClientData dummy; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ + if (argc != 1) { + Tcl_AppendResult(interp, "wrong # args: should be \"", + argv[0], "\"", (char *) NULL); + return TCL_ERROR; + } + return TCL_BREAK; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_CaseCmd -- + * + * This procedure is invoked to process the "case" Tcl command. + * See the user documentation for details on what it does. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * See the user documentation. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +int +Tcl_CaseCmd(dummy, interp, argc, argv) + ClientData dummy; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ + int i, result; + int body; + char *string; + int caseArgc, splitArgs; + char **caseArgv; + + if (argc < 3) { + Tcl_AppendResult(interp, "wrong # args: should be \"", + argv[0], " string ?in? patList body ... ?default body?\"", + (char *) NULL); + return TCL_ERROR; + } + string = argv[1]; + body = -1; + if (strcmp(argv[2], "in") == 0) { + i = 3; + } else { + i = 2; + } + caseArgc = argc - i; + caseArgv = argv + i; + + /* + * If all of the pattern/command pairs are lumped into a single + * argument, split them out again. + */ + + splitArgs = 0; + if (caseArgc == 1) { + result = Tcl_SplitList(interp, caseArgv[0], &caseArgc, &caseArgv); + if (result != TCL_OK) { + return result; + } + splitArgs = 1; + } + + for (i = 0; i < caseArgc; i += 2) { + int patArgc, j; + char **patArgv; + register char *p; + + if (i == (caseArgc-1)) { + interp->result = "extra case pattern with no body"; + result = TCL_ERROR; + goto cleanup; + } + + /* + * Check for special case of single pattern (no list) with + * no backslash sequences. + */ + + for (p = caseArgv[i]; *p != 0; p++) { + if (isspace(UCHAR(*p)) || (*p == '\\')) { + break; + } + } + if (*p == 0) { + if ((*caseArgv[i] == 'd') + && (strcmp(caseArgv[i], "default") == 0)) { + body = i+1; + } + if (Tcl_StringMatch(string, caseArgv[i])) { + body = i+1; + goto match; + } + continue; + } + + /* + * Break up pattern lists, then check each of the patterns + * in the list. + */ + + result = Tcl_SplitList(interp, caseArgv[i], &patArgc, &patArgv); + if (result != TCL_OK) { + goto cleanup; + } + for (j = 0; j < patArgc; j++) { + if (Tcl_StringMatch(string, patArgv[j])) { + body = i+1; + break; + } + } + ckfree((char *) patArgv); + if (j < patArgc) { + break; + } + } + + match: + if (body != -1) { + result = Tcl_Eval(interp, caseArgv[body]); + if (result == TCL_ERROR) { + char msg[100]; + sprintf(msg, "\n (\"%.50s\" arm line %d)", caseArgv[body-1], + interp->errorLine); + Tcl_AddErrorInfo(interp, msg); + } + goto cleanup; + } + + /* + * Nothing matched: return nothing. + */ + + result = TCL_OK; + + cleanup: + if (splitArgs) { + ckfree((char *) caseArgv); + } + return result; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_CatchCmd -- + * + * This procedure is invoked to process the "catch" Tcl command. + * See the user documentation for details on what it does. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * See the user documentation. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +int +Tcl_CatchCmd(dummy, interp, argc, argv) + ClientData dummy; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ + int result; + + if ((argc != 2) && (argc != 3)) { + Tcl_AppendResult(interp, "wrong # args: should be \"", + argv[0], " command ?varName?\"", (char *) NULL); + return TCL_ERROR; + } + result = Tcl_Eval(interp, argv[1]); + if (argc == 3) { + if (Tcl_SetVar(interp, argv[2], interp->result, 0) == NULL) { + Tcl_SetResult(interp, "couldn't save command result in variable", + TCL_STATIC); + return TCL_ERROR; + } + } + Tcl_ResetResult(interp); + sprintf(interp->result, "%d", result); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_CdCmd -- + * + * This procedure is invoked to process the "cd" Tcl command. + * See the user documentation for details on what it does. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * See the user documentation. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +int +Tcl_CdCmd(dummy, interp, argc, argv) + ClientData dummy; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ + char *dirName; + Tcl_DString buffer; + int result; + + if (argc > 2) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " dirName\"", (char *) NULL); + return TCL_ERROR; + } + + if (argc == 2) { + dirName = argv[1]; + } else { + dirName = "~"; + } + dirName = Tcl_TranslateFileName(interp, dirName, &buffer); + if (dirName == NULL) { + return TCL_ERROR; + } + result = TclChdir(interp, dirName); + Tcl_DStringFree(&buffer); + return result; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_ConcatCmd -- + * + * This procedure is invoked to process the "concat" Tcl command. + * See the user documentation for details on what it does. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * See the user documentation. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +int +Tcl_ConcatCmd(dummy, interp, argc, argv) + ClientData dummy; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ + if (argc >= 2) { + interp->result = Tcl_Concat(argc-1, argv+1); + interp->freeProc = TCL_DYNAMIC; + } + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_ContinueCmd -- + * + * This procedure is invoked to process the "continue" Tcl command. + * See the user documentation for details on what it does. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * See the user documentation. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +int +Tcl_ContinueCmd(dummy, interp, argc, argv) + ClientData dummy; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ + if (argc != 1) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + "\"", (char *) NULL); + return TCL_ERROR; + } + return TCL_CONTINUE; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_ErrorCmd -- + * + * This procedure is invoked to process the "error" Tcl command. + * See the user documentation for details on what it does. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * See the user documentation. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +int +Tcl_ErrorCmd(dummy, interp, argc, argv) + ClientData dummy; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ + Interp *iPtr = (Interp *) interp; + + if ((argc < 2) || (argc > 4)) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " message ?errorInfo? ?errorCode?\"", (char *) NULL); + return TCL_ERROR; + } + if ((argc >= 3) && (argv[2][0] != 0)) { + Tcl_AddErrorInfo(interp, argv[2]); + iPtr->flags |= ERR_ALREADY_LOGGED; + } + if (argc == 4) { + Tcl_SetVar2(interp, "errorCode", (char *) NULL, argv[3], + TCL_GLOBAL_ONLY); + iPtr->flags |= ERROR_CODE_SET; + } + Tcl_SetResult(interp, argv[1], TCL_VOLATILE); + return TCL_ERROR; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_EvalCmd -- + * + * This procedure is invoked to process the "eval" Tcl command. + * See the user documentation for details on what it does. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * See the user documentation. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +int +Tcl_EvalCmd(dummy, interp, argc, argv) + ClientData dummy; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ + int result; + char *cmd; + + if (argc < 2) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " arg ?arg ...?\"", (char *) NULL); + return TCL_ERROR; + } + if (argc == 2) { + result = Tcl_Eval(interp, argv[1]); + } else { + + /* + * More than one argument: concatenate them together with spaces + * between, then evaluate the result. + */ + + cmd = Tcl_Concat(argc-1, argv+1); + result = Tcl_Eval(interp, cmd); + ckfree(cmd); + } + if (result == TCL_ERROR) { + char msg[60]; + sprintf(msg, "\n (\"eval\" body line %d)", interp->errorLine); + Tcl_AddErrorInfo(interp, msg); + } + return result; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_ExitCmd -- + * + * This procedure is invoked to process the "exit" Tcl command. + * See the user documentation for details on what it does. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * See the user documentation. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +int +Tcl_ExitCmd(dummy, interp, argc, argv) + ClientData dummy; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ + int value; + + if ((argc != 1) && (argc != 2)) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " ?returnCode?\"", (char *) NULL); + return TCL_ERROR; + } + if (argc == 1) { + value = 0; + } else if (Tcl_GetInt(interp, argv[1], &value) != TCL_OK) { + return TCL_ERROR; + } + Tcl_Exit(value); + /*NOTREACHED*/ + return TCL_OK; /* Better not ever reach this! */ +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_ExprCmd -- + * + * This procedure is invoked to process the "expr" Tcl command. + * See the user documentation for details on what it does. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * See the user documentation. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +int +Tcl_ExprCmd(dummy, interp, argc, argv) + ClientData dummy; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ + Tcl_DString buffer; + int i, result; + + if (argc < 2) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " arg ?arg ...?\"", (char *) NULL); + return TCL_ERROR; + } + + if (argc == 2) { + return Tcl_ExprString(interp, argv[1]); + } + Tcl_DStringInit(&buffer); + Tcl_DStringAppend(&buffer, argv[1], -1); + for (i = 2; i < argc; i++) { + Tcl_DStringAppend(&buffer, " ", 1); + Tcl_DStringAppend(&buffer, argv[i], -1); + } + result = Tcl_ExprString(interp, buffer.string); + Tcl_DStringFree(&buffer); + return result; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_FileCmd -- + * + * This procedure is invoked to process the "file" Tcl command. + * See the user documentation for details on what it does. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * See the user documentation. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +int +Tcl_FileCmd(dummy, interp, argc, argv) + ClientData dummy; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ + char *fileName, *extension; + int c, statOp, result; + size_t length; + int mode = 0; /* Initialized only to prevent + * compiler warning message. */ + struct stat statBuf; + Tcl_DString buffer; + + if (argc < 3) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " option name ?arg ...?\"", (char *) NULL); + return TCL_ERROR; + } + c = argv[1][0]; + length = strlen(argv[1]); + result = TCL_OK; + Tcl_DStringInit(&buffer); + + /* + * First handle operations on the file name. + */ + + if ((c == 'd') && (strncmp(argv[1], "dirname", length) == 0)) { + int pargc; + char **pargv; + + if (argc != 3) { + argv[1] = "dirname"; + goto not3Args; + } + + fileName = argv[2]; + + /* + * If there is only one element, and it starts with a tilde, + * perform tilde substitution and resplit the path. + */ + + Tcl_SplitPath(fileName, &pargc, &pargv); + if ((pargc == 1) && (*fileName == '~')) { + ckfree((char*) pargv); + fileName = Tcl_TranslateFileName(interp, fileName, &buffer); + if (fileName == NULL) { + result = TCL_ERROR; + goto done; + } + Tcl_SplitPath(fileName, &pargc, &pargv); + Tcl_DStringSetLength(&buffer, 0); + } + + /* + * 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 (pargc > 1) { + Tcl_JoinPath(pargc-1, pargv, &buffer); + Tcl_DStringResult(interp, &buffer); + } else if ((pargc == 0) + || (Tcl_GetPathType(pargv[0]) == TCL_PATH_RELATIVE)) { + Tcl_SetResult(interp, + (tclPlatform == TCL_PLATFORM_MAC) ? ":" : ".", TCL_STATIC); + } else { + Tcl_SetResult(interp, pargv[0], TCL_VOLATILE); + } + ckfree((char *)pargv); + goto done; + + } else if ((c == 't') && (strncmp(argv[1], "tail", length) == 0) + && (length >= 2)) { + int pargc; + char **pargv; + + if (argc != 3) { + argv[1] = "tail"; + goto not3Args; + } + + Tcl_SplitPath(argv[2], &pargc, &pargv); + if (pargc > 0) { + if ((pargc > 1) + || (Tcl_GetPathType(pargv[0]) == TCL_PATH_RELATIVE)) { + Tcl_SetResult(interp, pargv[pargc-1], TCL_VOLATILE); + } + } + ckfree((char *)pargv); + goto done; + + } else if ((c == 'r') && (strncmp(argv[1], "rootname", length) == 0) + && (length >= 2)) { + char tmp; + if (argc != 3) { + argv[1] = "rootname"; + goto not3Args; + } + extension = TclGetExtension(argv[2]); + if (extension == NULL) { + Tcl_SetResult(interp, argv[2], TCL_VOLATILE); + } else { + tmp = *extension; + *extension = 0; + Tcl_SetResult(interp, argv[2], TCL_VOLATILE); + *extension = tmp; + } + goto done; + } else if ((c == 'e') && (strncmp(argv[1], "extension", length) == 0) + && (length >= 3)) { + if (argc != 3) { + argv[1] = "extension"; + goto not3Args; + } + extension = TclGetExtension(argv[2]); + + if (extension != NULL) { + Tcl_SetResult(interp, extension, TCL_VOLATILE); + } + goto done; + } else if ((c == 'p') && (strncmp(argv[1], "pathtype", length) == 0)) { + if (argc != 3) { + argv[1] = "pathtype"; + goto not3Args; + } + switch (Tcl_GetPathType(argv[2])) { + case TCL_PATH_ABSOLUTE: + Tcl_SetResult(interp, "absolute", TCL_STATIC); + break; + case TCL_PATH_RELATIVE: + Tcl_SetResult(interp, "relative", TCL_STATIC); + break; + case TCL_PATH_VOLUME_RELATIVE: + Tcl_SetResult(interp, "volumerelative", TCL_STATIC); + break; + } + goto done; + } else if ((c == 's') && (strncmp(argv[1], "split", length) == 0) + && (length >= 2)) { + int pargc, i; + char **pargvList; + + if (argc != 3) { + argv[1] = "split"; + goto not3Args; + } + + Tcl_SplitPath(argv[2], &pargc, &pargvList); + for (i = 0; i < pargc; i++) { + Tcl_AppendElement(interp, pargvList[i]); + } + ckfree((char *) pargvList); + goto done; + } else if ((c == 'j') && (strncmp(argv[1], "join", length) == 0)) { + Tcl_JoinPath(argc-2, argv+2, &buffer); + Tcl_DStringResult(interp, &buffer); + goto done; + } + + /* + * Next, handle operations that can be satisfied with the "access" + * kernel call. + */ + + fileName = Tcl_TranslateFileName(interp, argv[2], &buffer); + if (fileName == NULL) { + result = TCL_ERROR; + goto done; + } + if ((c == 'r') && (strncmp(argv[1], "readable", length) == 0) + && (length >= 5)) { + if (argc != 3) { + argv[1] = "readable"; + goto not3Args; + } + mode = R_OK; + checkAccess: + if (access(fileName, mode) == -1) { + interp->result = "0"; + } else { + interp->result = "1"; + } + goto done; + } else if ((c == 'w') && (strncmp(argv[1], "writable", length) == 0)) { + if (argc != 3) { + argv[1] = "writable"; + goto not3Args; + } + mode = W_OK; + goto checkAccess; + } else if ((c == 'e') && (strncmp(argv[1], "executable", length) == 0) + && (length >= 3)) { + if (argc != 3) { + argv[1] = "executable"; + goto not3Args; + } + mode = X_OK; + goto checkAccess; + } else if ((c == 'e') && (strncmp(argv[1], "exists", length) == 0) + && (length >= 3)) { + if (argc != 3) { + argv[1] = "exists"; + goto not3Args; + } + mode = F_OK; + goto checkAccess; + } + + /* + * Lastly, check stuff that requires the file to be stat-ed. + */ + + if ((c == 'a') && (strncmp(argv[1], "atime", length) == 0)) { + if (argc != 3) { + argv[1] = "atime"; + goto not3Args; + } + if (stat(fileName, &statBuf) == -1) { + goto badStat; + } + sprintf(interp->result, "%ld", (long) statBuf.st_atime); + goto done; + } else if ((c == 'i') && (strncmp(argv[1], "isdirectory", length) == 0) + && (length >= 3)) { + if (argc != 3) { + argv[1] = "isdirectory"; + goto not3Args; + } + statOp = 2; + } else if ((c == 'i') && (strncmp(argv[1], "isfile", length) == 0) + && (length >= 3)) { + if (argc != 3) { + argv[1] = "isfile"; + goto not3Args; + } + statOp = 1; + } else if ((c == 'l') && (strncmp(argv[1], "lstat", length) == 0)) { + if (argc != 4) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " lstat name varName\"", (char *) NULL); + result = TCL_ERROR; + goto done; + } + + if (lstat(fileName, &statBuf) == -1) { + Tcl_AppendResult(interp, "couldn't lstat \"", argv[2], + "\": ", Tcl_PosixError(interp), (char *) NULL); + result = TCL_ERROR; + goto done; + } + result = StoreStatData(interp, argv[3], &statBuf); + goto done; + } else if ((c == 'm') && (strncmp(argv[1], "mtime", length) == 0)) { + if (argc != 3) { + argv[1] = "mtime"; + goto not3Args; + } + if (stat(fileName, &statBuf) == -1) { + goto badStat; + } + sprintf(interp->result, "%ld", (long) statBuf.st_mtime); + goto done; + } else if ((c == 'o') && (strncmp(argv[1], "owned", length) == 0)) { + if (argc != 3) { + argv[1] = "owned"; + goto not3Args; + } + statOp = 0; + } else if ((c == 'r') && (strncmp(argv[1], "readlink", length) == 0) + && (length >= 5)) { + char linkValue[MAXPATHLEN+1]; + int linkLength; + + if (argc != 3) { + argv[1] = "readlink"; + goto not3Args; + } + + /* + * 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 + linkLength = -1; + errno = EINVAL; +#else + linkLength = readlink(fileName, linkValue, sizeof(linkValue) - 1); +#endif /* S_IFLNK */ + if (linkLength == -1) { + Tcl_AppendResult(interp, "couldn't readlink \"", argv[2], + "\": ", Tcl_PosixError(interp), (char *) NULL); + result = TCL_ERROR; + goto done; + } + linkValue[linkLength] = 0; + Tcl_SetResult(interp, linkValue, TCL_VOLATILE); + goto done; + } else if ((c == 's') && (strncmp(argv[1], "size", length) == 0) + && (length >= 2)) { + if (argc != 3) { + argv[1] = "size"; + goto not3Args; + } + if (stat(fileName, &statBuf) == -1) { + goto badStat; + } + sprintf(interp->result, "%lu", (unsigned long) statBuf.st_size); + goto done; + } else if ((c == 's') && (strncmp(argv[1], "stat", length) == 0) + && (length >= 2)) { + if (argc != 4) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " stat name varName\"", (char *) NULL); + result = TCL_ERROR; + goto done; + } + + if (stat(fileName, &statBuf) == -1) { + badStat: + Tcl_AppendResult(interp, "couldn't stat \"", argv[2], + "\": ", Tcl_PosixError(interp), (char *) NULL); + result = TCL_ERROR; + goto done; + } + result = StoreStatData(interp, argv[3], &statBuf); + goto done; + } else if ((c == 't') && (strncmp(argv[1], "type", length) == 0) + && (length >= 2)) { + if (argc != 3) { + argv[1] = "type"; + goto not3Args; + } + if (lstat(fileName, &statBuf) == -1) { + goto badStat; + } + interp->result = GetTypeFromMode((int) statBuf.st_mode); + goto done; + } else { + Tcl_AppendResult(interp, "bad option \"", argv[1], + "\": should be atime, dirname, executable, exists, ", + "extension, isdirectory, isfile, join, ", + "lstat, mtime, owned, pathtype, readable, readlink, ", + "root, size, split, stat, tail, type, ", + "or writable", + (char *) NULL); + result = TCL_ERROR; + goto done; + } + if (stat(fileName, &statBuf) == -1) { + interp->result = "0"; + goto done; + } + switch (statOp) { + case 0: + /* + * For Windows and Macintosh, there are no user ids + * associated with a file, so we always return 1. + */ + +#if (defined(__WIN32__) || defined(MAC_TCL)) + mode = 1; +#else + mode = (geteuid() == statBuf.st_uid); +#endif + break; + case 1: + mode = S_ISREG(statBuf.st_mode); + break; + case 2: + mode = S_ISDIR(statBuf.st_mode); + break; + } + if (mode) { + interp->result = "1"; + } else { + interp->result = "0"; + } + + done: + Tcl_DStringFree(&buffer); + return result; + + not3Args: + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " ", argv[1], " name\"", (char *) NULL); + result = TCL_ERROR; + goto done; +} + +/* + *---------------------------------------------------------------------- + * + * StoreStatData -- + * + * This is a utility procedure that breaks out the fields of a + * "stat" structure and stores them in textual form into the + * elements of an associative array. + * + * Results: + * Returns a standard Tcl return value. If an error occurs then + * a message is left in interp->result. + * + * Side effects: + * Elements of the associative array given by "varName" are modified. + * + *---------------------------------------------------------------------- + */ + +static int +StoreStatData(interp, varName, statPtr) + 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 + * stat data to store in varName. */ +{ + char string[30]; + + sprintf(string, "%ld", (long) statPtr->st_dev); + if (Tcl_SetVar2(interp, varName, "dev", string, TCL_LEAVE_ERR_MSG) + == NULL) { + return TCL_ERROR; + } + sprintf(string, "%ld", (long) statPtr->st_ino); + if (Tcl_SetVar2(interp, varName, "ino", string, TCL_LEAVE_ERR_MSG) + == NULL) { + return TCL_ERROR; + } + sprintf(string, "%ld", (long) statPtr->st_mode); + if (Tcl_SetVar2(interp, varName, "mode", string, TCL_LEAVE_ERR_MSG) + == NULL) { + return TCL_ERROR; + } + sprintf(string, "%ld", (long) statPtr->st_nlink); + if (Tcl_SetVar2(interp, varName, "nlink", string, TCL_LEAVE_ERR_MSG) + == NULL) { + return TCL_ERROR; + } + sprintf(string, "%ld", (long) statPtr->st_uid); + if (Tcl_SetVar2(interp, varName, "uid", string, TCL_LEAVE_ERR_MSG) + == NULL) { + return TCL_ERROR; + } + sprintf(string, "%ld", (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; + } + sprintf(string, "%ld", (long) statPtr->st_atime); + if (Tcl_SetVar2(interp, varName, "atime", string, TCL_LEAVE_ERR_MSG) + == NULL) { + return TCL_ERROR; + } + sprintf(string, "%ld", (long) statPtr->st_mtime); + if (Tcl_SetVar2(interp, varName, "mtime", string, TCL_LEAVE_ERR_MSG) + == NULL) { + return TCL_ERROR; + } + sprintf(string, "%ld", (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((int) statPtr->st_mode), TCL_LEAVE_ERR_MSG) == NULL) { + return TCL_ERROR; + } + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * GetTypeFromMode -- + * + * Given a mode word, returns a string identifying the type of a + * file. + * + * Results: + * A static text string giving the file type from mode. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static char * +GetTypeFromMode(mode) + int mode; +{ + if (S_ISREG(mode)) { + return "file"; + } else if (S_ISDIR(mode)) { + return "directory"; + } else if (S_ISCHR(mode)) { + return "characterSpecial"; + } else if (S_ISBLK(mode)) { + return "blockSpecial"; + } else if (S_ISFIFO(mode)) { + return "fifo"; + } else if (S_ISLNK(mode)) { + return "link"; + } else if (S_ISSOCK(mode)) { + return "socket"; + } + return "unknown"; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_ForCmd -- + * + * This procedure is invoked to process the "for" Tcl command. + * See the user documentation for details on what it does. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * See the user documentation. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +int +Tcl_ForCmd(dummy, interp, argc, argv) + ClientData dummy; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ + int result, value; + + if (argc != 5) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " start test next command\"", (char *) NULL); + return TCL_ERROR; + } + + result = Tcl_Eval(interp, argv[1]); + if (result != TCL_OK) { + if (result == TCL_ERROR) { + Tcl_AddErrorInfo(interp, "\n (\"for\" initial command)"); + } + return result; + } + while (1) { + result = Tcl_ExprBoolean(interp, argv[2], &value); + if (result != TCL_OK) { + return result; + } + if (!value) { + break; + } + result = Tcl_Eval(interp, argv[4]); + if ((result != TCL_OK) && (result != TCL_CONTINUE)) { + if (result == TCL_ERROR) { + char msg[60]; + sprintf(msg, "\n (\"for\" body line %d)", interp->errorLine); + Tcl_AddErrorInfo(interp, msg); + } + break; + } + result = Tcl_Eval(interp, argv[3]); + if (result == TCL_BREAK) { + break; + } else if (result != TCL_OK) { + if (result == TCL_ERROR) { + Tcl_AddErrorInfo(interp, "\n (\"for\" loop-end command)"); + } + return result; + } + } + if (result == TCL_BREAK) { + result = TCL_OK; + } + if (result == TCL_OK) { + Tcl_ResetResult(interp); + } + return result; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_ForeachCmd -- + * + * This procedure is invoked to process the "foreach" Tcl command. + * See the user documentation for details on what it does. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * See the user documentation. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +int +Tcl_ForeachCmd(dummy, interp, argc, argv) + ClientData dummy; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ + int result = TCL_OK; + int i; /* i selects a value list */ + int j, maxj; /* Number of loop iterations */ + int v; /* v selects a loop variable */ + int numLists; /* Count of value lists */ +#define STATIC_SIZE 4 + int indexArray[STATIC_SIZE]; /* Array of value list indices */ + int varcListArray[STATIC_SIZE]; /* Number of loop variables per list */ + char **varvListArray[STATIC_SIZE]; /* Array of variable name lists */ + int argcListArray[STATIC_SIZE]; /* Array of value list sizes */ + char **argvListArray[STATIC_SIZE]; /* Array of value lists */ + + int *index = indexArray; + int *varcList = varcListArray; + char ***varvList = varvListArray; + int *argcList = argcListArray; + char ***argvList = argvListArray; + + if (argc < 4 || (argc%2 != 0)) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " varList list ?varList list ...? command\"", (char *) NULL); + return TCL_ERROR; + } + + /* + * Manage numList parallel value lists. + * argvList[i] is a value list counted by argcList[i] + * varvList[i] is the list of variables associated with the value list + * varcList[i] is the number of variables associated with the value list + * index[i] is the current pointer into the value list argvList[i] + */ + + numLists = (argc-2)/2; + if (numLists > STATIC_SIZE) { + index = (int *) ckalloc(numLists * sizeof(int)); + varcList = (int *) ckalloc(numLists * sizeof(int)); + varvList = (char ***) ckalloc(numLists * sizeof(char **)); + argcList = (int *) ckalloc(numLists * sizeof(int)); + argvList = (char ***) ckalloc(numLists * sizeof(char **)); + } + for (i=0 ; i<numLists ; i++) { + index[i] = 0; + varcList[i] = 0; + varvList[i] = (char **)NULL; + argcList[i] = 0; + argvList[i] = (char **)NULL; + } + + /* + * Break up the value lists and variable lists into elements + */ + + maxj = 0; + for (i=0 ; i<numLists ; i++) { + result = Tcl_SplitList(interp, argv[1+i*2], &varcList[i], &varvList[i]); + if (result != TCL_OK) { + goto errorReturn; + } + result = Tcl_SplitList(interp, argv[2+i*2], &argcList[i], &argvList[i]); + if (result != TCL_OK) { + goto errorReturn; + } + j = argcList[i] / varcList[i]; + if ((argcList[i] % varcList[i]) != 0) { + j++; + } + if (j > maxj) { + maxj = j; + } + } + + /* + * Iterate maxj times through the lists in parallel + * If some value lists run out of values, set loop vars to "" + */ + for (j = 0; j < maxj; j++) { + for (i=0 ; i<numLists ; i++) { + for (v=0 ; v<varcList[i] ; v++) { + int k = index[i]++; + char *value = ""; + if (k < argcList[i]) { + value = argvList[i][k]; + } + if (Tcl_SetVar(interp, varvList[i][v], value, 0) == NULL) { + Tcl_AppendResult(interp, "couldn't set loop variable: \"", + varvList[i][v], "\"", (char *)NULL); + result = TCL_ERROR; + goto errorReturn; + } + } + } + + result = Tcl_Eval(interp, argv[argc-1]); + if (result != TCL_OK) { + if (result == TCL_CONTINUE) { + result = TCL_OK; + } else if (result == TCL_BREAK) { + result = TCL_OK; + break; + } else if (result == TCL_ERROR) { + char msg[100]; + sprintf(msg, "\n (\"foreach\" body line %d)", + interp->errorLine); + Tcl_AddErrorInfo(interp, msg); + break; + } else { + break; + } + } + } + if (result == TCL_OK) { + Tcl_ResetResult(interp); + } +errorReturn: + for (i=0 ; i<numLists ; i++) { + if (argvList[i] != (char **)NULL) { + ckfree((char *) argvList[i]); + } + if (varvList[i] != (char **)NULL) { + ckfree((char *) varvList[i]); + } + } + if (numLists > STATIC_SIZE) { + ckfree((char *) index); + ckfree((char *) varcList); + ckfree((char *) argcList); + ckfree((char *) varvList); + ckfree((char *) argvList); + } +#undef STATIC_SIZE + return result; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_FormatCmd -- + * + * This procedure is invoked to process the "format" Tcl command. + * See the user documentation for details on what it does. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * See the user documentation. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +int +Tcl_FormatCmd(dummy, interp, argc, argv) + ClientData dummy; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ + register char *format; /* Used to read characters from the format + * string. */ + char newFormat[40]; /* 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 + * if no precision given. */ + 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 + * 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. */ + int whichValue; /* Indicates which of intValue, ptrValue, + * or doubleValue has the value to pass to + * sprintf, according to the following + * definitions: */ +# define INT_VALUE 0 +# define PTR_VALUE 1 +# define DOUBLE_VALUE 2 + char *dst = interp->result; /* Where result is stored. Starts off at + * interp->resultSpace, but may get dynamically + * re-allocated if this isn't enough. */ + int dstSize = 0; /* Number of non-null characters currently + * stored at dst. */ + int dstSpace = TCL_RESULT_SIZE; + /* Total amount of storage space available + * in dst (not including null terminator. */ + int noPercent; /* Special case for speed: indicates there's + * no field specifier, just a string to copy. */ + int argIndex; /* Index of argument to substitute next. */ + int gotXpg = 0; /* Non-zero means that an XPG3 %n$-style + * specifier has been seen. */ + int gotSequential = 0; /* Non-zero means that a regular sequential + * (non-XPG3) conversion specifier has been + * seen. */ + int useShort; /* Value to be printed is short (half word). */ + char *end; /* Used to locate end of numerical fields. */ + + /* + * This procedure is a bit nasty. The goal is to use sprintf to + * do most of the dirty work. There are several problems: + * 1. this procedure can't trust its arguments. + * 2. we must be able to provide a large enough result area to hold + * whatever's generated. This is hard to estimate. + * 2. there's no way to move the arguments from argv to the call + * to sprintf in a reasonable way. This is particularly nasty + * because some of the arguments may be two-word values (doubles). + * So, what happens here is to scan the format string one % group + * at a time, making many individual calls to sprintf. + */ + + if (argc < 2) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " formatString ?arg arg ...?\"", (char *) NULL); + return TCL_ERROR; + } + argIndex = 2; + for (format = argv[1]; *format != 0; ) { + register char *newPtr = newFormat; + + width = precision = noPercent = useShort = 0; + whichValue = PTR_VALUE; + + /* + * Get rid of any characters before the next field specifier. + */ + + if (*format != '%') { + register char *p; + + ptrValue = p = format; + while ((*format != '%') && (*format != 0)) { + *p = *format; + p++; + format++; + } + size = p - ptrValue; + noPercent = 1; + goto doField; + } + + if (format[1] == '%') { + ptrValue = format; + size = 1; + noPercent = 1; + format += 2; + goto doField; + } + + /* + * Parse off a field specifier, compute how many characters + * will be needed to store the result, and substitute for + * "*" size specifiers. + */ + + *newPtr = '%'; + newPtr++; + format++; + if (isdigit(UCHAR(*format))) { + int tmp; + + /* + * Check for an XPG3-style %n$ specification. Note: there + * must not be a mixture of XPG3 specs and non-XPG3 specs + * in the same format string. + */ + + tmp = strtoul(format, &end, 10); + if (*end != '$') { + goto notXpg; + } + format = end+1; + gotXpg = 1; + if (gotSequential) { + goto mixedXPG; + } + argIndex = tmp+1; + if ((argIndex < 2) || (argIndex >= argc)) { + goto badIndex; + } + goto xpgCheckDone; + } + + notXpg: + gotSequential = 1; + if (gotXpg) { + goto mixedXPG; + } + + xpgCheckDone: + while ((*format == '-') || (*format == '#') || (*format == '0') + || (*format == ' ') || (*format == '+')) { + *newPtr = *format; + newPtr++; + format++; + } + if (isdigit(UCHAR(*format))) { + width = strtoul(format, &end, 10); + format = end; + } else if (*format == '*') { + if (argIndex >= argc) { + goto badIndex; + } + if (Tcl_GetInt(interp, argv[argIndex], &width) != TCL_OK) { + goto fmtError; + } + argIndex++; + format++; + } + if (width > 1000) { + /* + * Don't allow arbitrarily large widths: could cause core + * dump when we try to allocate a zillion bytes of memory + * below. + */ + + width = 1000; + } else if (width < 0) { + width = 0; + } + if (width != 0) { + sprintf(newPtr, "%d", width); + while (*newPtr != 0) { + newPtr++; + } + } + if (*format == '.') { + *newPtr = '.'; + newPtr++; + format++; + } + if (isdigit(UCHAR(*format))) { + precision = strtoul(format, &end, 10); + format = end; + } else if (*format == '*') { + if (argIndex >= argc) { + goto badIndex; + } + if (Tcl_GetInt(interp, argv[argIndex], &precision) != TCL_OK) { + goto fmtError; + } + argIndex++; + format++; + } + if (precision != 0) { + sprintf(newPtr, "%d", precision); + while (*newPtr != 0) { + newPtr++; + } + } + if (*format == 'l') { + format++; + } else if (*format == 'h') { + useShort = 1; + *newPtr = 'h'; + newPtr++; + format++; + } + *newPtr = *format; + newPtr++; + *newPtr = 0; + if (argIndex >= argc) { + goto badIndex; + } + switch (*format) { + case 'i': + newPtr[-1] = 'd'; + case 'd': + case 'o': + case 'u': + case 'x': + case 'X': + if (Tcl_GetInt(interp, argv[argIndex], (int *) &intValue) + != TCL_OK) { + goto fmtError; + } + whichValue = INT_VALUE; + size = 40 + precision; + break; + case 's': + ptrValue = argv[argIndex]; + size = strlen(argv[argIndex]); + break; + case 'c': + if (Tcl_GetInt(interp, argv[argIndex], (int *) &intValue) + != TCL_OK) { + goto fmtError; + } + whichValue = INT_VALUE; + size = 1; + break; + case 'e': + case 'E': + case 'f': + case 'g': + case 'G': + if (Tcl_GetDouble(interp, argv[argIndex], &doubleValue) + != TCL_OK) { + goto fmtError; + } + whichValue = DOUBLE_VALUE; + size = 320; + if (precision > 10) { + size += precision; + } + break; + case 0: + interp->result = + "format string ended in middle of field specifier"; + goto fmtError; + default: + sprintf(interp->result, "bad field specifier \"%c\"", *format); + goto fmtError; + } + argIndex++; + format++; + + /* + * Make sure that there's enough space to hold the formatted + * result, then format it. + */ + + doField: + if (width > size) { + size = width; + } + if ((dstSize + size) > dstSpace) { + char *newDst; + int newSpace; + + newSpace = 2*(dstSize + size); + newDst = (char *) ckalloc((unsigned) newSpace+1); + if (dstSize != 0) { + memcpy((VOID *) newDst, (VOID *) dst, (size_t) dstSize); + } + if (dstSpace != TCL_RESULT_SIZE) { + ckfree(dst); + } + dst = newDst; + dstSpace = newSpace; + } + if (noPercent) { + memcpy((VOID *) (dst+dstSize), (VOID *) ptrValue, (size_t) size); + dstSize += size; + dst[dstSize] = 0; + } else { + if (whichValue == DOUBLE_VALUE) { + sprintf(dst+dstSize, newFormat, doubleValue); + } else if (whichValue == INT_VALUE) { + if (useShort) { + sprintf(dst+dstSize, newFormat, (short) intValue); + } else { + sprintf(dst+dstSize, newFormat, intValue); + } + } else { + sprintf(dst+dstSize, newFormat, ptrValue); + } + dstSize += strlen(dst+dstSize); + } + } + + interp->result = dst; + if (dstSpace != TCL_RESULT_SIZE) { + interp->freeProc = TCL_DYNAMIC; + } else { + interp->freeProc = 0; + } + return TCL_OK; + + mixedXPG: + interp->result = "cannot mix \"%\" and \"%n$\" conversion specifiers"; + goto fmtError; + + badIndex: + if (gotXpg) { + interp->result = "\"%n$\" argument index out of range"; + } else { + interp->result = "not enough arguments for all format specifiers"; + } + + fmtError: + if (dstSpace != TCL_RESULT_SIZE) { + ckfree(dst); + } + return TCL_ERROR; +} diff --git a/contrib/tcl/generic/tclCmdIL.c b/contrib/tcl/generic/tclCmdIL.c new file mode 100644 index 0000000..9998e19 --- /dev/null +++ b/contrib/tcl/generic/tclCmdIL.c @@ -0,0 +1,1487 @@ +/* + * tclCmdIL.c -- + * + * This file contains the top-level command routines for most of + * the Tcl built-in commands whose names begin with the letters + * I through L. It contains only commands in the generic core + * (i.e. those that don't depend much upon UNIX facilities). + * + * Copyright (c) 1987-1993 The Regents of the University of California. + * Copyright (c) 1994-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: @(#) tclCmdIL.c 1.119 96/03/22 12:10:14 + */ + +#include "tclInt.h" +#include "tclPort.h" + +/* + * The following variable holds the full path name of the binary + * from which this application was executed, or NULL if it isn't + * know. The value of the variable is set by the procedure + * Tcl_FindExecutable. The storage space is dynamically allocated. + */ + +char *tclExecutableName = NULL; + +/* + * The variables below are used to implement the "lsort" command. + * Unfortunately, this use of static variables prevents "lsort" + * from being thread-safe, but there's no alternative given the + * current implementation of qsort. In a threaded environment + * these variables should be made thread-local if possible, or else + * "lsort" needs internal mutual exclusion. + */ + +static Tcl_Interp *sortInterp = NULL; /* Interpreter for "lsort" command. + * NULL means no lsort is active. */ +static enum {ASCII, INTEGER, REAL, COMMAND} sortMode; + /* Mode for sorting: compare as strings, + * compare as numbers, or call + * user-defined command for + * comparison. */ +static Tcl_DString sortCmd; /* Holds command if mode is COMMAND. + * pre-initialized to hold base of + * command. */ +static int sortIncreasing; /* 0 means sort in decreasing order, + * 1 means increasing order. */ +static int sortCode; /* Anything other than TCL_OK means a + * problem occurred while sorting; this + * executing a comparison command, so + * the sort was aborted. */ + +/* + * Forward declarations for procedures defined in this file: + */ + +static int SortCompareProc _ANSI_ARGS_((CONST VOID *first, + CONST VOID *second)); + +/* + *---------------------------------------------------------------------- + * + * Tcl_IfCmd -- + * + * This procedure is invoked to process the "if" Tcl command. + * See the user documentation for details on what it does. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * See the user documentation. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +int +Tcl_IfCmd(dummy, interp, argc, argv) + ClientData dummy; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ + int i, result, value; + + i = 1; + while (1) { + /* + * At this point in the loop, argv and argc refer to an expression + * to test, either for the main expression or an expression + * following an "elseif". The arguments after the expression must + * be "then" (optional) and a script to execute if the expression is + * true. + */ + + if (i >= argc) { + Tcl_AppendResult(interp, "wrong # args: no expression after \"", + argv[i-1], "\" argument", (char *) NULL); + return TCL_ERROR; + } + result = Tcl_ExprBoolean(interp, argv[i], &value); + if (result != TCL_OK) { + return result; + } + i++; + if ((i < argc) && (strcmp(argv[i], "then") == 0)) { + i++; + } + if (i >= argc) { + Tcl_AppendResult(interp, "wrong # args: no script following \"", + argv[i-1], "\" argument", (char *) NULL); + return TCL_ERROR; + } + if (value) { + return Tcl_Eval(interp, argv[i]); + } + + /* + * The expression evaluated to false. Skip the command, then + * see if there is an "else" or "elseif" clause. + */ + + i++; + if (i >= argc) { + return TCL_OK; + } + if ((argv[i][0] == 'e') && (strcmp(argv[i], "elseif") == 0)) { + i++; + continue; + } + break; + } + + /* + * Couldn't find a "then" or "elseif" clause to execute. Check now + * for an "else" clause. We know that there's at least one more + * argument when we get here. + */ + + if (strcmp(argv[i], "else") == 0) { + i++; + if (i >= argc) { + Tcl_AppendResult(interp, + "wrong # args: no script following \"else\" argument", + (char *) NULL); + return TCL_ERROR; + } + } + return Tcl_Eval(interp, argv[i]); +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_IncrCmd -- + * + * This procedure is invoked to process the "incr" Tcl command. + * See the user documentation for details on what it does. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * See the user documentation. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +int +Tcl_IncrCmd(dummy, interp, argc, argv) + ClientData dummy; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ + int value; + char *oldString, *result; + char newString[30]; + + if ((argc != 2) && (argc != 3)) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " varName ?increment?\"", (char *) NULL); + return TCL_ERROR; + } + + oldString = Tcl_GetVar(interp, argv[1], TCL_LEAVE_ERR_MSG); + if (oldString == NULL) { + return TCL_ERROR; + } + if (Tcl_GetInt(interp, oldString, &value) != TCL_OK) { + Tcl_AddErrorInfo(interp, + "\n (reading value of variable to increment)"); + return TCL_ERROR; + } + if (argc == 2) { + value += 1; + } else { + int increment; + + if (Tcl_GetInt(interp, argv[2], &increment) != TCL_OK) { + Tcl_AddErrorInfo(interp, + "\n (reading increment)"); + return TCL_ERROR; + } + value += increment; + } + sprintf(newString, "%d", value); + result = Tcl_SetVar(interp, argv[1], newString, TCL_LEAVE_ERR_MSG); + if (result == NULL) { + return TCL_ERROR; + } + interp->result = result; + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_InfoCmd -- + * + * This procedure is invoked to process the "info" Tcl command. + * See the user documentation for details on what it does. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * See the user documentation. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +int +Tcl_InfoCmd(dummy, interp, argc, argv) + ClientData dummy; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ + register Interp *iPtr = (Interp *) interp; + size_t length; + int c; + Arg *argPtr; + Proc *procPtr; + Var *varPtr; + Command *cmdPtr; + Tcl_HashEntry *hPtr; + Tcl_HashSearch search; + + if (argc < 2) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " option ?arg arg ...?\"", (char *) NULL); + return TCL_ERROR; + } + c = argv[1][0]; + length = strlen(argv[1]); + if ((c == 'a') && (strncmp(argv[1], "args", length)) == 0) { + if (argc != 3) { + Tcl_AppendResult(interp, "wrong # args: should be \"", + argv[0], " args procname\"", (char *) NULL); + return TCL_ERROR; + } + procPtr = TclFindProc(iPtr, argv[2]); + if (procPtr == NULL) { + infoNoSuchProc: + Tcl_AppendResult(interp, "\"", argv[2], + "\" isn't a procedure", (char *) NULL); + return TCL_ERROR; + } + for (argPtr = procPtr->argPtr; argPtr != NULL; + argPtr = argPtr->nextPtr) { + Tcl_AppendElement(interp, argPtr->name); + } + return TCL_OK; + } else if ((c == 'b') && (strncmp(argv[1], "body", length)) == 0) { + if (argc != 3) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " body procname\"", (char *) NULL); + return TCL_ERROR; + } + procPtr = TclFindProc(iPtr, argv[2]); + if (procPtr == NULL) { + goto infoNoSuchProc; + } + iPtr->result = procPtr->command; + return TCL_OK; + } else if ((c == 'c') && (strncmp(argv[1], "cmdcount", length) == 0) + && (length >= 2)) { + if (argc != 2) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " cmdcount\"", (char *) NULL); + return TCL_ERROR; + } + sprintf(iPtr->result, "%d", iPtr->cmdCount); + return TCL_OK; + } else if ((c == 'c') && (strncmp(argv[1], "commands", length) == 0) + && (length >= 4)) { + if (argc > 3) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " commands ?pattern?\"", (char *) NULL); + return TCL_ERROR; + } + for (hPtr = Tcl_FirstHashEntry(&iPtr->commandTable, &search); + hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) { + char *name = Tcl_GetHashKey(&iPtr->commandTable, hPtr); + if ((argc == 3) && !Tcl_StringMatch(name, argv[2])) { + continue; + } + Tcl_AppendElement(interp, name); + } + return TCL_OK; + } else if ((c == 'c') && (strncmp(argv[1], "complete", length) == 0) + && (length >= 4)) { + if (argc != 3) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " complete command\"", (char *) NULL); + return TCL_ERROR; + } + if (Tcl_CommandComplete(argv[2])) { + interp->result = "1"; + } else { + interp->result = "0"; + } + return TCL_OK; + } else if ((c == 'd') && (strncmp(argv[1], "default", length)) == 0) { + if (argc != 5) { + Tcl_AppendResult(interp, "wrong # args: should be \"", + argv[0], " default procname arg varname\"", + (char *) NULL); + return TCL_ERROR; + } + procPtr = TclFindProc(iPtr, argv[2]); + if (procPtr == NULL) { + goto infoNoSuchProc; + } + for (argPtr = procPtr->argPtr; ; argPtr = argPtr->nextPtr) { + if (argPtr == NULL) { + Tcl_AppendResult(interp, "procedure \"", argv[2], + "\" doesn't have an argument \"", argv[3], + "\"", (char *) NULL); + return TCL_ERROR; + } + if (strcmp(argv[3], argPtr->name) == 0) { + if (argPtr->defValue != NULL) { + if (Tcl_SetVar((Tcl_Interp *) iPtr, argv[4], + argPtr->defValue, 0) == NULL) { + defStoreError: + Tcl_AppendResult(interp, + "couldn't store default value in variable \"", + argv[4], "\"", (char *) NULL); + return TCL_ERROR; + } + iPtr->result = "1"; + } else { + if (Tcl_SetVar((Tcl_Interp *) iPtr, argv[4], "", 0) + == NULL) { + goto defStoreError; + } + iPtr->result = "0"; + } + return TCL_OK; + } + } + } else if ((c == 'e') && (strncmp(argv[1], "exists", length) == 0)) { + char *p; + if (argc != 3) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " exists varName\"", (char *) NULL); + return TCL_ERROR; + } + p = Tcl_GetVar((Tcl_Interp *) iPtr, argv[2], 0); + + /* + * The code below handles the special case where the name is for + * an array: Tcl_GetVar will reject this since you can't read + * an array variable without an index. + */ + + if (p == NULL) { + Tcl_HashEntry *hPtr; + Var *varPtr; + + if (strchr(argv[2], '(') != NULL) { + noVar: + iPtr->result = "0"; + return TCL_OK; + } + if (iPtr->varFramePtr == NULL) { + hPtr = Tcl_FindHashEntry(&iPtr->globalTable, argv[2]); + } else { + hPtr = Tcl_FindHashEntry(&iPtr->varFramePtr->varTable, argv[2]); + } + if (hPtr == NULL) { + goto noVar; + } + varPtr = (Var *) Tcl_GetHashValue(hPtr); + if (varPtr->flags & VAR_UPVAR) { + varPtr = varPtr->value.upvarPtr; + } + if (!(varPtr->flags & VAR_ARRAY)) { + goto noVar; + } + } + iPtr->result = "1"; + return TCL_OK; + } else if ((c == 'g') && (strncmp(argv[1], "globals", length) == 0)) { + char *name; + + if (argc > 3) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " globals ?pattern?\"", (char *) NULL); + return TCL_ERROR; + } + for (hPtr = Tcl_FirstHashEntry(&iPtr->globalTable, &search); + hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) { + varPtr = (Var *) Tcl_GetHashValue(hPtr); + if (varPtr->flags & VAR_UNDEFINED) { + continue; + } + name = Tcl_GetHashKey(&iPtr->globalTable, hPtr); + if ((argc == 3) && !Tcl_StringMatch(name, argv[2])) { + continue; + } + Tcl_AppendElement(interp, name); + } + return TCL_OK; + } else if ((c == 'h') && (strncmp(argv[1], "hostname", length) == 0)) { + if (argc > 2) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " hostname\"", (char *) NULL); + return TCL_ERROR; + } + Tcl_AppendResult(interp, Tcl_GetHostName(), NULL); + return TCL_OK; + } else if ((c == 'l') && (strncmp(argv[1], "level", length) == 0) + && (length >= 2)) { + if (argc == 2) { + if (iPtr->varFramePtr == NULL) { + iPtr->result = "0"; + } else { + sprintf(iPtr->result, "%d", iPtr->varFramePtr->level); + } + return TCL_OK; + } else if (argc == 3) { + int level; + CallFrame *framePtr; + + if (Tcl_GetInt(interp, argv[2], &level) != TCL_OK) { + return TCL_ERROR; + } + if (level <= 0) { + if (iPtr->varFramePtr == NULL) { + levelError: + Tcl_AppendResult(interp, "bad level \"", argv[2], + "\"", (char *) NULL); + return TCL_ERROR; + } + level += iPtr->varFramePtr->level; + } + for (framePtr = iPtr->varFramePtr; framePtr != NULL; + framePtr = framePtr->callerVarPtr) { + if (framePtr->level == level) { + break; + } + } + if (framePtr == NULL) { + goto levelError; + } + iPtr->result = Tcl_Merge(framePtr->argc, framePtr->argv); + iPtr->freeProc = TCL_DYNAMIC; + return TCL_OK; + } + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " level [number]\"", (char *) NULL); + return TCL_ERROR; + } else if ((c == 'l') && (strncmp(argv[1], "library", length) == 0) + && (length >= 2)) { + if (argc != 2) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " library\"", (char *) NULL); + return TCL_ERROR; + } + interp->result = Tcl_GetVar(interp, "tcl_library", TCL_GLOBAL_ONLY); + if (interp->result == NULL) { + interp->result = "no library has been specified for Tcl"; + return TCL_ERROR; + } + return TCL_OK; + } else if ((c == 'l') && (strncmp(argv[1], "loaded", length) == 0) + && (length >= 3)) { + if ((argc != 2) && (argc != 3)) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " loaded ?interp?\"", (char *) NULL); + return TCL_ERROR; + } + return TclGetLoadedPackages(interp, argv[2]); + } else if ((c == 'l') && (strncmp(argv[1], "locals", length) == 0) + && (length >= 3)) { + char *name; + + if (argc > 3) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " locals ?pattern?\"", (char *) NULL); + return TCL_ERROR; + } + if (iPtr->varFramePtr == NULL) { + return TCL_OK; + } + for (hPtr = Tcl_FirstHashEntry(&iPtr->varFramePtr->varTable, &search); + hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) { + varPtr = (Var *) Tcl_GetHashValue(hPtr); + if (varPtr->flags & (VAR_UNDEFINED|VAR_UPVAR)) { + continue; + } + name = Tcl_GetHashKey(&iPtr->varFramePtr->varTable, hPtr); + if ((argc == 3) && !Tcl_StringMatch(name, argv[2])) { + continue; + } + Tcl_AppendElement(interp, name); + } + return TCL_OK; + } else if ((c == 'n') && (strncmp(argv[1], "nameofexecutable", + length) == 0)) { + if (argc != 2) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " nameofexecutable\"", (char *) NULL); + return TCL_ERROR; + } + if (tclExecutableName != NULL) { + interp->result = tclExecutableName; + } + return TCL_OK; + } else if ((c == 'p') && (strncmp(argv[1], "patchlevel", length) == 0) + && (length >= 2)) { + char *value; + + if (argc != 2) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " patchlevel\"", (char *) NULL); + return TCL_ERROR; + } + value = Tcl_GetVar(interp, "tcl_patchLevel", + TCL_GLOBAL_ONLY|TCL_LEAVE_ERR_MSG); + if (value == NULL) { + return TCL_ERROR; + } + interp->result = value; + return TCL_OK; + } else if ((c == 'p') && (strncmp(argv[1], "procs", length) == 0) + && (length >= 2)) { + if (argc > 3) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " procs ?pattern?\"", (char *) NULL); + return TCL_ERROR; + } + for (hPtr = Tcl_FirstHashEntry(&iPtr->commandTable, &search); + hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) { + char *name = Tcl_GetHashKey(&iPtr->commandTable, hPtr); + + cmdPtr = (Command *) Tcl_GetHashValue(hPtr); + if (!TclIsProc(cmdPtr)) { + continue; + } + if ((argc == 3) && !Tcl_StringMatch(name, argv[2])) { + continue; + } + Tcl_AppendElement(interp, name); + } + return TCL_OK; + } else if ((c == 's') && (strncmp(argv[1], "script", length) == 0) + && (length >= 2)) { + if (argc != 2) { + Tcl_AppendResult(interp, "wrong # args: should be \"", + argv[0], " script\"", (char *) NULL); + return TCL_ERROR; + } + if (iPtr->scriptFile != NULL) { + /* + * Can't depend on iPtr->scriptFile to be non-volatile: + * if this command is returned as the result of the script, + * then iPtr->scriptFile will go away. + */ + + Tcl_SetResult(interp, iPtr->scriptFile, TCL_VOLATILE); + } + return TCL_OK; + } else if ((c == 's') && (strncmp(argv[1], "sharedlibextension", + length) == 0) && (length >= 2)) { + if (argc != 2) { + Tcl_AppendResult(interp, "wrong # args: should be \"", + argv[0], " sharedlibextension\"", (char *) NULL); + return TCL_ERROR; + } +#ifdef TCL_SHLIB_EXT + interp->result = TCL_SHLIB_EXT; +#endif + return TCL_OK; + } else if ((c == 't') && (strncmp(argv[1], "tclversion", length) == 0)) { + char *value; + + if (argc != 2) { + Tcl_AppendResult(interp, "wrong # args: should be \"", + argv[0], " tclversion\"", (char *) NULL); + return TCL_ERROR; + } + value = Tcl_GetVar(interp, "tcl_version", + TCL_GLOBAL_ONLY|TCL_LEAVE_ERR_MSG); + if (value == NULL) { + return TCL_ERROR; + } + interp->result = value; + return TCL_OK; + } else if ((c == 'v') && (strncmp(argv[1], "vars", length)) == 0) { + Tcl_HashTable *tablePtr; + char *name; + + if (argc > 3) { + Tcl_AppendResult(interp, "wrong # args: should be \"", + argv[0], " vars ?pattern?\"", (char *) NULL); + return TCL_ERROR; + } + if (iPtr->varFramePtr == NULL) { + tablePtr = &iPtr->globalTable; + } else { + tablePtr = &iPtr->varFramePtr->varTable; + } + for (hPtr = Tcl_FirstHashEntry(tablePtr, &search); + hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) { + varPtr = (Var *) Tcl_GetHashValue(hPtr); + if (varPtr->flags & VAR_UNDEFINED) { + continue; + } + name = Tcl_GetHashKey(tablePtr, hPtr); + if ((argc == 3) && !Tcl_StringMatch(name, argv[2])) { + continue; + } + Tcl_AppendElement(interp, name); + } + return TCL_OK; + } else { + Tcl_AppendResult(interp, "bad option \"", argv[1], + "\": should be args, body, cmdcount, commands, ", + "complete, default, ", + "exists, globals, hostname, level, library, loaded, locals, ", + "nameofexecutable, patchlevel, procs, script, ", + "sharedlibextension, tclversion, or vars", + (char *) NULL); + return TCL_ERROR; + } +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_JoinCmd -- + * + * This procedure is invoked to process the "join" Tcl command. + * See the user documentation for details on what it does. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * See the user documentation. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +int +Tcl_JoinCmd(dummy, interp, argc, argv) + ClientData dummy; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ + char *joinString; + char **listArgv; + int listArgc, i; + + if (argc == 2) { + joinString = " "; + } else if (argc == 3) { + joinString = argv[2]; + } else { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " list ?joinString?\"", (char *) NULL); + return TCL_ERROR; + } + + if (Tcl_SplitList(interp, argv[1], &listArgc, &listArgv) != TCL_OK) { + return TCL_ERROR; + } + for (i = 0; i < listArgc; i++) { + if (i == 0) { + Tcl_AppendResult(interp, listArgv[0], (char *) NULL); + } else { + Tcl_AppendResult(interp, joinString, listArgv[i], (char *) NULL); + } + } + ckfree((char *) listArgv); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_LindexCmd -- + * + * This procedure is invoked to process the "lindex" Tcl command. + * See the user documentation for details on what it does. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * See the user documentation. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +int +Tcl_LindexCmd(dummy, interp, argc, argv) + ClientData dummy; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ + char *p, *element, *next; + int index, size, parenthesized, result, returnLast; + + if (argc != 3) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " list index\"", (char *) NULL); + return TCL_ERROR; + } + if ((*argv[2] == 'e') && (strncmp(argv[2], "end", strlen(argv[2])) == 0)) { + returnLast = 1; + index = INT_MAX; + } else { + returnLast = 0; + if (Tcl_GetInt(interp, argv[2], &index) != TCL_OK) { + return TCL_ERROR; + } + } + if (index < 0) { + return TCL_OK; + } + for (p = argv[1] ; index >= 0; index--) { + result = TclFindElement(interp, p, &element, &next, &size, + &parenthesized); + if (result != TCL_OK) { + return result; + } + if ((*next == 0) && returnLast) { + break; + } + p = next; + } + if (size == 0) { + return TCL_OK; + } + if (size >= TCL_RESULT_SIZE) { + interp->result = (char *) ckalloc((unsigned) size+1); + interp->freeProc = TCL_DYNAMIC; + } + if (parenthesized) { + memcpy((VOID *) interp->result, (VOID *) element, (size_t) size); + interp->result[size] = 0; + } else { + TclCopyAndCollapse(size, element, interp->result); + } + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_LinsertCmd -- + * + * This procedure is invoked to process the "linsert" Tcl command. + * See the user documentation for details on what it does. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * See the user documentation. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +int +Tcl_LinsertCmd(dummy, interp, argc, argv) + ClientData dummy; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ + char *p, *element, savedChar; + int i, index, count, result, size; + + if (argc < 4) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " list index element ?element ...?\"", (char *) NULL); + return TCL_ERROR; + } + if ((*argv[2] == 'e') && (strncmp(argv[2], "end", strlen(argv[2])) == 0)) { + index = INT_MAX; + } else if (Tcl_GetInt(interp, argv[2], &index) != TCL_OK) { + return TCL_ERROR; + } + + /* + * Skip over the first "index" elements of the list, then add + * all of those elements to the result. + */ + + size = 0; + element = argv[1]; + for (count = 0, p = argv[1]; (count < index) && (*p != 0); count++) { + result = TclFindElement(interp, p, &element, &p, &size, (int *) NULL); + if (result != TCL_OK) { + return result; + } + } + if (*p == 0) { + Tcl_AppendResult(interp, argv[1], (char *) NULL); + } else { + char *end; + + end = element+size; + if (element != argv[1]) { + while ((*end != 0) && !isspace(UCHAR(*end))) { + end++; + } + } + savedChar = *end; + *end = 0; + Tcl_AppendResult(interp, argv[1], (char *) NULL); + *end = savedChar; + } + + /* + * Add the new list elements. + */ + + for (i = 3; i < argc; i++) { + Tcl_AppendElement(interp, argv[i]); + } + + /* + * Append the remainder of the original list. + */ + + if (*p != 0) { + Tcl_AppendResult(interp, " ", p, (char *) NULL); + } + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_ListCmd -- + * + * This procedure is invoked to process the "list" Tcl command. + * See the user documentation for details on what it does. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * See the user documentation. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +int +Tcl_ListCmd(dummy, interp, argc, argv) + ClientData dummy; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ + if (argc >= 2) { + interp->result = Tcl_Merge(argc-1, argv+1); + interp->freeProc = TCL_DYNAMIC; + } + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_LlengthCmd -- + * + * This procedure is invoked to process the "llength" Tcl command. + * See the user documentation for details on what it does. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * See the user documentation. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +int +Tcl_LlengthCmd(dummy, interp, argc, argv) + ClientData dummy; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ + int count, result; + char *element, *p; + + if (argc != 2) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " list\"", (char *) NULL); + return TCL_ERROR; + } + for (count = 0, p = argv[1]; *p != 0 ; count++) { + result = TclFindElement(interp, p, &element, &p, (int *) NULL, + (int *) NULL); + if (result != TCL_OK) { + return result; + } + if (*element == 0) { + break; + } + } + sprintf(interp->result, "%d", count); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_LrangeCmd -- + * + * This procedure is invoked to process the "lrange" Tcl command. + * See the user documentation for details on what it does. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * See the user documentation. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +int +Tcl_LrangeCmd(notUsed, interp, argc, argv) + ClientData notUsed; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ + int first, last, result; + char *begin, *end, c, *dummy, *next; + int count, firstIsEnd; + + if (argc != 4) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " list first last\"", (char *) NULL); + return TCL_ERROR; + } + if ((*argv[2] == 'e') && (strncmp(argv[2], "end", strlen(argv[2])) == 0)) { + firstIsEnd = 1; + first = INT_MAX; + } else { + firstIsEnd = 0; + if (Tcl_GetInt(interp, argv[2], &first) != TCL_OK) { + return TCL_ERROR; + } + } + if (first < 0) { + first = 0; + } + if ((*argv[3] == 'e') && (strncmp(argv[3], "end", strlen(argv[3])) == 0)) { + last = INT_MAX; + } else { + if (Tcl_GetInt(interp, argv[3], &last) != TCL_OK) { + Tcl_ResetResult(interp); + Tcl_AppendResult(interp, "expected integer or \"end\" but got \"", + argv[3], "\"", (char *) NULL); + return TCL_ERROR; + } + } + if ((first > last) && !firstIsEnd) { + return TCL_OK; + } + + /* + * Extract a range of fields. + */ + + for (count = 0, begin = argv[1]; count < first; begin = next, count++) { + result = TclFindElement(interp, begin, &dummy, &next, (int *) NULL, + (int *) NULL); + if (result != TCL_OK) { + return result; + } + if (*next == 0) { + if (firstIsEnd) { + first = count; + } else { + begin = next; + } + break; + } + } + for (count = first, end = begin; (count <= last) && (*end != 0); + count++) { + result = TclFindElement(interp, end, &dummy, &end, (int *) NULL, + (int *) NULL); + if (result != TCL_OK) { + return result; + } + } + if (end == begin) { + return TCL_OK; + } + + /* + * Chop off trailing spaces. + */ + + while (isspace(UCHAR(end[-1]))) { + end--; + } + c = *end; + *end = 0; + Tcl_SetResult(interp, begin, TCL_VOLATILE); + *end = c; + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_LreplaceCmd -- + * + * This procedure is invoked to process the "lreplace" Tcl command. + * See the user documentation for details on what it does. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * See the user documentation. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +int +Tcl_LreplaceCmd(notUsed, interp, argc, argv) + ClientData notUsed; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ + char *p1, *p2, *element, savedChar, *dummy, *next; + int i, first, last, count, result, size, firstIsEnd; + + if (argc < 4) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " list first last ?element element ...?\"", (char *) NULL); + return TCL_ERROR; + } + if ((*argv[2] == 'e') && (strncmp(argv[2], "end", strlen(argv[2])) == 0)) { + firstIsEnd = 1; + first = INT_MAX; + } else { + firstIsEnd = 0; + if (Tcl_GetInt(interp, argv[2], &first) != TCL_OK) { + Tcl_ResetResult(interp); + Tcl_AppendResult(interp, "bad index \"", argv[2], + "\": must be integer or \"end\"", (char *) NULL); + return TCL_ERROR; + } + } + if ((*argv[3] == 'e') && (strncmp(argv[3], "end", strlen(argv[3])) == 0)) { + last = INT_MAX; + } else { + if (Tcl_GetInt(interp, argv[3], &last) != TCL_OK) { + Tcl_ResetResult(interp); + Tcl_AppendResult(interp, "bad index \"", argv[3], + "\": must be integer or \"end\"", (char *) NULL); + return TCL_ERROR; + } + } + if (first < 0) { + first = 0; + } + + /* + * Skip over the elements of the list before "first". + */ + + size = 0; + element = argv[1]; + for (count = 0, p1 = argv[1]; (count < first) && (*p1 != 0); count++) { + result = TclFindElement(interp, p1, &element, &next, &size, + (int *) NULL); + if (result != TCL_OK) { + return result; + } + if ((*next == 0) && firstIsEnd) { + break; + } + p1 = next; + } + if (*p1 == 0) { + Tcl_AppendResult(interp, "list doesn't contain element ", + argv[2], (char *) NULL); + return TCL_ERROR; + } + + /* + * Skip over the elements of the list up through "last". + */ + + for (p2 = p1 ; (count <= last) && (*p2 != 0); count++) { + result = TclFindElement(interp, p2, &dummy, &p2, (int *) NULL, + (int *) NULL); + if (result != TCL_OK) { + return result; + } + } + + /* + * Add the elements before "first" to the result. Drop any terminating + * white space, since a separator will be added below, if needed. + */ + + while ((p1 != argv[1]) && (isspace(UCHAR(p1[-1])))) { + p1--; + } + savedChar = *p1; + *p1 = 0; + Tcl_AppendResult(interp, argv[1], (char *) NULL); + *p1 = savedChar; + + /* + * Add the new list elements. + */ + + for (i = 4; i < argc; i++) { + Tcl_AppendElement(interp, argv[i]); + } + + /* + * Append the remainder of the original list. + */ + + if (*p2 != 0) { + if (*interp->result == 0) { + Tcl_SetResult(interp, p2, TCL_VOLATILE); + } else { + Tcl_AppendResult(interp, " ", p2, (char *) NULL); + } + } + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_LsearchCmd -- + * + * This procedure is invoked to process the "lsearch" Tcl command. + * See the user documentation for details on what it does. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * See the user documentation. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +int +Tcl_LsearchCmd(notUsed, interp, argc, argv) + ClientData notUsed; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ +#define EXACT 0 +#define GLOB 1 +#define REGEXP 2 + int listArgc; + char **listArgv; + int i, match, mode, index; + + mode = GLOB; + if (argc == 4) { + if (strcmp(argv[1], "-exact") == 0) { + mode = EXACT; + } else if (strcmp(argv[1], "-glob") == 0) { + mode = GLOB; + } else if (strcmp(argv[1], "-regexp") == 0) { + mode = REGEXP; + } else { + Tcl_AppendResult(interp, "bad search mode \"", argv[1], + "\": must be -exact, -glob, or -regexp", (char *) NULL); + return TCL_ERROR; + } + } else if (argc != 3) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " ?mode? list pattern\"", (char *) NULL); + return TCL_ERROR; + } + if (Tcl_SplitList(interp, argv[argc-2], &listArgc, &listArgv) != TCL_OK) { + return TCL_ERROR; + } + index = -1; + for (i = 0; i < listArgc; i++) { + match = 0; + switch (mode) { + case EXACT: + match = (strcmp(listArgv[i], argv[argc-1]) == 0); + break; + case GLOB: + match = Tcl_StringMatch(listArgv[i], argv[argc-1]); + break; + case REGEXP: + match = Tcl_RegExpMatch(interp, listArgv[i], argv[argc-1]); + if (match < 0) { + ckfree((char *) listArgv); + return TCL_ERROR; + } + break; + } + if (match) { + index = i; + break; + } + } + sprintf(interp->result, "%d", index); + ckfree((char *) listArgv); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_LsortCmd -- + * + * This procedure is invoked to process the "lsort" Tcl command. + * See the user documentation for details on what it does. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * See the user documentation. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +int +Tcl_LsortCmd(notUsed, interp, argc, argv) + ClientData notUsed; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ + int listArgc, i, c; + size_t length; + char **listArgv; + char *command = NULL; /* Initialization needed only to + * prevent compiler warning. */ + + if (argc < 2) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " ?-ascii? ?-integer? ?-real? ?-increasing? ?-decreasing?", + " ?-command string? list\"", (char *) NULL); + return TCL_ERROR; + } + + if (sortInterp != NULL) { + interp->result = "can't invoke \"lsort\" recursively"; + return TCL_ERROR; + } + + /* + * Parse arguments to set up the mode for the sort. + */ + + sortInterp = interp; + sortMode = ASCII; + sortIncreasing = 1; + sortCode = TCL_OK; + for (i = 1; i < argc-1; i++) { + length = strlen(argv[i]); + if (length < 2) { + badSwitch: + Tcl_AppendResult(interp, "bad switch \"", argv[i], + "\": must be -ascii, -integer, -real, -increasing", + " -decreasing, or -command", (char *) NULL); + sortCode = TCL_ERROR; + goto done; + } + c = argv[i][1]; + if ((c == 'a') && (strncmp(argv[i], "-ascii", length) == 0)) { + sortMode = ASCII; + } else if ((c == 'c') && (strncmp(argv[i], "-command", length) == 0)) { + if (i == argc-2) { + Tcl_AppendResult(interp, "\"-command\" must be", + " followed by comparison command", (char *) NULL); + sortCode = TCL_ERROR; + goto done; + } + sortMode = COMMAND; + command = argv[i+1]; + i++; + } else if ((c == 'd') + && (strncmp(argv[i], "-decreasing", length) == 0)) { + sortIncreasing = 0; + } else if ((c == 'i') && (length >= 4) + && (strncmp(argv[i], "-increasing", length) == 0)) { + sortIncreasing = 1; + } else if ((c == 'i') && (length >= 4) + && (strncmp(argv[i], "-integer", length) == 0)) { + sortMode = INTEGER; + } else if ((c == 'r') + && (strncmp(argv[i], "-real", length) == 0)) { + sortMode = REAL; + } else { + goto badSwitch; + } + } + if (sortMode == COMMAND) { + Tcl_DStringInit(&sortCmd); + Tcl_DStringAppend(&sortCmd, command, -1); + } + + if (Tcl_SplitList(interp, argv[argc-1], &listArgc, &listArgv) != TCL_OK) { + sortCode = TCL_ERROR; + goto done; + } + qsort((VOID *) listArgv, (size_t) listArgc, sizeof (char *), + SortCompareProc); + if (sortCode == TCL_OK) { + Tcl_ResetResult(interp); + interp->result = Tcl_Merge(listArgc, listArgv); + interp->freeProc = TCL_DYNAMIC; + } + if (sortMode == COMMAND) { + Tcl_DStringFree(&sortCmd); + } + ckfree((char *) listArgv); + + done: + sortInterp = NULL; + return sortCode; +} + +/* + *---------------------------------------------------------------------- + * + * SortCompareProc -- + * + * This procedure is invoked by qsort to determine the proper + * ordering between two elements. + * + * Results: + * < 0 means first is "smaller" than "second", > 0 means "first" + * is larger than "second", and 0 means they should be treated + * as equal. + * + * Side effects: + * None, unless a user-defined comparison command does something + * weird. + * + *---------------------------------------------------------------------- + */ + +static int +SortCompareProc(first, second) + CONST VOID *first, *second; /* Elements to be compared. */ +{ + int order; + char *firstString = *((char **) first); + char *secondString = *((char **) second); + + order = 0; + if (sortCode != TCL_OK) { + /* + * Once an error has occurred, skip any future comparisons + * so as to preserve the error message in sortInterp->result. + */ + + return order; + } + if (sortMode == ASCII) { + order = strcmp(firstString, secondString); + } else if (sortMode == INTEGER) { + int a, b; + + if ((Tcl_GetInt(sortInterp, firstString, &a) != TCL_OK) + || (Tcl_GetInt(sortInterp, secondString, &b) != TCL_OK)) { + Tcl_AddErrorInfo(sortInterp, + "\n (converting list element from string to integer)"); + sortCode = TCL_ERROR; + return order; + } + if (a > b) { + order = 1; + } else if (b > a) { + order = -1; + } + } else if (sortMode == REAL) { + double a, b; + + if ((Tcl_GetDouble(sortInterp, firstString, &a) != TCL_OK) + || (Tcl_GetDouble(sortInterp, secondString, &b) != TCL_OK)) { + Tcl_AddErrorInfo(sortInterp, + "\n (converting list element from string to real)"); + sortCode = TCL_ERROR; + return order; + } + if (a > b) { + order = 1; + } else if (b > a) { + order = -1; + } + } else { + int oldLength; + char *end; + + /* + * Generate and evaluate a command to determine which string comes + * first. + */ + + oldLength = Tcl_DStringLength(&sortCmd); + Tcl_DStringAppendElement(&sortCmd, firstString); + Tcl_DStringAppendElement(&sortCmd, secondString); + sortCode = Tcl_Eval(sortInterp, Tcl_DStringValue(&sortCmd)); + Tcl_DStringTrunc(&sortCmd, oldLength); + if (sortCode != TCL_OK) { + Tcl_AddErrorInfo(sortInterp, + "\n (user-defined comparison command)"); + return order; + } + + /* + * Parse the result of the command. + */ + + order = strtol(sortInterp->result, &end, 0); + if ((end == sortInterp->result) || (*end != 0)) { + Tcl_ResetResult(sortInterp); + Tcl_AppendResult(sortInterp, + "comparison command returned non-numeric result", + (char *) NULL); + sortCode = TCL_ERROR; + return order; + } + } + if (!sortIncreasing) { + order = -order; + } + return order; +} diff --git a/contrib/tcl/generic/tclCmdMZ.c b/contrib/tcl/generic/tclCmdMZ.c new file mode 100644 index 0000000..faf9eed --- /dev/null +++ b/contrib/tcl/generic/tclCmdMZ.c @@ -0,0 +1,2107 @@ +/* + * tclCmdMZ.c -- + * + * This file contains the top-level command routines for most of + * the Tcl built-in commands whose names begin with the letters + * M to Z. It contains only commands in the generic core (i.e. + * those that don't depend much upon UNIX facilities). + * + * Copyright (c) 1987-1993 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: @(#) tclCmdMZ.c 1.65 96/02/09 14:59:52 + */ + +#include "tclInt.h" +#include "tclPort.h" + +/* + * Structure used to hold information about variable 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. */ + int 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; + +/* + * Forward declarations for procedures defined in this file: + */ + +static char * TraceVarProc _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, char *name1, char *name2, + int flags)); + +/* + *---------------------------------------------------------------------- + * + * Tcl_PwdCmd -- + * + * This procedure is invoked to process the "pwd" Tcl command. + * See the user documentation for details on what it does. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * See the user documentation. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +int +Tcl_PwdCmd(dummy, interp, argc, argv) + ClientData dummy; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ + char *dirName; + + if (argc != 1) { + Tcl_AppendResult(interp, "wrong # args: should be \"", + argv[0], "\"", (char *) NULL); + return TCL_ERROR; + } + + dirName = TclGetCwd(interp); + if (dirName == NULL) { + return TCL_ERROR; + } + interp->result = dirName; + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_RegexpCmd -- + * + * This procedure is invoked to process the "regexp" Tcl command. + * See the user documentation for details on what it does. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * See the user documentation. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +int +Tcl_RegexpCmd(dummy, interp, argc, argv) + ClientData dummy; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ + int noCase = 0; + int indices = 0; + Tcl_RegExp regExpr; + char **argPtr, *string, *pattern, *start, *end; + int match = 0; /* Initialization needed only to + * prevent compiler warning. */ + int i; + Tcl_DString stringDString, patternDString; + + if (argc < 3) { + wrongNumArgs: + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " ?switches? exp string ?matchVar? ?subMatchVar ", + "subMatchVar ...?\"", (char *) NULL); + return TCL_ERROR; + } + argPtr = argv+1; + argc--; + while ((argc > 0) && (argPtr[0][0] == '-')) { + if (strcmp(argPtr[0], "-indices") == 0) { + indices = 1; + } else if (strcmp(argPtr[0], "-nocase") == 0) { + noCase = 1; + } else if (strcmp(argPtr[0], "--") == 0) { + argPtr++; + argc--; + break; + } else { + Tcl_AppendResult(interp, "bad switch \"", argPtr[0], + "\": must be -indices, -nocase, or --", (char *) NULL); + return TCL_ERROR; + } + argPtr++; + argc--; + } + if (argc < 2) { + goto wrongNumArgs; + } + + /* + * Convert the string and pattern to lower case, if desired, and + * perform the matching operation. + */ + + if (noCase) { + register char *p; + + Tcl_DStringInit(&patternDString); + Tcl_DStringAppend(&patternDString, argPtr[0], -1); + pattern = Tcl_DStringValue(&patternDString); + for (p = pattern; *p != 0; p++) { + if (isupper(UCHAR(*p))) { + *p = (char)tolower(UCHAR(*p)); + } + } + Tcl_DStringInit(&stringDString); + Tcl_DStringAppend(&stringDString, argPtr[1], -1); + string = Tcl_DStringValue(&stringDString); + for (p = string; *p != 0; p++) { + if (isupper(UCHAR(*p))) { + *p = (char)tolower(UCHAR(*p)); + } + } + } else { + pattern = argPtr[0]; + string = argPtr[1]; + } + regExpr = Tcl_RegExpCompile(interp, pattern); + if (regExpr != NULL) { + match = Tcl_RegExpExec(interp, regExpr, string, string); + } + if (noCase) { + Tcl_DStringFree(&stringDString); + Tcl_DStringFree(&patternDString); + } + if (regExpr == NULL) { + return TCL_ERROR; + } + if (match < 0) { + return TCL_ERROR; + } + if (!match) { + interp->result = "0"; + return TCL_OK; + } + + /* + * If additional variable names have been specified, return + * index information in those variables. + */ + + argc -= 2; + for (i = 0; i < argc; i++) { + char *result, info[50]; + + Tcl_RegExpRange(regExpr, i, &start, &end); + if (start == NULL) { + if (indices) { + result = Tcl_SetVar(interp, argPtr[i+2], "-1 -1", 0); + } else { + result = Tcl_SetVar(interp, argPtr[i+2], "", 0); + } + } else { + if (indices) { + sprintf(info, "%d %d", (int)(start - string), + (int)(end - string - 1)); + result = Tcl_SetVar(interp, argPtr[i+2], info, 0); + } else { + char savedChar, *first, *last; + + first = argPtr[1] + (start - string); + last = argPtr[1] + (end - string); + savedChar = *last; + *last = 0; + result = Tcl_SetVar(interp, argPtr[i+2], first, 0); + *last = savedChar; + } + } + if (result == NULL) { + Tcl_AppendResult(interp, "couldn't set variable \"", + argPtr[i+2], "\"", (char *) NULL); + return TCL_ERROR; + } + } + interp->result = "1"; + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_RegsubCmd -- + * + * This procedure is invoked to process the "regsub" Tcl command. + * See the user documentation for details on what it does. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * See the user documentation. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +int +Tcl_RegsubCmd(dummy, interp, argc, argv) + ClientData dummy; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ + int noCase = 0, all = 0; + Tcl_RegExp regExpr; + char *string, *pattern, *p, *firstChar, *newValue, **argPtr; + int match, flags, code, numMatches; + char *start, *end, *subStart, *subEnd; + register char *src, c; + Tcl_DString stringDString, patternDString; + + if (argc < 5) { + wrongNumArgs: + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " ?switches? exp string subSpec varName\"", (char *) NULL); + return TCL_ERROR; + } + argPtr = argv+1; + argc--; + while (argPtr[0][0] == '-') { + if (strcmp(argPtr[0], "-nocase") == 0) { + noCase = 1; + } else if (strcmp(argPtr[0], "-all") == 0) { + all = 1; + } else if (strcmp(argPtr[0], "--") == 0) { + argPtr++; + argc--; + break; + } else { + Tcl_AppendResult(interp, "bad switch \"", argPtr[0], + "\": must be -all, -nocase, or --", (char *) NULL); + return TCL_ERROR; + } + argPtr++; + argc--; + } + if (argc != 4) { + goto wrongNumArgs; + } + + /* + * Convert the string and pattern to lower case, if desired. + */ + + if (noCase) { + Tcl_DStringInit(&patternDString); + Tcl_DStringAppend(&patternDString, argPtr[0], -1); + pattern = Tcl_DStringValue(&patternDString); + for (p = pattern; *p != 0; p++) { + if (isupper(UCHAR(*p))) { + *p = (char)tolower(UCHAR(*p)); + } + } + Tcl_DStringInit(&stringDString); + Tcl_DStringAppend(&stringDString, argPtr[1], -1); + string = Tcl_DStringValue(&stringDString); + for (p = string; *p != 0; p++) { + if (isupper(UCHAR(*p))) { + *p = (char)tolower(UCHAR(*p)); + } + } + } else { + pattern = argPtr[0]; + string = argPtr[1]; + } + regExpr = Tcl_RegExpCompile(interp, pattern); + if (regExpr == NULL) { + code = TCL_ERROR; + goto done; + } + + /* + * The following loop is to handle multiple matches within the + * same source string; each iteration handles one match and its + * corresponding substitution. If "-all" hasn't been specified + * then the loop body only gets executed once. + */ + + flags = 0; + numMatches = 0; + for (p = string; *p != 0; ) { + match = Tcl_RegExpExec(interp, regExpr, p, string); + if (match < 0) { + code = TCL_ERROR; + goto done; + } + if (!match) { + break; + } + numMatches += 1; + + /* + * Copy the portion of the source string before the match to the + * result variable. + */ + + Tcl_RegExpRange(regExpr, 0, &start, &end); + src = argPtr[1] + (start - string); + c = *src; + *src = 0; + newValue = Tcl_SetVar(interp, argPtr[3], argPtr[1] + (p - string), + flags); + *src = c; + flags = TCL_APPEND_VALUE; + if (newValue == NULL) { + cantSet: + Tcl_AppendResult(interp, "couldn't set variable \"", + argPtr[3], "\"", (char *) NULL); + code = TCL_ERROR; + goto done; + } + + /* + * Append the subSpec argument to the variable, making appropriate + * substitutions. This code is a bit hairy because of the backslash + * conventions and because the code saves up ranges of characters in + * subSpec to reduce the number of calls to Tcl_SetVar. + */ + + for (src = firstChar = argPtr[2], 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 == '&')) { + *src = c; + src[1] = 0; + newValue = Tcl_SetVar(interp, argPtr[3], firstChar, + TCL_APPEND_VALUE); + *src = '\\'; + src[1] = c; + if (newValue == NULL) { + goto cantSet; + } + firstChar = src+2; + src++; + continue; + } else { + continue; + } + } else { + continue; + } + if (firstChar != src) { + c = *src; + *src = 0; + newValue = Tcl_SetVar(interp, argPtr[3], firstChar, + TCL_APPEND_VALUE); + *src = c; + if (newValue == NULL) { + goto cantSet; + } + } + Tcl_RegExpRange(regExpr, index, &subStart, &subEnd); + if ((subStart != NULL) && (subEnd != NULL)) { + char *first, *last, saved; + + first = argPtr[1] + (subStart - string); + last = argPtr[1] + (subEnd - string); + saved = *last; + *last = 0; + newValue = Tcl_SetVar(interp, argPtr[3], first, + TCL_APPEND_VALUE); + *last = saved; + if (newValue == NULL) { + goto cantSet; + } + } + if (*src == '\\') { + src++; + } + firstChar = src+1; + } + if (firstChar != src) { + if (Tcl_SetVar(interp, argPtr[3], firstChar, + TCL_APPEND_VALUE) == NULL) { + goto cantSet; + } + } + if (end == p) { + char tmp[2]; + + /* + * Always consume at least one character of the input string + * in order to prevent infinite loops. + */ + + tmp[0] = argPtr[1][p - string]; + tmp[1] = 0; + newValue = Tcl_SetVar(interp, argPtr[3], tmp, flags); + if (newValue == NULL) { + goto cantSet; + } + p = end + 1; + } else { + p = end; + } + if (!all) { + break; + } + } + + /* + * Copy the portion of the source string after the last match to the + * result variable. + */ + + if ((*p != 0) || (numMatches == 0)) { + if (Tcl_SetVar(interp, argPtr[3], argPtr[1] + (p - string), + flags) == NULL) { + goto cantSet; + } + } + sprintf(interp->result, "%d", numMatches); + code = TCL_OK; + + done: + if (noCase) { + Tcl_DStringFree(&stringDString); + Tcl_DStringFree(&patternDString); + } + return code; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_RenameCmd -- + * + * This procedure is invoked to process the "rename" Tcl command. + * See the user documentation for details on what it does. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * See the user documentation. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +int +Tcl_RenameCmd(dummy, interp, argc, argv) + ClientData dummy; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ + register Command *cmdPtr; + Interp *iPtr = (Interp *) interp; + Tcl_HashEntry *hPtr; + int new; + char *srcName, *dstName; + + if (argc != 3) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " oldName newName\"", (char *) NULL); + return TCL_ERROR; + } + if (argv[2][0] == '\0') { + if (Tcl_DeleteCommand(interp, argv[1]) != 0) { + Tcl_AppendResult(interp, "can't delete \"", argv[1], + "\": command doesn't exist", (char *) NULL); + return TCL_ERROR; + } + return TCL_OK; + } + + srcName = argv[1]; + dstName = argv[2]; + hPtr = Tcl_FindHashEntry(&iPtr->commandTable, dstName); + if (hPtr != NULL) { + Tcl_AppendResult(interp, "can't rename to \"", argv[2], + "\": command already exists", (char *) NULL); + return TCL_ERROR; + } + + /* + * The code below was added in 11/95 to preserve backwards compatibility + * when "tkerror" was renamed "bgerror": we guarantee that the hash + * table entries for both commands refer to a single shared Command + * structure. This code should eventually become unnecessary. + */ + + if ((srcName[0] == 't') && (strcmp(srcName, "tkerror") == 0)) { + srcName = "bgerror"; + } + dstName = argv[2]; + if ((dstName[0] == 't') && (strcmp(dstName, "tkerror") == 0)) { + dstName = "bgerror"; + } + + hPtr = Tcl_FindHashEntry(&iPtr->commandTable, srcName); + if (hPtr == NULL) { + Tcl_AppendResult(interp, "can't rename \"", argv[1], + "\": command doesn't exist", (char *) NULL); + return TCL_ERROR; + } + cmdPtr = (Command *) Tcl_GetHashValue(hPtr); + + /* + * Prevent formation of alias loops through renaming. + */ + + if (TclPreventAliasLoop(interp, interp, dstName, cmdPtr->proc, + cmdPtr->clientData) != TCL_OK) { + return TCL_ERROR; + } + + Tcl_DeleteHashEntry(hPtr); + hPtr = Tcl_CreateHashEntry(&iPtr->commandTable, dstName, &new); + Tcl_SetHashValue(hPtr, cmdPtr); + cmdPtr->hPtr = hPtr; + + /* + * The code below provides more backwards compatibility for the + * "tkerror" => "bgerror" renaming. As with the other compatibility + * code above, it should eventually be removed. + */ + + if ((dstName[0] == 'b') && (strcmp(dstName, "bgerror") == 0)) { + /* + * The destination command is "bgerror"; create a "tkerror" + * command that shares the same Command structure. + */ + + hPtr = Tcl_CreateHashEntry(&iPtr->commandTable, "tkerror", &new); + Tcl_SetHashValue(hPtr, cmdPtr); + } + if ((srcName[0] == 'b') && (strcmp(srcName, "bgerror") == 0)) { + /* + * The source command is "bgerror": delete the hash table + * entry for "tkerror" if it exists. + */ + + Tcl_DeleteHashEntry(Tcl_FindHashEntry(&iPtr->commandTable, "tkerror")); + } + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_ReturnCmd -- + * + * This procedure is invoked to process the "return" Tcl command. + * See the user documentation for details on what it does. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * See the user documentation. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +int +Tcl_ReturnCmd(dummy, interp, argc, argv) + ClientData dummy; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ + Interp *iPtr = (Interp *) interp; + int c, code; + + if (iPtr->errorInfo != NULL) { + ckfree(iPtr->errorInfo); + iPtr->errorInfo = NULL; + } + if (iPtr->errorCode != NULL) { + ckfree(iPtr->errorCode); + iPtr->errorCode = NULL; + } + code = TCL_OK; + for (argv++, argc--; argc > 1; argv += 2, argc -= 2) { + if (strcmp(argv[0], "-code") == 0) { + c = argv[1][0]; + if ((c == 'o') && (strcmp(argv[1], "ok") == 0)) { + code = TCL_OK; + } else if ((c == 'e') && (strcmp(argv[1], "error") == 0)) { + code = TCL_ERROR; + } else if ((c == 'r') && (strcmp(argv[1], "return") == 0)) { + code = TCL_RETURN; + } else if ((c == 'b') && (strcmp(argv[1], "break") == 0)) { + code = TCL_BREAK; + } else if ((c == 'c') && (strcmp(argv[1], "continue") == 0)) { + code = TCL_CONTINUE; + } else if (Tcl_GetInt(interp, argv[1], &code) != TCL_OK) { + Tcl_ResetResult(interp); + Tcl_AppendResult(interp, "bad completion code \"", + argv[1], "\": must be ok, error, return, break, ", + "continue, or an integer", (char *) NULL); + return TCL_ERROR; + } + } else if (strcmp(argv[0], "-errorinfo") == 0) { + iPtr->errorInfo = (char *) ckalloc((unsigned) (strlen(argv[1]) + 1)); + strcpy(iPtr->errorInfo, argv[1]); + } else if (strcmp(argv[0], "-errorcode") == 0) { + iPtr->errorCode = (char *) ckalloc((unsigned) (strlen(argv[1]) + 1)); + strcpy(iPtr->errorCode, argv[1]); + } else { + Tcl_AppendResult(interp, "bad option \"", argv[0], + ": must be -code, -errorcode, or -errorinfo", + (char *) NULL); + return TCL_ERROR; + } + } + if (argc == 1) { + Tcl_SetResult(interp, argv[0], TCL_VOLATILE); + } + iPtr->returnCode = code; + return TCL_RETURN; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_ScanCmd -- + * + * This procedure is invoked to process the "scan" Tcl command. + * See the user documentation for details on what it does. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * See the user documentation. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +int +Tcl_ScanCmd(dummy, interp, argc, argv) + ClientData dummy; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ +# define MAX_FIELDS 20 + typedef struct { + char fmt; /* Format for field. */ + int size; /* How many bytes to allow for + * field. */ + char *location; /* Where field will be stored. */ + } Field; + Field fields[MAX_FIELDS]; /* Info about all the fields in the + * format string. */ + register Field *curField; + int numFields = 0; /* Number of fields actually + * specified. */ + int suppress; /* Current field is assignment- + * suppressed. */ + int totalSize = 0; /* Number of bytes needed to store + * all results combined. */ + char *results; /* Where scanned output goes. + * Malloced; NULL means not allocated + * yet. */ + int numScanned; /* sscanf's result. */ + register char *fmt; + int i, widthSpecified, length, code; + + /* + * The variables below are used to hold a copy of the format + * string, so that we can replace format specifiers like "%f" + * and "%F" with specifiers like "%lf" + */ + +# define STATIC_SIZE 5 + char copyBuf[STATIC_SIZE], *fmtCopy; + register char *dst; + + if (argc < 3) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " string format ?varName varName ...?\"", (char *) NULL); + return TCL_ERROR; + } + + /* + * This procedure operates in four stages: + * 1. Scan the format string, collecting information about each field. + * 2. Allocate an array to hold all of the scanned fields. + * 3. Call sscanf to do all the dirty work, and have it store the + * parsed fields in the array. + * 4. Pick off the fields from the array and assign them to variables. + */ + + code = TCL_OK; + results = NULL; + length = strlen(argv[2]) * 2 + 1; + if (length < STATIC_SIZE) { + fmtCopy = copyBuf; + } else { + fmtCopy = (char *) ckalloc((unsigned) length); + } + dst = fmtCopy; + for (fmt = argv[2]; *fmt != 0; fmt++) { + *dst = *fmt; + dst++; + if (*fmt != '%') { + continue; + } + fmt++; + if (*fmt == '%') { + *dst = *fmt; + dst++; + continue; + } + if (*fmt == '*') { + suppress = 1; + *dst = *fmt; + dst++; + fmt++; + } else { + suppress = 0; + } + widthSpecified = 0; + while (isdigit(UCHAR(*fmt))) { + widthSpecified = 1; + *dst = *fmt; + dst++; + fmt++; + } + if ((*fmt == 'l') || (*fmt == 'h') || (*fmt == 'L')) { + fmt++; + } + *dst = *fmt; + dst++; + if (suppress) { + continue; + } + if (numFields == MAX_FIELDS) { + interp->result = "too many fields to scan"; + code = TCL_ERROR; + goto done; + } + curField = &fields[numFields]; + numFields++; + switch (*fmt) { + case 'd': + case 'i': + case 'o': + case 'x': + curField->fmt = 'd'; + curField->size = sizeof(int); + break; + + case 'u': + curField->fmt = 'u'; + curField->size = sizeof(int); + break; + + case 's': + curField->fmt = 's'; + curField->size = strlen(argv[1]) + 1; + break; + + case 'c': + if (widthSpecified) { + interp->result = + "field width may not be specified in %c conversion"; + code = TCL_ERROR; + goto done; + } + curField->fmt = 'c'; + curField->size = sizeof(int); + break; + + case 'e': + case 'f': + case 'g': + dst[-1] = 'l'; + dst[0] = 'f'; + dst++; + curField->fmt = 'f'; + curField->size = sizeof(double); + break; + + case '[': + curField->fmt = 's'; + curField->size = strlen(argv[1]) + 1; + do { + fmt++; + if (*fmt == 0) { + interp->result = "unmatched [ in format string"; + code = TCL_ERROR; + goto done; + } + *dst = *fmt; + dst++; + } while (*fmt != ']'); + break; + + default: + sprintf(interp->result, "bad scan conversion character \"%c\"", + *fmt); + code = TCL_ERROR; + goto done; + } + curField->size = TCL_ALIGN(curField->size); + totalSize += curField->size; + } + *dst = 0; + + if (numFields != (argc-3)) { + interp->result = + "different numbers of variable names and field specifiers"; + code = TCL_ERROR; + goto done; + } + + /* + * Step 2: + */ + + results = (char *) ckalloc((unsigned) totalSize); + for (i = 0, totalSize = 0, curField = fields; + i < numFields; i++, curField++) { + curField->location = results + totalSize; + totalSize += curField->size; + } + + /* + * Fill in the remaining fields with NULL; the only purpose of + * this is to keep some memory analyzers, like Purify, from + * complaining. + */ + + for ( ; i < MAX_FIELDS; i++, curField++) { + curField->location = NULL; + } + + /* + * Step 3: + */ + + numScanned = sscanf(argv[1], fmtCopy, + fields[0].location, fields[1].location, fields[2].location, + fields[3].location, fields[4].location, fields[5].location, + fields[6].location, fields[7].location, fields[8].location, + fields[9].location, fields[10].location, fields[11].location, + fields[12].location, fields[13].location, fields[14].location, + fields[15].location, fields[16].location, fields[17].location, + fields[18].location, fields[19].location); + + /* + * Step 4: + */ + + if (numScanned < numFields) { + numFields = numScanned; + } + for (i = 0, curField = fields; i < numFields; i++, curField++) { + switch (curField->fmt) { + char string[TCL_DOUBLE_SPACE]; + + case 'd': + sprintf(string, "%d", *((int *) curField->location)); + if (Tcl_SetVar(interp, argv[i+3], string, 0) == NULL) { + storeError: + Tcl_AppendResult(interp, + "couldn't set variable \"", argv[i+3], "\"", + (char *) NULL); + code = TCL_ERROR; + goto done; + } + break; + + case 'u': + sprintf(string, "%u", *((int *) curField->location)); + if (Tcl_SetVar(interp, argv[i+3], string, 0) == NULL) { + goto storeError; + } + break; + + case 'c': + sprintf(string, "%d", *((char *) curField->location) & 0xff); + if (Tcl_SetVar(interp, argv[i+3], string, 0) == NULL) { + goto storeError; + } + break; + + case 's': + if (Tcl_SetVar(interp, argv[i+3], curField->location, 0) + == NULL) { + goto storeError; + } + break; + + case 'f': + Tcl_PrintDouble(interp, *((double *) curField->location), + string); + if (Tcl_SetVar(interp, argv[i+3], string, 0) == NULL) { + goto storeError; + } + break; + } + } + sprintf(interp->result, "%d", numScanned); + done: + if (results != NULL) { + ckfree(results); + } + if (fmtCopy != copyBuf) { + ckfree(fmtCopy); + } + return code; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_SourceCmd -- + * + * This procedure is invoked to process the "source" Tcl command. + * See the user documentation for details on what it does. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * See the user documentation. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +int +Tcl_SourceCmd(dummy, interp, argc, argv) + ClientData dummy; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ + if (argc != 2) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " fileName\"", (char *) NULL); + return TCL_ERROR; + } + return Tcl_EvalFile(interp, argv[1]); +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_SplitCmd -- + * + * This procedure is invoked to process the "split" Tcl command. + * See the user documentation for details on what it does. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * See the user documentation. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +int +Tcl_SplitCmd(dummy, interp, argc, argv) + ClientData dummy; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ + char *splitChars; + register char *p, *p2; + char *elementStart; + + if (argc == 2) { + splitChars = " \n\t\r"; + } else if (argc == 3) { + splitChars = argv[2]; + } else { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " string ?splitChars?\"", (char *) NULL); + return TCL_ERROR; + } + + /* + * Handle the special case of splitting on every character. + */ + + if (*splitChars == 0) { + char string[2]; + string[1] = 0; + for (p = argv[1]; *p != 0; p++) { + string[0] = *p; + Tcl_AppendElement(interp, string); + } + return TCL_OK; + } + + /* + * Normal case: split on any of a given set of characters. + * Discard instances of the split characters. + */ + + for (p = elementStart = argv[1]; *p != 0; p++) { + char c = *p; + for (p2 = splitChars; *p2 != 0; p2++) { + if (*p2 == c) { + *p = 0; + Tcl_AppendElement(interp, elementStart); + *p = c; + elementStart = p+1; + break; + } + } + } + if (p != argv[1]) { + Tcl_AppendElement(interp, elementStart); + } + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_StringCmd -- + * + * This procedure is invoked to process the "string" Tcl command. + * See the user documentation for details on what it does. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * See the user documentation. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +int +Tcl_StringCmd(dummy, interp, argc, argv) + ClientData dummy; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ + size_t length; + register char *p; + int match, c, first; + int left = 0, right = 0; + + if (argc < 2) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " option arg ?arg ...?\"", (char *) NULL); + return TCL_ERROR; + } + c = argv[1][0]; + length = strlen(argv[1]); + if ((c == 'c') && (strncmp(argv[1], "compare", length) == 0)) { + if (argc != 4) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " compare string1 string2\"", (char *) NULL); + return TCL_ERROR; + } + match = strcmp(argv[2], argv[3]); + if (match > 0) { + interp->result = "1"; + } else if (match < 0) { + interp->result = "-1"; + } else { + interp->result = "0"; + } + return TCL_OK; + } else if ((c == 'f') && (strncmp(argv[1], "first", length) == 0)) { + if (argc != 4) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " first string1 string2\"", (char *) NULL); + return TCL_ERROR; + } + first = 1; + + firstLast: + match = -1; + c = *argv[2]; + length = strlen(argv[2]); + for (p = argv[3]; *p != 0; p++) { + if (*p != c) { + continue; + } + if (strncmp(argv[2], p, length) == 0) { + match = p-argv[3]; + if (first) { + break; + } + } + } + sprintf(interp->result, "%d", match); + return TCL_OK; + } else if ((c == 'i') && (strncmp(argv[1], "index", length) == 0)) { + int index; + + if (argc != 4) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " index string charIndex\"", (char *) NULL); + return TCL_ERROR; + } + if (Tcl_GetInt(interp, argv[3], &index) != TCL_OK) { + return TCL_ERROR; + } + if ((index >= 0) && (index < (int) strlen(argv[2]))) { + interp->result[0] = argv[2][index]; + interp->result[1] = 0; + } + return TCL_OK; + } else if ((c == 'l') && (strncmp(argv[1], "last", length) == 0) + && (length >= 2)) { + if (argc != 4) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " last string1 string2\"", (char *) NULL); + return TCL_ERROR; + } + first = 0; + goto firstLast; + } else if ((c == 'l') && (strncmp(argv[1], "length", length) == 0) + && (length >= 2)) { + if (argc != 3) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " length string\"", (char *) NULL); + return TCL_ERROR; + } + sprintf(interp->result, "%d", strlen(argv[2])); + return TCL_OK; + } else if ((c == 'm') && (strncmp(argv[1], "match", length) == 0)) { + if (argc != 4) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " match pattern string\"", (char *) NULL); + return TCL_ERROR; + } + if (Tcl_StringMatch(argv[3], argv[2]) != 0) { + interp->result = "1"; + } else { + interp->result = "0"; + } + return TCL_OK; + } else if ((c == 'r') && (strncmp(argv[1], "range", length) == 0)) { + int first, last, stringLength; + + if (argc != 5) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " range string first last\"", (char *) NULL); + return TCL_ERROR; + } + stringLength = strlen(argv[2]); + if (Tcl_GetInt(interp, argv[3], &first) != TCL_OK) { + return TCL_ERROR; + } + if ((*argv[4] == 'e') + && (strncmp(argv[4], "end", strlen(argv[4])) == 0)) { + last = stringLength-1; + } else { + if (Tcl_GetInt(interp, argv[4], &last) != TCL_OK) { + Tcl_ResetResult(interp); + Tcl_AppendResult(interp, + "expected integer or \"end\" but got \"", + argv[4], "\"", (char *) NULL); + return TCL_ERROR; + } + } + if (first < 0) { + first = 0; + } + if (last >= stringLength) { + last = stringLength-1; + } + if (last >= first) { + char saved, *p; + + p = argv[2] + last + 1; + saved = *p; + *p = 0; + Tcl_SetResult(interp, argv[2] + first, TCL_VOLATILE); + *p = saved; + } + return TCL_OK; + } else if ((c == 't') && (strncmp(argv[1], "tolower", length) == 0) + && (length >= 3)) { + register char *p; + + if (argc != 3) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " tolower string\"", (char *) NULL); + return TCL_ERROR; + } + Tcl_SetResult(interp, argv[2], TCL_VOLATILE); + for (p = interp->result; *p != 0; p++) { + if (isupper(UCHAR(*p))) { + *p = (char)tolower(UCHAR(*p)); + } + } + return TCL_OK; + } else if ((c == 't') && (strncmp(argv[1], "toupper", length) == 0) + && (length >= 3)) { + register char *p; + + if (argc != 3) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " toupper string\"", (char *) NULL); + return TCL_ERROR; + } + Tcl_SetResult(interp, argv[2], TCL_VOLATILE); + for (p = interp->result; *p != 0; p++) { + if (islower(UCHAR(*p))) { + *p = (char) toupper(UCHAR(*p)); + } + } + return TCL_OK; + } else if ((c == 't') && (strncmp(argv[1], "trim", length) == 0) + && (length == 4)) { + char *trimChars; + register char *p, *checkPtr; + + left = right = 1; + + trim: + if (argc == 4) { + trimChars = argv[3]; + } else if (argc == 3) { + trimChars = " \t\n\r"; + } else { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " ", argv[1], " string ?chars?\"", (char *) NULL); + return TCL_ERROR; + } + p = argv[2]; + if (left) { + for (c = *p; c != 0; p++, c = *p) { + for (checkPtr = trimChars; *checkPtr != c; checkPtr++) { + if (*checkPtr == 0) { + goto doneLeft; + } + } + } + } + doneLeft: + Tcl_SetResult(interp, p, TCL_VOLATILE); + if (right) { + char *donePtr; + + p = interp->result + strlen(interp->result) - 1; + donePtr = &interp->result[-1]; + for (c = *p; p != donePtr; p--, c = *p) { + for (checkPtr = trimChars; *checkPtr != c; checkPtr++) { + if (*checkPtr == 0) { + goto doneRight; + } + } + } + doneRight: + p[1] = 0; + } + return TCL_OK; + } else if ((c == 't') && (strncmp(argv[1], "trimleft", length) == 0) + && (length > 4)) { + left = 1; + argv[1] = "trimleft"; + goto trim; + } else if ((c == 't') && (strncmp(argv[1], "trimright", length) == 0) + && (length > 4)) { + right = 1; + argv[1] = "trimright"; + goto trim; + } else if ((c == 'w') && (strncmp(argv[1], "wordend", length) == 0) + && (length > 4)) { + int length, index, cur; + char *string; + + if (argc != 4) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " ", argv[1], " string index\"", (char *) NULL); + return TCL_ERROR; + } + string = argv[2]; + if (Tcl_GetInt(interp, argv[3], &index) != TCL_OK) { + return TCL_ERROR; + } + length = strlen(argv[2]); + if (index < 0) { + index = 0; + } + if (index >= length) { + cur = length; + goto wordendDone; + } + for (cur = index ; cur < length; cur++) { + c = UCHAR(string[cur]); + if (!isalnum(c) && (c != '_')) { + break; + } + } + if (cur == index) { + cur = index+1; + } + wordendDone: + sprintf(interp->result, "%d", cur); + return TCL_OK; + } else if ((c == 'w') && (strncmp(argv[1], "wordstart", length) == 0) + && (length > 4)) { + int length, index, cur; + char *string; + + if (argc != 4) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " ", argv[1], " string index\"", (char *) NULL); + return TCL_ERROR; + } + string = argv[2]; + if (Tcl_GetInt(interp, argv[3], &index) != TCL_OK) { + return TCL_ERROR; + } + length = strlen(argv[2]); + if (index >= length) { + index = length-1; + } + if (index <= 0) { + cur = 0; + goto wordstartDone; + } + for (cur = index ; cur >= 0; cur--) { + c = UCHAR(string[cur]); + if (!isalnum(c) && (c != '_')) { + break; + } + } + if (cur != index) { + cur += 1; + } + wordstartDone: + sprintf(interp->result, "%d", cur); + return TCL_OK; + } else { + Tcl_AppendResult(interp, "bad option \"", argv[1], + "\": should be compare, first, index, last, length, match, ", + "range, tolower, toupper, trim, trimleft, trimright, ", + "wordend, or wordstart", (char *) NULL); + return TCL_ERROR; + } +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_SubstCmd -- + * + * 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. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * See the user documentation. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +int +Tcl_SubstCmd(dummy, interp, argc, argv) + ClientData dummy; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ + Interp *iPtr = (Interp *) interp; + Tcl_DString result; + char *p, *old, *value; + int code, count, doVars, doCmds, doBackslashes, i; + size_t length; + char c; + + /* + * Parse command-line options. + */ + + doVars = doCmds = doBackslashes = 1; + for (i = 1; i < (argc-1); i++) { + p = argv[i]; + if (*p != '-') { + break; + } + length = strlen(p); + if (length < 4) { + badSwitch: + Tcl_AppendResult(interp, "bad switch \"", p, + "\": must be -nobackslashes, -nocommands, ", + "or -novariables", (char *) NULL); + return TCL_ERROR; + } + if ((p[3] == 'b') && (strncmp(p, "-nobackslashes", length) == 0)) { + doBackslashes = 0; + } else if ((p[3] == 'c') && (strncmp(p, "-nocommands", length) == 0)) { + doCmds = 0; + } else if ((p[3] == 'v') && (strncmp(p, "-novariables", length) == 0)) { + doVars = 0; + } else { + goto badSwitch; + } + } + if (i != (argc-1)) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " ?-nobackslashes? ?-nocommands? ?-novariables? string\"", + (char *) NULL); + return TCL_ERROR; + } + + /* + * Scan through the string one character at a time, performing + * command, variable, and backslash substitutions. + */ + + Tcl_DStringInit(&result); + old = p = argv[i]; + while (*p != 0) { + switch (*p) { + case '\\': + if (doBackslashes) { + if (p != old) { + Tcl_DStringAppend(&result, old, p-old); + } + c = Tcl_Backslash(p, &count); + Tcl_DStringAppend(&result, &c, 1); + 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 { + p++; + } + 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 = iPtr->termPtr+1; + Tcl_DStringAppend(&result, iPtr->result, -1); + Tcl_ResetResult(interp); + } else { + p++; + } + break; + + default: + p++; + break; + } + } + if (p != old) { + Tcl_DStringAppend(&result, old, p-old); + } + Tcl_DStringResult(interp, &result); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_SwitchCmd -- + * + * This procedure is invoked to process the "switch" Tcl command. + * See the user documentation for details on what it does. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * See the user documentation. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +int +Tcl_SwitchCmd(dummy, interp, argc, argv) + ClientData dummy; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ +#define EXACT 0 +#define GLOB 1 +#define REGEXP 2 + int i, code, mode, matched; + int body; + char *string; + int switchArgc, splitArgs; + char **switchArgv; + + switchArgc = argc-1; + switchArgv = argv+1; + mode = EXACT; + while ((switchArgc > 0) && (*switchArgv[0] == '-')) { + if (strcmp(*switchArgv, "-exact") == 0) { + mode = EXACT; + } else if (strcmp(*switchArgv, "-glob") == 0) { + mode = GLOB; + } else if (strcmp(*switchArgv, "-regexp") == 0) { + mode = REGEXP; + } else if (strcmp(*switchArgv, "--") == 0) { + switchArgc--; + switchArgv++; + break; + } else { + Tcl_AppendResult(interp, "bad option \"", switchArgv[0], + "\": should be -exact, -glob, -regexp, or --", + (char *) NULL); + return TCL_ERROR; + } + switchArgc--; + switchArgv++; + } + if (switchArgc < 2) { + Tcl_AppendResult(interp, "wrong # args: should be \"", + argv[0], " ?switches? string pattern body ... ?default body?\"", + (char *) NULL); + return TCL_ERROR; + } + string = *switchArgv; + switchArgc--; + switchArgv++; + + /* + * If all of the pattern/command pairs are lumped into a single + * argument, split them out again. + */ + + splitArgs = 0; + if (switchArgc == 1) { + code = Tcl_SplitList(interp, switchArgv[0], &switchArgc, &switchArgv); + if (code != TCL_OK) { + return code; + } + splitArgs = 1; + } + + for (i = 0; i < switchArgc; i += 2) { + if (i == (switchArgc-1)) { + interp->result = "extra switch pattern with no body"; + code = TCL_ERROR; + goto cleanup; + } + + /* + * See if the pattern matches the string. + */ + + matched = 0; + if ((*switchArgv[i] == 'd') && (i == switchArgc-2) + && (strcmp(switchArgv[i], "default") == 0)) { + matched = 1; + } else { + switch (mode) { + case EXACT: + matched = (strcmp(string, switchArgv[i]) == 0); + break; + case GLOB: + matched = Tcl_StringMatch(string, switchArgv[i]); + break; + case REGEXP: + matched = Tcl_RegExpMatch(interp, string, switchArgv[i]); + if (matched < 0) { + code = TCL_ERROR; + goto cleanup; + } + break; + } + } + if (!matched) { + continue; + } + + /* + * We've got a match. Find a body to execute, skipping bodies + * that are "-". + */ + + for (body = i+1; ; body += 2) { + if (body >= switchArgc) { + Tcl_AppendResult(interp, "no body specified for pattern \"", + switchArgv[i], "\"", (char *) NULL); + code = TCL_ERROR; + goto cleanup; + } + if ((switchArgv[body][0] != '-') || (switchArgv[body][1] != 0)) { + break; + } + } + code = Tcl_Eval(interp, switchArgv[body]); + if (code == TCL_ERROR) { + char msg[100]; + sprintf(msg, "\n (\"%.50s\" arm line %d)", switchArgv[i], + interp->errorLine); + Tcl_AddErrorInfo(interp, msg); + } + goto cleanup; + } + + /* + * Nothing matched: return nothing. + */ + + code = TCL_OK; + + cleanup: + if (splitArgs) { + ckfree((char *) switchArgv); + } + return code; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_TimeCmd -- + * + * This procedure is invoked to process the "time" Tcl command. + * See the user documentation for details on what it does. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * See the user documentation. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +int +Tcl_TimeCmd(dummy, interp, argc, argv) + ClientData dummy; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ + int count, i, result; + double timePer; + Tcl_Time start, stop; + + if (argc == 2) { + count = 1; + } else if (argc == 3) { + if (Tcl_GetInt(interp, argv[2], &count) != TCL_OK) { + return TCL_ERROR; + } + } else { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " command ?count?\"", (char *) NULL); + return TCL_ERROR; + } + TclGetTime(&start); + for (i = count ; i > 0; i--) { + result = Tcl_Eval(interp, argv[1]); + if (result != TCL_OK) { + if (result == TCL_ERROR) { + char msg[60]; + sprintf(msg, "\n (\"time\" body line %d)", + interp->errorLine); + Tcl_AddErrorInfo(interp, msg); + } + return result; + } + } + TclGetTime(&stop); + timePer = (stop.sec - start.sec)*1000000 + (stop.usec - start.usec); + Tcl_ResetResult(interp); + sprintf(interp->result, "%.0f microseconds per iteration", + (count <= 0) ? 0 : timePer/count); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_TraceCmd -- + * + * This procedure is invoked to process the "trace" Tcl command. + * See the user documentation for details on what it does. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * See the user documentation. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +int +Tcl_TraceCmd(dummy, interp, argc, argv) + ClientData dummy; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ + int c; + size_t length; + + if (argc < 2) { + Tcl_AppendResult(interp, "too few args: should be \"", + argv[0], " option [arg arg ...]\"", (char *) NULL); + return TCL_ERROR; + } + c = argv[1][1]; + length = strlen(argv[1]); + if ((c == 'a') && (strncmp(argv[1], "variable", length) == 0) + && (length >= 2)) { + char *p; + int flags, length; + TraceVarInfo *tvarPtr; + + if (argc != 5) { + Tcl_AppendResult(interp, "wrong # args: should be \"", + argv[0], " variable name ops command\"", (char *) NULL); + return TCL_ERROR; + } + + flags = 0; + for (p = argv[3] ; *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; + } + + length = strlen(argv[4]); + 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, argv[4]); + if (Tcl_TraceVar(interp, argv[2], flags, TraceVarProc, + (ClientData) tvarPtr) != TCL_OK) { + ckfree((char *) tvarPtr); + return TCL_ERROR; + } + } else if ((c == 'd') && (strncmp(argv[1], "vdelete", length) + && (length >= 2)) == 0) { + char *p; + int flags, length; + TraceVarInfo *tvarPtr; + ClientData clientData; + + if (argc != 5) { + Tcl_AppendResult(interp, "wrong # args: should be \"", + argv[0], " vdelete name ops command\"", (char *) NULL); + return TCL_ERROR; + } + + flags = 0; + for (p = argv[3] ; *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. + */ + + length = strlen(argv[4]); + clientData = 0; + while ((clientData = Tcl_VarTraceInfo(interp, argv[2], 0, + TraceVarProc, clientData)) != 0) { + tvarPtr = (TraceVarInfo *) clientData; + if ((tvarPtr->length == length) && (tvarPtr->flags == flags) + && (strncmp(argv[4], tvarPtr->command, + (size_t) length) == 0)) { + Tcl_UntraceVar(interp, argv[2], flags | TCL_TRACE_UNSETS, + TraceVarProc, clientData); + if (tvarPtr->errMsg != NULL) { + ckfree(tvarPtr->errMsg); + } + ckfree((char *) tvarPtr); + break; + } + } + } else if ((c == 'i') && (strncmp(argv[1], "vinfo", length) == 0) + && (length >= 2)) { + ClientData clientData; + char ops[4], *p; + char *prefix = "{"; + + if (argc != 3) { + Tcl_AppendResult(interp, "wrong # args: should be \"", + argv[0], " vinfo name\"", (char *) NULL); + return TCL_ERROR; + } + clientData = 0; + while ((clientData = Tcl_VarTraceInfo(interp, argv[2], 0, + TraceVarProc, clientData)) != 0) { + TraceVarInfo *tvarPtr = (TraceVarInfo *) clientData; + 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'; + Tcl_AppendResult(interp, prefix, (char *) NULL); + Tcl_AppendElement(interp, ops); + Tcl_AppendElement(interp, tvarPtr->command); + Tcl_AppendResult(interp, "}", (char *) NULL); + prefix = " {"; + } + } else { + Tcl_AppendResult(interp, "bad option \"", argv[1], + "\": should be variable, vdelete, or vinfo", + (char *) NULL); + return TCL_ERROR; + } + return TCL_OK; + + badOps: + Tcl_AppendResult(interp, "bad operations \"", argv[3], + "\": should be one or more of rwu", (char *) NULL); + return TCL_ERROR; +} + +/* + *---------------------------------------------------------------------- + * + * 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. */ + char *name1; /* Name of variable or array. */ + char *name2; /* Name of element within array; NULL means + * scalar variable is being referenced. */ + int flags; /* OR-ed bits giving operation and other + * information. */ +{ + TraceVarInfo *tvarPtr = (TraceVarInfo *) clientData; + char *result; + int code; + Interp dummy; + Tcl_DString cmd; + + result = NULL; + if (tvarPtr->errMsg != NULL) { + ckfree(tvarPtr->errMsg); + tvarPtr->errMsg = NULL; + } + if ((tvarPtr->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. + */ + + if (name2 == NULL) { + name2 = ""; + } + Tcl_DStringInit(&cmd); + Tcl_DStringAppend(&cmd, tvarPtr->command, 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); + } + + /* + * Execute the command. Be careful to save and restore the + * result from the interpreter used for the command. + */ + + if (interp->freeProc == 0) { + dummy.freeProc = (Tcl_FreeProc *) 0; + dummy.result = ""; + Tcl_SetResult((Tcl_Interp *) &dummy, interp->result, TCL_VOLATILE); + } else { + dummy.freeProc = interp->freeProc; + dummy.result = interp->result; + interp->freeProc = (Tcl_FreeProc *) 0; + } + code = Tcl_Eval(interp, Tcl_DStringValue(&cmd)); + Tcl_DStringFree(&cmd); + if (code != TCL_OK) { + tvarPtr->errMsg = (char *) ckalloc((unsigned) (strlen(interp->result) + 1)); + strcpy(tvarPtr->errMsg, interp->result); + result = tvarPtr->errMsg; + Tcl_ResetResult(interp); /* Must clear error state. */ + } + Tcl_SetResult(interp, dummy.result, + (dummy.freeProc == 0) ? TCL_VOLATILE : dummy.freeProc); + } + if (flags & TCL_TRACE_DESTROYED) { + result = NULL; + if (tvarPtr->errMsg != NULL) { + ckfree(tvarPtr->errMsg); + } + ckfree((char *) tvarPtr); + } + return result; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_WhileCmd -- + * + * This procedure is invoked to process the "while" Tcl command. + * See the user documentation for details on what it does. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * See the user documentation. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +int +Tcl_WhileCmd(dummy, interp, argc, argv) + ClientData dummy; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ + int result, value; + + if (argc != 3) { + Tcl_AppendResult(interp, "wrong # args: should be \"", + argv[0], " test command\"", (char *) NULL); + return TCL_ERROR; + } + + while (1) { + result = Tcl_ExprBoolean(interp, argv[1], &value); + if (result != TCL_OK) { + return result; + } + if (!value) { + break; + } + result = Tcl_Eval(interp, argv[2]); + if ((result != TCL_OK) && (result != TCL_CONTINUE)) { + if (result == TCL_ERROR) { + char msg[60]; + sprintf(msg, "\n (\"while\" body line %d)", + interp->errorLine); + Tcl_AddErrorInfo(interp, msg); + } + break; + } + } + if (result == TCL_BREAK) { + result = TCL_OK; + } + if (result == TCL_OK) { + Tcl_ResetResult(interp); + } + return result; +} diff --git a/contrib/tcl/generic/tclDate.c b/contrib/tcl/generic/tclDate.c new file mode 100644 index 0000000..b39d817 --- /dev/null +++ b/contrib/tcl/generic/tclDate.c @@ -0,0 +1,1619 @@ +/* + * tclGetdate.c -- + * + * This file is generated from a yacc grammar defined in + * the file tclGetdate.y + * + * Copyright (c) 1992-1995 Karl Lehenbauer and Mark Diekhans. + * Copyright (c) 1995-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. + * + * @(#) tclDate.c 1.24 96/04/18 16:53:56 + */ + +#include "tclInt.h" +#include "tclPort.h" + +#ifdef MAC_TCL +# define EPOCH 1904 +# define START_OF_TIME 1904 +# define END_OF_TIME 2039 +#else +# define EPOCH 1970 +# define START_OF_TIME 1902 +# define END_OF_TIME 2037 + +extern struct tm *localtime(); +#endif + +#define HOUR(x) ((int) (60 * x)) +#define SECSPERDAY (24L * 60L * 60L) + + +/* + * An entry in the lexical lookup table. + */ +typedef struct _TABLE { + char *name; + int type; + time_t value; +} TABLE; + + +/* + * Daylight-savings mode: on, off, or not yet known. + */ +typedef enum _DSTMODE { + DSTon, DSToff, DSTmaybe +} DSTMODE; + +/* + * Meridian: am, pm, or 24-hour style. + */ +typedef enum _MERIDIAN { + MERam, MERpm, MER24 +} MERIDIAN; + + +/* + * Global variables. We could get rid of most of these by using a good + * union as the yacc stack. (This routine was originally written before + * yacc had the %union construct.) Maybe someday; right now we only use + * the %union very rarely. + */ +static char *TclDateInput; +static DSTMODE TclDateDSTmode; +static time_t TclDateDayOrdinal; +static time_t TclDateDayNumber; +static int TclDateHaveDate; +static int TclDateHaveDay; +static int TclDateHaveRel; +static int TclDateHaveTime; +static int TclDateHaveZone; +static time_t TclDateTimezone; +static time_t TclDateDay; +static time_t TclDateHour; +static time_t TclDateMinutes; +static time_t TclDateMonth; +static time_t TclDateSeconds; +static time_t TclDateYear; +static MERIDIAN TclDateMeridian; +static time_t TclDateRelMonth; +static time_t TclDateRelSeconds; + + +/* + * Prototypes of internal functions. + */ +static void +TclDateerror _ANSI_ARGS_((char *s)); + +static time_t +ToSeconds _ANSI_ARGS_((time_t Hours, + time_t Minutes, + time_t Seconds, + MERIDIAN Meridian)); + +static int +Convert _ANSI_ARGS_((time_t Month, + time_t Day, + time_t Year, + time_t Hours, + time_t Minutes, + time_t Seconds, + MERIDIAN Meridia, + DSTMODE DSTmode, + time_t *TimePtr)); + +static time_t +DSTcorrect _ANSI_ARGS_((time_t Start, + time_t Future)); + +static time_t +RelativeDate _ANSI_ARGS_((time_t Start, + time_t DayOrdinal, + time_t DayNumber)); + +static int +RelativeMonth _ANSI_ARGS_((time_t Start, + time_t RelMonth, + time_t *TimePtr)); +static int +LookupWord _ANSI_ARGS_((char *buff)); + +static int +TclDatelex _ANSI_ARGS_((void)); + +int +TclDateparse _ANSI_ARGS_((void)); +typedef union +#ifdef __cplusplus + YYSTYPE +#endif + { + time_t Number; + enum _MERIDIAN Meridian; +} YYSTYPE; +# define tAGO 257 +# define tDAY 258 +# define tDAYZONE 259 +# define tID 260 +# define tMERIDIAN 261 +# define tMINUTE_UNIT 262 +# define tMONTH 263 +# define tMONTH_UNIT 264 +# define tSEC_UNIT 265 +# define tSNUMBER 266 +# define tUNUMBER 267 +# define tZONE 268 +# define tEPOCH 269 +# define tDST 270 + + + +#ifdef __cplusplus + +#ifndef TclDateerror + void TclDateerror(const char *); +#endif + +#ifndef TclDatelex +#ifdef __EXTERN_C__ + extern "C" { int TclDatelex(void); } +#else + int TclDatelex(void); +#endif +#endif + int TclDateparse(void); + +#endif +#define TclDateclearin TclDatechar = -1 +#define TclDateerrok TclDateerrflag = 0 +extern int TclDatechar; +extern int TclDateerrflag; +YYSTYPE TclDatelval; +YYSTYPE TclDateval; +typedef int TclDatetabelem; +#ifndef YYMAXDEPTH +#define YYMAXDEPTH 150 +#endif +#if YYMAXDEPTH > 0 +int TclDate_TclDates[YYMAXDEPTH], *TclDates = TclDate_TclDates; +YYSTYPE TclDate_TclDatev[YYMAXDEPTH], *TclDatev = TclDate_TclDatev; +#else /* user does initial allocation */ +int *TclDates; +YYSTYPE *TclDatev; +#endif +static int TclDatemaxdepth = YYMAXDEPTH; +# define YYERRCODE 256 + + +/* + * Month and day table. + */ +static TABLE MonthDayTable[] = { + { "january", tMONTH, 1 }, + { "february", tMONTH, 2 }, + { "march", tMONTH, 3 }, + { "april", tMONTH, 4 }, + { "may", tMONTH, 5 }, + { "june", tMONTH, 6 }, + { "july", tMONTH, 7 }, + { "august", tMONTH, 8 }, + { "september", tMONTH, 9 }, + { "sept", tMONTH, 9 }, + { "october", tMONTH, 10 }, + { "november", tMONTH, 11 }, + { "december", tMONTH, 12 }, + { "sunday", tDAY, 0 }, + { "monday", tDAY, 1 }, + { "tuesday", tDAY, 2 }, + { "tues", tDAY, 2 }, + { "wednesday", tDAY, 3 }, + { "wednes", tDAY, 3 }, + { "thursday", tDAY, 4 }, + { "thur", tDAY, 4 }, + { "thurs", tDAY, 4 }, + { "friday", tDAY, 5 }, + { "saturday", tDAY, 6 }, + { NULL } +}; + +/* + * Time units table. + */ +static TABLE UnitsTable[] = { + { "year", tMONTH_UNIT, 12 }, + { "month", tMONTH_UNIT, 1 }, + { "fortnight", tMINUTE_UNIT, 14 * 24 * 60 }, + { "week", tMINUTE_UNIT, 7 * 24 * 60 }, + { "day", tMINUTE_UNIT, 1 * 24 * 60 }, + { "hour", tMINUTE_UNIT, 60 }, + { "minute", tMINUTE_UNIT, 1 }, + { "min", tMINUTE_UNIT, 1 }, + { "second", tSEC_UNIT, 1 }, + { "sec", tSEC_UNIT, 1 }, + { NULL } +}; + +/* + * Assorted relative-time words. + */ +static TABLE OtherTable[] = { + { "tomorrow", tMINUTE_UNIT, 1 * 24 * 60 }, + { "yesterday", tMINUTE_UNIT, -1 * 24 * 60 }, + { "today", tMINUTE_UNIT, 0 }, + { "now", tMINUTE_UNIT, 0 }, + { "last", tUNUMBER, -1 }, + { "this", tMINUTE_UNIT, 0 }, + { "next", tUNUMBER, 2 }, +#if 0 + { "first", tUNUMBER, 1 }, +/* { "second", tUNUMBER, 2 }, */ + { "third", tUNUMBER, 3 }, + { "fourth", tUNUMBER, 4 }, + { "fifth", tUNUMBER, 5 }, + { "sixth", tUNUMBER, 6 }, + { "seventh", tUNUMBER, 7 }, + { "eighth", tUNUMBER, 8 }, + { "ninth", tUNUMBER, 9 }, + { "tenth", tUNUMBER, 10 }, + { "eleventh", tUNUMBER, 11 }, + { "twelfth", tUNUMBER, 12 }, +#endif + { "ago", tAGO, 1 }, + { "epoch", tEPOCH, 0 }, + { NULL } +}; + +/* + * The timezone table. (Note: This table was modified to not use any floating + * point constants to work around an SGI compiler bug). + */ +static TABLE TimezoneTable[] = { + { "gmt", tZONE, HOUR( 0) }, /* Greenwich Mean */ + { "ut", tZONE, HOUR( 0) }, /* Universal (Coordinated) */ + { "utc", tZONE, HOUR( 0) }, + { "wet", tZONE, HOUR( 0) } , /* Western European */ + { "bst", tDAYZONE, HOUR( 0) }, /* British Summer */ + { "wat", tZONE, HOUR( 1) }, /* West Africa */ + { "at", tZONE, HOUR( 2) }, /* Azores */ +#if 0 + /* For completeness. BST is also British Summer, and GST is + * also Guam Standard. */ + { "bst", tZONE, HOUR( 3) }, /* Brazil Standard */ + { "gst", tZONE, HOUR( 3) }, /* Greenland Standard */ +#endif + { "nft", tZONE, HOUR( 7/2) }, /* Newfoundland */ + { "nst", tZONE, HOUR( 7/2) }, /* Newfoundland Standard */ + { "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 */ + { "cat", tZONE, HOUR(10) }, /* Central Alaska */ + { "ahst", tZONE, HOUR(10) }, /* Alaska-Hawaii Standard */ + { "nt", tZONE, HOUR(11) }, /* Nome */ + { "idlw", tZONE, HOUR(12) }, /* International Date Line West */ + { "cet", tZONE, -HOUR( 1) }, /* Central European */ + { "met", tZONE, -HOUR( 1) }, /* Middle European */ + { "mewt", tZONE, -HOUR( 1) }, /* Middle European Winter */ + { "mest", tDAYZONE, -HOUR( 1) }, /* Middle European Summer */ + { "swt", tZONE, -HOUR( 1) }, /* Swedish Winter */ + { "sst", tDAYZONE, -HOUR( 1) }, /* Swedish Summer */ + { "fwt", tZONE, -HOUR( 1) }, /* French Winter */ + { "fst", tDAYZONE, -HOUR( 1) }, /* French Summer */ + { "eet", tZONE, -HOUR( 2) }, /* Eastern Europe, USSR Zone 1 */ + { "bt", tZONE, -HOUR( 3) }, /* Baghdad, USSR Zone 2 */ + { "it", tZONE, -HOUR( 7/2) }, /* Iran */ + { "zp4", tZONE, -HOUR( 4) }, /* USSR Zone 3 */ + { "zp5", tZONE, -HOUR( 5) }, /* USSR Zone 4 */ + { "ist", tZONE, -HOUR(11/2) }, /* Indian Standard */ + { "zp6", tZONE, -HOUR( 6) }, /* USSR Zone 5 */ +#if 0 + /* For completeness. NST is also Newfoundland Stanard, nad SST is + * also Swedish Summer. */ + { "nst", tZONE, -HOUR(13/2) }, /* North Sumatra */ + { "sst", tZONE, -HOUR( 7) }, /* South Sumatra, USSR Zone 6 */ +#endif /* 0 */ + { "wast", tZONE, -HOUR( 7) }, /* West Australian Standard */ + { "wadt", tDAYZONE, -HOUR( 7) }, /* West Australian Daylight */ + { "jt", tZONE, -HOUR(15/2) }, /* Java (3pm in Cronusland!) */ + { "cct", tZONE, -HOUR( 8) }, /* China Coast, USSR Zone 7 */ + { "jst", tZONE, -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 */ + { "gst", tZONE, -HOUR(10) }, /* Guam Standard, USSR Zone 9 */ + { "nzt", tZONE, -HOUR(12) }, /* New Zealand */ + { "nzst", tZONE, -HOUR(12) }, /* New Zealand Standard */ + { "nzdt", tDAYZONE, -HOUR(12) }, /* New Zealand Daylight */ + { "idle", tZONE, -HOUR(12) }, /* International Date Line East */ + /* ADDED BY Marco Nijdam */ + { "dst", tDST, HOUR( 0) }, /* DST on (hour is ignored) */ + /* End ADDED */ + { NULL } +}; + +/* + * Military timezone table. + */ +static TABLE MilitaryTable[] = { + { "a", tZONE, HOUR( 1) }, + { "b", tZONE, HOUR( 2) }, + { "c", tZONE, HOUR( 3) }, + { "d", tZONE, HOUR( 4) }, + { "e", tZONE, HOUR( 5) }, + { "f", tZONE, HOUR( 6) }, + { "g", tZONE, HOUR( 7) }, + { "h", tZONE, HOUR( 8) }, + { "i", tZONE, HOUR( 9) }, + { "k", tZONE, HOUR( 10) }, + { "l", tZONE, HOUR( 11) }, + { "m", tZONE, HOUR( 12) }, + { "n", tZONE, HOUR(- 1) }, + { "o", tZONE, HOUR(- 2) }, + { "p", tZONE, HOUR(- 3) }, + { "q", tZONE, HOUR(- 4) }, + { "r", tZONE, HOUR(- 5) }, + { "s", tZONE, HOUR(- 6) }, + { "t", tZONE, HOUR(- 7) }, + { "u", tZONE, HOUR(- 8) }, + { "v", tZONE, HOUR(- 9) }, + { "w", tZONE, HOUR(-10) }, + { "x", tZONE, HOUR(-11) }, + { "y", tZONE, HOUR(-12) }, + { "z", tZONE, HOUR( 0) }, + { NULL } +}; + + +/* + * Dump error messages in the bit bucket. + */ +static void +TclDateerror(s) + char *s; +{ +} + + +static time_t +ToSeconds(Hours, Minutes, Seconds, Meridian) + time_t Hours; + time_t Minutes; + time_t Seconds; + MERIDIAN Meridian; +{ + if (Minutes < 0 || Minutes > 59 || Seconds < 0 || Seconds > 59) + return -1; + switch (Meridian) { + case MER24: + if (Hours < 0 || Hours > 23) + return -1; + return (Hours * 60L + Minutes) * 60L + Seconds; + case MERam: + if (Hours < 1 || Hours > 12) + return -1; + return ((Hours % 12) * 60L + Minutes) * 60L + Seconds; + case MERpm: + if (Hours < 1 || Hours > 12) + return -1; + return (((Hours % 12) + 12) * 60L + Minutes) * 60L + Seconds; + } + return -1; /* Should never be reached */ +} + + +static int +Convert(Month, Day, Year, Hours, Minutes, Seconds, Meridian, DSTmode, TimePtr) + time_t Month; + time_t Day; + time_t Year; + time_t Hours; + time_t Minutes; + time_t Seconds; + MERIDIAN Meridian; + DSTMODE DSTmode; + time_t *TimePtr; +{ + static int DaysInMonth[12] = { + 31, 0, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31 + }; + time_t tod; + time_t Julian; + int i; + + if (Year < 0) + Year = -Year; + if (Year < 100) + Year += 1900; + DaysInMonth[1] = Year % 4 == 0 && (Year % 100 != 0 || Year % 400 == 0) + ? 29 : 28; + if (Month < 1 || Month > 12 + || Year < START_OF_TIME || Year > END_OF_TIME + || Day < 1 || Day > DaysInMonth[(int)--Month]) + return -1; + + for (Julian = Day - 1, i = 0; i < Month; i++) + Julian += DaysInMonth[i]; + if (Year >= EPOCH) { + for (i = EPOCH; i < Year; i++) + Julian += 365 + (i % 4 == 0); + } else { + for (i = Year; i < EPOCH; i++) + Julian -= 365 + (i % 4 == 0); + } + Julian *= SECSPERDAY; + Julian += TclDateTimezone * 60L; + if ((tod = ToSeconds(Hours, Minutes, Seconds, Meridian)) < 0) + return -1; + Julian += tod; + if (DSTmode == DSTon + || (DSTmode == DSTmaybe && localtime(&Julian)->tm_isdst)) + Julian -= 60 * 60; + *TimePtr = Julian; + return 0; +} + + +static time_t +DSTcorrect(Start, Future) + time_t Start; + time_t Future; +{ + time_t StartDay; + time_t FutureDay; + + StartDay = (localtime(&Start)->tm_hour + 1) % 24; + FutureDay = (localtime(&Future)->tm_hour + 1) % 24; + return (Future - Start) + (StartDay - FutureDay) * 60L * 60L; +} + + +static time_t +RelativeDate(Start, DayOrdinal, DayNumber) + time_t Start; + time_t DayOrdinal; + time_t DayNumber; +{ + struct tm *tm; + time_t now; + + now = Start; + tm = localtime(&now); + now += SECSPERDAY * ((DayNumber - tm->tm_wday + 7) % 7); + now += 7 * SECSPERDAY * (DayOrdinal <= 0 ? DayOrdinal : DayOrdinal - 1); + return DSTcorrect(Start, now); +} + + +static int +RelativeMonth(Start, RelMonth, TimePtr) + time_t Start; + time_t RelMonth; + time_t *TimePtr; +{ + struct tm *tm; + time_t Month; + time_t Year; + time_t Julian; + + if (RelMonth == 0) { + *TimePtr = 0; + return 0; + } + tm = localtime(&Start); + Month = 12 * tm->tm_year + tm->tm_mon + RelMonth; + Year = Month / 12; + Month = Month % 12 + 1; + if (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) < 0) + return -1; + *TimePtr = DSTcorrect(Start, Julian); + return 0; +} + + +static int +LookupWord(buff) + char *buff; +{ + register char *p; + register char *q; + register TABLE *tp; + int i; + int abbrev; + + /* + * Make it lowercase. + */ + for (p = buff; *p; p++) { + if (isupper(*p)) { + *p = (char) tolower(*p); + } + } + + if (strcmp(buff, "am") == 0 || strcmp(buff, "a.m.") == 0) { + TclDatelval.Meridian = MERam; + return tMERIDIAN; + } + if (strcmp(buff, "pm") == 0 || strcmp(buff, "p.m.") == 0) { + TclDatelval.Meridian = MERpm; + return tMERIDIAN; + } + + /* + * See if we have an abbreviation for a month. + */ + if (strlen(buff) == 3) { + abbrev = 1; + } else if (strlen(buff) == 4 && buff[3] == '.') { + abbrev = 1; + buff[3] = '\0'; + } else { + abbrev = 0; + } + + for (tp = MonthDayTable; tp->name; tp++) { + if (abbrev) { + if (strncmp(buff, tp->name, 3) == 0) { + TclDatelval.Number = tp->value; + return tp->type; + } + } else if (strcmp(buff, tp->name) == 0) { + TclDatelval.Number = tp->value; + return tp->type; + } + } + + for (tp = TimezoneTable; tp->name; tp++) { + if (strcmp(buff, tp->name) == 0) { + TclDatelval.Number = tp->value; + return tp->type; + } + } + + for (tp = UnitsTable; tp->name; tp++) { + if (strcmp(buff, tp->name) == 0) { + TclDatelval.Number = tp->value; + return tp->type; + } + } + + /* + * Strip off any plural and try the units table again. + */ + i = strlen(buff) - 1; + if (buff[i] == 's') { + buff[i] = '\0'; + for (tp = UnitsTable; tp->name; tp++) { + if (strcmp(buff, tp->name) == 0) { + TclDatelval.Number = tp->value; + return tp->type; + } + } + } + + for (tp = OtherTable; tp->name; tp++) { + if (strcmp(buff, tp->name) == 0) { + TclDatelval.Number = tp->value; + return tp->type; + } + } + + /* + * Military timezones. + */ + if (buff[1] == '\0' && isalpha(*buff)) { + for (tp = MilitaryTable; tp->name; tp++) { + if (strcmp(buff, tp->name) == 0) { + TclDatelval.Number = tp->value; + return tp->type; + } + } + } + + /* + * Drop out any periods and try the timezone table again. + */ + for (i = 0, p = q = buff; *q; q++) + if (*q != '.') + *p++ = *q; + else + i++; + *p = '\0'; + if (i) + for (tp = TimezoneTable; tp->name; tp++) { + if (strcmp(buff, tp->name) == 0) { + TclDatelval.Number = tp->value; + return tp->type; + } + } + + return tID; +} + + +static int +TclDatelex() +{ + register char c; + register char *p; + char buff[20]; + int Count; + int sign; + + for ( ; ; ) { + while (isspace((unsigned char) (*TclDateInput))) { + TclDateInput++; + } + + if (isdigit(c = *TclDateInput) || c == '-' || c == '+') { + if (c == '-' || c == '+') { + sign = c == '-' ? -1 : 1; + if (!isdigit(*++TclDateInput)) { + /* + * skip the '-' sign + */ + continue; + } + } else { + sign = 0; + } + for (TclDatelval.Number = 0; isdigit(c = *TclDateInput++); ) { + TclDatelval.Number = 10 * TclDatelval.Number + c - '0'; + } + TclDateInput--; + if (sign < 0) { + TclDatelval.Number = -TclDatelval.Number; + } + return sign ? tSNUMBER : tUNUMBER; + } + if (isalpha(c)) { + for (p = buff; isalpha(c = *TclDateInput++) || c == '.'; ) { + if (p < &buff[sizeof buff - 1]) { + *p++ = c; + } + } + *p = '\0'; + TclDateInput--; + return LookupWord(buff); + } + if (c != '(') { + return *TclDateInput++; + } + Count = 0; + do { + c = *TclDateInput++; + if (c == '\0') { + return c; + } else if (c == '(') { + Count++; + } else if (c == ')') { + Count--; + } + } while (Count > 0); + } +} + +/* + * Specify zone is of -50000 to force GMT. (This allows BST to work). + */ + +int +TclGetDate(p, now, zone, timePtr) + char *p; + unsigned long now; + long zone; + unsigned long *timePtr; +{ + struct tm *tm; + time_t Start; + time_t Time; + time_t tod; + + TclDateInput = p; + tm = localtime((time_t *) &now); + TclDateYear = tm->tm_year; + TclDateMonth = tm->tm_mon + 1; + TclDateDay = tm->tm_mday; + TclDateTimezone = zone; + if (zone == -50000) { + TclDateDSTmode = DSToff; /* assume GMT */ + TclDateTimezone = 0; + } else { + TclDateDSTmode = DSTmaybe; + } + TclDateHour = 0; + TclDateMinutes = 0; + TclDateSeconds = 0; + TclDateMeridian = MER24; + TclDateRelSeconds = 0; + TclDateRelMonth = 0; + TclDateHaveDate = 0; + TclDateHaveDay = 0; + TclDateHaveRel = 0; + TclDateHaveTime = 0; + TclDateHaveZone = 0; + + if (TclDateparse() || TclDateHaveTime > 1 || TclDateHaveZone > 1 || TclDateHaveDate > 1 || + TclDateHaveDay > 1) { + return -1; + } + + if (TclDateHaveDate || TclDateHaveTime || TclDateHaveDay) { + if (Convert(TclDateMonth, TclDateDay, TclDateYear, TclDateHour, TclDateMinutes, TclDateSeconds, + TclDateMeridian, TclDateDSTmode, &Start) < 0) + return -1; + } + else { + Start = now; + if (!TclDateHaveRel) + Start -= ((tm->tm_hour * 60L) + tm->tm_min * 60L) + tm->tm_sec; + } + + Start += TclDateRelSeconds; + if (RelativeMonth(Start, TclDateRelMonth, &Time) < 0) { + return -1; + } + Start += Time; + + if (TclDateHaveDay && !TclDateHaveDate) { + tod = RelativeDate(Start, TclDateDayOrdinal, TclDateDayNumber); + Start += tod; + } + + *timePtr = Start; + return 0; +} +TclDatetabelem TclDateexca[] ={ +-1, 1, + 0, -1, + -2, 0, + }; +# define YYNPROD 41 +# define YYLAST 227 +TclDatetabelem TclDateact[]={ + + 14, 11, 23, 28, 17, 12, 19, 18, 16, 9, + 10, 13, 42, 21, 46, 45, 44, 48, 41, 37, + 36, 35, 32, 29, 34, 33, 31, 43, 39, 38, + 30, 15, 8, 7, 6, 5, 4, 3, 2, 1, + 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, 47, 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, 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, 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, 22, 0, 0, 20, 25, 24, 27, + 26, 42, 0, 0, 0, 0, 40 }; +TclDatetabelem TclDatepact[]={ + +-10000000, -258,-10000000,-10000000,-10000000,-10000000,-10000000,-10000000,-10000000, -45, + -267,-10000000, -244,-10000000, -14, -231, -240,-10000000,-10000000,-10000000, +-10000000, -246,-10000000, -247, -248,-10000000,-10000000,-10000000,-10000000, -15, +-10000000,-10000000,-10000000,-10000000,-10000000, -40, -20,-10000000, -251,-10000000, +-10000000, -252,-10000000, -253,-10000000, -249,-10000000,-10000000,-10000000 }; +TclDatetabelem TclDatepgo[]={ + + 0, 28, 39, 38, 37, 36, 35, 34, 33, 32, + 31 }; +TclDatetabelem TclDater1[]={ + + 0, 2, 2, 3, 3, 3, 3, 3, 3, 4, + 4, 4, 4, 4, 5, 5, 5, 7, 7, 7, + 6, 6, 6, 6, 6, 6, 6, 8, 8, 10, + 10, 10, 10, 10, 10, 10, 10, 10, 9, 1, + 1 }; +TclDatetabelem TclDater2[]={ + + 0, 0, 4, 3, 3, 3, 3, 3, 2, 5, + 9, 9, 13, 13, 5, 3, 3, 3, 5, 5, + 7, 11, 5, 9, 5, 3, 7, 5, 2, 5, + 5, 3, 5, 5, 3, 5, 5, 3, 3, 1, + 3 }; +TclDatetabelem TclDatechk[]={ + +-10000000, -2, -3, -4, -5, -6, -7, -8, -9, 267, + 268, 259, 263, 269, 258, -10, 266, 262, 265, 264, + 261, 58, 258, 47, 263, 262, 265, 264, 270, 267, + 44, 257, 262, 265, 264, 267, 267, 267, 44, -1, + 266, 58, 261, 47, 267, 267, 267, -1, 266 }; +TclDatetabelem TclDatedef[]={ + + 1, -2, 2, 3, 4, 5, 6, 7, 8, 38, + 15, 16, 0, 25, 17, 28, 0, 31, 34, 37, + 9, 0, 19, 0, 24, 29, 33, 36, 14, 22, + 18, 27, 30, 32, 35, 39, 20, 26, 0, 10, + 11, 0, 40, 0, 23, 39, 21, 12, 13 }; +typedef struct +#ifdef __cplusplus + TclDatetoktype +#endif +{ char *t_name; int t_val; } TclDatetoktype; +#ifndef YYDEBUG +# define YYDEBUG 0 /* don't allow debugging */ +#endif + +#if YYDEBUG + +TclDatetoktype TclDatetoks[] = +{ + "tAGO", 257, + "tDAY", 258, + "tDAYZONE", 259, + "tID", 260, + "tMERIDIAN", 261, + "tMINUTE_UNIT", 262, + "tMONTH", 263, + "tMONTH_UNIT", 264, + "tSEC_UNIT", 265, + "tSNUMBER", 266, + "tUNUMBER", 267, + "tZONE", 268, + "tEPOCH", 269, + "tDST", 270, + "-unknown-", -1 /* ends search */ +}; + +char * TclDatereds[] = +{ + "-no such reduction-", + "spec : /* empty */", + "spec : spec item", + "item : time", + "item : zone", + "item : date", + "item : day", + "item : rel", + "item : number", + "time : tUNUMBER tMERIDIAN", + "time : tUNUMBER ':' tUNUMBER o_merid", + "time : tUNUMBER ':' tUNUMBER tSNUMBER", + "time : tUNUMBER ':' tUNUMBER ':' tUNUMBER o_merid", + "time : tUNUMBER ':' tUNUMBER ':' tUNUMBER tSNUMBER", + "zone : tZONE tDST", + "zone : tZONE", + "zone : tDAYZONE", + "day : tDAY", + "day : tDAY ','", + "day : tUNUMBER tDAY", + "date : tUNUMBER '/' tUNUMBER", + "date : tUNUMBER '/' tUNUMBER '/' tUNUMBER", + "date : tMONTH tUNUMBER", + "date : tMONTH tUNUMBER ',' tUNUMBER", + "date : tUNUMBER tMONTH", + "date : tEPOCH", + "date : tUNUMBER tMONTH tUNUMBER", + "rel : relunit tAGO", + "rel : relunit", + "relunit : tUNUMBER tMINUTE_UNIT", + "relunit : tSNUMBER tMINUTE_UNIT", + "relunit : tMINUTE_UNIT", + "relunit : tSNUMBER tSEC_UNIT", + "relunit : tUNUMBER tSEC_UNIT", + "relunit : tSEC_UNIT", + "relunit : tSNUMBER tMONTH_UNIT", + "relunit : tUNUMBER tMONTH_UNIT", + "relunit : tMONTH_UNIT", + "number : tUNUMBER", + "o_merid : /* empty */", + "o_merid : tMERIDIAN", +}; +#endif /* YYDEBUG */ +/* + * Copyright (c) 1993 by Sun Microsystems, Inc. + */ + + +/* +** Skeleton parser driver for yacc output +*/ + +/* +** yacc user known macros and defines +*/ +#define YYERROR goto TclDateerrlab +#define YYACCEPT return(0) +#define YYABORT return(1) +#define YYBACKUP( newtoken, newvalue )\ +{\ + if ( TclDatechar >= 0 || ( TclDater2[ TclDatetmp ] >> 1 ) != 1 )\ + {\ + TclDateerror( "syntax error - cannot backup" );\ + goto TclDateerrlab;\ + }\ + TclDatechar = newtoken;\ + TclDatestate = *TclDateps;\ + TclDatelval = newvalue;\ + goto TclDatenewstate;\ +} +#define YYRECOVERING() (!!TclDateerrflag) +#define YYNEW(type) malloc(sizeof(type) * TclDatenewmax) +#define YYCOPY(to, from, type) \ + (type *) memcpy(to, (char *) from, TclDatenewmax * sizeof(type)) +#define YYENLARGE( from, type) \ + (type *) realloc((char *) from, TclDatenewmax * sizeof(type)) +#ifndef YYDEBUG +# define YYDEBUG 1 /* make debugging available */ +#endif + +/* +** user known globals +*/ +int TclDatedebug; /* set to 1 to get debugging */ + +/* +** driver internal defines +*/ +#define YYFLAG (-10000000) + +/* +** global variables used by the parser +*/ +YYSTYPE *TclDatepv; /* top of value stack */ +int *TclDateps; /* top of state stack */ + +int TclDatestate; /* current state */ +int TclDatetmp; /* extra var (lasts between blocks) */ + +int TclDatenerrs; /* number of errors */ +int TclDateerrflag; /* error recovery flag */ +int TclDatechar; /* current input token number */ + + + +#ifdef YYNMBCHARS +#define YYLEX() TclDatecvtok(TclDatelex()) +/* +** TclDatecvtok - return a token if i is a wchar_t value that exceeds 255. +** If i<255, i itself is the token. If i>255 but the neither +** of the 30th or 31st bit is on, i is already a token. +*/ +#if defined(__STDC__) || defined(__cplusplus) +int TclDatecvtok(int i) +#else +int TclDatecvtok(i) int i; +#endif +{ + int first = 0; + int last = YYNMBCHARS - 1; + int mid; + wchar_t j; + + if(i&0x60000000){/*Must convert to a token. */ + if( TclDatembchars[last].character < i ){ + return i;/*Giving up*/ + } + while ((last>=first)&&(first>=0)) {/*Binary search loop*/ + mid = (first+last)/2; + j = TclDatembchars[mid].character; + if( j==i ){/*Found*/ + return TclDatembchars[mid].tvalue; + }else if( j<i ){ + first = mid + 1; + }else{ + last = mid -1; + } + } + /*No entry in the table.*/ + return i;/* Giving up.*/ + }else{/* i is already a token. */ + return i; + } +} +#else/*!YYNMBCHARS*/ +#define YYLEX() TclDatelex() +#endif/*!YYNMBCHARS*/ + +/* +** TclDateparse - return 0 if worked, 1 if syntax error not recovered from +*/ +#if defined(__STDC__) || defined(__cplusplus) +int TclDateparse(void) +#else +int TclDateparse() +#endif +{ + register YYSTYPE *TclDatepvt; /* top of value stack for $vars */ + +#if defined(__cplusplus) || defined(lint) +/* + hacks to please C++ and lint - goto's inside switch should never be + executed; TclDatepvt is set to 0 to avoid "used before set" warning. +*/ + static int __yaccpar_lint_hack__ = 0; + switch (__yaccpar_lint_hack__) + { + case 1: goto TclDateerrlab; + case 2: goto TclDatenewstate; + } + TclDatepvt = 0; +#endif + + /* + ** Initialize externals - TclDateparse may be called more than once + */ + TclDatepv = &TclDatev[-1]; + TclDateps = &TclDates[-1]; + TclDatestate = 0; + TclDatetmp = 0; + TclDatenerrs = 0; + TclDateerrflag = 0; + TclDatechar = -1; + +#if YYMAXDEPTH <= 0 + if (TclDatemaxdepth <= 0) + { + if ((TclDatemaxdepth = YYEXPAND(0)) <= 0) + { + TclDateerror("yacc initialization error"); + YYABORT; + } + } +#endif + + { + register YYSTYPE *TclDate_pv; /* top of value stack */ + register int *TclDate_ps; /* top of state stack */ + register int TclDate_state; /* current state */ + register int TclDate_n; /* internal state number info */ + goto TclDatestack; /* moved from 6 lines above to here to please C++ */ + + /* + ** get globals into registers. + ** branch to here only if YYBACKUP was called. + */ + TclDate_pv = TclDatepv; + TclDate_ps = TclDateps; + TclDate_state = TclDatestate; + goto TclDate_newstate; + + /* + ** get globals into registers. + ** either we just started, or we just finished a reduction + */ + TclDatestack: + TclDate_pv = TclDatepv; + TclDate_ps = TclDateps; + TclDate_state = TclDatestate; + + /* + ** top of for (;;) loop while no reductions done + */ + TclDate_stack: + /* + ** put a state and value onto the stacks + */ +#if YYDEBUG + /* + ** if debugging, look up token value in list of value vs. + ** name pairs. 0 and negative (-1) are special values. + ** Note: linear search is used since time is not a real + ** consideration while debugging. + */ + if ( TclDatedebug ) + { + register int TclDate_i; + + printf( "State %d, token ", TclDate_state ); + if ( TclDatechar == 0 ) + printf( "end-of-file\n" ); + else if ( TclDatechar < 0 ) + printf( "-none-\n" ); + else + { + for ( TclDate_i = 0; TclDatetoks[TclDate_i].t_val >= 0; + TclDate_i++ ) + { + if ( TclDatetoks[TclDate_i].t_val == TclDatechar ) + break; + } + printf( "%s\n", TclDatetoks[TclDate_i].t_name ); + } + } +#endif /* YYDEBUG */ + if ( ++TclDate_ps >= &TclDates[ TclDatemaxdepth ] ) /* room on stack? */ + { + /* + ** reallocate and recover. Note that pointers + ** have to be reset, or bad things will happen + */ + int TclDateps_index = (TclDate_ps - TclDates); + int TclDatepv_index = (TclDate_pv - TclDatev); + int TclDatepvt_index = (TclDatepvt - TclDatev); + int TclDatenewmax; +#ifdef YYEXPAND + TclDatenewmax = YYEXPAND(TclDatemaxdepth); +#else + TclDatenewmax = 2 * TclDatemaxdepth; /* double table size */ + if (TclDatemaxdepth == YYMAXDEPTH) /* first time growth */ + { + char *newTclDates = (char *)YYNEW(int); + char *newTclDatev = (char *)YYNEW(YYSTYPE); + if (newTclDates != 0 && newTclDatev != 0) + { + TclDates = YYCOPY(newTclDates, TclDates, int); + TclDatev = YYCOPY(newTclDatev, TclDatev, YYSTYPE); + } + else + TclDatenewmax = 0; /* failed */ + } + else /* not first time */ + { + TclDates = YYENLARGE(TclDates, int); + TclDatev = YYENLARGE(TclDatev, YYSTYPE); + if (TclDates == 0 || TclDatev == 0) + TclDatenewmax = 0; /* failed */ + } +#endif + if (TclDatenewmax <= TclDatemaxdepth) /* tables not expanded */ + { + TclDateerror( "yacc stack overflow" ); + YYABORT; + } + TclDatemaxdepth = TclDatenewmax; + + TclDate_ps = TclDates + TclDateps_index; + TclDate_pv = TclDatev + TclDatepv_index; + TclDatepvt = TclDatev + TclDatepvt_index; + } + *TclDate_ps = TclDate_state; + *++TclDate_pv = TclDateval; + + /* + ** we have a new state - find out what to do + */ + TclDate_newstate: + if ( ( TclDate_n = TclDatepact[ TclDate_state ] ) <= YYFLAG ) + goto TclDatedefault; /* simple state */ +#if YYDEBUG + /* + ** if debugging, need to mark whether new token grabbed + */ + TclDatetmp = TclDatechar < 0; +#endif + if ( ( TclDatechar < 0 ) && ( ( TclDatechar = YYLEX() ) < 0 ) ) + TclDatechar = 0; /* reached EOF */ +#if YYDEBUG + if ( TclDatedebug && TclDatetmp ) + { + register int TclDate_i; + + printf( "Received token " ); + if ( TclDatechar == 0 ) + printf( "end-of-file\n" ); + else if ( TclDatechar < 0 ) + printf( "-none-\n" ); + else + { + for ( TclDate_i = 0; TclDatetoks[TclDate_i].t_val >= 0; + TclDate_i++ ) + { + if ( TclDatetoks[TclDate_i].t_val == TclDatechar ) + break; + } + printf( "%s\n", TclDatetoks[TclDate_i].t_name ); + } + } +#endif /* YYDEBUG */ + if ( ( ( TclDate_n += TclDatechar ) < 0 ) || ( TclDate_n >= YYLAST ) ) + goto TclDatedefault; + if ( TclDatechk[ TclDate_n = TclDateact[ TclDate_n ] ] == TclDatechar ) /*valid shift*/ + { + TclDatechar = -1; + TclDateval = TclDatelval; + TclDate_state = TclDate_n; + if ( TclDateerrflag > 0 ) + TclDateerrflag--; + goto TclDate_stack; + } + + TclDatedefault: + if ( ( TclDate_n = TclDatedef[ TclDate_state ] ) == -2 ) + { +#if YYDEBUG + TclDatetmp = TclDatechar < 0; +#endif + if ( ( TclDatechar < 0 ) && ( ( TclDatechar = YYLEX() ) < 0 ) ) + TclDatechar = 0; /* reached EOF */ +#if YYDEBUG + if ( TclDatedebug && TclDatetmp ) + { + register int TclDate_i; + + printf( "Received token " ); + if ( TclDatechar == 0 ) + printf( "end-of-file\n" ); + else if ( TclDatechar < 0 ) + printf( "-none-\n" ); + else + { + for ( TclDate_i = 0; + TclDatetoks[TclDate_i].t_val >= 0; + TclDate_i++ ) + { + if ( TclDatetoks[TclDate_i].t_val + == TclDatechar ) + { + break; + } + } + printf( "%s\n", TclDatetoks[TclDate_i].t_name ); + } + } +#endif /* YYDEBUG */ + /* + ** look through exception table + */ + { + register int *TclDatexi = TclDateexca; + + while ( ( *TclDatexi != -1 ) || + ( TclDatexi[1] != TclDate_state ) ) + { + TclDatexi += 2; + } + while ( ( *(TclDatexi += 2) >= 0 ) && + ( *TclDatexi != TclDatechar ) ) + ; + if ( ( TclDate_n = TclDatexi[1] ) < 0 ) + YYACCEPT; + } + } + + /* + ** check for syntax error + */ + if ( TclDate_n == 0 ) /* have an error */ + { + /* no worry about speed here! */ + switch ( TclDateerrflag ) + { + case 0: /* new error */ + TclDateerror( "syntax error" ); + goto skip_init; + /* + ** get globals into registers. + ** we have a user generated syntax type error + */ + TclDate_pv = TclDatepv; + TclDate_ps = TclDateps; + TclDate_state = TclDatestate; + skip_init: + TclDatenerrs++; + /* FALLTHRU */ + case 1: + case 2: /* incompletely recovered error */ + /* try again... */ + TclDateerrflag = 3; + /* + ** find state where "error" is a legal + ** shift action + */ + while ( TclDate_ps >= TclDates ) + { + TclDate_n = TclDatepact[ *TclDate_ps ] + YYERRCODE; + if ( TclDate_n >= 0 && TclDate_n < YYLAST && + TclDatechk[TclDateact[TclDate_n]] == YYERRCODE) { + /* + ** simulate shift of "error" + */ + TclDate_state = TclDateact[ TclDate_n ]; + goto TclDate_stack; + } + /* + ** current state has no shift on + ** "error", pop stack + */ +#if YYDEBUG +# define _POP_ "Error recovery pops state %d, uncovers state %d\n" + if ( TclDatedebug ) + printf( _POP_, *TclDate_ps, + TclDate_ps[-1] ); +# undef _POP_ +#endif + TclDate_ps--; + TclDate_pv--; + } + /* + ** there is no state on stack with "error" as + ** a valid shift. give up. + */ + YYABORT; + case 3: /* no shift yet; eat a token */ +#if YYDEBUG + /* + ** if debugging, look up token in list of + ** pairs. 0 and negative shouldn't occur, + ** but since timing doesn't matter when + ** debugging, it doesn't hurt to leave the + ** tests here. + */ + if ( TclDatedebug ) + { + register int TclDate_i; + + printf( "Error recovery discards " ); + if ( TclDatechar == 0 ) + printf( "token end-of-file\n" ); + else if ( TclDatechar < 0 ) + printf( "token -none-\n" ); + else + { + for ( TclDate_i = 0; + TclDatetoks[TclDate_i].t_val >= 0; + TclDate_i++ ) + { + if ( TclDatetoks[TclDate_i].t_val + == TclDatechar ) + { + break; + } + } + printf( "token %s\n", + TclDatetoks[TclDate_i].t_name ); + } + } +#endif /* YYDEBUG */ + if ( TclDatechar == 0 ) /* reached EOF. quit */ + YYABORT; + TclDatechar = -1; + goto TclDate_newstate; + } + }/* end if ( TclDate_n == 0 ) */ + /* + ** reduction by production TclDate_n + ** put stack tops, etc. so things right after switch + */ +#if YYDEBUG + /* + ** if debugging, print the string that is the user's + ** specification of the reduction which is just about + ** to be done. + */ + if ( TclDatedebug ) + printf( "Reduce by (%d) \"%s\"\n", + TclDate_n, TclDatereds[ TclDate_n ] ); +#endif + TclDatetmp = TclDate_n; /* value to switch over */ + TclDatepvt = TclDate_pv; /* $vars top of value stack */ + /* + ** Look in goto table for next state + ** Sorry about using TclDate_state here as temporary + ** register variable, but why not, if it works... + ** If TclDater2[ TclDate_n ] doesn't have the low order bit + ** set, then there is no action to be done for + ** this reduction. So, no saving & unsaving of + ** registers done. The only difference between the + ** code just after the if and the body of the if is + ** the goto TclDate_stack in the body. This way the test + ** can be made before the choice of what to do is needed. + */ + { + /* length of production doubled with extra bit */ + register int TclDate_len = TclDater2[ TclDate_n ]; + + if ( !( TclDate_len & 01 ) ) + { + TclDate_len >>= 1; + TclDateval = ( TclDate_pv -= TclDate_len )[1]; /* $$ = $1 */ + TclDate_state = TclDatepgo[ TclDate_n = TclDater1[ TclDate_n ] ] + + *( TclDate_ps -= TclDate_len ) + 1; + if ( TclDate_state >= YYLAST || + TclDatechk[ TclDate_state = + TclDateact[ TclDate_state ] ] != -TclDate_n ) + { + TclDate_state = TclDateact[ TclDatepgo[ TclDate_n ] ]; + } + goto TclDate_stack; + } + TclDate_len >>= 1; + TclDateval = ( TclDate_pv -= TclDate_len )[1]; /* $$ = $1 */ + TclDate_state = TclDatepgo[ TclDate_n = TclDater1[ TclDate_n ] ] + + *( TclDate_ps -= TclDate_len ) + 1; + if ( TclDate_state >= YYLAST || + TclDatechk[ TclDate_state = TclDateact[ TclDate_state ] ] != -TclDate_n ) + { + TclDate_state = TclDateact[ TclDatepgo[ TclDate_n ] ]; + } + } + /* save until reenter driver code */ + TclDatestate = TclDate_state; + TclDateps = TclDate_ps; + TclDatepv = TclDate_pv; + } + /* + ** code supplied by user is placed in this switch + */ + switch( TclDatetmp ) + { + +case 3:{ + TclDateHaveTime++; + } break; +case 4:{ + TclDateHaveZone++; + } break; +case 5:{ + TclDateHaveDate++; + } break; +case 6:{ + TclDateHaveDay++; + } break; +case 7:{ + TclDateHaveRel++; + } break; +case 9:{ + TclDateHour = TclDatepvt[-1].Number; + TclDateMinutes = 0; + TclDateSeconds = 0; + TclDateMeridian = TclDatepvt[-0].Meridian; + } break; +case 10:{ + TclDateHour = TclDatepvt[-3].Number; + TclDateMinutes = TclDatepvt[-1].Number; + TclDateSeconds = 0; + TclDateMeridian = TclDatepvt[-0].Meridian; + } break; +case 11:{ + TclDateHour = TclDatepvt[-3].Number; + TclDateMinutes = TclDatepvt[-1].Number; + TclDateMeridian = MER24; + TclDateDSTmode = DSToff; + TclDateTimezone = - (TclDatepvt[-0].Number % 100 + (TclDatepvt[-0].Number / 100) * 60); + } break; +case 12:{ + TclDateHour = TclDatepvt[-5].Number; + TclDateMinutes = TclDatepvt[-3].Number; + TclDateSeconds = TclDatepvt[-1].Number; + TclDateMeridian = TclDatepvt[-0].Meridian; + } break; +case 13:{ + TclDateHour = TclDatepvt[-5].Number; + TclDateMinutes = TclDatepvt[-3].Number; + TclDateSeconds = TclDatepvt[-1].Number; + TclDateMeridian = MER24; + TclDateDSTmode = DSToff; + TclDateTimezone = - (TclDatepvt[-0].Number % 100 + (TclDatepvt[-0].Number / 100) * 60); + } break; +case 14:{ + TclDateTimezone = TclDatepvt[-1].Number; + TclDateDSTmode = DSTon; + } break; +case 15:{ + TclDateTimezone = TclDatepvt[-0].Number; + TclDateDSTmode = DSToff; + } break; +case 16:{ + TclDateTimezone = TclDatepvt[-0].Number; + TclDateDSTmode = DSTon; + } break; +case 17:{ + TclDateDayOrdinal = 1; + TclDateDayNumber = TclDatepvt[-0].Number; + } break; +case 18:{ + TclDateDayOrdinal = 1; + TclDateDayNumber = TclDatepvt[-1].Number; + } break; +case 19:{ + TclDateDayOrdinal = TclDatepvt[-1].Number; + TclDateDayNumber = TclDatepvt[-0].Number; + } break; +case 20:{ + TclDateMonth = TclDatepvt[-2].Number; + TclDateDay = TclDatepvt[-0].Number; + } break; +case 21:{ + TclDateMonth = TclDatepvt[-4].Number; + TclDateDay = TclDatepvt[-2].Number; + TclDateYear = TclDatepvt[-0].Number; + } break; +case 22:{ + TclDateMonth = TclDatepvt[-1].Number; + TclDateDay = TclDatepvt[-0].Number; + } break; +case 23:{ + TclDateMonth = TclDatepvt[-3].Number; + TclDateDay = TclDatepvt[-2].Number; + TclDateYear = TclDatepvt[-0].Number; + } break; +case 24:{ + TclDateMonth = TclDatepvt[-0].Number; + TclDateDay = TclDatepvt[-1].Number; + } break; +case 25:{ + TclDateMonth = 1; + TclDateDay = 1; + TclDateYear = EPOCH; + } break; +case 26:{ + TclDateMonth = TclDatepvt[-1].Number; + TclDateDay = TclDatepvt[-2].Number; + TclDateYear = TclDatepvt[-0].Number; + } break; +case 27:{ + TclDateRelSeconds = -TclDateRelSeconds; + TclDateRelMonth = -TclDateRelMonth; + } break; +case 29:{ + TclDateRelSeconds += TclDatepvt[-1].Number * TclDatepvt[-0].Number * 60L; + } break; +case 30:{ + TclDateRelSeconds += TclDatepvt[-1].Number * TclDatepvt[-0].Number * 60L; + } break; +case 31:{ + TclDateRelSeconds += TclDatepvt[-0].Number * 60L; + } break; +case 32:{ + TclDateRelSeconds += TclDatepvt[-1].Number; + } break; +case 33:{ + TclDateRelSeconds += TclDatepvt[-1].Number; + } break; +case 34:{ + TclDateRelSeconds++; + } break; +case 35:{ + TclDateRelMonth += TclDatepvt[-1].Number * TclDatepvt[-0].Number; + } break; +case 36:{ + TclDateRelMonth += TclDatepvt[-1].Number * TclDatepvt[-0].Number; + } break; +case 37:{ + TclDateRelMonth += TclDatepvt[-0].Number; + } break; +case 38:{ + if (TclDateHaveTime && TclDateHaveDate && !TclDateHaveRel) + TclDateYear = TclDatepvt[-0].Number; + else { + TclDateHaveTime++; + if (TclDatepvt[-0].Number < 100) { + TclDateHour = TclDatepvt[-0].Number; + TclDateMinutes = 0; + } + else { + TclDateHour = TclDatepvt[-0].Number / 100; + TclDateMinutes = TclDatepvt[-0].Number % 100; + } + TclDateSeconds = 0; + TclDateMeridian = MER24; + } + } break; +case 39:{ + TclDateval.Meridian = MER24; + } break; +case 40:{ + TclDateval.Meridian = TclDatepvt[-0].Meridian; + } break; + } + goto TclDatestack; /* reset registers in driver code */ +} + diff --git a/contrib/tcl/generic/tclEnv.c b/contrib/tcl/generic/tclEnv.c new file mode 100644 index 0000000..4b92cc2 --- /dev/null +++ b/contrib/tcl/generic/tclEnv.c @@ -0,0 +1,604 @@ +/* + * tclEnv.c -- + * + * Tcl support for environment variables, including a setenv + * procedure. + * + * Copyright (c) 1991-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: @(#) tclEnv.c 1.34 96/04/15 18:18:36 + */ + +/* + * The putenv and setenv definitions below cause any system prototypes for + * those procedures to be ignored so that there won't be a clash when the + * versions in this file are compiled. + */ + +#define putenv ignore_putenv +#define setenv ignore_setenv +#include "tclInt.h" +#include "tclPort.h" +#undef putenv +#undef setenv + +/* + * The structure below is used to keep track of all of the interpereters + * for which we're managing the "env" array. It's needed so that they + * can all be updated whenever an environment variable is changed + * anywhere. + */ + +typedef struct EnvInterp { + Tcl_Interp *interp; /* Interpreter for which we're managing + * the env array. */ + struct EnvInterp *nextPtr; /* Next in list of all such interpreters, + * or zero. */ +} EnvInterp; + +static EnvInterp *firstInterpPtr; + /* First in list of all managed interpreters, + * or NULL if none. */ + +static int environSize = 0; /* Non-zero means that the all of the + * environ-related information is malloc-ed + * and the environ array itself has this + * many total entries allocated to it (not + * all may be in use at once). Zero means + * that the environment array is in its + * original static state. */ + +/* + * Declarations for local procedures defined in this file: + */ + +static void EnvExitProc _ANSI_ARGS_((ClientData clientData)); +static void EnvInit _ANSI_ARGS_((void)); +static char * EnvTraceProc _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, char *name1, char *name2, + int flags)); +static int FindVariable _ANSI_ARGS_((CONST char *name, + int *lengthPtr)); +void TclSetEnv _ANSI_ARGS_((CONST char *name, + CONST char *value)); +void TclUnsetEnv _ANSI_ARGS_((CONST char *name)); + +/* + *---------------------------------------------------------------------- + * + * TclSetupEnv -- + * + * This procedure is invoked for an interpreter to make environment + * variables accessible from that interpreter via the "env" + * associative array. + * + * Results: + * None. + * + * Side effects: + * The interpreter is added to a list of interpreters managed + * by us, so that its view of envariables can be kept consistent + * with the view in other interpreters. If this is the first + * call to Tcl_SetupEnv, then additional initialization happens, + * such as copying the environment to dynamically-allocated space + * for ease of management. + * + *---------------------------------------------------------------------- + */ + +void +TclSetupEnv(interp) + Tcl_Interp *interp; /* Interpreter whose "env" array is to be + * managed. */ +{ + EnvInterp *eiPtr; + int i; + + /* + * First, initialize our environment-related information, if + * necessary. + */ + + if (environSize == 0) { + EnvInit(); + } + + /* + * Next, add the interpreter to the list of those that we manage. + */ + + eiPtr = (EnvInterp *) ckalloc(sizeof(EnvInterp)); + eiPtr->interp = interp; + eiPtr->nextPtr = firstInterpPtr; + firstInterpPtr = eiPtr; + + /* + * Store the environment variable values into the interpreter's + * "env" array, and arrange for us to be notified on future + * writes and unsets to that array. + */ + + (void) Tcl_UnsetVar2(interp, "env", (char *) NULL, TCL_GLOBAL_ONLY); + for (i = 0; ; i++) { + char *p, *p2; + + p = environ[i]; + if (p == NULL) { + break; + } + for (p2 = p; *p2 != '='; p2++) { + /* Empty loop body. */ + } + *p2 = 0; + (void) Tcl_SetVar2(interp, "env", p, p2+1, TCL_GLOBAL_ONLY); + *p2 = '='; + } + Tcl_TraceVar2(interp, "env", (char *) NULL, + TCL_GLOBAL_ONLY | TCL_TRACE_WRITES | TCL_TRACE_UNSETS, + EnvTraceProc, (ClientData) NULL); +} + +/* + *---------------------------------------------------------------------- + * + * FindVariable -- + * + * Locate the entry in environ for a given name. + * + * Results: + * The return value is the index in environ of an entry with the + * name "name", or -1 if there is no such entry. The integer at + * *lengthPtr is filled in with the length of name (if a matching + * entry is found) or the length of the environ array (if no matching + * entry is found). + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static int +FindVariable(name, lengthPtr) + CONST char *name; /* Name of desired environment variable. */ + int *lengthPtr; /* Used to return length of name (for + * successful searches) or number of non-NULL + * entries in environ (for unsuccessful + * searches). */ +{ + int i; + register CONST char *p1, *p2; + + for (i = 0, p1 = environ[i]; p1 != NULL; i++, p1 = environ[i]) { + for (p2 = name; *p2 == *p1; p1++, p2++) { + /* NULL loop body. */ + } + if ((*p1 == '=') && (*p2 == '\0')) { + *lengthPtr = p2-name; + return i; + } + } + *lengthPtr = i; + return -1; +} + +/* + *---------------------------------------------------------------------- + * + * TclGetEnv -- + * + * Get an environment variable or return NULL if the variable + * doesn't exist. This procedure is intended to be a + * stand-in for the UNIX "getenv" procedure so that applications + * using that procedure will interface properly to Tcl. To make + * it a stand-in, the Makefile must define "TclGetEnv" to "getenv". + * + * Results: + * ptr to value on success, NULL if error. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +char * +TclGetEnv(name) + char *name; /* Name of desired environment variable. */ +{ + int i; + size_t len; + + for (i = 0; environ[i] != NULL; i++) { + len = (size_t) ((char *) strchr(environ[i], '=') - environ[i]); + if ((len > 0 && !strncmp(name, environ[i], len)) + || (*name == '\0')) { + /* + * The caller of this function should regard this + * as static memory. + */ + return &environ[i][len+1]; + } + } + + return NULL; +} + +/* + *---------------------------------------------------------------------- + * + * TclSetEnv -- + * + * Set an environment variable, replacing an existing value + * or creating a new variable if there doesn't exist a variable + * by the given name. This procedure is intended to be a + * stand-in for the UNIX "setenv" procedure so that applications + * using that procedure will interface properly to Tcl. To make + * it a stand-in, the Makefile must define "TclSetEnv" to "setenv". + * + * Results: + * None. + * + * Side effects: + * The environ array gets updated, as do all of the interpreters + * that we manage. + * + *---------------------------------------------------------------------- + */ + +void +TclSetEnv(name, value) + CONST char *name; /* Name of variable whose value is to be + * set. */ + CONST char *value; /* New value for variable. */ +{ + int index, length, nameLength; + char *p; + EnvInterp *eiPtr; + + if (environSize == 0) { + EnvInit(); + } + + /* + * Figure out where the entry is going to go. If the name doesn't + * already exist, enlarge the array if necessary to make room. If + * the name exists, free its old entry. + */ + + index = FindVariable(name, &length); + if (index == -1) { + if ((length+2) > environSize) { + char **newEnviron; + + newEnviron = (char **) ckalloc((unsigned) + ((length+5) * sizeof(char *))); + memcpy((VOID *) newEnviron, (VOID *) environ, + length*sizeof(char *)); + ckfree((char *) environ); + environ = newEnviron; + environSize = length+5; + } + index = length; + environ[index+1] = NULL; + nameLength = strlen(name); + } else { + /* + * Compare the new value to the existing value. If they're + * the same then quit immediately (e.g. don't rewrite the + * value or propagate it to other interpreters). Otherwise, + * when there are N interpreters there will be N! propagations + * of the same value among the interpreters. + */ + + if (strcmp(value, environ[index]+length+1) == 0) { + return; + } + ckfree(environ[index]); + nameLength = length; + } + + /* + * Create a new entry and enter it into the table. + */ + + p = (char *) ckalloc((unsigned) (nameLength + strlen(value) + 2)); + environ[index] = p; + strcpy(p, name); + p += nameLength; + *p = '='; + strcpy(p+1, value); + + /* + * Update all of the interpreters. + */ + + for (eiPtr= firstInterpPtr; eiPtr != NULL; eiPtr = eiPtr->nextPtr) { + (void) Tcl_SetVar2(eiPtr->interp, "env", (char *) name, + p+1, TCL_GLOBAL_ONLY); + } + + /* + * Update the system environment. + */ + + TclSetSystemEnv(name, value); +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_PutEnv -- + * + * Set an environment variable. Similar to setenv except that + * the information is passed in a single string of the form + * NAME=value, rather than as separate name strings. This procedure + * is intended to be a stand-in for the UNIX "putenv" procedure + * so that applications using that procedure will interface + * properly to Tcl. To make it a stand-in, the Makefile will + * define "Tcl_PutEnv" to "putenv". + * + * Results: + * None. + * + * Side effects: + * The environ array gets updated, as do all of the interpreters + * that we manage. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_PutEnv(string) + CONST char *string; /* Info about environment variable in the + * form NAME=value. */ +{ + int nameLength; + char *name, *value; + + if (string == NULL) { + return 0; + } + + /* + * Separate the string into name and value parts, then call + * TclSetEnv to do all of the real work. + */ + + value = strchr(string, '='); + if (value == NULL) { + return 0; + } + nameLength = value - string; + if (nameLength == 0) { + return 0; + } + name = (char *) ckalloc((unsigned) nameLength+1); + memcpy(name, string, (size_t) nameLength); + name[nameLength] = 0; + TclSetEnv(name, value+1); + ckfree(name); + return 0; +} + +/* + *---------------------------------------------------------------------- + * + * TclUnsetEnv -- + * + * Remove an environment variable, updating the "env" arrays + * in all interpreters managed by us. This function is intended + * to replace the UNIX "unsetenv" function (but to do this the + * Makefile must be modified to redefine "TclUnsetEnv" to + * "unsetenv". + * + * Results: + * None. + * + * Side effects: + * Interpreters are updated, as is environ. + * + *---------------------------------------------------------------------- + */ + +void +TclUnsetEnv(name) + CONST char *name; /* Name of variable to remove. */ +{ + int index, dummy; + char **envPtr; + EnvInterp *eiPtr; + + if (environSize == 0) { + EnvInit(); + } + + /* + * Update the environ array. + */ + + index = FindVariable(name, &dummy); + if (index == -1) { + return; + } + ckfree(environ[index]); + for (envPtr = environ+index+1; ; envPtr++) { + envPtr[-1] = *envPtr; + if (*envPtr == NULL) { + break; + } + } + + /* + * Update all of the interpreters. + */ + + for (eiPtr = firstInterpPtr; eiPtr != NULL; eiPtr = eiPtr->nextPtr) { + (void) Tcl_UnsetVar2(eiPtr->interp, "env", (char *) name, + TCL_GLOBAL_ONLY); + } + + /* + * Update the system environment. + */ + + TclSetSystemEnv(name, NULL); +} + +/* + *---------------------------------------------------------------------- + * + * EnvTraceProc -- + * + * This procedure is invoked whenever an environment variable + * is modified or deleted. It propagates the change to the + * "environ" array and to any other interpreters for whom + * we're managing an "env" array. + * + * Results: + * Always returns NULL to indicate success. + * + * Side effects: + * Environment variable changes get propagated. If the whole + * "env" array is deleted, then we stop managing things for + * this interpreter (usually this happens because the whole + * interpreter is being deleted). + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +static char * +EnvTraceProc(clientData, interp, name1, name2, flags) + 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 if whole array is being deleted. */ + int flags; /* Indicates what's happening. */ +{ + /* + * First see if the whole "env" variable is being deleted. If + * so, just forget about this interpreter. + */ + + if (name2 == NULL) { + register EnvInterp *eiPtr, *prevPtr; + + if ((flags & (TCL_TRACE_UNSETS|TCL_TRACE_DESTROYED)) + != (TCL_TRACE_UNSETS|TCL_TRACE_DESTROYED)) { + panic("EnvTraceProc called with confusing arguments"); + } + eiPtr = firstInterpPtr; + if (eiPtr->interp == interp) { + firstInterpPtr = eiPtr->nextPtr; + } else { + for (prevPtr = eiPtr, eiPtr = eiPtr->nextPtr; ; + prevPtr = eiPtr, eiPtr = eiPtr->nextPtr) { + if (eiPtr == NULL) { + panic("EnvTraceProc couldn't find interpreter"); + } + if (eiPtr->interp == interp) { + prevPtr->nextPtr = eiPtr->nextPtr; + break; + } + } + } + ckfree((char *) eiPtr); + return NULL; + } + + /* + * If a value is being set, call TclSetEnv to do all of the work. + */ + + if (flags & TCL_TRACE_WRITES) { + TclSetEnv(name2, Tcl_GetVar2(interp, "env", name2, TCL_GLOBAL_ONLY)); + } + + if (flags & TCL_TRACE_UNSETS) { + TclUnsetEnv(name2); + } + return NULL; +} + +/* + *---------------------------------------------------------------------- + * + * EnvInit -- + * + * This procedure is called to initialize our management + * of the environ array. + * + * Results: + * None. + * + * Side effects: + * Environ gets copied to malloc-ed storage, so that in + * the future we don't have to worry about which entries + * are malloc-ed and which are static. + * + *---------------------------------------------------------------------- + */ + +static void +EnvInit() +{ +#ifdef MAC_TCL + environSize = TclMacCreateEnv(); +#else + char **newEnviron; + int i, length; + + if (environSize != 0) { + return; + } + for (length = 0; environ[length] != NULL; length++) { + /* Empty loop body. */ + } + environSize = length+5; + newEnviron = (char **) ckalloc((unsigned) + (environSize * sizeof(char *))); + for (i = 0; i < length; i++) { + newEnviron[i] = (char *) ckalloc((unsigned) (strlen(environ[i]) + 1)); + strcpy(newEnviron[i], environ[i]); + } + newEnviron[length] = NULL; + environ = newEnviron; + Tcl_CreateExitHandler(EnvExitProc, (ClientData) NULL); +#endif +} + +/* + *---------------------------------------------------------------------- + * + * EnvExitProc -- + * + * This procedure is called just before the process exits. It + * frees the memory associated with environment variables. + * + * Results: + * None. + * + * Side effects: + * Memory is freed. + * + *---------------------------------------------------------------------- + */ + +static void +EnvExitProc(clientData) + ClientData clientData; /* Not used. */ +{ + char **p; + + for (p = environ; *p != NULL; p++) { + ckfree(*p); + } + ckfree((char *) environ); +} diff --git a/contrib/tcl/generic/tclEvent.c b/contrib/tcl/generic/tclEvent.c new file mode 100644 index 0000000..3c9f7d2 --- /dev/null +++ b/contrib/tcl/generic/tclEvent.c @@ -0,0 +1,2187 @@ +/* + * tclEvent.c -- + * + * This file provides basic event-managing facilities for Tcl, + * including an event queue, and mechanisms for attaching + * callbacks to certain events. + * + * It also contains the command procedures for the commands + * "after", "vwait", and "update". + * + * Copyright (c) 1990-1994 The Regents of the University of California. + * Copyright (c) 1994-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: @(#) tclEvent.c 1.127 96/03/22 12:12:33 + */ + +#include "tclInt.h" +#include "tclPort.h" + +/* + * For each file registered in a call to Tcl_CreateFileHandler, + * there is one record of the following type. All of these records + * are chained together into a single list. + */ + +typedef struct FileHandler { + Tcl_File file; /* Generic file handle for file. */ + int mask; /* Mask of desired events: TCL_READABLE, etc. */ + int readyMask; /* Events that were ready the last time that + * FileHandlerCheckProc checked this file. */ + Tcl_FileProc *proc; /* Procedure to call, in the style of + * Tcl_CreateFileHandler. This is NULL + * if the handler was created by + * Tcl_CreateFileHandler2. */ + ClientData clientData; /* Argument to pass to proc. */ + struct FileHandler *nextPtr;/* Next in list of all files we care + * about (NULL for end of list). */ +} FileHandler; + +static FileHandler *firstFileHandlerPtr = (FileHandler *) NULL; + /* List of all file handlers. */ +static int fileEventSourceCreated = 0; + /* Non-zero means that the file event source + * hasn't been registerd with the Tcl + * notifier yet. */ + +/* + * The following structure is what is added to the Tcl event queue when + * file handlers are ready to fire. + */ + +typedef struct FileHandlerEvent { + Tcl_Event header; /* Information that is standard for + * all events. */ + Tcl_File file; /* File descriptor that is ready. Used + * to find the FileHandler structure for + * the file (can't point directly to the + * FileHandler structure because it could + * go away while the event is queued). */ +} FileHandlerEvent; + +/* + * For each timer callback that's pending (either regular or "modal"), + * there is one record of the following type. The normal handlers + * (created by Tcl_CreateTimerHandler) are chained together in a + * list sorted by time (earliest event first). + */ + +typedef struct TimerHandler { + Tcl_Time time; /* When timer is to fire. */ + Tcl_TimerProc *proc; /* Procedure to call. */ + ClientData clientData; /* Argument to pass to proc. */ + Tcl_TimerToken token; /* Identifies event so it can be + * deleted. Not used in modal + * timeouts. */ + struct TimerHandler *nextPtr; /* Next event in queue, or NULL for + * end of queue. */ +} TimerHandler; + +static TimerHandler *firstTimerHandlerPtr = NULL; + /* First event in queue. */ +static int timerEventSourceCreated = 0; /* 0 means that the timer event source + * hasn't yet been registered with the + * Tcl notifier. */ + +/* + * The information below describes a stack of modal timeouts managed by + * Tcl_CreateModalTimer and Tcl_DeleteModalTimer. Only the first element + * in the list is used at any given time. + */ + +static TimerHandler *firstModalHandlerPtr = NULL; + +/* + * The following structure is what's added to the Tcl event queue when + * timer handlers are ready to fire. + */ + +typedef struct TimerEvent { + Tcl_Event header; /* Information that is standard for + * all events. */ + Tcl_Time time; /* All timer events that specify this + * time or earlier are ready + * to fire. */ +} TimerEvent; + +/* + * There is one of the following structures for each of the + * handlers declared in a call to Tcl_DoWhenIdle. All of the + * currently-active handlers are linked together into a list. + */ + +typedef struct IdleHandler { + Tcl_IdleProc (*proc); /* Procedure to call. */ + ClientData clientData; /* Value to pass to proc. */ + int generation; /* Used to distinguish older handlers from + * recently-created ones. */ + struct IdleHandler *nextPtr;/* Next in list of active handlers. */ +} IdleHandler; + +static IdleHandler *idleList = NULL; + /* First in list of all idle handlers. */ +static IdleHandler *lastIdlePtr = NULL; + /* Last in list (or NULL for empty list). */ +static int idleGeneration = 0; /* Used to fill in the "generation" fields + * of IdleHandler structures. Increments + * each time Tcl_DoOneEvent starts calling + * idle handlers, so that all old handlers + * can be called without calling any of the + * new ones created by old ones. */ + +/* + * The data structure below is used by the "after" command to remember + * the command to be executed later. All of the pending "after" commands + * for an interpreter are linked together in a list. + */ + +typedef struct AfterInfo { + struct AfterAssocData *assocPtr; + /* Pointer to the "tclAfter" assocData for + * the interp in which command will be + * executed. */ + char *command; /* Command to execute. Malloc'ed, so must + * be freed when structure is deallocated. */ + int id; /* Integer identifier for command; used to + * cancel it. */ + Tcl_TimerToken token; /* Used to cancel the "after" command. NULL + * means that the command is run as an + * idle handler rather than as a timer + * handler. NULL means this is an "after + * idle" handler rather than a + * timer handler. */ + struct AfterInfo *nextPtr; /* Next in list of all "after" commands for + * this interpreter. */ +} AfterInfo; + +/* + * One of the following structures is associated with each interpreter + * for which an "after" command has ever been invoked. A pointer to + * this structure is stored in the AssocData for the "tclAfter" key. + */ + +typedef struct AfterAssocData { + Tcl_Interp *interp; /* The interpreter for which this data is + * registered. */ + AfterInfo *firstAfterPtr; /* First in list of all "after" commands + * still pending for this interpreter, or + * NULL if none. */ +} AfterAssocData; + +/* + * The data structure below is used to report background errors. One + * such structure is allocated for each error; it holds information + * about the interpreter and the error until bgerror can be invoked + * later as an idle handler. + */ + +typedef struct BgError { + Tcl_Interp *interp; /* Interpreter in which error occurred. NULL + * means this error report has been cancelled + * (a previous report generated a break). */ + char *errorMsg; /* The error message (interp->result when + * the error occurred). Malloc-ed. */ + char *errorInfo; /* Value of the errorInfo variable + * (malloc-ed). */ + char *errorCode; /* Value of the errorCode variable + * (malloc-ed). */ + struct BgError *nextPtr; /* Next in list of all pending error + * reports for this interpreter, or NULL + * for end of list. */ +} BgError; + +/* + * One of the structures below is associated with the "tclBgError" + * assoc data for each interpreter. It keeps track of the head and + * tail of the list of pending background errors for the interpreter. + */ + +typedef struct ErrAssocData { + BgError *firstBgPtr; /* First in list of all background errors + * waiting to be processed for this + * interpreter (NULL if none). */ + BgError *lastBgPtr; /* Last in list of all background errors + * waiting to be processed for this + * interpreter (NULL if none). */ +} ErrAssocData; + +/* + * For each exit handler created with a call to Tcl_CreateExitHandler + * there is a structure of the following type: + */ + +typedef struct ExitHandler { + Tcl_ExitProc *proc; /* Procedure to call when process exits. */ + ClientData clientData; /* One word of information to pass to proc. */ + struct ExitHandler *nextPtr;/* Next in list of all exit handlers for + * this application, or NULL for end of list. */ +} ExitHandler; + +static ExitHandler *firstExitPtr = NULL; + /* First in list of all exit handlers for + * application. */ + +/* + * Structures of the following type are used during the execution + * of Tcl_WaitForFile, to keep track of the file and timeout. + */ + +typedef struct FileWait { + Tcl_File file; /* File to wait on. */ + int mask; /* Conditions to wait for (TCL_READABLE, + * etc.) */ + int timeout; /* Original "timeout" argument to + * Tcl_WaitForFile. */ + Tcl_Time abortTime; /* Time at which to abort the wait. */ + int present; /* Conditions present on the file during + * the last time through the event loop. */ + int done; /* Non-zero means we're done: either one of + * the desired conditions is present or the + * timeout period has elapsed. */ +} FileWait; + +/* + * The following variable is a "secret" indication to Tcl_Exit that + * it should dump out the state of memory before exiting. If the + * value is non-NULL, it gives the name of the file in which to + * dump memory usage information. + */ + +char *tclMemDumpFileName = NULL; + +/* + * Prototypes for procedures referenced only in this file: + */ + +static void AfterCleanupProc _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp)); +static void AfterProc _ANSI_ARGS_((ClientData clientData)); +static void BgErrorDeleteProc _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp)); +static void FileHandlerCheckProc _ANSI_ARGS_(( + ClientData clientData, int flags)); +static int FileHandlerEventProc _ANSI_ARGS_((Tcl_Event *evPtr, + int flags)); +static void FileHandlerExitProc _ANSI_ARGS_((ClientData data)); +static void FileHandlerSetupProc _ANSI_ARGS_(( + ClientData clientData, int flags)); +static void FreeAfterPtr _ANSI_ARGS_((AfterInfo *afterPtr)); +static AfterInfo * GetAfterEvent _ANSI_ARGS_((AfterAssocData *assocPtr, + char *string)); +static void HandleBgErrors _ANSI_ARGS_((ClientData clientData)); +static void TimerHandlerCheckProc _ANSI_ARGS_(( + ClientData clientData, int flags)); +static int TimerHandlerEventProc _ANSI_ARGS_((Tcl_Event *evPtr, + int flags)); +static void TimerHandlerExitProc _ANSI_ARGS_((ClientData data)); +static void TimerHandlerSetupProc _ANSI_ARGS_(( + ClientData clientData, int flags)); +static char * VwaitVarProc _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, char *name1, char *name2, + int flags)); + +/* + *-------------------------------------------------------------- + * + * Tcl_CreateFileHandler -- + * + * Arrange for a given procedure to be invoked whenever + * a given file becomes readable or writable. + * + * Results: + * None. + * + * Side effects: + * From now on, whenever the I/O channel given by file becomes + * ready in the way indicated by mask, proc will be invoked. + * See the manual entry for details on the calling sequence + * to proc. If file is already registered then the old mask + * and proc and clientData values will be replaced with + * new ones. + * + *-------------------------------------------------------------- + */ + +void +Tcl_CreateFileHandler(file, mask, proc, clientData) + Tcl_File file; /* Handle of stream to watch. */ + int mask; /* OR'ed combination of TCL_READABLE, + * TCL_WRITABLE, and TCL_EXCEPTION: + * indicates conditions under which + * proc should be called. */ + Tcl_FileProc *proc; /* Procedure to call for each + * selected event. */ + ClientData clientData; /* Arbitrary data to pass to proc. */ +{ + register FileHandler *filePtr; + + if (!fileEventSourceCreated) { + fileEventSourceCreated = 1; + Tcl_CreateEventSource(FileHandlerSetupProc, FileHandlerCheckProc, + (ClientData) NULL); + Tcl_CreateExitHandler(FileHandlerExitProc, (ClientData) NULL); + } + + /* + * Make sure the file isn't already registered. Create a + * new record in the normal case where there's no existing + * record. + */ + + for (filePtr = firstFileHandlerPtr; filePtr != NULL; + filePtr = filePtr->nextPtr) { + if (filePtr->file == file) { + break; + } + } + if (filePtr == NULL) { + filePtr = (FileHandler *) ckalloc(sizeof(FileHandler)); + filePtr->file = file; + filePtr->nextPtr = firstFileHandlerPtr; + firstFileHandlerPtr = filePtr; + } + + /* + * The remainder of the initialization below is done regardless + * of whether or not this is a new record or a modification of + * an old one. + */ + + filePtr->mask = mask; + filePtr->readyMask = 0; + filePtr->proc = proc; + filePtr->clientData = clientData; +} + +/* + *-------------------------------------------------------------- + * + * Tcl_DeleteFileHandler -- + * + * Cancel a previously-arranged callback arrangement for + * a file. + * + * Results: + * None. + * + * Side effects: + * If a callback was previously registered on file, remove it. + * + *-------------------------------------------------------------- + */ + +void +Tcl_DeleteFileHandler(file) + Tcl_File file; /* Stream id for which to remove + * callback procedure. */ +{ + FileHandler *filePtr, *prevPtr; + + /* + * Find the entry for the given file (and return if there + * isn't one). + */ + + for (prevPtr = NULL, filePtr = firstFileHandlerPtr; ; + prevPtr = filePtr, filePtr = filePtr->nextPtr) { + if (filePtr == NULL) { + return; + } + if (filePtr->file == file) { + break; + } + } + + /* + * Clean up information in the callback record. + */ + + if (prevPtr == NULL) { + firstFileHandlerPtr = filePtr->nextPtr; + } else { + prevPtr->nextPtr = filePtr->nextPtr; + } + ckfree((char *) filePtr); +} + +/* + *---------------------------------------------------------------------- + * + * FileHandlerExitProc -- + * + * Cleanup procedure to delete the file event source during exit + * cleanup. + * + * Results: + * None. + * + * Side effects: + * Destroys the file event source. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +static void +FileHandlerExitProc(clientData) + ClientData clientData; /* Not used. */ +{ + Tcl_DeleteEventSource(FileHandlerSetupProc, FileHandlerCheckProc, + (ClientData) NULL); +} + +/* + *---------------------------------------------------------------------- + * + * FileHandlerSetupProc -- + * + * This procedure is part of the "event source" for file handlers. + * It is invoked by Tcl_DoOneEvent before it calls select (or + * whatever it uses to wait). + * + * Results: + * None. + * + * Side effects: + * Tells the notifier which files should be waited for. + * + *---------------------------------------------------------------------- + */ + +static void +FileHandlerSetupProc(clientData, flags) + ClientData clientData; /* Not used. */ + int flags; /* Flags passed to Tk_DoOneEvent: + * if it doesn't include + * TCL_FILE_EVENTS then we do + * nothing. */ +{ + FileHandler *filePtr; + + if (!(flags & TCL_FILE_EVENTS)) { + return; + } + for (filePtr = firstFileHandlerPtr; filePtr != NULL; + filePtr = filePtr->nextPtr) { + if (filePtr->mask != 0) { + Tcl_WatchFile(filePtr->file, filePtr->mask); + } + } +} + +/* + *---------------------------------------------------------------------- + * + * FileHandlerCheckProc -- + * + * This procedure is the second part of the "event source" for + * file handlers. It is invoked by Tcl_DoOneEvent after it calls + * select (or whatever it uses to wait for events). + * + * Results: + * None. + * + * Side effects: + * Makes entries on the Tcl event queue for each file that is + * now ready. + * + *---------------------------------------------------------------------- + */ + +static void +FileHandlerCheckProc(clientData, flags) + ClientData clientData; /* Not used. */ + int flags; /* Flags passed to Tk_DoOneEvent: + * if it doesn't include + * TCL_FILE_EVENTS then we do + * nothing. */ +{ + FileHandler *filePtr; + FileHandlerEvent *fileEvPtr; + + if (!(flags & TCL_FILE_EVENTS)) { + return; + } + for (filePtr = firstFileHandlerPtr; filePtr != NULL; + filePtr = filePtr->nextPtr) { + if (filePtr->mask != 0) { + filePtr->readyMask = Tcl_FileReady(filePtr->file, filePtr->mask); + if (filePtr->readyMask != 0) { + fileEvPtr = (FileHandlerEvent *) ckalloc( + sizeof(FileHandlerEvent)); + fileEvPtr->header.proc = FileHandlerEventProc; + fileEvPtr->file = filePtr->file; + Tcl_QueueEvent((Tcl_Event *) fileEvPtr, TCL_QUEUE_TAIL); + } + } + } +} + +/* + *---------------------------------------------------------------------- + * + * FileHandlerEventProc -- + * + * This procedure is called by Tcl_DoOneEvent when a file event + * reaches the front of the event queue. This procedure is responsible + * for actually handling the event by invoking the callback for the + * file handler. + * + * Results: + * Returns 1 if the event was handled, meaning it should be removed + * from the queue. Returns 0 if the event was not handled, meaning + * it should stay on the queue. The only time the event isn't + * handled is if the TCL_FILE_EVENTS flag bit isn't set. + * + * Side effects: + * Whatever the file handler's callback procedure does + * + *---------------------------------------------------------------------- + */ + +static int +FileHandlerEventProc(evPtr, flags) + Tcl_Event *evPtr; /* Event to service. */ + int flags; /* Flags that indicate what events to + * handle, such as TCL_FILE_EVENTS. */ +{ + FileHandler *filePtr; + FileHandlerEvent *fileEvPtr = (FileHandlerEvent *) evPtr; + int mask; + + if (!(flags & TCL_FILE_EVENTS)) { + return 0; + } + + /* + * Search through the file handlers to find the one whose handle matches + * the event. We do this rather than keeping a pointer to the file + * handler directly in the event, so that the handler can be deleted + * while the event is queued without leaving a dangling pointer. + */ + + for (filePtr = firstFileHandlerPtr; filePtr != NULL; + filePtr = filePtr->nextPtr) { + if (filePtr->file != fileEvPtr->file) { + continue; + } + + /* + * The code is tricky for two reasons: + * 1. The file handler's desired events could have changed + * since the time when the event was queued, so AND the + * ready mask with the desired mask. + * 2. The file could have been closed and re-opened since + * the time when the event was queued. This is why the + * ready mask is stored in the file handler rather than + * the queued event: it will be zeroed when a new + * file handler is created for the newly opened file. + */ + + mask = filePtr->readyMask & filePtr->mask; + filePtr->readyMask = 0; + if (mask != 0) { + (*filePtr->proc)(filePtr->clientData, mask); + } + break; + } + return 1; +} + +/* + *-------------------------------------------------------------- + * + * Tcl_CreateTimerHandler -- + * + * Arrange for a given procedure to be invoked at a particular + * time in the future. + * + * Results: + * The return value is a token for the timer event, which + * may be used to delete the event before it fires. + * + * Side effects: + * When milliseconds have elapsed, proc will be invoked + * exactly once. + * + *-------------------------------------------------------------- + */ + +Tcl_TimerToken +Tcl_CreateTimerHandler(milliseconds, proc, clientData) + int milliseconds; /* How many milliseconds to wait + * before invoking proc. */ + Tcl_TimerProc *proc; /* Procedure to invoke. */ + ClientData clientData; /* Arbitrary data to pass to proc. */ +{ + register TimerHandler *timerHandlerPtr, *tPtr2, *prevPtr; + static int id = 0; + + if (!timerEventSourceCreated) { + timerEventSourceCreated = 1; + Tcl_CreateEventSource(TimerHandlerSetupProc, TimerHandlerCheckProc, + (ClientData) NULL); + Tcl_CreateExitHandler(TimerHandlerExitProc, (ClientData) NULL); + } + + timerHandlerPtr = (TimerHandler *) ckalloc(sizeof(TimerHandler)); + + /* + * Compute when the event should fire. + */ + + TclGetTime(&timerHandlerPtr->time); + timerHandlerPtr->time.sec += milliseconds/1000; + timerHandlerPtr->time.usec += (milliseconds%1000)*1000; + if (timerHandlerPtr->time.usec >= 1000000) { + timerHandlerPtr->time.usec -= 1000000; + timerHandlerPtr->time.sec += 1; + } + + /* + * Fill in other fields for the event. + */ + + timerHandlerPtr->proc = proc; + timerHandlerPtr->clientData = clientData; + id++; + timerHandlerPtr->token = (Tcl_TimerToken) id; + + /* + * Add the event to the queue in the correct position + * (ordered by event firing time). + */ + + for (tPtr2 = firstTimerHandlerPtr, prevPtr = NULL; tPtr2 != NULL; + prevPtr = tPtr2, tPtr2 = tPtr2->nextPtr) { + if ((tPtr2->time.sec > timerHandlerPtr->time.sec) + || ((tPtr2->time.sec == timerHandlerPtr->time.sec) + && (tPtr2->time.usec > timerHandlerPtr->time.usec))) { + break; + } + } + timerHandlerPtr->nextPtr = tPtr2; + if (prevPtr == NULL) { + firstTimerHandlerPtr = timerHandlerPtr; + } else { + prevPtr->nextPtr = timerHandlerPtr; + } + return timerHandlerPtr->token; +} + +/* + *-------------------------------------------------------------- + * + * Tcl_DeleteTimerHandler -- + * + * Delete a previously-registered timer handler. + * + * Results: + * None. + * + * Side effects: + * Destroy the timer callback identified by TimerToken, + * so that its associated procedure will not be called. + * If the callback has already fired, or if the given + * token doesn't exist, then nothing happens. + * + *-------------------------------------------------------------- + */ + +void +Tcl_DeleteTimerHandler(token) + Tcl_TimerToken token; /* Result previously returned by + * Tcl_DeleteTimerHandler. */ +{ + register TimerHandler *timerHandlerPtr, *prevPtr; + + for (timerHandlerPtr = firstTimerHandlerPtr, prevPtr = NULL; + timerHandlerPtr != NULL; prevPtr = timerHandlerPtr, + timerHandlerPtr = timerHandlerPtr->nextPtr) { + if (timerHandlerPtr->token != token) { + continue; + } + if (prevPtr == NULL) { + firstTimerHandlerPtr = timerHandlerPtr->nextPtr; + } else { + prevPtr->nextPtr = timerHandlerPtr->nextPtr; + } + ckfree((char *) timerHandlerPtr); + return; + } +} + +/* + *-------------------------------------------------------------- + * + * Tcl_CreateModalTimeout -- + * + * Arrange for a given procedure to be invoked at a particular + * time in the future, independently of all other timer events. + * + * Results: + * None. + * + * Side effects: + * When milliseconds have elapsed, proc will be invoked + * exactly once. + * + *-------------------------------------------------------------- + */ + +void +Tcl_CreateModalTimeout(milliseconds, proc, clientData) + int milliseconds; /* How many milliseconds to wait + * before invoking proc. */ + Tcl_TimerProc *proc; /* Procedure to invoke. */ + ClientData clientData; /* Arbitrary data to pass to proc. */ +{ + TimerHandler *timerHandlerPtr; + + if (!timerEventSourceCreated) { + timerEventSourceCreated = 1; + Tcl_CreateEventSource(TimerHandlerSetupProc, TimerHandlerCheckProc, + (ClientData) NULL); + Tcl_CreateExitHandler(TimerHandlerExitProc, (ClientData) NULL); + } + + timerHandlerPtr = (TimerHandler *) ckalloc(sizeof(TimerHandler)); + + /* + * Compute when the timeout should fire and fill in the other fields + * of the handler. + */ + + TclGetTime(&timerHandlerPtr->time); + timerHandlerPtr->time.sec += milliseconds/1000; + timerHandlerPtr->time.usec += (milliseconds%1000)*1000; + if (timerHandlerPtr->time.usec >= 1000000) { + timerHandlerPtr->time.usec -= 1000000; + timerHandlerPtr->time.sec += 1; + } + timerHandlerPtr->proc = proc; + timerHandlerPtr->clientData = clientData; + + /* + * Push the handler on the top of the modal stack. + */ + + timerHandlerPtr->nextPtr = firstModalHandlerPtr; + firstModalHandlerPtr = timerHandlerPtr; +} + +/* + *-------------------------------------------------------------- + * + * Tcl_DeleteModalTimeout -- + * + * Remove the topmost modal timer handler from the stack of + * modal handlers. + * + * Results: + * None. + * + * Side effects: + * Destroys the topmost modal timeout handler, which must + * match proc and clientData. + * + *-------------------------------------------------------------- + */ + +void +Tcl_DeleteModalTimeout(proc, clientData) + Tcl_TimerProc *proc; /* Callback procedure for the timeout. */ + ClientData clientData; /* Arbitrary data to pass to proc. */ +{ + TimerHandler *timerHandlerPtr; + + timerHandlerPtr = firstModalHandlerPtr; + firstModalHandlerPtr = timerHandlerPtr->nextPtr; + if ((timerHandlerPtr->proc != proc) + || (timerHandlerPtr->clientData != clientData)) { + panic("Tcl_DeleteModalTimeout found timeout stack corrupted"); + } + ckfree((char *) timerHandlerPtr); +} + +/* + *---------------------------------------------------------------------- + * + * TimerHandlerSetupProc -- + * + * This procedure is part of the "event source" for timers. + * It is invoked by Tcl_DoOneEvent before it calls select (or + * whatever it uses to wait). + * + * Results: + * None. + * + * Side effects: + * Tells the notifier how long to sleep if it decides to block. + * + *---------------------------------------------------------------------- + */ + +static void +TimerHandlerSetupProc(clientData, flags) + ClientData clientData; /* Not used. */ + int flags; /* Flags passed to Tk_DoOneEvent: + * if it doesn't include + * TCL_TIMER_EVENTS then we only + * consider modal timers. */ +{ + TimerHandler *timerHandlerPtr, *tPtr2; + Tcl_Time blockTime; + + /* + * Find the timer handler (regular or modal) that fires first. + */ + + timerHandlerPtr = firstTimerHandlerPtr; + if (!(flags & TCL_TIMER_EVENTS)) { + timerHandlerPtr = NULL; + } + if (timerHandlerPtr != NULL) { + tPtr2 = firstModalHandlerPtr; + if (tPtr2 != NULL) { + if ((timerHandlerPtr->time.sec > tPtr2->time.sec) + || ((timerHandlerPtr->time.sec == tPtr2->time.sec) + && (timerHandlerPtr->time.usec > tPtr2->time.usec))) { + timerHandlerPtr = tPtr2; + } + } + } else { + timerHandlerPtr = firstModalHandlerPtr; + } + if (timerHandlerPtr == NULL) { + return; + } + + TclGetTime(&blockTime); + blockTime.sec = timerHandlerPtr->time.sec - blockTime.sec; + blockTime.usec = timerHandlerPtr->time.usec - blockTime.usec; + if (blockTime.usec < 0) { + blockTime.sec -= 1; + blockTime.usec += 1000000; + } + if (blockTime.sec < 0) { + blockTime.sec = 0; + blockTime.usec = 0; + } + Tcl_SetMaxBlockTime(&blockTime); +} + +/* + *---------------------------------------------------------------------- + * + * TimerHandlerCheckProc -- + * + * This procedure is the second part of the "event source" for + * file handlers. It is invoked by Tcl_DoOneEvent after it calls + * select (or whatever it uses to wait for events). + * + * Results: + * None. + * + * Side effects: + * Makes entries on the Tcl event queue for each file that is + * now ready. + * + *---------------------------------------------------------------------- + */ + +static void +TimerHandlerCheckProc(clientData, flags) + ClientData clientData; /* Not used. */ + int flags; /* Flags passed to Tk_DoOneEvent: + * if it doesn't include + * TCL_TIMER_EVENTS then we only + * consider modal timeouts. */ +{ + TimerHandler *timerHandlerPtr; + TimerEvent *timerEvPtr; + int triggered, gotTime; + Tcl_Time curTime; + + triggered = 0; + gotTime = 0; + timerHandlerPtr = firstTimerHandlerPtr; + if ((flags & TCL_TIMER_EVENTS) && (timerHandlerPtr != NULL)) { + TclGetTime(&curTime); + gotTime = 1; + if ((timerHandlerPtr->time.sec < curTime.sec) + || ((timerHandlerPtr->time.sec == curTime.sec) + && (timerHandlerPtr->time.usec <= curTime.usec))) { + triggered = 1; + } + } + timerHandlerPtr = firstModalHandlerPtr; + if (timerHandlerPtr != NULL) { + if (!gotTime) { + TclGetTime(&curTime); + } + if ((timerHandlerPtr->time.sec < curTime.sec) + || ((timerHandlerPtr->time.sec == curTime.sec) + && (timerHandlerPtr->time.usec <= curTime.usec))) { + triggered = 1; + } + } + if (triggered) { + timerEvPtr = (TimerEvent *) ckalloc(sizeof(TimerEvent)); + timerEvPtr->header.proc = TimerHandlerEventProc; + timerEvPtr->time.sec = curTime.sec; + timerEvPtr->time.usec = curTime.usec; + Tcl_QueueEvent((Tcl_Event *) timerEvPtr, TCL_QUEUE_TAIL); + } +} + +/* + *---------------------------------------------------------------------- + * + * TimerHandlerExitProc -- + * + * Callback invoked during exit cleanup to destroy the timer event + * source. + * + * Results: + * None. + * + * Side effects: + * Destroys the timer event source. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +static void +TimerHandlerExitProc(clientData) + ClientData clientData; /* Not used. */ +{ + Tcl_DeleteEventSource(TimerHandlerSetupProc, TimerHandlerCheckProc, + (ClientData) NULL); +} + +/* + *---------------------------------------------------------------------- + * + * TimerHandlerEventProc -- + * + * This procedure is called by Tcl_DoOneEvent when a timer event + * reaches the front of the event queue. This procedure handles + * the event by invoking the callbacks for all timers that are + * ready. + * + * Results: + * Returns 1 if the event was handled, meaning it should be removed + * from the queue. Returns 0 if the event was not handled, meaning + * it should stay on the queue. The only time the event isn't + * handled is if the TCL_TIMER_EVENTS flag bit isn't set. + * + * Side effects: + * Whatever the timer handler callback procedures do. + * + *---------------------------------------------------------------------- + */ + +static int +TimerHandlerEventProc(evPtr, flags) + Tcl_Event *evPtr; /* Event to service. */ + int flags; /* Flags that indicate what events to + * handle, such as TCL_FILE_EVENTS. */ +{ + TimerHandler *timerHandlerPtr; + TimerEvent *timerEvPtr = (TimerEvent *) evPtr; + + /* + * Invoke the current modal timeout first, if there is one and + * it has triggered. + */ + + timerHandlerPtr = firstModalHandlerPtr; + if (firstModalHandlerPtr != NULL) { + if ((timerHandlerPtr->time.sec < timerEvPtr->time.sec) + || ((timerHandlerPtr->time.sec == timerEvPtr->time.sec) + && (timerHandlerPtr->time.usec <= timerEvPtr->time.usec))) { + (*timerHandlerPtr->proc)(timerHandlerPtr->clientData); + } + } + + /* + * Invoke any normal timers that have fired. + */ + + if (!(flags & TCL_TIMER_EVENTS)) { + return 1; + } + + while (1) { + timerHandlerPtr = firstTimerHandlerPtr; + if (timerHandlerPtr == NULL) { + break; + } + if ((timerHandlerPtr->time.sec > timerEvPtr->time.sec) + || ((timerHandlerPtr->time.sec == timerEvPtr->time.sec) + && (timerHandlerPtr->time.usec >= timerEvPtr->time.usec))) { + break; + } + + /* + * Remove the handler from the queue before invoking it, + * to avoid potential reentrancy problems. + */ + + firstTimerHandlerPtr = timerHandlerPtr->nextPtr; + (*timerHandlerPtr->proc)(timerHandlerPtr->clientData); + ckfree((char *) timerHandlerPtr); + } + return 1; +} + +/* + *-------------------------------------------------------------- + * + * Tcl_DoWhenIdle -- + * + * Arrange for proc to be invoked the next time the system is + * idle (i.e., just before the next time that Tcl_DoOneEvent + * would have to wait for something to happen). + * + * Results: + * None. + * + * Side effects: + * Proc will eventually be called, with clientData as argument. + * See the manual entry for details. + * + *-------------------------------------------------------------- + */ + +void +Tcl_DoWhenIdle(proc, clientData) + Tcl_IdleProc *proc; /* Procedure to invoke. */ + ClientData clientData; /* Arbitrary value to pass to proc. */ +{ + register IdleHandler *idlePtr; + + idlePtr = (IdleHandler *) ckalloc(sizeof(IdleHandler)); + idlePtr->proc = proc; + idlePtr->clientData = clientData; + idlePtr->generation = idleGeneration; + idlePtr->nextPtr = NULL; + if (lastIdlePtr == NULL) { + idleList = idlePtr; + } else { + lastIdlePtr->nextPtr = idlePtr; + } + lastIdlePtr = idlePtr; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_CancelIdleCall -- + * + * If there are any when-idle calls requested to a given procedure + * with given clientData, cancel all of them. + * + * Results: + * None. + * + * Side effects: + * If the proc/clientData combination were on the when-idle list, + * they are removed so that they will never be called. + * + *---------------------------------------------------------------------- + */ + +void +Tcl_CancelIdleCall(proc, clientData) + Tcl_IdleProc *proc; /* Procedure that was previously registered. */ + ClientData clientData; /* Arbitrary value to pass to proc. */ +{ + register IdleHandler *idlePtr, *prevPtr; + IdleHandler *nextPtr; + + for (prevPtr = NULL, idlePtr = idleList; idlePtr != NULL; + prevPtr = idlePtr, idlePtr = idlePtr->nextPtr) { + while ((idlePtr->proc == proc) + && (idlePtr->clientData == clientData)) { + nextPtr = idlePtr->nextPtr; + ckfree((char *) idlePtr); + idlePtr = nextPtr; + if (prevPtr == NULL) { + idleList = idlePtr; + } else { + prevPtr->nextPtr = idlePtr; + } + if (idlePtr == NULL) { + lastIdlePtr = prevPtr; + return; + } + } + } +} + +/* + *---------------------------------------------------------------------- + * + * TclIdlePending -- + * + * This function is called by the notifier subsystem to determine + * whether there are any idle handlers currently scheduled. + * + * Results: + * Returns 0 if the idle list is empty, otherwise it returns 1. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +int +TclIdlePending() +{ + return (idleList == NULL) ? 0 : 1; +} + +/* + *---------------------------------------------------------------------- + * + * TclServiceIdle -- + * + * This procedure is invoked by the notifier when it becomes idle. + * + * Results: + * The return value is 1 if the procedure actually found an idle + * handler to invoke. If no handler was found then 0 is returned. + * + * Side effects: + * Invokes all pending idle handlers. + * + *---------------------------------------------------------------------- + */ + +int +TclServiceIdle() +{ + IdleHandler *idlePtr; + int oldGeneration; + int foundIdle; + + if (idleList == NULL) { + return 0; + } + + foundIdle = 0; + oldGeneration = idleGeneration; + idleGeneration++; + + /* + * The code below is trickier than it may look, for the following + * reasons: + * + * 1. New handlers can get added to the list while the current + * one is being processed. If new ones get added, we don't + * want to process them during this pass through the list (want + * to check for other work to do first). This is implemented + * using the generation number in the handler: new handlers + * will have a different generation than any of the ones currently + * on the list. + * 2. The handler can call Tcl_DoOneEvent, so we have to remove + * the handler from the list before calling it. Otherwise an + * infinite loop could result. + * 3. Tcl_CancelIdleCall can be called to remove an element from + * the list while a handler is executing, so the list could + * change structure during the call. + */ + + for (idlePtr = idleList; + ((idlePtr != NULL) + && ((oldGeneration - idlePtr->generation) >= 0)); + idlePtr = idleList) { + idleList = idlePtr->nextPtr; + if (idleList == NULL) { + lastIdlePtr = NULL; + } + foundIdle = 1; + (*idlePtr->proc)(idlePtr->clientData); + ckfree((char *) idlePtr); + } + + return foundIdle; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_BackgroundError -- + * + * This procedure is invoked to handle errors that occur in Tcl + * commands that are invoked in "background" (e.g. from event or + * timer bindings). + * + * Results: + * None. + * + * Side effects: + * The command "bgerror" is invoked later as an idle handler to + * process the error, passing it the error message. If that fails, + * then an error message is output on stderr. + * + *---------------------------------------------------------------------- + */ + +void +Tcl_BackgroundError(interp) + Tcl_Interp *interp; /* Interpreter in which an error has + * occurred. */ +{ + BgError *errPtr; + char *varValue; + ErrAssocData *assocPtr; + + /* + * The Tcl_AddErrorInfo call below (with an empty string) ensures that + * errorInfo gets properly set. It's needed in cases where the error + * came from a utility procedure like Tcl_GetVar instead of Tcl_Eval; + * in these cases errorInfo still won't have been set when this + * procedure is called. + */ + + Tcl_AddErrorInfo(interp, ""); + errPtr = (BgError *) ckalloc(sizeof(BgError)); + errPtr->interp = interp; + errPtr->errorMsg = (char *) ckalloc((unsigned) (strlen(interp->result) + + 1)); + strcpy(errPtr->errorMsg, interp->result); + varValue = Tcl_GetVar(interp, "errorInfo", TCL_GLOBAL_ONLY); + if (varValue == NULL) { + varValue = errPtr->errorMsg; + } + errPtr->errorInfo = (char *) ckalloc((unsigned) (strlen(varValue) + 1)); + strcpy(errPtr->errorInfo, varValue); + varValue = Tcl_GetVar(interp, "errorCode", TCL_GLOBAL_ONLY); + if (varValue == NULL) { + varValue = ""; + } + errPtr->errorCode = (char *) ckalloc((unsigned) (strlen(varValue) + 1)); + strcpy(errPtr->errorCode, varValue); + errPtr->nextPtr = NULL; + + assocPtr = (ErrAssocData *) Tcl_GetAssocData(interp, "tclBgError", + (Tcl_InterpDeleteProc **) NULL); + if (assocPtr == NULL) { + + /* + * This is the first time a background error has occurred in + * this interpreter. Create associated data to keep track of + * pending error reports. + */ + + assocPtr = (ErrAssocData *) ckalloc(sizeof(ErrAssocData)); + assocPtr->firstBgPtr = NULL; + assocPtr->lastBgPtr = NULL; + Tcl_SetAssocData(interp, "tclBgError", BgErrorDeleteProc, + (ClientData) assocPtr); + } + if (assocPtr->firstBgPtr == NULL) { + assocPtr->firstBgPtr = errPtr; + Tcl_DoWhenIdle(HandleBgErrors, (ClientData) assocPtr); + } else { + assocPtr->lastBgPtr->nextPtr = errPtr; + } + assocPtr->lastBgPtr = errPtr; + Tcl_ResetResult(interp); +} + +/* + *---------------------------------------------------------------------- + * + * HandleBgErrors -- + * + * This procedure is invoked as an idle handler to process all of + * the accumulated background errors. + * + * Results: + * None. + * + * Side effects: + * Depends on what actions "bgerror" takes for the errors. + * + *---------------------------------------------------------------------- + */ + +static void +HandleBgErrors(clientData) + ClientData clientData; /* Pointer to ErrAssocData structure. */ +{ + Tcl_Interp *interp; + char *command; + char *argv[2]; + int code; + BgError *errPtr; + ErrAssocData *assocPtr = (ErrAssocData *) clientData; + Tcl_Channel errChannel; + + while (assocPtr->firstBgPtr != NULL) { + interp = assocPtr->firstBgPtr->interp; + if (interp == NULL) { + goto doneWithReport; + } + + /* + * Restore important state variables to what they were at + * the time the error occurred. + */ + + Tcl_SetVar(interp, "errorInfo", assocPtr->firstBgPtr->errorInfo, + TCL_GLOBAL_ONLY); + Tcl_SetVar(interp, "errorCode", assocPtr->firstBgPtr->errorCode, + TCL_GLOBAL_ONLY); + + /* + * Create and invoke the bgerror command. + */ + + argv[0] = "bgerror"; + argv[1] = assocPtr->firstBgPtr->errorMsg; + command = Tcl_Merge(2, argv); + Tcl_AllowExceptions(interp); + Tcl_Preserve((ClientData) interp); + code = Tcl_GlobalEval(interp, command); + ckfree(command); + if (code == TCL_ERROR) { + + /* + * We have to get the error output channel at the latest possible + * time, because the eval (above) might have changed the channel. + */ + + errChannel = Tcl_GetStdChannel(TCL_STDERR); + if (errChannel != (Tcl_Channel) NULL) { + if (strcmp(interp->result, + "\"bgerror\" is an invalid command name or ambiguous abbreviation") + == 0) { + Tcl_Write(errChannel, assocPtr->firstBgPtr->errorInfo, -1); + Tcl_Write(errChannel, "\n", -1); + } else { + Tcl_Write(errChannel, + "bgerror failed to handle background error.\n", + -1); + Tcl_Write(errChannel, " Original error: ", -1); + Tcl_Write(errChannel, assocPtr->firstBgPtr->errorMsg, + -1); + Tcl_Write(errChannel, "\n", -1); + Tcl_Write(errChannel, " Error in bgerror: ", -1); + Tcl_Write(errChannel, interp->result, -1); + Tcl_Write(errChannel, "\n", -1); + } + Tcl_Flush(errChannel); + } + } else if (code == TCL_BREAK) { + + /* + * Break means cancel any remaining error reports for this + * interpreter. + */ + + for (errPtr = assocPtr->firstBgPtr; errPtr != NULL; + errPtr = errPtr->nextPtr) { + if (errPtr->interp == interp) { + errPtr->interp = NULL; + } + } + } + + Tcl_Release((ClientData) interp); + + /* + * Discard the command and the information about the error report. + */ + + doneWithReport: + ckfree(assocPtr->firstBgPtr->errorMsg); + ckfree(assocPtr->firstBgPtr->errorInfo); + ckfree(assocPtr->firstBgPtr->errorCode); + errPtr = assocPtr->firstBgPtr->nextPtr; + ckfree((char *) assocPtr->firstBgPtr); + assocPtr->firstBgPtr = errPtr; + } + assocPtr->lastBgPtr = NULL; +} + +/* + *---------------------------------------------------------------------- + * + * BgErrorDeleteProc -- + * + * This procedure is associated with the "tclBgError" assoc data + * for an interpreter; it is invoked when the interpreter is + * deleted in order to free the information assoicated with any + * pending error reports. + * + * Results: + * None. + * + * Side effects: + * Background error information is freed: if there were any + * pending error reports, they are cancelled. + * + *---------------------------------------------------------------------- + */ + +static void +BgErrorDeleteProc(clientData, interp) + ClientData clientData; /* Pointer to ErrAssocData structure. */ + Tcl_Interp *interp; /* Interpreter being deleted. */ +{ + ErrAssocData *assocPtr = (ErrAssocData *) clientData; + BgError *errPtr; + + while (assocPtr->firstBgPtr != NULL) { + errPtr = assocPtr->firstBgPtr; + assocPtr->firstBgPtr = errPtr->nextPtr; + ckfree(errPtr->errorMsg); + ckfree(errPtr->errorInfo); + ckfree(errPtr->errorCode); + ckfree((char *) errPtr); + } + ckfree((char *) assocPtr); + Tcl_CancelIdleCall(HandleBgErrors, (ClientData) assocPtr); +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_CreateExitHandler -- + * + * Arrange for a given procedure to be invoked just before the + * application exits. + * + * Results: + * None. + * + * Side effects: + * Proc will be invoked with clientData as argument when the + * application exits. + * + *---------------------------------------------------------------------- + */ + +void +Tcl_CreateExitHandler(proc, clientData) + Tcl_ExitProc *proc; /* Procedure to invoke. */ + ClientData clientData; /* Arbitrary value to pass to proc. */ +{ + ExitHandler *exitPtr; + + exitPtr = (ExitHandler *) ckalloc(sizeof(ExitHandler)); + exitPtr->proc = proc; + exitPtr->clientData = clientData; + exitPtr->nextPtr = firstExitPtr; + firstExitPtr = exitPtr; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_DeleteExitHandler -- + * + * This procedure cancels an existing exit handler matching proc + * and clientData, if such a handler exits. + * + * Results: + * None. + * + * Side effects: + * If there is an exit handler corresponding to proc and clientData + * then it is cancelled; if no such handler exists then nothing + * happens. + * + *---------------------------------------------------------------------- + */ + +void +Tcl_DeleteExitHandler(proc, clientData) + Tcl_ExitProc *proc; /* Procedure that was previously registered. */ + ClientData clientData; /* Arbitrary value to pass to proc. */ +{ + ExitHandler *exitPtr, *prevPtr; + + for (prevPtr = NULL, exitPtr = firstExitPtr; exitPtr != NULL; + prevPtr = exitPtr, exitPtr = exitPtr->nextPtr) { + if ((exitPtr->proc == proc) + && (exitPtr->clientData == clientData)) { + if (prevPtr == NULL) { + firstExitPtr = exitPtr->nextPtr; + } else { + prevPtr->nextPtr = exitPtr->nextPtr; + } + ckfree((char *) exitPtr); + return; + } + } +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_Exit -- + * + * This procedure is called to terminate the application. + * + * Results: + * None. + * + * Side effects: + * All existing exit handlers are invoked, then the application + * ends. + * + *---------------------------------------------------------------------- + */ + +void +Tcl_Exit(status) + int status; /* Exit status for application; typically + * 0 for normal return, 1 for error return. */ +{ + ExitHandler *exitPtr; + + for (exitPtr = firstExitPtr; exitPtr != NULL; exitPtr = firstExitPtr) { + /* + * Be careful to remove the handler from the list before invoking + * its callback. This protects us against double-freeing if the + * callback should call Tcl_DeleteExitHandler on itself. + */ + + firstExitPtr = exitPtr->nextPtr; + (*exitPtr->proc)(exitPtr->clientData); + ckfree((char *) exitPtr); + } +#ifdef TCL_MEM_DEBUG + if (tclMemDumpFileName != NULL) { + Tcl_DumpActiveMemory(tclMemDumpFileName); + } +#endif + + TclPlatformExit(status); +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_AfterCmd -- + * + * This procedure is invoked to process the "after" Tcl command. + * See the user documentation for details on what it does. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * See the user documentation. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +int +Tcl_AfterCmd(clientData, interp, argc, argv) + ClientData clientData; /* Points to the "tclAfter" assocData for + * this interpreter, or NULL if the assocData + * hasn't been created yet.*/ + Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ + /* + * The variable below is used to generate unique identifiers for + * after commands. This id can wrap around, which can potentially + * cause problems. However, there are not likely to be problems + * in practice, because after commands can only be requested to + * about a month in the future, and wrap-around is unlikely to + * occur in less than about 1-10 years. Thus it's unlikely that + * any old ids will still be around when wrap-around occurs. + */ + + static int nextId = 1; + int ms; + AfterInfo *afterPtr; + AfterAssocData *assocPtr = (AfterAssocData *) clientData; + Tcl_CmdInfo cmdInfo; + size_t length; + + if (argc < 2) { + Tcl_AppendResult(interp, "wrong # args: should be \"", + argv[0], " option ?arg arg ...?\"", (char *) NULL); + return TCL_ERROR; + } + + /* + * Create the "after" information associated for this interpreter, + * if it doesn't already exist. Associate it with the command too, + * so that it will be passed in as the ClientData argument in the + * future. + */ + + if (assocPtr == NULL) { + assocPtr = (AfterAssocData *) ckalloc(sizeof(AfterAssocData)); + assocPtr->interp = interp; + assocPtr->firstAfterPtr = NULL; + Tcl_SetAssocData(interp, "tclAfter", AfterCleanupProc, + (ClientData) assocPtr); + cmdInfo.proc = Tcl_AfterCmd; + cmdInfo.clientData = (ClientData) assocPtr; + cmdInfo.deleteProc = NULL; + cmdInfo.deleteData = (ClientData) assocPtr; + Tcl_SetCommandInfo(interp, argv[0], &cmdInfo); + } + + /* + * Parse the command. + */ + + length = strlen(argv[1]); + if (isdigit(UCHAR(argv[1][0]))) { + if (Tcl_GetInt(interp, argv[1], &ms) != TCL_OK) { + return TCL_ERROR; + } + if (ms < 0) { + ms = 0; + } + if (argc == 2) { + Tcl_Sleep(ms); + return TCL_OK; + } + afterPtr = (AfterInfo *) ckalloc((unsigned) (sizeof(AfterInfo))); + afterPtr->assocPtr = assocPtr; + if (argc == 3) { + afterPtr->command = (char *) ckalloc((unsigned) + (strlen(argv[2]) + 1)); + strcpy(afterPtr->command, argv[2]); + } else { + afterPtr->command = Tcl_Concat(argc-2, argv+2); + } + afterPtr->id = nextId; + nextId += 1; + afterPtr->token = Tcl_CreateTimerHandler(ms, AfterProc, + (ClientData) afterPtr); + afterPtr->nextPtr = assocPtr->firstAfterPtr; + assocPtr->firstAfterPtr = afterPtr; + sprintf(interp->result, "after#%d", afterPtr->id); + } else if (strncmp(argv[1], "cancel", length) == 0) { + char *arg; + + if (argc < 3) { + Tcl_AppendResult(interp, "wrong # args: should be \"", + argv[0], " cancel id|command\"", (char *) NULL); + return TCL_ERROR; + } + if (argc == 3) { + arg = argv[2]; + } else { + arg = Tcl_Concat(argc-2, argv+2); + } + for (afterPtr = assocPtr->firstAfterPtr; afterPtr != NULL; + afterPtr = afterPtr->nextPtr) { + if (strcmp(afterPtr->command, arg) == 0) { + break; + } + } + if (afterPtr == NULL) { + afterPtr = GetAfterEvent(assocPtr, arg); + } + if (arg != argv[2]) { + ckfree(arg); + } + if (afterPtr != NULL) { + if (afterPtr->token != NULL) { + Tcl_DeleteTimerHandler(afterPtr->token); + } else { + Tcl_CancelIdleCall(AfterProc, (ClientData) afterPtr); + } + FreeAfterPtr(afterPtr); + } + } else if ((strncmp(argv[1], "idle", length) == 0) + && (length >= 2)) { + if (argc < 3) { + Tcl_AppendResult(interp, "wrong # args: should be \"", + argv[0], " idle script script ...\"", (char *) NULL); + return TCL_ERROR; + } + afterPtr = (AfterInfo *) ckalloc((unsigned) (sizeof(AfterInfo))); + afterPtr->assocPtr = assocPtr; + if (argc == 3) { + afterPtr->command = (char *) ckalloc((unsigned) + (strlen(argv[2]) + 1)); + strcpy(afterPtr->command, argv[2]); + } else { + afterPtr->command = Tcl_Concat(argc-2, argv+2); + } + afterPtr->id = nextId; + nextId += 1; + afterPtr->token = NULL; + afterPtr->nextPtr = assocPtr->firstAfterPtr; + assocPtr->firstAfterPtr = afterPtr; + Tcl_DoWhenIdle(AfterProc, (ClientData) afterPtr); + sprintf(interp->result, "after#%d", afterPtr->id); + } else if ((strncmp(argv[1], "info", length) == 0) + && (length >= 2)) { + if (argc == 2) { + char buffer[30]; + + for (afterPtr = assocPtr->firstAfterPtr; afterPtr != NULL; + afterPtr = afterPtr->nextPtr) { + if (assocPtr->interp == interp) { + sprintf(buffer, "after#%d", afterPtr->id); + Tcl_AppendElement(interp, buffer); + } + } + return TCL_OK; + } + if (argc != 3) { + Tcl_AppendResult(interp, "wrong # args: should be \"", + argv[0], " info ?id?\"", (char *) NULL); + return TCL_ERROR; + } + afterPtr = GetAfterEvent(assocPtr, argv[2]); + if (afterPtr == NULL) { + Tcl_AppendResult(interp, "event \"", argv[2], + "\" doesn't exist", (char *) NULL); + return TCL_ERROR; + } + Tcl_AppendElement(interp, afterPtr->command); + Tcl_AppendElement(interp, + (afterPtr->token == NULL) ? "idle" : "timer"); + } else { + Tcl_AppendResult(interp, "bad argument \"", argv[1], + "\": must be cancel, idle, info, or a number", + (char *) NULL); + return TCL_ERROR; + } + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * GetAfterEvent -- + * + * This procedure parses an "after" id such as "after#4" and + * returns a pointer to the AfterInfo structure. + * + * Results: + * The return value is either a pointer to an AfterInfo structure, + * if one is found that corresponds to "string" and is for interp, + * or NULL if no corresponding after event can be found. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static AfterInfo * +GetAfterEvent(assocPtr, string) + AfterAssocData *assocPtr; /* Points to "after"-related information for + * this interpreter. */ + char *string; /* Textual identifier for after event, such + * as "after#6". */ +{ + AfterInfo *afterPtr; + int id; + char *end; + + if (strncmp(string, "after#", 6) != 0) { + return NULL; + } + string += 6; + id = strtoul(string, &end, 10); + if ((end == string) || (*end != 0)) { + return NULL; + } + for (afterPtr = assocPtr->firstAfterPtr; afterPtr != NULL; + afterPtr = afterPtr->nextPtr) { + if (afterPtr->id == id) { + return afterPtr; + } + } + return NULL; +} + +/* + *---------------------------------------------------------------------- + * + * AfterProc -- + * + * Timer callback to execute commands registered with the + * "after" command. + * + * Results: + * None. + * + * Side effects: + * Executes whatever command was specified. If the command + * returns an error, then the command "bgerror" is invoked + * to process the error; if bgerror fails then information + * about the error is output on stderr. + * + *---------------------------------------------------------------------- + */ + +static void +AfterProc(clientData) + ClientData clientData; /* Describes command to execute. */ +{ + AfterInfo *afterPtr = (AfterInfo *) clientData; + AfterAssocData *assocPtr = afterPtr->assocPtr; + AfterInfo *prevPtr; + int result; + Tcl_Interp *interp; + + /* + * First remove the callback from our list of callbacks; otherwise + * someone could delete the callback while it's being executed, which + * could cause a core dump. + */ + + if (assocPtr->firstAfterPtr == afterPtr) { + assocPtr->firstAfterPtr = afterPtr->nextPtr; + } else { + for (prevPtr = assocPtr->firstAfterPtr; prevPtr->nextPtr != afterPtr; + prevPtr = prevPtr->nextPtr) { + /* Empty loop body. */ + } + prevPtr->nextPtr = afterPtr->nextPtr; + } + + /* + * Execute the callback. + */ + + interp = assocPtr->interp; + Tcl_Preserve((ClientData) interp); + result = Tcl_GlobalEval(interp, afterPtr->command); + if (result != TCL_OK) { + Tcl_AddErrorInfo(interp, "\n (\"after\" script)"); + Tcl_BackgroundError(interp); + } + Tcl_Release((ClientData) interp); + + /* + * Free the memory for the callback. + */ + + ckfree(afterPtr->command); + ckfree((char *) afterPtr); +} + +/* + *---------------------------------------------------------------------- + * + * FreeAfterPtr -- + * + * This procedure removes an "after" command from the list of + * those that are pending and frees its resources. This procedure + * does *not* cancel the timer handler; if that's needed, the + * caller must do it. + * + * Results: + * None. + * + * Side effects: + * The memory associated with afterPtr is released. + * + *---------------------------------------------------------------------- + */ + +static void +FreeAfterPtr(afterPtr) + AfterInfo *afterPtr; /* Command to be deleted. */ +{ + AfterInfo *prevPtr; + AfterAssocData *assocPtr = afterPtr->assocPtr; + + if (assocPtr->firstAfterPtr == afterPtr) { + assocPtr->firstAfterPtr = afterPtr->nextPtr; + } else { + for (prevPtr = assocPtr->firstAfterPtr; prevPtr->nextPtr != afterPtr; + prevPtr = prevPtr->nextPtr) { + /* Empty loop body. */ + } + prevPtr->nextPtr = afterPtr->nextPtr; + } + ckfree(afterPtr->command); + ckfree((char *) afterPtr); +} + +/* + *---------------------------------------------------------------------- + * + * AfterCleanupProc -- + * + * This procedure is invoked whenever an interpreter is deleted + * to cleanup the AssocData for "tclAfter". + * + * Results: + * None. + * + * Side effects: + * After commands are removed. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +static void +AfterCleanupProc(clientData, interp) + ClientData clientData; /* Points to AfterAssocData for the + * interpreter. */ + Tcl_Interp *interp; /* Interpreter that is being deleted. */ +{ + AfterAssocData *assocPtr = (AfterAssocData *) clientData; + AfterInfo *afterPtr; + + while (assocPtr->firstAfterPtr != NULL) { + afterPtr = assocPtr->firstAfterPtr; + assocPtr->firstAfterPtr = afterPtr->nextPtr; + if (afterPtr->token != NULL) { + Tcl_DeleteTimerHandler(afterPtr->token); + } else { + Tcl_CancelIdleCall(AfterProc, (ClientData) afterPtr); + } + ckfree(afterPtr->command); + ckfree((char *) afterPtr); + } + ckfree((char *) assocPtr); +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_VwaitCmd -- + * + * This procedure is invoked to process the "vwait" Tcl command. + * See the user documentation for details on what it does. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * See the user documentation. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +int +Tcl_VwaitCmd(clientData, interp, argc, argv) + ClientData clientData; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ + int done, foundEvent; + + if (argc != 2) { + Tcl_AppendResult(interp, "wrong # args: should be \"", + argv[0], " name\"", (char *) NULL); + return TCL_ERROR; + } + Tcl_TraceVar(interp, argv[1], + TCL_GLOBAL_ONLY|TCL_TRACE_WRITES|TCL_TRACE_UNSETS, + VwaitVarProc, (ClientData) &done); + done = 0; + foundEvent = 1; + while (!done && foundEvent) { + foundEvent = Tcl_DoOneEvent(0); + } + Tcl_UntraceVar(interp, argv[1], + TCL_GLOBAL_ONLY|TCL_TRACE_WRITES|TCL_TRACE_UNSETS, + VwaitVarProc, (ClientData) &done); + + /* + * Clear out the interpreter's result, since it may have been set + * by event handlers. + */ + + Tcl_ResetResult(interp); + if (!foundEvent) { + Tcl_AppendResult(interp, "can't wait for variable \"", argv[1], + "\": would wait forever", (char *) NULL); + return TCL_ERROR; + } + return TCL_OK; +} + + /* ARGSUSED */ +static char * +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. */ + int flags; /* Information about what happened. */ +{ + int *donePtr = (int *) clientData; + + *donePtr = 1; + return (char *) NULL; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_UpdateCmd -- + * + * This procedure is invoked to process the "update" Tcl command. + * See the user documentation for details on what it does. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * See the user documentation. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +int +Tcl_UpdateCmd(clientData, interp, argc, argv) + ClientData clientData; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ + int flags = 0; /* Initialization needed only to stop + * compiler warnings. */ + + if (argc == 1) { + flags = TCL_ALL_EVENTS|TCL_DONT_WAIT; + } else if (argc == 2) { + if (strncmp(argv[1], "idletasks", strlen(argv[1])) != 0) { + Tcl_AppendResult(interp, "bad option \"", argv[1], + "\": must be idletasks", (char *) NULL); + return TCL_ERROR; + } + flags = TCL_IDLE_EVENTS|TCL_DONT_WAIT; + } else { + Tcl_AppendResult(interp, "wrong # args: should be \"", + argv[0], " ?idletasks?\"", (char *) NULL); + return TCL_ERROR; + } + + while (Tcl_DoOneEvent(flags) != 0) { + /* Empty loop body */ + } + + /* + * Must clear the interpreter's result because event handlers could + * have executed commands. + */ + + Tcl_ResetResult(interp); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * TclWaitForFile -- + * + * This procedure waits synchronously for a file to become readable + * or writable, with an optional timeout. + * + * Results: + * The return value is an OR'ed combination of TCL_READABLE, + * TCL_WRITABLE, and TCL_EXCEPTION, indicating the conditions + * that are present on file at the time of the return. This + * procedure will not return until either "timeout" milliseconds + * have elapsed or at least one of the conditions given by mask + * has occurred for file (a return value of 0 means that a timeout + * occurred). No normal events will be serviced during the + * execution of this procedure. + * + * Side effects: + * Time passes. + * + *---------------------------------------------------------------------- + */ + +int +TclWaitForFile(file, mask, timeout) + Tcl_File file; /* Handle for file on which to wait. */ + int mask; /* What to wait for: OR'ed combination of + * TCL_READABLE, TCL_WRITABLE, and + * TCL_EXCEPTION. */ + int timeout; /* Maximum amount of time to wait for one + * of the conditions in mask to occur, in + * milliseconds. A value of 0 means don't + * wait at all, and a value of -1 means + * wait forever. */ +{ + Tcl_Time abortTime, now, blockTime; + int present; + + /* + * If there is a non-zero finite timeout, compute the time when + * we give up. + */ + + if (timeout > 0) { + TclGetTime(&now); + abortTime.sec = now.sec + timeout/1000; + abortTime.usec = now.usec + (timeout%1000)*1000; + if (abortTime.usec >= 1000000) { + abortTime.usec -= 1000000; + abortTime.sec += 1; + } + } + + /* + * Loop in a mini-event loop of our own, waiting for either the + * file to become ready or a timeout to occur. + */ + + while (1) { + Tcl_WatchFile(file, mask); + if (timeout > 0) { + blockTime.sec = abortTime.sec - now.sec; + blockTime.usec = abortTime.usec - now.usec; + if (blockTime.usec < 0) { + blockTime.sec -= 1; + blockTime.usec += 1000000; + } + if (blockTime.sec < 0) { + blockTime.sec = 0; + blockTime.usec = 0; + } + Tcl_WaitForEvent(&blockTime); + } else if (timeout == 0) { + blockTime.sec = 0; + blockTime.usec = 0; + Tcl_WaitForEvent(&blockTime); + } else { + Tcl_WaitForEvent((Tcl_Time *) NULL); + } + present = Tcl_FileReady(file, mask); + if (present != 0) { + break; + } + if (timeout == 0) { + break; + } + TclGetTime(&now); + if ((abortTime.sec < now.sec) + || ((abortTime.sec == now.sec) + && (abortTime.usec <= now.usec))) { + break; + } + } + return present; +} diff --git a/contrib/tcl/generic/tclExpr.c b/contrib/tcl/generic/tclExpr.c new file mode 100644 index 0000000..13d020f --- /dev/null +++ b/contrib/tcl/generic/tclExpr.c @@ -0,0 +1,2055 @@ +/* + * 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.91 96/02/15 11:42: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}, +}; + +/* + *-------------------------------------------------------------- + * + * 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; +} + +/* + *---------------------------------------------------------------------- + * + * 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; + } +} + +/* + *---------------------------------------------------------------------- + * + * 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 atual + * 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 (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); + } + 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; +} + +/* + *-------------------------------------------------------------- + * + * 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; +} + +/* + *-------------------------------------------------------------- + * + * 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; +} + +/* + *-------------------------------------------------------------- + * + * 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; +} + +/* + *-------------------------------------------------------------- + * + * 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; +} + +/* + *---------------------------------------------------------------------- + * + * 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; +} + +/* + *---------------------------------------------------------------------- + * + * 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; +} + +/* + *---------------------------------------------------------------------- + * + * 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); + } +} + +/* + *---------------------------------------------------------------------- + * + * 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; +} + +/* + *---------------------------------------------------------------------- + * + * 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; +} diff --git a/contrib/tcl/generic/tclFHandle.c b/contrib/tcl/generic/tclFHandle.c new file mode 100644 index 0000000..19875c5 --- /dev/null +++ b/contrib/tcl/generic/tclFHandle.c @@ -0,0 +1,254 @@ +/* + * 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.6 96/02/13 16:29:55 + */ + +#include "tcl.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)); + +/* + *---------------------------------------------------------------------- + * + * 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); +} + +/* + *---------------------------------------------------------------------- + * + * 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); + } + + entryPtr = Tcl_FindHashEntry(&fileTable, (char *) &handlePtr->key); + if (entryPtr) { + Tcl_DeleteHashEntry(entryPtr); + ckfree((char *) handlePtr); + } +} + +/* + *---------------------------------------------------------------------- + * + * 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; +} + +/* + *---------------------------------------------------------------------- + * + * 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; +} + +/* + *---------------------------------------------------------------------- + * + * 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; +} + +/* + *---------------------------------------------------------------------- + * + * 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_HashSearch search; + Tcl_HashEntry *entryPtr; + + entryPtr = Tcl_FirstHashEntry(&fileTable, &search); + + while (entryPtr) { + ckfree(Tcl_GetHashValue(entryPtr)); + entryPtr = Tcl_NextHashEntry(&search); + } + + Tcl_DeleteHashTable(&fileTable); +} diff --git a/contrib/tcl/generic/tclFileName.c b/contrib/tcl/generic/tclFileName.c new file mode 100644 index 0000000..90beb11 --- /dev/null +++ b/contrib/tcl/generic/tclFileName.c @@ -0,0 +1,1591 @@ +/* + * tclFileName.c -- + * + * This file contains routines for converting file names betwen + * native and network form. + * + * Copyright (c) 1995-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: @(#) tclFileName.c 1.23 96/04/19 12:34:28 + */ + +#include "tclInt.h" +#include "tclPort.h" +#include "tclRegexp.h" + +/* + * This variable indicates whether the cleanup procedure has been + * registered for this file yet. + */ + +static int initialized = 0; + +/* + * 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. + */ + +#define WIN_ROOT_PATTERN "^(([a-zA-Z]:)|[/\\][/\\]+([^/\\]+)[/\\]+([^/\\]+)|([/\\]))([/\\])*" + +/* + * 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. + */ + +#define MAC_ROOT_PATTERN "^((/+([.][.]?/+)*([.][.]?)?)|(~[^:/]*)(/[^:]*)?|(~[^:]*)(:.*)?|/+([.][.]?/+)*([^:/]+)(/[^:]*)?|([^:]+):.*)$" + +/* + * The following variables are used to hold precompiled regular expressions + * for use in filename matching. + */ + +static regexp *winRootPatternPtr = NULL; +static regexp *macRootPatternPtr = NULL; + +/* + * 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; + +/* + * Prototypes for local procedures defined in this file: + */ + +static char * DoTildeSubst _ANSI_ARGS_((Tcl_Interp *interp, + char *user, Tcl_DString *resultPtr)); +static char * ExtractWinRoot _ANSI_ARGS_((char *path, + Tcl_DString *resultPtr, int offset)); +static void FileNameCleanup _ANSI_ARGS_((ClientData clientData)); +static int SkipToChar _ANSI_ARGS_((char **stringPtr, + char *match)); +static char * SplitMacPath _ANSI_ARGS_((char *path, + Tcl_DString *bufPtr)); +static char * SplitWinPath _ANSI_ARGS_((char *path, + Tcl_DString *bufPtr)); +static char * SplitUnixPath _ANSI_ARGS_((char *path, + Tcl_DString *bufPtr)); + +/* + *---------------------------------------------------------------------- + * + * FileNameCleanup -- + * + * This procedure is a Tcl_ExitProc used to clean up the static + * data structures used in this file. + * + * Results: + * None. + * + * Side effects: + * Deallocates storage used by the procedures in this file. + * + *---------------------------------------------------------------------- + */ + +static void +FileNameCleanup(clientData) + ClientData clientData; /* Not used. */ +{ + if (winRootPatternPtr != NULL) { + ckfree((char *)winRootPatternPtr); + } + if (macRootPatternPtr != NULL) { + ckfree((char *)macRootPatternPtr); + } +} + +/* + *---------------------------------------------------------------------- + * + * ExtractWinRoot -- + * + * Matches the root portion of a Windows path and appends it + * to the specified Tcl_DString. + * + * Results: + * Returns the position in the path immediately after the root + * including any trailing slashes. + * Appends a cleaned up version of the root to the Tcl_DString + * at the specified offest. + * + * Side effects: + * Modifies the specified Tcl_DString. + * + *---------------------------------------------------------------------- + */ + +static char * +ExtractWinRoot(path, resultPtr, offset) + char *path; /* Path to parse. */ + Tcl_DString *resultPtr; /* Buffer to hold result. */ + int offset; /* Offset in buffer where result should be + * stored. */ +{ + int length; + + /* + * Initialize the path name parser for Windows path names. + */ + + if (winRootPatternPtr == NULL) { + winRootPatternPtr = TclRegComp(WIN_ROOT_PATTERN); + if (!initialized) { + Tcl_CreateExitHandler(FileNameCleanup, NULL); + initialized = 1; + } + } + + /* + * Match the root portion of a Windows path name. + */ + + if (!TclRegExec(winRootPatternPtr, path, path)) { + return path; + } + + Tcl_DStringSetLength(resultPtr, offset); + + if (winRootPatternPtr->startp[2] != NULL) { + Tcl_DStringAppend(resultPtr, winRootPatternPtr->startp[2], 2); + if (winRootPatternPtr->startp[6] != NULL) { + Tcl_DStringAppend(resultPtr, "/", 1); + } + } else if (winRootPatternPtr->startp[4] != NULL) { + Tcl_DStringAppend(resultPtr, "//", 2); + length = winRootPatternPtr->endp[3] + - winRootPatternPtr->startp[3]; + Tcl_DStringAppend(resultPtr, winRootPatternPtr->startp[3], length); + Tcl_DStringAppend(resultPtr, "/", 1); + length = winRootPatternPtr->endp[4] + - winRootPatternPtr->startp[4]; + Tcl_DStringAppend(resultPtr, winRootPatternPtr->startp[4], length); + } else { + Tcl_DStringAppend(resultPtr, "/", 1); + } + return winRootPatternPtr->endp[0]; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_GetPathType -- + * + * 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_GetPathType(path) + char *path; +{ + Tcl_PathType type = TCL_PATH_ABSOLUTE; + + switch (tclPlatform) { + case TCL_PLATFORM_UNIX: + /* + * Paths that begin with / or ~ are absolute. + */ + + if ((path[0] != '/') && (path[0] != '~')) { + type = TCL_PATH_RELATIVE; + } + break; + + case TCL_PLATFORM_MAC: + if (path[0] == ':') { + type = TCL_PATH_RELATIVE; + } else if (path[0] != '~') { + + /* + * Since we have eliminated the easy cases, use the + * root pattern to look for the other types. + */ + + if (!macRootPatternPtr) { + macRootPatternPtr = TclRegComp(MAC_ROOT_PATTERN); + if (!initialized) { + Tcl_CreateExitHandler(FileNameCleanup, NULL); + initialized = 1; + } + } + if (!TclRegExec(macRootPatternPtr, path, path) + || (macRootPatternPtr->startp[2] != NULL)) { + type = TCL_PATH_RELATIVE; + } + } + break; + + case TCL_PLATFORM_WINDOWS: + if (path[0] != '~') { + + /* + * Since we have eliminated the easy cases, check for + * drive relative paths using the regular expression. + */ + + if (!winRootPatternPtr) { + winRootPatternPtr = TclRegComp(WIN_ROOT_PATTERN); + if (!initialized) { + Tcl_CreateExitHandler(FileNameCleanup, NULL); + initialized = 1; + } + } + if (TclRegExec(winRootPatternPtr, path, path)) { + if (winRootPatternPtr->startp[5] + || (winRootPatternPtr->startp[2] + && !(winRootPatternPtr->startp[6]))) { + type = TCL_PATH_VOLUME_RELATIVE; + } + } else { + type = TCL_PATH_RELATIVE; + } + } + break; + } + return type; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_SplitPath -- + * + * Split a path into a list of path components. The first element + * of the list will have the same path type as the original path. + * + * Results: + * Returns a standard Tcl result. The interpreter result contains + * a list of path components. + * *argvPtr will be filled in with the address of an array + * whose elements point to the elements of path, in order. + * *argcPtr will get filled in with the number of valid elements + * in the array. A single block of memory is dynamically allocated + * to hold both the argv array and a copy of the path elements. + * The caller must eventually free this memory by calling ckfree() + * on *argvPtr. Note: *argvPtr and *argcPtr are only modified + * if the procedure returns normally. + * + * Side effects: + * Allocates memory. + * + *---------------------------------------------------------------------- + */ + +void +Tcl_SplitPath(path, argcPtr, argvPtr) + 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 + * of pointers to path elements. */ +{ + int i, size; + char *p; + Tcl_DString buffer; + Tcl_DStringInit(&buffer); + + /* + * Perform platform specific splitting. These routines will leave the + * result in the specified buffer. Individual elements are terminated + * with a null character. + */ + + 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. + */ + + size = Tcl_DStringLength(&buffer); + *argcPtr = 0; + for (i = 0; i < size; i++) { + if (p[i] == '\0') { + (*argcPtr)++; + } + } + + /* + * Allocate a buffer large enough to hold the contents of the + * DString plus the argv pointers and the terminating NULL pointer. + */ + + *argvPtr = (char **) ckalloc((unsigned) + ((((*argcPtr) + 1) * sizeof(char *)) + size)); + + /* + * Position p after the last argv pointer and copy the contents of + * the DString. + */ + + p = (char *) &(*argvPtr)[(*argcPtr) + 1]; + memcpy((VOID *) p, (VOID *) Tcl_DStringValue(&buffer), (size_t) size); + + /* + * Now set up the argv pointers. + */ + + for (i = 0; i < *argcPtr; i++) { + (*argvPtr)[i] = p; + while ((*p++) != '\0') {} + } + (*argvPtr)[i] = NULL; + + Tcl_DStringFree(&buffer); +} + +/* + *---------------------------------------------------------------------- + * + * SplitUnixPath -- + * + * This routine is used by Tcl_SplitPath to handle splitting + * Unix paths. + * + * Results: + * Stores a null separated array of strings in the specified + * Tcl_DString. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static char * +SplitUnixPath(path, bufPtr) + char *path; /* Pointer to string containing a path. */ + Tcl_DString *bufPtr; /* Pointer to DString to use for the result. */ +{ + int length; + char *p, *elementStart; + + /* + * Deal with the root directory as a special case. + */ + + if (path[0] == '/') { + Tcl_DStringAppend(bufPtr, "/", 2); + p = path+1; + } else { + p = path; + } + + /* + * Split on slashes. Embedded elements that start with tilde will be + * prefixed with "./" so they are not affected by tilde substitution. + */ + + for (;;) { + elementStart = p; + while ((*p != '\0') && (*p != '/')) { + p++; + } + length = p - elementStart; + if (length > 0) { + if ((elementStart[0] == '~') && (elementStart != path)) { + Tcl_DStringAppend(bufPtr, "./", 2); + } + Tcl_DStringAppend(bufPtr, elementStart, length); + Tcl_DStringAppend(bufPtr, "", 1); + } + if (*p++ == '\0') { + break; + } + } + return Tcl_DStringValue(bufPtr); +} + +/* + *---------------------------------------------------------------------- + * + * SplitWinPath -- + * + * This routine is used by Tcl_SplitPath to handle splitting + * Windows paths. + * + * Results: + * Stores a null separated array of strings in the specified + * Tcl_DString. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static char * +SplitWinPath(path, bufPtr) + char *path; /* Pointer to string containing a path. */ + Tcl_DString *bufPtr; /* Pointer to DString to use for the result. */ +{ + int length; + char *p, *elementStart; + + p = ExtractWinRoot(path, bufPtr, 0); + + /* + * Terminate the root portion, if we matched something. + */ + + if (p != path) { + Tcl_DStringAppend(bufPtr, "", 1); + } + + /* + * Split on slashes. Embedded elements that start with tilde will be + * prefixed with "./" so they are not affected by tilde substitution. + */ + + do { + elementStart = p; + while ((*p != '\0') && (*p != '/') && (*p != '\\')) { + p++; + } + length = p - elementStart; + if (length > 0) { + if ((elementStart[0] == '~') && (elementStart != path)) { + Tcl_DStringAppend(bufPtr, "./", 2); + } + Tcl_DStringAppend(bufPtr, elementStart, length); + Tcl_DStringAppend(bufPtr, "", 1); + } + } while (*p++ != '\0'); + + return Tcl_DStringValue(bufPtr); +} + +/* + *---------------------------------------------------------------------- + * + * SplitMacPath -- + * + * This routine is used by Tcl_SplitPath to handle splitting + * Macintosh paths. + * + * Results: + * Returns a newly allocated argv array. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static char * +SplitMacPath(path, bufPtr) + 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; + char *p, *elementStart; + + /* + * Initialize the path name parser for Macintosh path names. + */ + + if (macRootPatternPtr == NULL) { + macRootPatternPtr = TclRegComp(MAC_ROOT_PATTERN); + if (!initialized) { + Tcl_CreateExitHandler(FileNameCleanup, NULL); + initialized = 1; + } + } + + /* + * Match the root portion of a Mac path name. + */ + + i = 0; /* Needed only to prevent gcc warnings. */ + if (TclRegExec(macRootPatternPtr, path, path) == 1) { + /* + * Treat degenerate absolute paths like / and /../.. as + * Mac relative file names for lack of anything else to do. + */ + + if (macRootPatternPtr->startp[2] != NULL) { + Tcl_DStringAppend(bufPtr, ":", 1); + Tcl_DStringAppend(bufPtr, path, macRootPatternPtr->endp[0] + - macRootPatternPtr->startp[0] + 1); + return Tcl_DStringValue(bufPtr); + } + + if (macRootPatternPtr->startp[5] != NULL) { + + /* + * Unix-style tilde prefixed paths. + */ + + isMac = 0; + i = 5; + } else if (macRootPatternPtr->startp[7] != NULL) { + + /* + * Mac-style tilde prefixed paths. + */ + + isMac = 1; + i = 7; + } else if (macRootPatternPtr->startp[10] != NULL) { + + /* + * Normal Unix style paths. + */ + + isMac = 0; + i = 10; + } else if (macRootPatternPtr->startp[12] != NULL) { + + /* + * Normal Mac style paths. + */ + + isMac = 1; + i = 12; + } + + length = macRootPatternPtr->endp[i] + - macRootPatternPtr->startp[i]; + + /* + * 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. + */ + + Tcl_DStringAppend(bufPtr, macRootPatternPtr->startp[i], length); + Tcl_DStringAppend(bufPtr, ":", 2); + p = macRootPatternPtr->endp[i]; + } else { + isMac = (strchr(path, ':') != NULL); + p = path; + } + + if (isMac) { + + /* + * p is pointing at the first colon in the path. There + * will always be one, since this is a Mac-style path. + */ + + elementStart = p++; + while ((p = strchr(p, ':')) != NULL) { + length = p - elementStart; + if (length == 1) { + while (*p == ':') { + Tcl_DStringAppend(bufPtr, "::", 3); + elementStart = p++; + } + } else { + /* + * If this is a simple component, drop the leading colon. + */ + + if ((elementStart[1] != '~') + && (strchr(elementStart+1, '/') == NULL)) { + elementStart++; + length--; + } + Tcl_DStringAppend(bufPtr, elementStart, length); + Tcl_DStringAppend(bufPtr, "", 1); + elementStart = p++; + } + } + if (elementStart[1] != '\0' || elementStart == path) { + if ((elementStart[1] != '~') && (elementStart[1] != '\0') + && (strchr(elementStart+1, '/') == NULL)) { + elementStart++; + } + Tcl_DStringAppend(bufPtr, elementStart, -1); + Tcl_DStringAppend(bufPtr, "", 1); + } + } else { + + /* + * Split on slashes, suppress extra /'s, and convert .. to ::. + */ + + for (;;) { + elementStart = p; + while ((*p != '\0') && (*p != '/')) { + p++; + } + length = p - elementStart; + if (length > 0) { + if ((length == 1) && (elementStart[0] == '.')) { + Tcl_DStringAppend(bufPtr, ":", 2); + } else if ((length == 2) && (elementStart[0] == '.') + && (elementStart[1] == '.')) { + Tcl_DStringAppend(bufPtr, "::", 3); + } else { + if (*elementStart == '~') { + Tcl_DStringAppend(bufPtr, ":", 1); + } + Tcl_DStringAppend(bufPtr, elementStart, length); + Tcl_DStringAppend(bufPtr, "", 1); + } + } + if (*p++ == '\0') { + break; + } + } + } + return Tcl_DStringValue(bufPtr); +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_JoinPath -- + * + * Combine a list of paths in a platform specific manner. + * + * 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. + * + * Side effects: + * Modifies the Tcl_DString. + * + *---------------------------------------------------------------------- + */ + +char * +Tcl_JoinPath(argc, argv, resultPtr) + int argc; + char **argv; + Tcl_DString *resultPtr; /* Pointer to previously initialized DString. */ +{ + int oldLength, length, i, needsSep; + Tcl_DString buffer; + char *p, c, *dest; + + 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. + */ + + if (*p == '/') { + Tcl_DStringSetLength(resultPtr, oldLength); + Tcl_DStringAppend(resultPtr, "/", 1); + while (*p == '/') { + 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; + } + + /* + * Append a separator if needed. + */ + + length = Tcl_DStringLength(resultPtr); + if ((length != oldLength) + && (Tcl_DStringValue(resultPtr)[length-1] != '/')) { + Tcl_DStringAppend(resultPtr, "/", 1); + length++; + } + + /* + * 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; + } + } + length = dest - Tcl_DStringValue(resultPtr); + Tcl_DStringSetLength(resultPtr, length); + } + break; + + case TCL_PLATFORM_WINDOWS: + /* + * 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. + */ + + for (i = 0; i < argc; i++) { + p = ExtractWinRoot(argv[i], resultPtr, oldLength); + 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; + } + } + + 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; + } + } + length = dest - Tcl_DStringValue(resultPtr); + Tcl_DStringSetLength(resultPtr, length); + } + } + break; + + 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; + } + + /* + * 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; + } + length = strlen(p); + Tcl_DStringAppend(resultPtr, p, length); + } + } + break; + + } + Tcl_DStringFree(&buffer); + return Tcl_DStringValue(resultPtr); +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_TranslateFileName -- + * + * Converts a file name into a form usable by the native system + * interfaces. If the name starts with a tilde, it will produce + * a name where the tilde and following characters have been + * replaced by the home directory location for the named user. + * + * Results: + * The result is a pointer to a static string containing + * the new name. If there was an error in processing the + * name, then an error message is left in interp->result + * and the return value is NULL. The result will be stored + * in bufferPtr; the caller must call Tcl_DStringFree(bufferPtr) + * to free the name if the return value was not NULL. + * + * Side effects: + * Information may be left in bufferPtr. + * + *---------------------------------------------------------------------- */ + +char * +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 indicate current user's home directory) + * or "~<user>" (to indicate any user's + * home directory). */ + Tcl_DString *bufferPtr; /* May be used to hold result. Must not hold + * anything at the time of the call, and need + * not even be initialized. */ +{ + register char *p; + + /* + * Handle tilde substitutions, if needed. + */ + + if (name[0] == '~') { + int argc, length; + char **argv; + Tcl_DString temp; + + Tcl_SplitPath(name, &argc, &argv); + + /* + * Strip the trailing ':' off of a Mac path + * before passing the user name to DoTildeSubst. + */ + + 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; + } + Tcl_DStringInit(bufferPtr); + Tcl_JoinPath(argc, argv, bufferPtr); + Tcl_DStringFree(&temp); + ckfree((char*)argv); + } else { + Tcl_DStringInit(bufferPtr); + Tcl_JoinPath(1, &name, bufferPtr); + } + + /* + * Convert forward slashes to backslashes in Windows paths because + * some system interfaces don't accept forward slashes. + */ + + if (tclPlatform == TCL_PLATFORM_WINDOWS) { + for (p = Tcl_DStringValue(bufferPtr); *p != '\0'; p++) { + if (*p == '/') { + *p = '\\'; + } + } + } + return Tcl_DStringValue(bufferPtr); +} + +/* + *---------------------------------------------------------------------- + * + * TclGetExtension -- + * + * This function returns a pointer to the beginning of the + * extension part of a file name. + * + * Results: + * Returns a pointer into name which indicates where the extension + * starts. If there is no extension, returns NULL. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +char * +TclGetExtension(name) + char *name; /* File name to parse. */ +{ + char *p, *lastSep; + + /* + * First find the last directory separator. + */ + + lastSep = NULL; /* Needed only to prevent gcc warnings. */ + switch (tclPlatform) { + case TCL_PLATFORM_UNIX: + lastSep = strrchr(name, '/'); + break; + + case TCL_PLATFORM_MAC: + if (strchr(name, ':') == NULL) { + lastSep = strrchr(name, '/'); + } else { + lastSep = strrchr(name, ':'); + } + break; + + case TCL_PLATFORM_WINDOWS: + lastSep = NULL; + for (p = name; *p != '\0'; p++) { + if (strchr("/\\:", *p) != NULL) { + lastSep = p; + } + } + break; + } + p = strrchr(name, '.'); + if ((p != NULL) && (lastSep != NULL) + && (lastSep > p)) { + p = NULL; + } + return p; +} + +/* + *---------------------------------------------------------------------- + * + * DoTildeSubst -- + * + * Given a string following a tilde, this routine returns the + * corresponding home directory. + * + * Results: + * The result is a pointer to a static string containing the home + * directory in native format. If there was an error in processing + * the substitution, then an error message is left in interp->result + * and the return value is NULL. On success, the results are appended + * to resultPtr, and the contents of resultPtr are returned. + * + * Side effects: + * Information may be left in resultPtr. + * + *---------------------------------------------------------------------- + */ + +static char * +DoTildeSubst(interp, user, resultPtr) + Tcl_Interp *interp; /* Interpreter in which to store error + * message (if necessary). */ + char *user; /* Name of user whose home directory should be + * substituted, or "" for current user. */ + Tcl_DString *resultPtr; /* May be used to hold result. Must not hold + * anything at the time of the call, and need + * not even be initialized. */ +{ + char *dir; + + if (*user == '\0') { + dir = TclGetEnv("HOME"); + if (dir == NULL) { + if (interp) { + Tcl_ResetResult(interp); + Tcl_AppendResult(interp, "couldn't find HOME environment ", + "variable to expand path", (char *) NULL); + } + return NULL; + } + Tcl_JoinPath(1, &dir, resultPtr); + } else { + if (TclGetUserHome(user, resultPtr) == NULL) { + if (interp) { + Tcl_ResetResult(interp); + Tcl_AppendResult(interp, "user \"", user, "\" doesn't exist", + (char *) NULL); + } + return NULL; + } + } + return resultPtr->string; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_GlobCmd -- + * + * This procedure is invoked to process the "glob" Tcl command. + * See the user documentation for details on what it does. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * See the user documentation. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +int +Tcl_GlobCmd(dummy, interp, argc, argv) + ClientData dummy; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ + int i, noComplain, firstArg; + char c; + int result = TCL_OK; + Tcl_DString buffer; + char *separators, *head, *tail; + + noComplain = 0; + for (firstArg = 1; (firstArg < argc) && (argv[firstArg][0] == '-'); + firstArg++) { + if (strcmp(argv[firstArg], "-nocomplain") == 0) { + noComplain = 1; + } else if (strcmp(argv[firstArg], "--") == 0) { + firstArg++; + break; + } else { + Tcl_AppendResult(interp, "bad switch \"", argv[firstArg], + "\": must be -nocomplain or --", (char *) NULL); + return TCL_ERROR; + } + } + if (firstArg >= argc) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " ?switches? name ?name ...?\"", (char *) NULL); + return TCL_ERROR; + } + + Tcl_DStringInit(&buffer); + separators = NULL; /* Needed only to prevent gcc warnings. */ + for (i = firstArg; i < argc; i++) { + head = tail = ""; + + switch (tclPlatform) { + case TCL_PLATFORM_UNIX: + separators = "/"; + break; + case TCL_PLATFORM_WINDOWS: + separators = "/\\:"; + break; + case TCL_PLATFORM_MAC: + separators = (strchr(argv[i], ':') == NULL) ? "/" : ":"; + break; + } + + Tcl_DStringSetLength(&buffer, 0); + + /* + * Perform tilde substitution, if needed. + */ + + if (argv[i][0] == '~') { + char *p; + + /* + * Find the first path separator after the tilde. + */ + + for (tail = argv[i]; *tail != '\0'; tail++) { + if (*tail == '\\') { + if (strchr(separators, tail[1]) != NULL) { + break; + } + } else if (strchr(separators, *tail) != NULL) { + break; + } + } + + /* + * Determine the home directory for the specified user. Note that + * we don't allow special characters in the user name. + */ + + c = *tail; + *tail = '\0'; + p = strpbrk(argv[i]+1, "\\[]*?{}"); + if (p == NULL) { + head = DoTildeSubst(interp, argv[i]+1, &buffer); + } else { + if (!noComplain) { + Tcl_ResetResult(interp); + Tcl_AppendResult(interp, "globbing characters not ", + "supported in user names", (char *) NULL); + } + head = NULL; + } + *tail = c; + if (head == NULL) { + if (noComplain) { + Tcl_ResetResult(interp); + continue; + } else { + result = TCL_ERROR; + goto done; + } + } + if (head != Tcl_DStringValue(&buffer)) { + Tcl_DStringAppend(&buffer, head, -1); + } + } else { + tail = argv[i]; + } + + result = TclDoGlob(interp, separators, &buffer, tail); + if (result != TCL_OK) { + if (noComplain) { + Tcl_ResetResult(interp); + continue; + } else { + goto done; + } + } + } + + if ((*interp->result == 0) && !noComplain) { + char *sep = ""; + + Tcl_AppendResult(interp, "no files matched glob pattern", + (argc == 2) ? " \"" : "s \"", (char *) NULL); + for (i = firstArg; i < argc; i++) { + Tcl_AppendResult(interp, sep, argv[i], (char *) NULL); + sep = " "; + } + Tcl_AppendResult(interp, "\"", (char *) NULL); + result = TCL_ERROR; + } +done: + Tcl_DStringFree(&buffer); + return result; +} + +/* + *---------------------------------------------------------------------- + * + * SkipToChar -- + * + * This function traverses a glob pattern looking for the next + * unquoted occurance of the specified character at the same braces + * nesting level. + * + * Results: + * Updates stringPtr to point to the matching character, or to + * the end of the string if nothing matched. The return value + * is 1 if a match was found at the top level, otherwise it is 0. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static int +SkipToChar(stringPtr, match) + char **stringPtr; /* Pointer string to check. */ + char *match; /* Pointer to character to find. */ +{ + int quoted, level; + register char *p; + + quoted = 0; + level = 0; + + for (p = *stringPtr; *p != '\0'; p++) { + if (quoted) { + quoted = 0; + continue; + } + if ((level == 0) && (*p == *match)) { + *stringPtr = p; + return 1; + } + if (*p == '{') { + level++; + } else if (*p == '}') { + level--; + } else if (*p == '\\') { + quoted = 1; + } + } + *stringPtr = p; + return 0; +} + +/* + *---------------------------------------------------------------------- + * + * TclDoGlob -- + * + * This recursive procedure forms the heart of the globbing + * code. It performs a depth-first traversal of the tree + * given by the path name to be globbed. The directory and + * remainder are assumed to be native format paths. + * + * Results: + * The return value is a standard Tcl result indicating whether + * an error occurred in globbing. After a normal return the + * result in interp will be set to hold all of the file names + * given by the dir and rem arguments. After an error the + * result in interp will hold an error message. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +int +TclDoGlob(interp, separators, headPtr, tail) + Tcl_Interp *interp; /* Interpreter to use for error reporting + * (e.g. unmatched brace). */ + char *separators; /* String containing separator characters + * that should be used to identify globbing + * boundaries. */ + Tcl_DString *headPtr; /* Completely expanded prefix. */ + char *tail; /* The unexpanded remainder of the path. */ +{ + int level, baseLength, quoted, count; + int result = TCL_OK; + char *p, *openBrace, *closeBrace, *name, savedChar; + char lastChar = 0; + int length = Tcl_DStringLength(headPtr); + + if (length > 0) { + lastChar = Tcl_DStringValue(headPtr)[length-1]; + } + + /* + * Consume any leading directory separators, leaving tail pointing + * just past the last initial separator. + */ + + count = 0; + name = tail; + for (; *tail != '\0'; tail++) { + if ((*tail == '\\') && (strchr(separators, tail[1]) != NULL)) { + tail++; + } else if (strchr(separators, *tail) == NULL) { + break; + } + count++; + } + + /* + * Deal with path separators. On the Mac, we have to watch out + * for multiple separators, since they are special in Mac-style + * paths. + */ + + switch (tclPlatform) { + case TCL_PLATFORM_MAC: + if (*separators == '/') { + if (((length == 0) && (count == 0)) + || ((length > 0) && (lastChar != ':'))) { + Tcl_DStringAppend(headPtr, ":", 1); + } + } else { + if (count == 0) { + if ((length > 0) && (lastChar != ':')) { + Tcl_DStringAppend(headPtr, ":", 1); + } + } else { + if (lastChar == ':') { + count--; + } + while (count-- > 0) { + Tcl_DStringAppend(headPtr, ":", 1); + } + } + } + break; + case TCL_PLATFORM_WINDOWS: + /* + * If this is a drive relative path, add the colon and the + * trailing slash if needed. Otherwise add the slash if + * this is the first absolute element, or a later relative + * element. Add an extra slash if this is a UNC path. + */ + + if (*name == ':') { + Tcl_DStringAppend(headPtr, ":", 1); + if (count > 1) { + Tcl_DStringAppend(headPtr, "/", 1); + } + } else if ((*tail != '\0') + && (((length > 0) + && (strchr(separators, lastChar) == NULL)) + || ((length == 0) && (count > 0)))) { + Tcl_DStringAppend(headPtr, "/", 1); + if ((length == 0) && (count > 1)) { + Tcl_DStringAppend(headPtr, "/", 1); + } + } + + break; + case TCL_PLATFORM_UNIX: + /* + * Add a separator if this is the first absolute element, or + * a later relative element. + */ + + if ((*tail != '\0') + && (((length > 0) + && (strchr(separators, lastChar) == NULL)) + || ((length == 0) && (count > 0)))) { + Tcl_DStringAppend(headPtr, "/", 1); + } + break; + } + + /* + * Look for the first matching pair of braces or the first + * directory separator that is not inside a pair of braces. + */ + + openBrace = closeBrace = NULL; + level = 0; + quoted = 0; + for (p = tail; *p != '\0'; p++) { + if (quoted) { + quoted = 0; + } else if (*p == '\\') { + quoted = 1; + if (strchr(separators, p[1]) != NULL) { + break; /* Quoted directory separator. */ + } + } else if (strchr(separators, *p) != NULL) { + break; /* Unquoted directory separator. */ + } else if (*p == '{') { + openBrace = p; + p++; + if (SkipToChar(&p, "}")) { + closeBrace = p; /* Balanced braces. */ + break; + } + Tcl_ResetResult(interp); + interp->result = "unmatched open-brace in file name"; + return TCL_ERROR; + } else if (*p == '}') { + Tcl_ResetResult(interp); + interp->result = "unmatched close-brace in file name"; + return TCL_ERROR; + } + } + + /* + * Substitute the alternate patterns from the braces and recurse. + */ + + if (openBrace != NULL) { + char *element; + Tcl_DString newName; + Tcl_DStringInit(&newName); + + /* + * For each element within in the outermost pair of braces, + * append the element and the remainder to the fixed portion + * before the first brace and recursively call TclDoGlob. + */ + + Tcl_DStringAppend(&newName, tail, openBrace-tail); + baseLength = Tcl_DStringLength(&newName); + length = Tcl_DStringLength(headPtr); + *closeBrace = '\0'; + for (p = openBrace; p != closeBrace; ) { + p++; + element = p; + SkipToChar(&p, ","); + Tcl_DStringSetLength(headPtr, length); + Tcl_DStringSetLength(&newName, baseLength); + Tcl_DStringAppend(&newName, element, p-element); + Tcl_DStringAppend(&newName, closeBrace+1, -1); + result = TclDoGlob(interp, separators, + headPtr, Tcl_DStringValue(&newName)); + if (result != TCL_OK) { + break; + } + } + *closeBrace = '}'; + Tcl_DStringFree(&newName); + return result; + } + + /* + * At this point, there are no more brace substitutions to perform on + * this path component. The variable p is pointing at a quoted or + * unquoted directory separator or the end of the string. So we need + * to check for special globbing characters in the current pattern. + */ + + savedChar = *p; + *p = '\0'; + + if (strpbrk(tail, "*[]?\\") != NULL) { + *p = savedChar; + /* + * 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->result, or call TclDoGlob if there + * are more characters to be processed. + */ + + return TclMatchFiles(interp, separators, headPtr, tail, p); + } + *p = savedChar; + Tcl_DStringAppend(headPtr, tail, p-tail); + if (*p != '\0') { + return TclDoGlob(interp, separators, headPtr, p); + } + + /* + * 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. + */ + + switch (tclPlatform) { + case TCL_PLATFORM_MAC: + if (strchr(Tcl_DStringValue(headPtr), ':') == NULL) { + Tcl_DStringAppend(headPtr, ":", 1); + } + name = Tcl_DStringValue(headPtr); + if (access(name, F_OK) == 0) { + if ((name[1] != '\0') && (strchr(name+1, ':') == NULL)) { + Tcl_AppendElement(interp, name+1); + } else { + Tcl_AppendElement(interp, name); + } + } + break; + case TCL_PLATFORM_WINDOWS: { + int exists; + /* + * 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); + } + } else { + for (p = Tcl_DStringValue(headPtr); *p != '\0'; p++) { + if (*p == '/') { + *p = '\\'; + } + } + } + name = Tcl_DStringValue(headPtr); + exists = (access(name, F_OK) == 0); + for (p = name; *p != '\0'; p++) { + if (*p == '\\') { + *p = '/'; + } + } + if (exists) { + Tcl_AppendElement(interp, name); + } + 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 (access(name, F_OK) == 0) { + Tcl_AppendElement(interp, name); + } + break; + } + + return TCL_OK; +} diff --git a/contrib/tcl/generic/tclGet.c b/contrib/tcl/generic/tclGet.c new file mode 100644 index 0000000..9e208b9 --- /dev/null +++ b/contrib/tcl/generic/tclGet.c @@ -0,0 +1,232 @@ +/* + * tclGet.c -- + * + * This file contains procedures to convert strings into + * other forms, like integers or floating-point numbers or + * booleans, doing syntax checking along the way. + * + * Copyright (c) 1990-1993 The Regents of the University of California. + * Copyright (c) 1994-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: @(#) tclGet.c 1.24 96/02/15 11:42:47 + */ + +#include "tclInt.h" +#include "tclPort.h" + + +/* + *---------------------------------------------------------------------- + * + * Tcl_GetInt -- + * + * Given a string, produce the corresponding integer value. + * + * Results: + * The return value is normally TCL_OK; in this case *intPtr + * will be set to the integer value equivalent to string. If + * string is improperly formed then TCL_ERROR is returned and + * an error message will be left in interp->result. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_GetInt(interp, string, intPtr) + Tcl_Interp *interp; /* Interpreter to use for error reporting. */ + char *string; /* String containing a (possibly signed) + * integer in a form acceptable to strtol. */ + int *intPtr; /* Place to store converted result. */ +{ + char *end, *p; + int i; + + /* + * 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. + */ + + errno = 0; + for (p = string; isspace(UCHAR(*p)); p++) { + /* Empty loop body. */ + } + if (*p == '-') { + p++; + i = -(int)strtoul(p, &end, 0); + } else if (*p == '+') { + p++; + i = strtoul(p, &end, 0); + } else { + i = strtoul(p, &end, 0); + } + if (end == p) { + badInteger: + if (interp != (Tcl_Interp *) NULL) { + Tcl_AppendResult(interp, "expected integer but got \"", string, + "\"", (char *) NULL); + } + return TCL_ERROR; + } + if (errno == ERANGE) { + if (interp != (Tcl_Interp *) NULL) { + interp->result = "integer value too large to represent"; + Tcl_SetErrorCode(interp, "ARITH", "IOVERFLOW", + interp->result, (char *) NULL); + } + return TCL_ERROR; + } + while ((*end != '\0') && isspace(UCHAR(*end))) { + end++; + } + if (*end != 0) { + goto badInteger; + } + *intPtr = i; + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_GetDouble -- + * + * Given a string, produce the corresponding double-precision + * floating-point value. + * + * Results: + * The return value is normally TCL_OK; in this case *doublePtr + * will be set to the double-precision value equivalent to string. + * If string is improperly formed then TCL_ERROR is returned and + * an error message will be left in interp->result. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_GetDouble(interp, string, doublePtr) + Tcl_Interp *interp; /* Interpreter to use for error reporting. */ + char *string; /* String containing a floating-point number + * in a form acceptable to strtod. */ + double *doublePtr; /* Place to store converted result. */ +{ + char *end; + double d; + + errno = 0; + d = strtod(string, &end); + if (end == string) { + badDouble: + if (interp != (Tcl_Interp *) NULL) { + Tcl_AppendResult(interp, + "expected floating-point number but got \"", + string, "\"", (char *) NULL); + } + return TCL_ERROR; + } + if (errno != 0) { + if (interp != (Tcl_Interp *) NULL) { + TclExprFloatError(interp, d); + } + return TCL_ERROR; + } + while ((*end != 0) && isspace(UCHAR(*end))) { + end++; + } + if (*end != 0) { + goto badDouble; + } + *doublePtr = d; + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_GetBoolean -- + * + * Given a string, return a 0/1 boolean value corresponding + * to the string. + * + * Results: + * The return value is normally TCL_OK; in this case *boolPtr + * will be set to the 0/1 value equivalent to string. If + * string is improperly formed then TCL_ERROR is returned and + * an error message will be left in interp->result. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_GetBoolean(interp, string, boolPtr) + Tcl_Interp *interp; /* Interpreter to use for error reporting. */ + 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 + * will be 0 or 1. */ +{ + int i; + char lowerCase[10], c; + size_t length; + + /* + * Convert the input string to all lower-case. + */ + + for (i = 0; i < 9; i++) { + c = string[i]; + if (c == 0) { + break; + } + if ((c >= 'A') && (c <= 'Z')) { + c += (char) ('a' - 'A'); + } + lowerCase[i] = c; + } + lowerCase[i] = 0; + + length = strlen(lowerCase); + c = lowerCase[0]; + if ((c == '0') && (lowerCase[1] == '\0')) { + *boolPtr = 0; + } else if ((c == '1') && (lowerCase[1] == '\0')) { + *boolPtr = 1; + } else if ((c == 'y') && (strncmp(lowerCase, "yes", length) == 0)) { + *boolPtr = 1; + } else if ((c == 'n') && (strncmp(lowerCase, "no", length) == 0)) { + *boolPtr = 0; + } else if ((c == 't') && (strncmp(lowerCase, "true", length) == 0)) { + *boolPtr = 1; + } else if ((c == 'f') && (strncmp(lowerCase, "false", length) == 0)) { + *boolPtr = 0; + } else if ((c == 'o') && (length >= 2)) { + if (strncmp(lowerCase, "on", length) == 0) { + *boolPtr = 1; + } else if (strncmp(lowerCase, "off", length) == 0) { + *boolPtr = 0; + } else { + goto badBoolean; + } + } else { + badBoolean: + if (interp != (Tcl_Interp *) NULL) { + Tcl_AppendResult(interp, "expected boolean value but got \"", + string, "\"", (char *) NULL); + } + return TCL_ERROR; + } + return TCL_OK; +} diff --git a/contrib/tcl/generic/tclGetDate.y b/contrib/tcl/generic/tclGetDate.y new file mode 100644 index 0000000..89a678e --- /dev/null +++ b/contrib/tcl/generic/tclGetDate.y @@ -0,0 +1,937 @@ +/* + * tclGetdate.y -- + * + * Contains yacc grammar for parsing date and time strings + * based on getdate.y. + * + * Copyright (c) 1992-1995 Karl Lehenbauer and Mark Diekhans. + * Copyright (c) 1995-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: @(#) tclGetDate.y 1.25 96/02/15 20:04:06 + */ + +%{ +/* + * tclGetdate.c -- + * + * This file is generated from a yacc grammar defined in + * the file tclGetdate.y + * + * Copyright (c) 1992-1995 Karl Lehenbauer and Mark Diekhans. + * Copyright (c) 1995-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. + * + * SCCSID + */ + +#include "tclInt.h" +#include "tclPort.h" + +#ifdef MAC_TCL +# define EPOCH 1904 +# define START_OF_TIME 1904 +# define END_OF_TIME 2039 +#else +# define EPOCH 1970 +# define START_OF_TIME 1902 +# define END_OF_TIME 2037 + +extern struct tm *localtime(); +#endif + +#define HOUR(x) ((int) (60 * x)) +#define SECSPERDAY (24L * 60L * 60L) + + +/* + * An entry in the lexical lookup table. + */ +typedef struct _TABLE { + char *name; + int type; + time_t value; +} TABLE; + + +/* + * Daylight-savings mode: on, off, or not yet known. + */ +typedef enum _DSTMODE { + DSTon, DSToff, DSTmaybe +} DSTMODE; + +/* + * Meridian: am, pm, or 24-hour style. + */ +typedef enum _MERIDIAN { + MERam, MERpm, MER24 +} MERIDIAN; + + +/* + * Global variables. We could get rid of most of these by using a good + * union as the yacc stack. (This routine was originally written before + * yacc had the %union construct.) Maybe someday; right now we only use + * the %union very rarely. + */ +static char *yyInput; +static DSTMODE yyDSTmode; +static time_t yyDayOrdinal; +static time_t yyDayNumber; +static int yyHaveDate; +static int yyHaveDay; +static int yyHaveRel; +static int yyHaveTime; +static int yyHaveZone; +static time_t yyTimezone; +static time_t yyDay; +static time_t yyHour; +static time_t yyMinutes; +static time_t yyMonth; +static time_t yySeconds; +static time_t yyYear; +static MERIDIAN yyMeridian; +static time_t yyRelMonth; +static time_t yyRelSeconds; + + +/* + * Prototypes of internal functions. + */ +static void +yyerror _ANSI_ARGS_((char *s)); + +static time_t +ToSeconds _ANSI_ARGS_((time_t Hours, + time_t Minutes, + time_t Seconds, + MERIDIAN Meridian)); + +static int +Convert _ANSI_ARGS_((time_t Month, + time_t Day, + time_t Year, + time_t Hours, + time_t Minutes, + time_t Seconds, + MERIDIAN Meridia, + DSTMODE DSTmode, + time_t *TimePtr)); + +static time_t +DSTcorrect _ANSI_ARGS_((time_t Start, + time_t Future)); + +static time_t +RelativeDate _ANSI_ARGS_((time_t Start, + time_t DayOrdinal, + time_t DayNumber)); + +static int +RelativeMonth _ANSI_ARGS_((time_t Start, + time_t RelMonth, + time_t *TimePtr)); +static int +LookupWord _ANSI_ARGS_((char *buff)); + +static int +yylex _ANSI_ARGS_((void)); + +int +yyparse _ANSI_ARGS_((void)); +%} + +%union { + time_t Number; + enum _MERIDIAN Meridian; +} + +%token tAGO tDAY tDAYZONE tID tMERIDIAN tMINUTE_UNIT tMONTH tMONTH_UNIT +%token tSEC_UNIT tSNUMBER tUNUMBER tZONE tEPOCH tDST + +%type <Number> tDAY tDAYZONE tMINUTE_UNIT tMONTH tMONTH_UNIT tDST +%type <Number> tSEC_UNIT tSNUMBER tUNUMBER tZONE +%type <Meridian> tMERIDIAN o_merid + +%% + +spec : /* NULL */ + | spec item + ; + +item : time { + yyHaveTime++; + } + | zone { + yyHaveZone++; + } + | date { + yyHaveDate++; + } + | day { + yyHaveDay++; + } + | rel { + yyHaveRel++; + } + | number + ; + +time : tUNUMBER tMERIDIAN { + yyHour = $1; + yyMinutes = 0; + yySeconds = 0; + yyMeridian = $2; + } + | tUNUMBER ':' tUNUMBER o_merid { + yyHour = $1; + yyMinutes = $3; + yySeconds = 0; + yyMeridian = $4; + } + | tUNUMBER ':' tUNUMBER tSNUMBER { + yyHour = $1; + yyMinutes = $3; + yyMeridian = MER24; + yyDSTmode = DSToff; + yyTimezone = - ($4 % 100 + ($4 / 100) * 60); + } + | tUNUMBER ':' tUNUMBER ':' tUNUMBER o_merid { + yyHour = $1; + yyMinutes = $3; + yySeconds = $5; + yyMeridian = $6; + } + | tUNUMBER ':' tUNUMBER ':' tUNUMBER tSNUMBER { + yyHour = $1; + yyMinutes = $3; + yySeconds = $5; + yyMeridian = MER24; + yyDSTmode = DSToff; + yyTimezone = - ($6 % 100 + ($6 / 100) * 60); + } + ; + +zone : tZONE tDST { + yyTimezone = $1; + yyDSTmode = DSTon; + } + | tZONE { + yyTimezone = $1; + yyDSTmode = DSToff; + } + | tDAYZONE { + yyTimezone = $1; + yyDSTmode = DSTon; + } + ; + +day : tDAY { + yyDayOrdinal = 1; + yyDayNumber = $1; + } + | tDAY ',' { + yyDayOrdinal = 1; + yyDayNumber = $1; + } + | tUNUMBER tDAY { + yyDayOrdinal = $1; + yyDayNumber = $2; + } + ; + +date : tUNUMBER '/' tUNUMBER { + yyMonth = $1; + yyDay = $3; + } + | tUNUMBER '/' tUNUMBER '/' tUNUMBER { + yyMonth = $1; + yyDay = $3; + yyYear = $5; + } + | tMONTH tUNUMBER { + yyMonth = $1; + yyDay = $2; + } + | tMONTH tUNUMBER ',' tUNUMBER { + yyMonth = $1; + yyDay = $2; + yyYear = $4; + } + | tUNUMBER tMONTH { + yyMonth = $2; + yyDay = $1; + } + | tEPOCH { + yyMonth = 1; + yyDay = 1; + yyYear = EPOCH; + } + | tUNUMBER tMONTH tUNUMBER { + yyMonth = $2; + yyDay = $1; + yyYear = $3; + } + ; + +rel : relunit tAGO { + yyRelSeconds = -yyRelSeconds; + yyRelMonth = -yyRelMonth; + } + | relunit + ; + +relunit : tUNUMBER tMINUTE_UNIT { + yyRelSeconds += $1 * $2 * 60L; + } + | tSNUMBER tMINUTE_UNIT { + yyRelSeconds += $1 * $2 * 60L; + } + | tMINUTE_UNIT { + yyRelSeconds += $1 * 60L; + } + | tSNUMBER tSEC_UNIT { + yyRelSeconds += $1; + } + | tUNUMBER tSEC_UNIT { + yyRelSeconds += $1; + } + | tSEC_UNIT { + yyRelSeconds++; + } + | tSNUMBER tMONTH_UNIT { + yyRelMonth += $1 * $2; + } + | tUNUMBER tMONTH_UNIT { + yyRelMonth += $1 * $2; + } + | tMONTH_UNIT { + yyRelMonth += $1; + } + ; + +number : tUNUMBER { + if (yyHaveTime && yyHaveDate && !yyHaveRel) + yyYear = $1; + else { + yyHaveTime++; + if ($1 < 100) { + yyHour = $1; + yyMinutes = 0; + } + else { + yyHour = $1 / 100; + yyMinutes = $1 % 100; + } + yySeconds = 0; + yyMeridian = MER24; + } + } + ; + +o_merid : /* NULL */ { + $$ = MER24; + } + | tMERIDIAN { + $$ = $1; + } + ; + +%% + +/* + * Month and day table. + */ +static TABLE MonthDayTable[] = { + { "january", tMONTH, 1 }, + { "february", tMONTH, 2 }, + { "march", tMONTH, 3 }, + { "april", tMONTH, 4 }, + { "may", tMONTH, 5 }, + { "june", tMONTH, 6 }, + { "july", tMONTH, 7 }, + { "august", tMONTH, 8 }, + { "september", tMONTH, 9 }, + { "sept", tMONTH, 9 }, + { "october", tMONTH, 10 }, + { "november", tMONTH, 11 }, + { "december", tMONTH, 12 }, + { "sunday", tDAY, 0 }, + { "monday", tDAY, 1 }, + { "tuesday", tDAY, 2 }, + { "tues", tDAY, 2 }, + { "wednesday", tDAY, 3 }, + { "wednes", tDAY, 3 }, + { "thursday", tDAY, 4 }, + { "thur", tDAY, 4 }, + { "thurs", tDAY, 4 }, + { "friday", tDAY, 5 }, + { "saturday", tDAY, 6 }, + { NULL } +}; + +/* + * Time units table. + */ +static TABLE UnitsTable[] = { + { "year", tMONTH_UNIT, 12 }, + { "month", tMONTH_UNIT, 1 }, + { "fortnight", tMINUTE_UNIT, 14 * 24 * 60 }, + { "week", tMINUTE_UNIT, 7 * 24 * 60 }, + { "day", tMINUTE_UNIT, 1 * 24 * 60 }, + { "hour", tMINUTE_UNIT, 60 }, + { "minute", tMINUTE_UNIT, 1 }, + { "min", tMINUTE_UNIT, 1 }, + { "second", tSEC_UNIT, 1 }, + { "sec", tSEC_UNIT, 1 }, + { NULL } +}; + +/* + * Assorted relative-time words. + */ +static TABLE OtherTable[] = { + { "tomorrow", tMINUTE_UNIT, 1 * 24 * 60 }, + { "yesterday", tMINUTE_UNIT, -1 * 24 * 60 }, + { "today", tMINUTE_UNIT, 0 }, + { "now", tMINUTE_UNIT, 0 }, + { "last", tUNUMBER, -1 }, + { "this", tMINUTE_UNIT, 0 }, + { "next", tUNUMBER, 2 }, +#if 0 + { "first", tUNUMBER, 1 }, +/* { "second", tUNUMBER, 2 }, */ + { "third", tUNUMBER, 3 }, + { "fourth", tUNUMBER, 4 }, + { "fifth", tUNUMBER, 5 }, + { "sixth", tUNUMBER, 6 }, + { "seventh", tUNUMBER, 7 }, + { "eighth", tUNUMBER, 8 }, + { "ninth", tUNUMBER, 9 }, + { "tenth", tUNUMBER, 10 }, + { "eleventh", tUNUMBER, 11 }, + { "twelfth", tUNUMBER, 12 }, +#endif + { "ago", tAGO, 1 }, + { "epoch", tEPOCH, 0 }, + { NULL } +}; + +/* + * The timezone table. (Note: This table was modified to not use any floating + * point constants to work around an SGI compiler bug). + */ +static TABLE TimezoneTable[] = { + { "gmt", tZONE, HOUR( 0) }, /* Greenwich Mean */ + { "ut", tZONE, HOUR( 0) }, /* Universal (Coordinated) */ + { "utc", tZONE, HOUR( 0) }, + { "wet", tZONE, HOUR( 0) } , /* Western European */ + { "bst", tDAYZONE, HOUR( 0) }, /* British Summer */ + { "wat", tZONE, HOUR( 1) }, /* West Africa */ + { "at", tZONE, HOUR( 2) }, /* Azores */ +#if 0 + /* For completeness. BST is also British Summer, and GST is + * also Guam Standard. */ + { "bst", tZONE, HOUR( 3) }, /* Brazil Standard */ + { "gst", tZONE, HOUR( 3) }, /* Greenland Standard */ +#endif + { "nft", tZONE, HOUR( 7/2) }, /* Newfoundland */ + { "nst", tZONE, HOUR( 7/2) }, /* Newfoundland Standard */ + { "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 */ + { "cat", tZONE, HOUR(10) }, /* Central Alaska */ + { "ahst", tZONE, HOUR(10) }, /* Alaska-Hawaii Standard */ + { "nt", tZONE, HOUR(11) }, /* Nome */ + { "idlw", tZONE, HOUR(12) }, /* International Date Line West */ + { "cet", tZONE, -HOUR( 1) }, /* Central European */ + { "met", tZONE, -HOUR( 1) }, /* Middle European */ + { "mewt", tZONE, -HOUR( 1) }, /* Middle European Winter */ + { "mest", tDAYZONE, -HOUR( 1) }, /* Middle European Summer */ + { "swt", tZONE, -HOUR( 1) }, /* Swedish Winter */ + { "sst", tDAYZONE, -HOUR( 1) }, /* Swedish Summer */ + { "fwt", tZONE, -HOUR( 1) }, /* French Winter */ + { "fst", tDAYZONE, -HOUR( 1) }, /* French Summer */ + { "eet", tZONE, -HOUR( 2) }, /* Eastern Europe, USSR Zone 1 */ + { "bt", tZONE, -HOUR( 3) }, /* Baghdad, USSR Zone 2 */ + { "it", tZONE, -HOUR( 7/2) }, /* Iran */ + { "zp4", tZONE, -HOUR( 4) }, /* USSR Zone 3 */ + { "zp5", tZONE, -HOUR( 5) }, /* USSR Zone 4 */ + { "ist", tZONE, -HOUR(11/2) }, /* Indian Standard */ + { "zp6", tZONE, -HOUR( 6) }, /* USSR Zone 5 */ +#if 0 + /* For completeness. NST is also Newfoundland Stanard, nad SST is + * also Swedish Summer. */ + { "nst", tZONE, -HOUR(13/2) }, /* North Sumatra */ + { "sst", tZONE, -HOUR( 7) }, /* South Sumatra, USSR Zone 6 */ +#endif /* 0 */ + { "wast", tZONE, -HOUR( 7) }, /* West Australian Standard */ + { "wadt", tDAYZONE, -HOUR( 7) }, /* West Australian Daylight */ + { "jt", tZONE, -HOUR(15/2) }, /* Java (3pm in Cronusland!) */ + { "cct", tZONE, -HOUR( 8) }, /* China Coast, USSR Zone 7 */ + { "jst", tZONE, -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 */ + { "gst", tZONE, -HOUR(10) }, /* Guam Standard, USSR Zone 9 */ + { "nzt", tZONE, -HOUR(12) }, /* New Zealand */ + { "nzst", tZONE, -HOUR(12) }, /* New Zealand Standard */ + { "nzdt", tDAYZONE, -HOUR(12) }, /* New Zealand Daylight */ + { "idle", tZONE, -HOUR(12) }, /* International Date Line East */ + /* ADDED BY Marco Nijdam */ + { "dst", tDST, HOUR( 0) }, /* DST on (hour is ignored) */ + /* End ADDED */ + { NULL } +}; + +/* + * Military timezone table. + */ +static TABLE MilitaryTable[] = { + { "a", tZONE, HOUR( 1) }, + { "b", tZONE, HOUR( 2) }, + { "c", tZONE, HOUR( 3) }, + { "d", tZONE, HOUR( 4) }, + { "e", tZONE, HOUR( 5) }, + { "f", tZONE, HOUR( 6) }, + { "g", tZONE, HOUR( 7) }, + { "h", tZONE, HOUR( 8) }, + { "i", tZONE, HOUR( 9) }, + { "k", tZONE, HOUR( 10) }, + { "l", tZONE, HOUR( 11) }, + { "m", tZONE, HOUR( 12) }, + { "n", tZONE, HOUR(- 1) }, + { "o", tZONE, HOUR(- 2) }, + { "p", tZONE, HOUR(- 3) }, + { "q", tZONE, HOUR(- 4) }, + { "r", tZONE, HOUR(- 5) }, + { "s", tZONE, HOUR(- 6) }, + { "t", tZONE, HOUR(- 7) }, + { "u", tZONE, HOUR(- 8) }, + { "v", tZONE, HOUR(- 9) }, + { "w", tZONE, HOUR(-10) }, + { "x", tZONE, HOUR(-11) }, + { "y", tZONE, HOUR(-12) }, + { "z", tZONE, HOUR( 0) }, + { NULL } +}; + + +/* + * Dump error messages in the bit bucket. + */ +static void +yyerror(s) + char *s; +{ +} + + +static time_t +ToSeconds(Hours, Minutes, Seconds, Meridian) + time_t Hours; + time_t Minutes; + time_t Seconds; + MERIDIAN Meridian; +{ + if (Minutes < 0 || Minutes > 59 || Seconds < 0 || Seconds > 59) + return -1; + switch (Meridian) { + case MER24: + if (Hours < 0 || Hours > 23) + return -1; + return (Hours * 60L + Minutes) * 60L + Seconds; + case MERam: + if (Hours < 1 || Hours > 12) + return -1; + return ((Hours % 12) * 60L + Minutes) * 60L + Seconds; + case MERpm: + if (Hours < 1 || Hours > 12) + return -1; + return (((Hours % 12) + 12) * 60L + Minutes) * 60L + Seconds; + } + return -1; /* Should never be reached */ +} + + +static int +Convert(Month, Day, Year, Hours, Minutes, Seconds, Meridian, DSTmode, TimePtr) + time_t Month; + time_t Day; + time_t Year; + time_t Hours; + time_t Minutes; + time_t Seconds; + MERIDIAN Meridian; + DSTMODE DSTmode; + time_t *TimePtr; +{ + static int DaysInMonth[12] = { + 31, 0, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31 + }; + time_t tod; + time_t Julian; + int i; + + if (Year < 0) + Year = -Year; + if (Year < 100) + Year += 1900; + DaysInMonth[1] = Year % 4 == 0 && (Year % 100 != 0 || Year % 400 == 0) + ? 29 : 28; + if (Month < 1 || Month > 12 + || Year < START_OF_TIME || Year > END_OF_TIME + || Day < 1 || Day > DaysInMonth[(int)--Month]) + return -1; + + for (Julian = Day - 1, i = 0; i < Month; i++) + Julian += DaysInMonth[i]; + if (Year >= EPOCH) { + for (i = EPOCH; i < Year; i++) + Julian += 365 + (i % 4 == 0); + } else { + for (i = Year; i < EPOCH; i++) + Julian -= 365 + (i % 4 == 0); + } + Julian *= SECSPERDAY; + Julian += yyTimezone * 60L; + if ((tod = ToSeconds(Hours, Minutes, Seconds, Meridian)) < 0) + return -1; + Julian += tod; + if (DSTmode == DSTon + || (DSTmode == DSTmaybe && localtime(&Julian)->tm_isdst)) + Julian -= 60 * 60; + *TimePtr = Julian; + return 0; +} + + +static time_t +DSTcorrect(Start, Future) + time_t Start; + time_t Future; +{ + time_t StartDay; + time_t FutureDay; + + StartDay = (localtime(&Start)->tm_hour + 1) % 24; + FutureDay = (localtime(&Future)->tm_hour + 1) % 24; + return (Future - Start) + (StartDay - FutureDay) * 60L * 60L; +} + + +static time_t +RelativeDate(Start, DayOrdinal, DayNumber) + time_t Start; + time_t DayOrdinal; + time_t DayNumber; +{ + struct tm *tm; + time_t now; + + now = Start; + tm = localtime(&now); + now += SECSPERDAY * ((DayNumber - tm->tm_wday + 7) % 7); + now += 7 * SECSPERDAY * (DayOrdinal <= 0 ? DayOrdinal : DayOrdinal - 1); + return DSTcorrect(Start, now); +} + + +static int +RelativeMonth(Start, RelMonth, TimePtr) + time_t Start; + time_t RelMonth; + time_t *TimePtr; +{ + struct tm *tm; + time_t Month; + time_t Year; + time_t Julian; + + if (RelMonth == 0) { + *TimePtr = 0; + return 0; + } + tm = localtime(&Start); + Month = 12 * tm->tm_year + tm->tm_mon + RelMonth; + Year = Month / 12; + Month = Month % 12 + 1; + if (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) < 0) + return -1; + *TimePtr = DSTcorrect(Start, Julian); + return 0; +} + + +static int +LookupWord(buff) + char *buff; +{ + register char *p; + register char *q; + register TABLE *tp; + int i; + int abbrev; + + /* + * Make it lowercase. + */ + for (p = buff; *p; p++) { + if (isupper(*p)) { + *p = (char) tolower(*p); + } + } + + if (strcmp(buff, "am") == 0 || strcmp(buff, "a.m.") == 0) { + yylval.Meridian = MERam; + return tMERIDIAN; + } + if (strcmp(buff, "pm") == 0 || strcmp(buff, "p.m.") == 0) { + yylval.Meridian = MERpm; + return tMERIDIAN; + } + + /* + * See if we have an abbreviation for a month. + */ + if (strlen(buff) == 3) { + abbrev = 1; + } else if (strlen(buff) == 4 && buff[3] == '.') { + abbrev = 1; + buff[3] = '\0'; + } else { + abbrev = 0; + } + + for (tp = MonthDayTable; tp->name; tp++) { + if (abbrev) { + if (strncmp(buff, tp->name, 3) == 0) { + yylval.Number = tp->value; + return tp->type; + } + } else if (strcmp(buff, tp->name) == 0) { + yylval.Number = tp->value; + return tp->type; + } + } + + for (tp = TimezoneTable; tp->name; tp++) { + if (strcmp(buff, tp->name) == 0) { + yylval.Number = tp->value; + return tp->type; + } + } + + for (tp = UnitsTable; tp->name; tp++) { + if (strcmp(buff, tp->name) == 0) { + yylval.Number = tp->value; + return tp->type; + } + } + + /* + * Strip off any plural and try the units table again. + */ + i = strlen(buff) - 1; + if (buff[i] == 's') { + buff[i] = '\0'; + for (tp = UnitsTable; tp->name; tp++) { + if (strcmp(buff, tp->name) == 0) { + yylval.Number = tp->value; + return tp->type; + } + } + } + + for (tp = OtherTable; tp->name; tp++) { + if (strcmp(buff, tp->name) == 0) { + yylval.Number = tp->value; + return tp->type; + } + } + + /* + * Military timezones. + */ + if (buff[1] == '\0' && isalpha(*buff)) { + for (tp = MilitaryTable; tp->name; tp++) { + if (strcmp(buff, tp->name) == 0) { + yylval.Number = tp->value; + return tp->type; + } + } + } + + /* + * Drop out any periods and try the timezone table again. + */ + for (i = 0, p = q = buff; *q; q++) + if (*q != '.') + *p++ = *q; + else + i++; + *p = '\0'; + if (i) + for (tp = TimezoneTable; tp->name; tp++) { + if (strcmp(buff, tp->name) == 0) { + yylval.Number = tp->value; + return tp->type; + } + } + + return tID; +} + + +static int +yylex() +{ + register char c; + register char *p; + char buff[20]; + int Count; + int sign; + + for ( ; ; ) { + while (isspace((unsigned char) (*yyInput))) { + yyInput++; + } + + if (isdigit(c = *yyInput) || c == '-' || c == '+') { + if (c == '-' || c == '+') { + sign = c == '-' ? -1 : 1; + if (!isdigit(*++yyInput)) { + /* + * skip the '-' sign + */ + continue; + } + } else { + sign = 0; + } + for (yylval.Number = 0; isdigit(c = *yyInput++); ) { + yylval.Number = 10 * yylval.Number + c - '0'; + } + yyInput--; + if (sign < 0) { + yylval.Number = -yylval.Number; + } + return sign ? tSNUMBER : tUNUMBER; + } + if (isalpha(c)) { + for (p = buff; isalpha(c = *yyInput++) || c == '.'; ) { + if (p < &buff[sizeof buff - 1]) { + *p++ = c; + } + } + *p = '\0'; + yyInput--; + return LookupWord(buff); + } + if (c != '(') { + return *yyInput++; + } + Count = 0; + do { + c = *yyInput++; + if (c == '\0') { + return c; + } else if (c == '(') { + Count++; + } else if (c == ')') { + Count--; + } + } while (Count > 0); + } +} + +/* + * Specify zone is of -50000 to force GMT. (This allows BST to work). + */ + +int +TclGetDate(p, now, zone, timePtr) + char *p; + unsigned long now; + long zone; + unsigned long *timePtr; +{ + struct tm *tm; + time_t Start; + time_t Time; + time_t tod; + + yyInput = p; + tm = localtime((time_t *) &now); + yyYear = tm->tm_year; + yyMonth = tm->tm_mon + 1; + yyDay = tm->tm_mday; + yyTimezone = zone; + if (zone == -50000) { + yyDSTmode = DSToff; /* assume GMT */ + yyTimezone = 0; + } else { + yyDSTmode = DSTmaybe; + } + yyHour = 0; + yyMinutes = 0; + yySeconds = 0; + yyMeridian = MER24; + yyRelSeconds = 0; + yyRelMonth = 0; + yyHaveDate = 0; + yyHaveDay = 0; + yyHaveRel = 0; + yyHaveTime = 0; + yyHaveZone = 0; + + if (yyparse() || yyHaveTime > 1 || yyHaveZone > 1 || yyHaveDate > 1 || + yyHaveDay > 1) { + return -1; + } + + if (yyHaveDate || yyHaveTime || yyHaveDay) { + if (Convert(yyMonth, yyDay, yyYear, yyHour, yyMinutes, yySeconds, + yyMeridian, yyDSTmode, &Start) < 0) + return -1; + } + else { + Start = now; + if (!yyHaveRel) + Start -= ((tm->tm_hour * 60L) + tm->tm_min * 60L) + tm->tm_sec; + } + + Start += yyRelSeconds; + if (RelativeMonth(Start, yyRelMonth, &Time) < 0) { + return -1; + } + Start += Time; + + if (yyHaveDay && !yyHaveDate) { + tod = RelativeDate(Start, yyDayOrdinal, yyDayNumber); + Start += tod; + } + + *timePtr = Start; + return 0; +} diff --git a/contrib/tcl/generic/tclHash.c b/contrib/tcl/generic/tclHash.c new file mode 100644 index 0000000..41de0b2 --- /dev/null +++ b/contrib/tcl/generic/tclHash.c @@ -0,0 +1,921 @@ +/* + * tclHash.c -- + * + * Implementation of in-memory hash tables for Tcl and Tcl-based + * applications. + * + * Copyright (c) 1991-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: @(#) tclHash.c 1.15 96/02/15 11:50:23 + */ + +#include "tclInt.h" + +/* + * 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 + * to make it so that preliminary values that are arbitrarily similar + * will end up in different buckets. The hash function was taken + * from a random-number generator. + */ + +#define RANDOM_INDEX(tablePtr, i) \ + (((((long) (i))*1103515245) >> (tablePtr)->downShift) & (tablePtr)->mask) + +/* + * Procedure prototypes for static procedures in this file: + */ + +static Tcl_HashEntry * ArrayFind _ANSI_ARGS_((Tcl_HashTable *tablePtr, + char *key)); +static Tcl_HashEntry * ArrayCreate _ANSI_ARGS_((Tcl_HashTable *tablePtr, + char *key, int *newPtr)); +static Tcl_HashEntry * BogusFind _ANSI_ARGS_((Tcl_HashTable *tablePtr, + char *key)); +static Tcl_HashEntry * BogusCreate _ANSI_ARGS_((Tcl_HashTable *tablePtr, + char *key, int *newPtr)); +static unsigned int HashString _ANSI_ARGS_((char *string)); +static void RebuildTable _ANSI_ARGS_((Tcl_HashTable *tablePtr)); +static Tcl_HashEntry * StringFind _ANSI_ARGS_((Tcl_HashTable *tablePtr, + char *key)); +static Tcl_HashEntry * StringCreate _ANSI_ARGS_((Tcl_HashTable *tablePtr, + char *key, int *newPtr)); +static Tcl_HashEntry * OneWordFind _ANSI_ARGS_((Tcl_HashTable *tablePtr, + char *key)); +static Tcl_HashEntry * OneWordCreate _ANSI_ARGS_((Tcl_HashTable *tablePtr, + char *key, int *newPtr)); + +/* + *---------------------------------------------------------------------- + * + * Tcl_InitHashTable -- + * + * Given storage for a hash table, set up the fields to prepare + * the hash table for use. + * + * Results: + * None. + * + * Side effects: + * TablePtr is now ready to be passed to Tcl_FindHashEntry and + * Tcl_CreateHashEntry. + * + *---------------------------------------------------------------------- + */ + +void +Tcl_InitHashTable(tablePtr, keyType) + 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, + * or an integer >= 2. */ +{ + tablePtr->buckets = tablePtr->staticBuckets; + tablePtr->staticBuckets[0] = tablePtr->staticBuckets[1] = 0; + tablePtr->staticBuckets[2] = tablePtr->staticBuckets[3] = 0; + tablePtr->numBuckets = TCL_SMALL_HASH_TABLE; + tablePtr->numEntries = 0; + tablePtr->rebuildSize = TCL_SMALL_HASH_TABLE*REBUILD_MULTIPLIER; + 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; + } else { + tablePtr->findProc = ArrayFind; + tablePtr->createProc = ArrayCreate; + }; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_DeleteHashEntry -- + * + * Remove a single entry from a hash table. + * + * Results: + * None. + * + * Side effects: + * The entry given by entryPtr is deleted from its table and + * should never again be used by the caller. It is up to the + * caller to free the clientData field of the entry, if that + * is relevant. + * + *---------------------------------------------------------------------- + */ + +void +Tcl_DeleteHashEntry(entryPtr) + Tcl_HashEntry *entryPtr; +{ + register Tcl_HashEntry *prevPtr; + + if (*entryPtr->bucketPtr == entryPtr) { + *entryPtr->bucketPtr = entryPtr->nextPtr; + } else { + for (prevPtr = *entryPtr->bucketPtr; ; prevPtr = prevPtr->nextPtr) { + if (prevPtr == NULL) { + panic("malformed bucket chain in Tcl_DeleteHashEntry"); + } + if (prevPtr->nextPtr == entryPtr) { + prevPtr->nextPtr = entryPtr->nextPtr; + break; + } + } + } + entryPtr->tablePtr->numEntries--; + ckfree((char *) entryPtr); +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_DeleteHashTable -- + * + * Free up everything associated with a hash table except for + * the record for the table itself. + * + * Results: + * None. + * + * Side effects: + * The hash table is no longer useable. + * + *---------------------------------------------------------------------- + */ + +void +Tcl_DeleteHashTable(tablePtr) + register Tcl_HashTable *tablePtr; /* Table to delete. */ +{ + register Tcl_HashEntry *hPtr, *nextPtr; + int i; + + /* + * Free up all the entries in the table. + */ + + for (i = 0; i < tablePtr->numBuckets; i++) { + hPtr = tablePtr->buckets[i]; + while (hPtr != NULL) { + nextPtr = hPtr->nextPtr; + ckfree((char *) hPtr); + hPtr = nextPtr; + } + } + + /* + * Free up the bucket array, if it was dynamically allocated. + */ + + if (tablePtr->buckets != tablePtr->staticBuckets) { + ckfree((char *) tablePtr->buckets); + } + + /* + * Arrange for panics if the table is used again without + * re-initialization. + */ + + tablePtr->findProc = BogusFind; + tablePtr->createProc = BogusCreate; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_FirstHashEntry -- + * + * Locate the first entry in a hash table and set up a record + * that can be used to step through all the remaining entries + * of the table. + * + * Results: + * The return value is a pointer to the first entry in tablePtr, + * or NULL if tablePtr has no entries in it. The memory at + * *searchPtr is initialized so that subsequent calls to + * Tcl_NextHashEntry will return all of the entries in the table, + * one at a time. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +Tcl_HashEntry * +Tcl_FirstHashEntry(tablePtr, searchPtr) + Tcl_HashTable *tablePtr; /* Table to search. */ + Tcl_HashSearch *searchPtr; /* Place to store information about + * progress through the table. */ +{ + searchPtr->tablePtr = tablePtr; + searchPtr->nextIndex = 0; + searchPtr->nextEntryPtr = NULL; + return Tcl_NextHashEntry(searchPtr); +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_NextHashEntry -- + * + * Once a hash table enumeration has been initiated by calling + * Tcl_FirstHashEntry, this procedure may be called to return + * successive elements of the table. + * + * Results: + * The return value is the next entry in the hash table being + * enumerated, or NULL if the end of the table is reached. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +Tcl_HashEntry * +Tcl_NextHashEntry(searchPtr) + register Tcl_HashSearch *searchPtr; /* Place to store information about + * progress through the table. Must + * have been initialized by calling + * Tcl_FirstHashEntry. */ +{ + Tcl_HashEntry *hPtr; + + while (searchPtr->nextEntryPtr == NULL) { + if (searchPtr->nextIndex >= searchPtr->tablePtr->numBuckets) { + return NULL; + } + searchPtr->nextEntryPtr = + searchPtr->tablePtr->buckets[searchPtr->nextIndex]; + searchPtr->nextIndex++; + } + hPtr = searchPtr->nextEntryPtr; + searchPtr->nextEntryPtr = hPtr->nextPtr; + return hPtr; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_HashStats -- + * + * Return statistics describing the layout of the hash table + * in its hash buckets. + * + * Results: + * The return value is a malloc-ed string containing information + * about tablePtr. It is the caller's responsibility to free + * this string. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +char * +Tcl_HashStats(tablePtr) + Tcl_HashTable *tablePtr; /* Table for which to produce stats. */ +{ +#define NUM_COUNTERS 10 + int count[NUM_COUNTERS], overflow, i, j; + double average, tmp; + register Tcl_HashEntry *hPtr; + char *result, *p; + + /* + * Compute a histogram of bucket usage. + */ + + for (i = 0; i < NUM_COUNTERS; i++) { + count[i] = 0; + } + overflow = 0; + average = 0.0; + for (i = 0; i < tablePtr->numBuckets; i++) { + j = 0; + for (hPtr = tablePtr->buckets[i]; hPtr != NULL; hPtr = hPtr->nextPtr) { + j++; + } + if (j < NUM_COUNTERS) { + count[j]++; + } else { + overflow++; + } + tmp = j; + average += (tmp+1.0)*(tmp/tablePtr->numEntries)/2.0; + } + + /* + * Print out the histogram and a few other pieces of information. + */ + + result = (char *) ckalloc((unsigned) ((NUM_COUNTERS*60) + 300)); + sprintf(result, "%d entries in table, %d buckets\n", + tablePtr->numEntries, tablePtr->numBuckets); + p = result + strlen(result); + for (i = 0; i < NUM_COUNTERS; i++) { + sprintf(p, "number of buckets with %d entries: %d\n", + i, count[i]); + p += strlen(p); + } + sprintf(p, "number of buckets with %d or more entries: %d\n", + NUM_COUNTERS, overflow); + p += strlen(p); + sprintf(p, "average search distance for entry: %.1f", average); + return result; +} + +/* + *---------------------------------------------------------------------- + * + * HashString -- + * + * Compute a one-word summary of a text string, which can be + * used to generate a hash index. + * + * Results: + * The return value is a one-word summary of the information in + * string. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static unsigned int +HashString(string) + register char *string; /* String from which to compute hash value. */ +{ + 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. + */ + + result = 0; + while (1) { + c = *string; + string++; + if (c == 0) { + break; + } + result += (result<<3) + c; + } + return result; +} + +/* + *---------------------------------------------------------------------- + * + * StringFind -- + * + * Given a hash table with string keys, and a string key, 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. + * + *---------------------------------------------------------------------- + */ + +static Tcl_HashEntry * +StringFind(tablePtr, key) + Tcl_HashTable *tablePtr; /* Table in which to lookup entry. */ + char *key; /* Key to use to find matching entry. */ +{ + register Tcl_HashEntry *hPtr; + register 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; + } + } + } + return NULL; +} + +/* + *---------------------------------------------------------------------- + * + * 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. */ + 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 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; + } + } + } + + /* + * 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; +} + +/* + *---------------------------------------------------------------------- + * + * OneWordFind -- + * + * Given a hash table with one-word keys, and a one-word key, 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. + * + *---------------------------------------------------------------------- + */ + +static Tcl_HashEntry * +OneWordFind(tablePtr, key) + Tcl_HashTable *tablePtr; /* Table in which to lookup entry. */ + register char *key; /* Key to use to find matching entry. */ +{ + register Tcl_HashEntry *hPtr; + int index; + + index = RANDOM_INDEX(tablePtr, key); + + /* + * Search all of the entries in the appropriate bucket. + */ + + for (hPtr = tablePtr->buckets[index]; hPtr != NULL; + hPtr = hPtr->nextPtr) { + if (hPtr->key.oneWordValue == key) { + return hPtr; + } + } + return NULL; +} + +/* + *---------------------------------------------------------------------- + * + * OneWordCreate -- + * + * 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. + * + * 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 * +OneWordCreate(tablePtr, key, newPtr) + Tcl_HashTable *tablePtr; /* Table in which to lookup entry. */ + register 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; + 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 = 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; +} + +/* + *---------------------------------------------------------------------- + * + * ArrayFind -- + * + * Given a hash table with array-of-int keys, and a key, 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. + * + *---------------------------------------------------------------------- + */ + +static Tcl_HashEntry * +ArrayFind(tablePtr, key) + Tcl_HashTable *tablePtr; /* Table in which to lookup entry. */ + char *key; /* Key to use to find matching entry. */ +{ + 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. + */ + + 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; + } + } + } + return NULL; +} + +/* + *---------------------------------------------------------------------- + * + * ArrayCreate -- + * + * 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. + * + * 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 * +ArrayCreate(tablePtr, key, newPtr) + Tcl_HashTable *tablePtr; /* Table in which to lookup entry. */ + register 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; + 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. + */ + + 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; + } + } + } + + /* + * 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; +} + +/* + *---------------------------------------------------------------------- + * + * BogusFind -- + * + * This procedure is invoked when an Tcl_FindHashEntry is called + * on a table that has been deleted. + * + * Results: + * If panic returns (which it shouldn't) this procedure returns + * NULL. + * + * Side effects: + * Generates a panic. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +static Tcl_HashEntry * +BogusFind(tablePtr, key) + Tcl_HashTable *tablePtr; /* Table in which to lookup entry. */ + char *key; /* Key to use to find matching entry. */ +{ + panic("called Tcl_FindHashEntry on deleted table"); + return NULL; +} + +/* + *---------------------------------------------------------------------- + * + * BogusCreate -- + * + * This procedure is invoked when an Tcl_CreateHashEntry is called + * on a table that has been deleted. + * + * Results: + * If panic returns (which it shouldn't) this procedure returns + * NULL. + * + * Side effects: + * Generates a panic. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +static Tcl_HashEntry * +BogusCreate(tablePtr, key, newPtr) + Tcl_HashTable *tablePtr; /* Table in which to lookup entry. */ + char *key; /* Key to use to find or create matching + * entry. */ + int *newPtr; /* Store info here telling whether a new + * entry was created. */ +{ + panic("called Tcl_CreateHashEntry on deleted table"); + return NULL; +} + +/* + *---------------------------------------------------------------------- + * + * RebuildTable -- + * + * This procedure is invoked when the ratio of entries to hash + * buckets becomes too large. It creates a new table with a + * larger bucket array and moves all of the entries into the + * new table. + * + * Results: + * None. + * + * Side effects: + * Memory gets reallocated and entries get re-hashed to new + * buckets. + * + *---------------------------------------------------------------------- + */ + +static void +RebuildTable(tablePtr) + register Tcl_HashTable *tablePtr; /* Table to enlarge. */ +{ + int oldSize, count, index; + Tcl_HashEntry **oldBuckets; + register Tcl_HashEntry **oldChainPtr, **newChainPtr; + register Tcl_HashEntry *hPtr; + + oldSize = tablePtr->numBuckets; + oldBuckets = tablePtr->buckets; + + /* + * Allocate and initialize the new bucket array, and set up + * hashing constants for new array size. + */ + + tablePtr->numBuckets *= 4; + tablePtr->buckets = (Tcl_HashEntry **) ckalloc((unsigned) + (tablePtr->numBuckets * sizeof(Tcl_HashEntry *))); + for (count = tablePtr->numBuckets, newChainPtr = tablePtr->buckets; + count > 0; count--, newChainPtr++) { + *newChainPtr = NULL; + } + tablePtr->rebuildSize *= 4; + tablePtr->downShift -= 2; + tablePtr->mask = (tablePtr->mask << 2) + 3; + + /* + * 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; + } + index = RANDOM_INDEX(tablePtr, index); + } + hPtr->bucketPtr = &(tablePtr->buckets[index]); + hPtr->nextPtr = *hPtr->bucketPtr; + *hPtr->bucketPtr = hPtr; + } + } + + /* + * Free up the old bucket array, if it was dynamically allocated. + */ + + if (oldBuckets != tablePtr->staticBuckets) { + ckfree((char *) oldBuckets); + } +} diff --git a/contrib/tcl/generic/tclHistory.c b/contrib/tcl/generic/tclHistory.c new file mode 100644 index 0000000..c0cfd1f --- /dev/null +++ b/contrib/tcl/generic/tclHistory.c @@ -0,0 +1,1096 @@ +/* + * tclHistory.c -- + * + * This module implements history as an optional addition to Tcl. + * It can be called to record commands ("events") before they are + * executed, and it provides a command that may be used to perform + * history substitutions. + * + * Copyright (c) 1990-1993 The Regents of the University of California. + * Copyright (c) 1994-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: @(#) tclHistory.c 1.40 96/02/15 11:50:24 + */ + +#include "tclInt.h" +#include "tclPort.h" + +/* + * This history stuff is mostly straightforward, except for one thing + * that makes everything very complicated. Suppose that the following + * commands get executed: + * echo foo + * history redo + * It's important that the history event recorded for the second command + * be "echo foo", not "history redo". Otherwise, if another "history redo" + * command is typed, it will result in infinite recursions on the + * "history redo" command. Thus, the actual recorded history must be + * echo foo + * echo foo + * To do this, the history command revises recorded history as part of + * its execution. In the example above, when "history redo" starts + * execution, the current event is "history redo", but the history + * command arranges for the current event to be changed to "echo foo". + * + * There are three additional complications. The first is that history + * substitution may only be part of a command, as in the following + * command sequence: + * echo foo bar + * echo [history word 3] + * In this case, the second event should be recorded as "echo bar". Only + * part of the recorded event is to be modified. Fortunately, Tcl_Eval + * helps with this by recording (in the evalFirst and evalLast fields of + * the intepreter) the location of the command being executed, so the + * history module can replace exactly the range of bytes corresponding + * to the history substitution command. + * + * The second complication is that there are two ways to revise history: + * replace a command, and replace the result of a command. Consider the + * two examples below: + * format {result is %d} $num | format {result is %d} $num + * print [history redo] | print [history word 3] + * Recorded history for these two cases should be as follows: + * format {result is %d} $num | format {result is %d} $num + * print [format {result is %d} $num] | print $num + * In the left case, the history command was replaced with another command + * to be executed (the brackets were retained), but in the case on the + * right the result of executing the history command was replaced (i.e. + * brackets were replaced too). + * + * The third complication is that there could potentially be many + * history substitutions within a single command, as in: + * echo [history word 3] [history word 2] + * There could even be nested history substitutions, as in: + * history subs abc [history word 2] + * If history revisions were made immediately during each "history" command + * invocations, it would be very difficult to produce the correct cumulative + * effect from several substitutions in the same command. To get around + * this problem, the actual history revision isn't made during the execution + * of the "history" command. Information about the changes is just recorded, + * in xxx records, and the actual changes are made during the next call to + * Tcl_RecordHistory (when we know that execution of the previous command + * has finished). + */ + +/* + * Default space allocation for command strings: + */ + +#define INITIAL_CMD_SIZE 40 + +/* + * Forward declarations for procedures defined later in this file: + */ + +static void DoRevs _ANSI_ARGS_((Interp *iPtr)); +static HistoryEvent * GetEvent _ANSI_ARGS_((Interp *iPtr, char *string)); +static char * GetWords _ANSI_ARGS_((Interp *iPtr, char *command, + char *words)); +static void InitHistory _ANSI_ARGS_((Interp *iPtr)); +static void InsertRev _ANSI_ARGS_((Interp *iPtr, + HistoryRev *revPtr)); +static void MakeSpace _ANSI_ARGS_((HistoryEvent *hPtr, int size)); +static void RevCommand _ANSI_ARGS_((Interp *iPtr, char *string)); +static void RevResult _ANSI_ARGS_((Interp *iPtr, char *string)); +static int SubsAndEval _ANSI_ARGS_((Interp *iPtr, char *cmd, + char *old, char *new)); + +/* + *---------------------------------------------------------------------- + * + * InitHistory -- + * + * Initialize history-related state in an interpreter. + * + * Results: + * None. + * + * Side effects: + * History info is initialized in iPtr. + * + *---------------------------------------------------------------------- + */ + +static void +InitHistory(iPtr) + register Interp *iPtr; /* Interpreter to initialize. */ +{ + int i; + + if (iPtr->numEvents != 0) { + return; + } + iPtr->numEvents = 20; + iPtr->events = (HistoryEvent *) + ckalloc((unsigned) (iPtr->numEvents * sizeof(HistoryEvent))); + for (i = 0; i < iPtr->numEvents; i++) { + iPtr->events[i].command = (char *) ckalloc(INITIAL_CMD_SIZE); + *iPtr->events[i].command = 0; + iPtr->events[i].bytesAvl = INITIAL_CMD_SIZE; + } + iPtr->curEvent = 0; + iPtr->curEventNum = 0; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_RecordAndEval -- + * + * This procedure adds its command argument to the current list of + * recorded events and then executes the command by calling + * Tcl_Eval. + * + * Results: + * The return value is a standard Tcl return value, the result of + * executing cmd. + * + * Side effects: + * The command is recorded and executed. In addition, pending history + * revisions are carried out, and information is set up to enable + * Tcl_Eval to identify history command ranges. This procedure also + * initializes history information for the interpreter, if it hasn't + * already been initialized. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_RecordAndEval(interp, cmd, flags) + Tcl_Interp *interp; /* Token for interpreter in which command + * will be executed. */ + 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 + * instead of Tcl_Eval. */ +{ + register Interp *iPtr = (Interp *) interp; + register HistoryEvent *eventPtr; + int length, result; + + if (iPtr->numEvents == 0) { + InitHistory(iPtr); + } + DoRevs(iPtr); + + /* + * Don't record empty commands. + */ + + while (isspace(UCHAR(*cmd))) { + cmd++; + } + if (*cmd == '\0') { + Tcl_ResetResult(interp); + return TCL_OK; + } + + iPtr->curEventNum++; + iPtr->curEvent++; + if (iPtr->curEvent >= iPtr->numEvents) { + iPtr->curEvent = 0; + } + eventPtr = &iPtr->events[iPtr->curEvent]; + + /* + * Chop off trailing newlines before recording the command. + */ + + length = strlen(cmd); + while (cmd[length-1] == '\n') { + length--; + } + MakeSpace(eventPtr, length + 1); + strncpy(eventPtr->command, cmd, (size_t) length); + eventPtr->command[length] = 0; + + /* + * Execute the command. Note: history revision isn't possible after + * a nested call to this procedure, because the event at the top of + * the history list no longer corresponds to what's going on when + * a nested call here returns. Thus, must leave history revision + * disabled when we return. + */ + + result = TCL_OK; + if (!(flags & TCL_NO_EVAL)) { + iPtr->historyFirst = cmd; + iPtr->revDisables = 0; + iPtr->evalFlags = (flags & ~TCL_EVAL_GLOBAL) | TCL_RECORD_BOUNDS; + if (flags & TCL_EVAL_GLOBAL) { + result = Tcl_GlobalEval(interp, cmd); + } else { + result = Tcl_Eval(interp, cmd); + } + } + iPtr->revDisables = 1; + return result; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_HistoryCmd -- + * + * This procedure is invoked to process the "history" Tcl command. + * See the user documentation for details on what it does. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * See the user documentation. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +int +Tcl_HistoryCmd(dummy, interp, argc, argv) + ClientData dummy; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ + register Interp *iPtr = (Interp *) interp; + register HistoryEvent *eventPtr; + size_t length; + int c; + + if (iPtr->numEvents == 0) { + InitHistory(iPtr); + } + + /* + * If no arguments, treat the same as "history info". + */ + + if (argc == 1) { + goto infoCmd; + } + + c = argv[1][0]; + length = strlen(argv[1]); + + if ((c == 'a') && (strncmp(argv[1], "add", length)) == 0) { + if ((argc != 3) && (argc != 4)) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " add event ?exec?\"", (char *) NULL); + return TCL_ERROR; + } + if (argc == 4) { + if (strncmp(argv[3], "exec", strlen(argv[3])) != 0) { + Tcl_AppendResult(interp, "bad argument \"", argv[3], + "\": should be \"exec\"", (char *) NULL); + return TCL_ERROR; + } + return Tcl_RecordAndEval(interp, argv[2], 0); + } + return Tcl_RecordAndEval(interp, argv[2], TCL_NO_EVAL); + } else if ((c == 'c') && (strncmp(argv[1], "change", length)) == 0) { + if ((argc != 3) && (argc != 4)) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " change newValue ?event?\"", (char *) NULL); + return TCL_ERROR; + } + if (argc == 3) { + eventPtr = &iPtr->events[iPtr->curEvent]; + iPtr->revDisables += 1; + while (iPtr->revPtr != NULL) { + HistoryRev *nextPtr; + + ckfree(iPtr->revPtr->newBytes); + nextPtr = iPtr->revPtr->nextPtr; + ckfree((char *) iPtr->revPtr); + iPtr->revPtr = nextPtr; + } + } else { + eventPtr = GetEvent(iPtr, argv[3]); + if (eventPtr == NULL) { + return TCL_ERROR; + } + } + MakeSpace(eventPtr, (int) strlen(argv[2]) + 1); + strcpy(eventPtr->command, argv[2]); + return TCL_OK; + } else if ((c == 'e') && (strncmp(argv[1], "event", length)) == 0) { + if (argc > 3) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " event ?event?\"", (char *) NULL); + return TCL_ERROR; + } + eventPtr = GetEvent(iPtr, argc==2 ? "-1" : argv[2]); + if (eventPtr == NULL) { + return TCL_ERROR; + } + RevResult(iPtr, eventPtr->command); + Tcl_SetResult(interp, eventPtr->command, TCL_VOLATILE); + return TCL_OK; + } else if ((c == 'i') && (strncmp(argv[1], "info", length)) == 0) { + int count, indx, i; + char *newline; + + if ((argc != 2) && (argc != 3)) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " info ?count?\"", (char *) NULL); + return TCL_ERROR; + } + infoCmd: + if (argc == 3) { + if (Tcl_GetInt(interp, argv[2], &count) != TCL_OK) { + return TCL_ERROR; + } + if (count > iPtr->numEvents) { + count = iPtr->numEvents; + } + } else { + count = iPtr->numEvents; + } + newline = ""; + for (i = 0, indx = iPtr->curEvent + 1 + iPtr->numEvents - count; + i < count; i++, indx++) { + char *cur, *next, savedChar; + char serial[20]; + + if (indx >= iPtr->numEvents) { + indx -= iPtr->numEvents; + } + cur = iPtr->events[indx].command; + if (*cur == '\0') { + continue; /* No command recorded here. */ + } + sprintf(serial, "%6d ", iPtr->curEventNum + 1 - (count - i)); + Tcl_AppendResult(interp, newline, serial, (char *) NULL); + newline = "\n"; + + /* + * Tricky formatting here: for multi-line commands, indent + * the continuation lines. + */ + + while (1) { + next = strchr(cur, '\n'); + if (next == NULL) { + break; + } + next++; + savedChar = *next; + *next = 0; + Tcl_AppendResult(interp, cur, "\t", (char *) NULL); + *next = savedChar; + cur = next; + } + Tcl_AppendResult(interp, cur, (char *) NULL); + } + return TCL_OK; + } else if ((c == 'k') && (strncmp(argv[1], "keep", length)) == 0) { + int count, i, src; + HistoryEvent *events; + + if (argc != 3) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " keep number\"", (char *) NULL); + return TCL_ERROR; + } + if (Tcl_GetInt(interp, argv[2], &count) != TCL_OK) { + return TCL_ERROR; + } + if ((count <= 0) || (count > 1000)) { + Tcl_AppendResult(interp, "illegal keep count \"", argv[2], + "\"", (char *) NULL); + return TCL_ERROR; + } + + /* + * Create a new history array and copy as much existing history + * as possible from the old array. + */ + + events = (HistoryEvent *) + ckalloc((unsigned) (count * sizeof(HistoryEvent))); + if (count < iPtr->numEvents) { + src = iPtr->curEvent + 1 - count; + if (src < 0) { + src += iPtr->numEvents; + } + } else { + src = iPtr->curEvent + 1; + } + for (i = 0; i < count; i++, src++) { + if (src >= iPtr->numEvents) { + src = 0; + } + if (i < iPtr->numEvents) { + events[i] = iPtr->events[src]; + iPtr->events[src].command = NULL; + } else { + events[i].command = (char *) ckalloc(INITIAL_CMD_SIZE); + events[i].command[0] = 0; + events[i].bytesAvl = INITIAL_CMD_SIZE; + } + } + + /* + * Throw away everything left in the old history array, and + * substitute the new one for the old one. + */ + + for (i = 0; i < iPtr->numEvents; i++) { + if (iPtr->events[i].command != NULL) { + ckfree(iPtr->events[i].command); + } + } + ckfree((char *) iPtr->events); + iPtr->events = events; + if (count < iPtr->numEvents) { + iPtr->curEvent = count-1; + } else { + iPtr->curEvent = iPtr->numEvents-1; + } + iPtr->numEvents = count; + return TCL_OK; + } else if ((c == 'n') && (strncmp(argv[1], "nextid", length)) == 0) { + if (argc != 2) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " nextid\"", (char *) NULL); + return TCL_ERROR; + } + sprintf(iPtr->result, "%d", iPtr->curEventNum+1); + return TCL_OK; + } else if ((c == 'r') && (strncmp(argv[1], "redo", length)) == 0) { + if (argc > 3) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " redo ?event?\"", (char *) NULL); + return TCL_ERROR; + } + eventPtr = GetEvent(iPtr, argc==2 ? "-1" : argv[2]); + if (eventPtr == NULL) { + return TCL_ERROR; + } + RevCommand(iPtr, eventPtr->command); + return Tcl_Eval(interp, eventPtr->command); + } else if ((c == 's') && (strncmp(argv[1], "substitute", length)) == 0) { + if ((argc > 5) || (argc < 4)) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " substitute old new ?event?\"", (char *) NULL); + return TCL_ERROR; + } + eventPtr = GetEvent(iPtr, argc==4 ? "-1" : argv[4]); + if (eventPtr == NULL) { + return TCL_ERROR; + } + return SubsAndEval(iPtr, eventPtr->command, argv[2], argv[3]); + } else if ((c == 'w') && (strncmp(argv[1], "words", length)) == 0) { + char *words; + + if ((argc != 3) && (argc != 4)) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " words num-num/pat ?event?\"", (char *) NULL); + return TCL_ERROR; + } + eventPtr = GetEvent(iPtr, argc==3 ? "-1" : argv[3]); + if (eventPtr == NULL) { + return TCL_ERROR; + } + words = GetWords(iPtr, eventPtr->command, argv[2]); + if (words == NULL) { + return TCL_ERROR; + } + RevResult(iPtr, words); + iPtr->result = words; + iPtr->freeProc = TCL_DYNAMIC; + return TCL_OK; + } + + Tcl_AppendResult(interp, "bad option \"", argv[1], + "\": must be add, change, event, info, keep, nextid, ", + "redo, substitute, or words", (char *) NULL); + return TCL_ERROR; +} + +/* + *---------------------------------------------------------------------- + * + * MakeSpace -- + * + * Given a history event, make sure it has enough space for + * a string of a given length (enlarge the string area if + * necessary). + * + * Results: + * None. + * + * Side effects: + * More memory may get allocated. + * + *---------------------------------------------------------------------- + */ + +static void +MakeSpace(hPtr, size) + HistoryEvent *hPtr; + int size; /* # of bytes needed in hPtr. */ +{ + if (hPtr->bytesAvl < size) { + ckfree(hPtr->command); + hPtr->command = (char *) ckalloc((unsigned) size); + hPtr->bytesAvl = size; + } +} + +/* + *---------------------------------------------------------------------- + * + * InsertRev -- + * + * Add a new revision to the list of those pending for iPtr. + * Do it in a way that keeps the revision list sorted in + * increasing order of firstIndex. Also, eliminate revisions + * that are subsets of other revisions. + * + * Results: + * None. + * + * Side effects: + * RevPtr is added to iPtr's revision list. + * + *---------------------------------------------------------------------- + */ + +static void +InsertRev(iPtr, revPtr) + Interp *iPtr; /* Interpreter to use. */ + register HistoryRev *revPtr; /* Revision to add to iPtr's list. */ +{ + register HistoryRev *curPtr; + register HistoryRev *prevPtr; + + for (curPtr = iPtr->revPtr, prevPtr = NULL; curPtr != NULL; + prevPtr = curPtr, curPtr = curPtr->nextPtr) { + /* + * If this revision includes the new one (or vice versa) then + * just eliminate the one that is a subset of the other. + */ + + if ((revPtr->firstIndex <= curPtr->firstIndex) + && (revPtr->lastIndex >= curPtr->firstIndex)) { + curPtr->firstIndex = revPtr->firstIndex; + curPtr->lastIndex = revPtr->lastIndex; + curPtr->newSize = revPtr->newSize; + ckfree(curPtr->newBytes); + curPtr->newBytes = revPtr->newBytes; + ckfree((char *) revPtr); + return; + } + if ((revPtr->firstIndex >= curPtr->firstIndex) + && (revPtr->lastIndex <= curPtr->lastIndex)) { + ckfree(revPtr->newBytes); + ckfree((char *) revPtr); + return; + } + + if (revPtr->firstIndex < curPtr->firstIndex) { + break; + } + } + + /* + * Insert revPtr just after prevPtr. + */ + + if (prevPtr == NULL) { + revPtr->nextPtr = iPtr->revPtr; + iPtr->revPtr = revPtr; + } else { + revPtr->nextPtr = prevPtr->nextPtr; + prevPtr->nextPtr = revPtr; + } +} + +/* + *---------------------------------------------------------------------- + * + * RevCommand -- + * + * This procedure is invoked by the "history" command to record + * a command revision. See the comments at the beginning of the + * file for more information about revisions. + * + * Results: + * None. + * + * Side effects: + * Revision information is recorded. + * + *---------------------------------------------------------------------- + */ + +static void +RevCommand(iPtr, string) + register Interp *iPtr; /* Interpreter in which to perform the + * substitution. */ + char *string; /* String to substitute. */ +{ + register HistoryRev *revPtr; + + if ((iPtr->evalFirst == NULL) || (iPtr->revDisables > 0)) { + return; + } + revPtr = (HistoryRev *) ckalloc(sizeof(HistoryRev)); + revPtr->firstIndex = iPtr->evalFirst - iPtr->historyFirst; + revPtr->lastIndex = iPtr->evalLast - iPtr->historyFirst; + revPtr->newSize = strlen(string); + revPtr->newBytes = (char *) ckalloc((unsigned) (revPtr->newSize+1)); + strcpy(revPtr->newBytes, string); + InsertRev(iPtr, revPtr); +} + +/* + *---------------------------------------------------------------------- + * + * RevResult -- + * + * This procedure is invoked by the "history" command to record + * a result revision. See the comments at the beginning of the + * file for more information about revisions. + * + * Results: + * None. + * + * Side effects: + * Revision information is recorded. + * + *---------------------------------------------------------------------- + */ + +static void +RevResult(iPtr, string) + register Interp *iPtr; /* Interpreter in which to perform the + * substitution. */ + char *string; /* String to substitute. */ +{ + register HistoryRev *revPtr; + char *evalFirst, *evalLast; + char *argv[2]; + + if ((iPtr->evalFirst == NULL) || (iPtr->revDisables > 0)) { + return; + } + + /* + * Expand the replacement range to include the brackets that surround + * the command. If there aren't any brackets (i.e. this command was + * invoked at top-level) then don't do any revision. Also, if there + * are several commands in brackets, of which this is just one, + * then don't do any revision. + */ + + evalFirst = iPtr->evalFirst; + evalLast = iPtr->evalLast + 1; + while (1) { + if (evalFirst == iPtr->historyFirst) { + return; + } + evalFirst--; + if (*evalFirst == '[') { + break; + } + if (!isspace(UCHAR(*evalFirst))) { + return; + } + } + if (*evalLast != ']') { + return; + } + + revPtr = (HistoryRev *) ckalloc(sizeof(HistoryRev)); + revPtr->firstIndex = evalFirst - iPtr->historyFirst; + revPtr->lastIndex = evalLast - iPtr->historyFirst; + argv[0] = string; + revPtr->newBytes = Tcl_Merge(1, argv); + revPtr->newSize = strlen(revPtr->newBytes); + InsertRev(iPtr, revPtr); +} + +/* + *---------------------------------------------------------------------- + * + * DoRevs -- + * + * This procedure is called to apply the history revisions that + * have been recorded in iPtr. + * + * Results: + * None. + * + * Side effects: + * The most recent entry in the history for iPtr may be modified. + * + *---------------------------------------------------------------------- + */ + +static void +DoRevs(iPtr) + register Interp *iPtr; /* Interpreter whose history is to + * be modified. */ +{ + register HistoryRev *revPtr; + register HistoryEvent *eventPtr; + char *newCommand, *p; + unsigned int size; + int bytesSeen, count; + + if (iPtr->revPtr == NULL) { + return; + } + + /* + * The revision is done in two passes. The first pass computes the + * amount of space needed for the revised event, and the second pass + * pieces together the new event and frees up the revisions. + */ + + eventPtr = &iPtr->events[iPtr->curEvent]; + size = strlen(eventPtr->command) + 1; + for (revPtr = iPtr->revPtr; revPtr != NULL; revPtr = revPtr->nextPtr) { + size -= revPtr->lastIndex + 1 - revPtr->firstIndex; + size += revPtr->newSize; + } + + newCommand = (char *) ckalloc(size); + p = newCommand; + bytesSeen = 0; + for (revPtr = iPtr->revPtr; revPtr != NULL; ) { + HistoryRev *nextPtr = revPtr->nextPtr; + + count = revPtr->firstIndex - bytesSeen; + if (count > 0) { + strncpy(p, eventPtr->command + bytesSeen, (size_t) count); + p += count; + } + strncpy(p, revPtr->newBytes, (size_t) revPtr->newSize); + p += revPtr->newSize; + bytesSeen = revPtr->lastIndex+1; + ckfree(revPtr->newBytes); + ckfree((char *) revPtr); + revPtr = nextPtr; + } + strcpy(p, eventPtr->command + bytesSeen); + + /* + * Replace the command in the event. + */ + + ckfree(eventPtr->command); + eventPtr->command = newCommand; + eventPtr->bytesAvl = size; + iPtr->revPtr = NULL; +} + +/* + *---------------------------------------------------------------------- + * + * GetEvent -- + * + * Given a textual description of an event (see the manual page + * for legal values) find the corresponding event and return its + * command string. + * + * Results: + * The return value is a pointer to the event named by "string". + * If no such event exists, then NULL is returned and an error + * message is left in iPtr. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static HistoryEvent * +GetEvent(iPtr, string) + register Interp *iPtr; /* Interpreter in which to look. */ + char *string; /* Description of event. */ +{ + int eventNum, index; + register HistoryEvent *eventPtr; + int length; + + /* + * First check for a numeric specification of an event. + */ + + if (isdigit(UCHAR(*string)) || (*string == '-')) { + if (Tcl_GetInt((Tcl_Interp *) iPtr, string, &eventNum) != TCL_OK) { + return NULL; + } + if (eventNum < 0) { + eventNum += iPtr->curEventNum; + } + if (eventNum > iPtr->curEventNum) { + Tcl_AppendResult((Tcl_Interp *) iPtr, "event \"", string, + "\" hasn't occurred yet", (char *) NULL); + return NULL; + } + if ((eventNum <= iPtr->curEventNum-iPtr->numEvents) + || (eventNum <= 0)) { + Tcl_AppendResult((Tcl_Interp *) iPtr, "event \"", string, + "\" is too far in the past", (char *) NULL); + return NULL; + } + index = iPtr->curEvent + (eventNum - iPtr->curEventNum); + if (index < 0) { + index += iPtr->numEvents; + } + return &iPtr->events[index]; + } + + /* + * Next, check for an event that contains the string as a prefix or + * that matches the string in the sense of Tcl_StringMatch. + */ + + length = strlen(string); + for (index = iPtr->curEvent - 1; ; index--) { + if (index < 0) { + index += iPtr->numEvents; + } + if (index == iPtr->curEvent) { + break; + } + eventPtr = &iPtr->events[index]; + if ((strncmp(eventPtr->command, string, (size_t) length) == 0) + || Tcl_StringMatch(eventPtr->command, string)) { + return eventPtr; + } + } + + Tcl_AppendResult((Tcl_Interp *) iPtr, "no event matches \"", string, + "\"", (char *) NULL); + return NULL; +} + +/* + *---------------------------------------------------------------------- + * + * SubsAndEval -- + * + * Generate a new command by making a textual substitution in + * the "cmd" argument. Then execute the new command. + * + * Results: + * The return value is a standard Tcl error. + * + * Side effects: + * History gets revised if the substitution is occurring on + * a recorded command line. Also, the re-executed command + * may produce side-effects. + * + *---------------------------------------------------------------------- + */ + +static int +SubsAndEval(iPtr, cmd, old, new) + register Interp *iPtr; /* Interpreter in which to execute + * new command. */ + char *cmd; /* Command in which to substitute. */ + char *old; /* String to search for in command. */ + char *new; /* Replacement string for "old". */ +{ + char *src, *dst, *newCmd; + int count, oldLength, newLength, length, result; + + /* + * Figure out how much space it will take to hold the + * substituted command (and complain if the old string + * doesn't appear in the original command). + */ + + oldLength = strlen(old); + newLength = strlen(new); + src = cmd; + count = 0; + while (1) { + src = strstr(src, old); + if (src == NULL) { + break; + } + src += oldLength; + count++; + } + if (count == 0) { + Tcl_AppendResult((Tcl_Interp *) iPtr, "\"", old, + "\" doesn't appear in event", (char *) NULL); + return TCL_ERROR; + } + length = strlen(cmd) + count*(newLength - oldLength); + + /* + * Generate a substituted command. + */ + + newCmd = (char *) ckalloc((unsigned) (length + 1)); + dst = newCmd; + while (1) { + src = strstr(cmd, old); + if (src == NULL) { + strcpy(dst, cmd); + break; + } + strncpy(dst, cmd, (size_t) (src-cmd)); + dst += src-cmd; + strcpy(dst, new); + dst += newLength; + cmd = src + oldLength; + } + + RevCommand(iPtr, newCmd); + result = Tcl_Eval((Tcl_Interp *) iPtr, newCmd); + ckfree(newCmd); + return result; +} + +/* + *---------------------------------------------------------------------- + * + * GetWords -- + * + * Given a command string, return one or more words from the + * command string. + * + * Results: + * The return value is a pointer to a dynamically-allocated + * string containing the words of command specified by "words". + * If the word specifier has improper syntax then an error + * message is placed in iPtr->result and NULL is returned. + * + * Side effects: + * Memory is allocated. It is the caller's responsibilty to + * free the returned string.. + * + *---------------------------------------------------------------------- + */ + +static char * +GetWords(iPtr, command, words) + register Interp *iPtr; /* Tcl interpreter in which to place + * an error message if needed. */ + char *command; /* Command string. */ + char *words; /* Description of which words to extract + * from the command. Either num[-num] or + * a pattern. */ +{ + char *result; + char *start, *end, *dst; + register char *next; + int first; /* First word desired. -1 means last word + * only. */ + int last; /* Last word desired. -1 means use everything + * up to the end. */ + int index; /* Index of current word. */ + char *pattern; + + /* + * Figure out whether we're looking for a numerical range or for + * a pattern. + */ + + pattern = NULL; + first = 0; + last = -1; + if (*words == '$') { + if (words[1] != '\0') { + goto error; + } + first = -1; + } else if (isdigit(UCHAR(*words))) { + first = strtoul(words, &start, 0); + if (*start == 0) { + last = first; + } else if (*start == '-') { + start++; + if (*start == '$') { + start++; + } else if (isdigit(UCHAR(*start))) { + last = strtoul(start, &start, 0); + } else { + goto error; + } + if (*start != 0) { + goto error; + } + } + if ((first > last) && (last != -1)) { + goto error; + } + } else { + pattern = words; + } + + /* + * Scan through the words one at a time, copying those that are + * relevant into the result string. Allocate a result area large + * enough to hold all the words if necessary. + */ + + result = (char *) ckalloc((unsigned) (strlen(command) + 1)); + dst = result; + for (next = command; isspace(UCHAR(*next)); next++) { + /* Empty loop body: just find start of first word. */ + } + for (index = 0; *next != 0; index++) { + start = next; + end = TclWordEnd(next, 0, (int *) NULL); + if (*end != 0) { + end++; + for (next = end; isspace(UCHAR(*next)); next++) { + /* Empty loop body: just find start of next word. */ + } + } + if ((first > index) || ((first == -1) && (*next != 0))) { + continue; + } + if ((last != -1) && (last < index)) { + continue; + } + if (pattern != NULL) { + int match; + char savedChar = *end; + + *end = 0; + match = Tcl_StringMatch(start, pattern); + *end = savedChar; + if (!match) { + continue; + } + } + if (dst != result) { + *dst = ' '; + dst++; + } + strncpy(dst, start, (size_t) (end-start)); + dst += end-start; + } + *dst = 0; + + /* + * Check for an out-of-range argument index. + */ + + if ((last >= index) || (first >= index)) { + ckfree(result); + Tcl_AppendResult((Tcl_Interp *) iPtr, "word selector \"", words, + "\" specified non-existent words", (char *) NULL); + return NULL; + } + return result; + + error: + Tcl_AppendResult((Tcl_Interp *) iPtr, "bad word selector \"", words, + "\": should be num-num or pattern", (char *) NULL); + return NULL; +} diff --git a/contrib/tcl/generic/tclIO.c b/contrib/tcl/generic/tclIO.c new file mode 100644 index 0000000..0c54c12 --- /dev/null +++ b/contrib/tcl/generic/tclIO.c @@ -0,0 +1,5055 @@ +/* + * tclIO.c -- + * + * This file provides the generic portions (those that are the same on + * all platforms and for all channel types) of Tcl's IO facilities. + * + * Copyright (c) 1995-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: @(#) tclIO.c 1.211 96/04/18 09:59:06 + */ + +#include "tclInt.h" +#include "tclPort.h" + +/* + * Make sure that both EAGAIN and EWOULDBLOCK are defined. This does not + * compile on systems where neither is defined. We want both defined so + * that we can test safely for both. In the code we still have to test for + * both because there may be systems on which both are defined and have + * different values. + */ + +#if ((!defined(EWOULDBLOCK)) && (defined(EAGAIN))) +# define EWOULDBLOCK EAGAIN +#endif +#if ((!defined(EAGAIN)) && (defined(EWOULDBLOCK))) +# define EAGAIN EWOULDBLOCK +#endif +#if ((!defined(EAGAIN)) && (!defined(EWOULDBLOCK))) + error one of EWOULDBLOCK or EAGAIN must be defined +#endif + +/* + * struct ChannelBuffer: + * + * Buffers data being sent to or from a channel. + */ + +typedef struct ChannelBuffer { + int nextAdded; /* The next position into which a character + * will be put in the buffer. */ + int nextRemoved; /* Position of next byte to be removed + * from the buffer. */ + int bufSize; /* How big is the buffer? */ + struct ChannelBuffer *nextPtr; + /* Next buffer in chain. */ + char buf[4]; /* Placeholder for real buffer. The real + * buffer occuppies this space + bufSize-4 + * bytes. This must be the last field in + * the structure. */ +} ChannelBuffer; + +#define CHANNELBUFFER_HEADER_SIZE (sizeof(ChannelBuffer) - 4) + +/* + * The following defines the *default* buffer size for channels. + */ + +#define CHANNELBUFFER_DEFAULT_SIZE (1024 * 4) + +/* + * Structure to record a close callback. One such record exists for + * each close callback registered for a channel. + */ + +typedef struct CloseCallback { + Tcl_CloseProc *proc; /* The procedure to call. */ + ClientData clientData; /* Arbitrary one-word data to pass + * to the callback. */ + struct CloseCallback *nextPtr; /* For chaining close callbacks. */ +} CloseCallback; + +/* + * Forward declaration of Channel; being used in struct EventScriptRecord, + * below. + */ + +typedef struct Channel *ChanPtr; + +/* + * The following structure describes the information saved from a call to + * "fileevent". This is used later when the event being waited for to + * invoke the saved script in the interpreter designed in this record. + */ + +typedef struct EventScriptRecord { + struct Channel *chanPtr; /* The channel for which this script is + * registered. This is used only when an + * error occurs during evaluation of the + * script, to delete the handler. */ + char *script; /* Script to invoke. */ + Tcl_Interp *interp; /* In what interpreter to invoke script? */ + int mask; /* Events must overlap current mask for the + * stored script to be invoked. */ + struct EventScriptRecord *nextPtr; + /* Next in chain of records. */ +} EventScriptRecord; + +/* + * Forward declaration of ChannelHandler; being used in struct Channel, + * below. + */ + +typedef struct ChannelHandler *ChannelHandlerPtr; + +/* + * struct Channel: + * + * One of these structures is allocated for each open channel. It contains data + * specific to the channel but which belongs to the generic part of the Tcl + * channel mechanism, and it points at an instance specific (and type + * specific) * instance data, and at a channel type structure. + */ + +typedef struct Channel { + 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 + * below. */ + Tcl_EolTranslation inputTranslation; + /* What translation to apply for end of line + * sequences on input? */ + Tcl_EolTranslation outputTranslation; + /* What translation to use for generating + * end of line sequences in output? */ + int inEofChar; /* If nonzero, use this as a signal of EOF + * on input. */ + int outEofChar; /* If nonzero, append this to the channel + * when it is closed if it is open for + * writing. */ + int unreportedError; /* Non-zero if an error report was deferred + * because it happened in the background. The + * value is the POSIX error code. */ + ClientData instanceData; /* Instance specific data. */ + Tcl_File inFile; /* File to use for input, or NULL. */ + Tcl_File outFile; /* File to use for output, or NULL. */ + Tcl_ChannelType *typePtr; /* Pointer to channel type structure. */ + int refCount; /* How many interpreters hold references to + * this IO channel? */ + CloseCallback *closeCbPtr; /* Callbacks registered to be called when the + * channel is closed. */ + ChannelBuffer *curOutPtr; /* Current output buffer being filled. */ + ChannelBuffer *outQueueHead;/* Points at first buffer in output queue. */ + ChannelBuffer *outQueueTail;/* Points at last buffer in output queue. */ + + ChannelBuffer *saveInBufPtr;/* Buffer saved for input queue - eliminates + * need to allocate a new buffer for "gets" + * that crosses buffer boundaries. */ + ChannelBuffer *inQueueHead; /* Points at first buffer in input queue. */ + ChannelBuffer *inQueueTail; /* Points at last buffer in input queue. */ + + struct ChannelHandler *chPtr;/* List of channel handlers registered + * for this channel. */ + int interestMask; /* Mask of all events this channel has + * handlers for. */ + struct Channel *nextChanPtr;/* Next in list of channels currently open. */ + EventScriptRecord *scriptRecordPtr; + /* Chain of all scripts registered for + * event handlers ("fileevent") on this + * channel. */ + int bufSize; /* What size buffers to allocate? */ +} Channel; + +/* + * Values for the flags field in Channel. Any ORed combination of the + * following flags can be stored in the field. These flags record various + * options and state bits about the channel. In addition to the flags below, + * the channel can also have TCL_READABLE (1<<1) and TCL_WRITABLE (1<<2) set. + */ + +#define CHANNEL_NONBLOCKING (1<<3) /* Channel is currently in + * nonblocking mode. */ +#define CHANNEL_LINEBUFFERED (1<<4) /* Output to the channel must be + * flushed after every newline. */ +#define CHANNEL_UNBUFFERED (1<<5) /* Output to the channel must always + * be flushed immediately. */ +#define BUFFER_READY (1<<6) /* Current output buffer (the + * curOutPtr field in the + * channel structure) should be + * output as soon as possible event + * though it may not be full. */ +#define BG_FLUSH_SCHEDULED (1<<7) /* A background flush of the + * queued output buffers has been + * scheduled. */ +#define CHANNEL_CLOSED (1<<8) /* Channel has been closed. No + * further Tcl-level IO on the + * channel is allowed. */ +#define CHANNEL_EOF (1<<9) /* EOF occurred on this channel. + * This bit is cleared before every + * input operation. */ +#define CHANNEL_STICKY_EOF (1<<10) /* EOF occurred on this channel because + * we saw the input eofChar. This bit + * prevents clearing of the EOF bit + * before every input operation. */ +#define CHANNEL_BLOCKED (1<<11) /* EWOULDBLOCK or EAGAIN occurred + * on this channel. This bit is + * cleared before every input or + * output operation. */ +#define INPUT_SAW_CR (1<<12) /* Channel is in CRLF eol input + * translation mode and the last + * byte seen was a "\r". */ + +/* + * For each channel handler registered in a call to Tcl_CreateChannelHandler, + * there is one record of the following type. All of records for a specific + * channel are chained together in a singly linked list which is stored in + * the channel structure. + */ + +typedef struct ChannelHandler { + Channel *chanPtr; /* The channel structure for this channel. */ + int mask; /* Mask of desired events. */ + Tcl_ChannelProc *proc; /* Procedure to call in the type of + * Tcl_CreateChannelHandler. */ + ClientData clientData; /* Argument to pass to procedure. */ + struct ChannelHandler *nextPtr; + /* Next one in list of registered handlers. */ +} ChannelHandler; + +/* + * This structure keeps track of the current ChannelHandler being invoked in + * the current invocation of ChannelHandlerEventProc. There is a potential + * problem if a ChannelHandler is deleted while it is the current one, since + * ChannelHandlerEventProc needs to look at the nextPtr field. To handle this + * problem, structures of the type below indicate the next handler to be + * processed for any (recursively nested) dispatches in progress. The + * nextHandlerPtr field is updated if the handler being pointed to is deleted. + * The nextPtr field is used to chain together all recursive invocations, so + * that Tcl_DeleteChannelHandler can find all the recursively nested + * invocations of ChannelHandlerEventProc and compare the handler being + * deleted against the NEXT handler to be invoked in that invocation; when it + * finds such a situation, Tcl_DeleteChannelHandler updates the nextHandlerPtr + * field of the structure to the next handler. + */ + +typedef struct NextChannelHandler { + ChannelHandler *nextHandlerPtr; /* The next handler to be invoked in + * this invocation. */ + struct NextChannelHandler *nestedHandlerPtr; + /* Next nested invocation of + * ChannelHandlerEventProc. */ +} NextChannelHandler; + +/* + * This variable holds the list of nested ChannelHandlerEventProc invocations. + */ + +static NextChannelHandler *nestedHandlerPtr = (NextChannelHandler *) NULL; + +/* + * List of all channels currently open. + */ + +static Channel *firstChanPtr = (Channel *) NULL; + +/* + * Has a channel exit handler been created yet? + */ + +static int channelExitHandlerCreated = 0; + +/* + * Has the channel event source been created and registered with the + * notifier? + */ + +static int channelEventSourceCreated = 0; + +/* + * The following structure describes the event that is added to the Tcl + * event queue by the channel handler check procedure. + */ + +typedef struct ChannelHandlerEvent { + Tcl_Event header; /* Standard header for all events. */ + Channel *chanPtr; /* The channel that is ready. */ + int readyMask; /* Events that have occurred. */ +} ChannelHandlerEvent; + +/* + * Static buffer used to sprintf channel option values and return + * them to the caller. + */ + +static char optionVal[128]; + +/* + * Static variables to hold channels for stdin, stdout and stderr. + */ + +static Tcl_Channel stdinChannel = NULL; +static int stdinInitialized = 0; +static Tcl_Channel stdoutChannel = NULL; +static int stdoutInitialized = 0; +static Tcl_Channel stderrChannel = NULL; +static int stderrInitialized = 0; + +/* + * Static functions in this file: + */ + +static int ChannelEventDeleteProc _ANSI_ARGS_(( + Tcl_Event *evPtr, ClientData clientData)); +static void ChannelEventSourceExitProc _ANSI_ARGS_(( + ClientData data)); +static int ChannelHandlerEventProc _ANSI_ARGS_(( + Tcl_Event *evPtr, int flags)); +static void ChannelHandlerCheckProc _ANSI_ARGS_(( + ClientData clientData, int flags)); +static void ChannelHandlerSetupProc _ANSI_ARGS_(( + ClientData clientData, int flags)); +static void ChannelEventScriptInvoker _ANSI_ARGS_(( + ClientData clientData, int flags)); +static int CloseChannel _ANSI_ARGS_((Tcl_Interp *interp, + Channel *chanPtr, int errorCode)); +static void CloseChannelsOnExit _ANSI_ARGS_((ClientData data)); +static int CopyAndTranslateBuffer _ANSI_ARGS_(( + Channel *chanPtr, char *result, int space)); +static void CreateScriptRecord _ANSI_ARGS_(( + Tcl_Interp *interp, Channel *chanPtr, + int mask, char *script)); +static void DeleteChannelTable _ANSI_ARGS_(( + ClientData clientData, Tcl_Interp *interp)); +static void DeleteScriptRecord _ANSI_ARGS_((Tcl_Interp *interp, + Channel *chanPtr, int mask)); +static void DiscardInputQueued _ANSI_ARGS_(( + Channel *chanPtr, int discardSavedBuffers)); +static void DiscardOutputQueued _ANSI_ARGS_(( + Channel *chanPtr)); +static int FlushChannel _ANSI_ARGS_((Tcl_Interp *interp, + Channel *chanPtr, int calledFromAsyncFlush)); +static void FlushEventProc _ANSI_ARGS_((ClientData clientData, + int mask)); +static Tcl_HashTable *GetChannelTable _ANSI_ARGS_((Tcl_Interp *interp)); +static int GetEOL _ANSI_ARGS_((Channel *chanPtr)); +static int GetInput _ANSI_ARGS_((Channel *chanPtr)); +static void RecycleBuffer _ANSI_ARGS_((Channel *chanPtr, + ChannelBuffer *bufPtr, int mustDiscard)); +static void ReturnScriptRecord _ANSI_ARGS_((Tcl_Interp *interp, + Channel *chanPtr, int mask)); +static int ScanBufferForEOL _ANSI_ARGS_((Channel *chanPtr, + ChannelBuffer *bufPtr, + Tcl_EolTranslation translation, int eofChar, + int *bytesToEOLPtr, int *crSeenPtr)); +static int ScanInputForEOL _ANSI_ARGS_((Channel *chanPtr, + int *bytesQueuedPtr)); + +/* + *---------------------------------------------------------------------- + * + * Tcl_SetStdChannel -- + * + * This function is used to change the channels that are used + * for stdin/stdout/stderr in new interpreters. + * + * Results: + * None + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +void +Tcl_SetStdChannel(channel, type) + Tcl_Channel channel; + int type; /* One of TCL_STDIN, TCL_STDOUT, TCL_STDERR. */ +{ + switch (type) { + case TCL_STDIN: + stdinInitialized = 1; + stdinChannel = channel; + break; + case TCL_STDOUT: + stdoutInitialized = 1; + stdoutChannel = channel; + break; + case TCL_STDERR: + stderrInitialized = 1; + stderrChannel = channel; + break; + } +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_GetStdChannel -- + * + * Returns the specified standard channel. + * + * Results: + * Returns the specified standard channel, or NULL. + * + * Side effects: + * May cause the creation of a standard channel and the underlying + * file. + * + *---------------------------------------------------------------------- + */ + +Tcl_Channel +Tcl_GetStdChannel(type) + int type; /* One of TCL_STDIN, TCL_STDOUT, TCL_STDERR. */ +{ + Tcl_Channel channel = NULL; + + /* + * If the channels were not created yet, create them now and + * store them in the static variables. Note that we need to set + * stdinInitialized before calling TclGetDefaultStdChannel in order + * to avoid recursive loops when TclGetDefaultStdChannel calls + * Tcl_CreateChannel. + */ + + switch (type) { + case TCL_STDIN: + if (!stdinInitialized) { + stdinInitialized = 1; + stdinChannel = TclGetDefaultStdChannel(TCL_STDIN); + } + channel = stdinChannel; + break; + case TCL_STDOUT: + if (!stdoutInitialized) { + stdoutInitialized = 1; + stdoutChannel = TclGetDefaultStdChannel(TCL_STDOUT); + } + channel = stdoutChannel; + break; + case TCL_STDERR: + if (!stderrInitialized) { + stderrInitialized = 1; + stderrChannel = TclGetDefaultStdChannel(TCL_STDERR); + } + channel = stderrChannel; + break; + } + return channel; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_CreateCloseHandler + * + * Creates a close callback which will be called when the channel is + * closed. + * + * Results: + * None. + * + * Side effects: + * Causes the callback to be called in the future when the channel + * will be closed. + * + *---------------------------------------------------------------------- + */ + +void +Tcl_CreateCloseHandler(chan, proc, clientData) + Tcl_Channel chan; /* The channel for which to create the + * close callback. */ + Tcl_CloseProc *proc; /* The callback routine to call when the + * channel will be closed. */ + ClientData clientData; /* Arbitrary data to pass to the + * close callback. */ +{ + Channel *chanPtr; + CloseCallback *cbPtr; + + chanPtr = (Channel *) chan; + + cbPtr = (CloseCallback *) ckalloc((unsigned) sizeof(CloseCallback)); + cbPtr->proc = proc; + cbPtr->clientData = clientData; + + cbPtr->nextPtr = chanPtr->closeCbPtr; + chanPtr->closeCbPtr = cbPtr; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_DeleteCloseHandler -- + * + * Removes a callback that would have been called on closing + * the channel. If there is no matching callback then this + * function has no effect. + * + * Results: + * None. + * + * Side effects: + * The callback will not be called in the future when the channel + * is eventually closed. + * + *---------------------------------------------------------------------- + */ + +void +Tcl_DeleteCloseHandler(chan, proc, clientData) + Tcl_Channel chan; /* The channel for which to cancel the + * close callback. */ + Tcl_CloseProc *proc; /* The procedure for the callback to + * remove. */ + ClientData clientData; /* The callback data for the callback + * to remove. */ +{ + Channel *chanPtr; + CloseCallback *cbPtr, *cbPrevPtr; + + chanPtr = (Channel *) chan; + for (cbPtr = chanPtr->closeCbPtr, cbPrevPtr = (CloseCallback *) NULL; + cbPtr != (CloseCallback *) NULL; + cbPtr = cbPtr->nextPtr) { + if ((cbPtr->proc == proc) && (cbPtr->clientData == clientData)) { + if (cbPrevPtr == (CloseCallback *) NULL) { + chanPtr->closeCbPtr = cbPtr->nextPtr; + } else { + cbPrevPtr = cbPtr->nextPtr; + } + ckfree((char *) cbPtr); + break; + } else { + cbPrevPtr = cbPtr; + } + } +} + +/* + *---------------------------------------------------------------------- + * + * CloseChannelsOnExit -- + * + * Closes all the existing channels, on exit. This routine is called + * during exit processing. + * + * Results: + * None. + * + * Side effects: + * Closes all channels. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +static void +CloseChannelsOnExit(clientData) + ClientData clientData; /* NULL - unused. */ +{ + Channel *chanPtr; /* Iterates over open channels. */ + Channel *nextChanPtr; /* Iterates over open channels. */ + + + for (chanPtr = firstChanPtr; chanPtr != (Channel *) NULL; + chanPtr = nextChanPtr) { + nextChanPtr = chanPtr->nextChanPtr; + + /* + * Close it only if the refcount indicates that the channel is not + * referenced from any interpreter. If it is, that interpreter will + * close the channel when it gets destroyed. + */ + + if (chanPtr->refCount <= 0) { + + /* + * Switch the channel back into synchronous mode to ensure that it + * gets flushed now. + */ + + (void) Tcl_SetChannelOption(NULL, (Tcl_Channel) chanPtr, + "-blocking", "on"); + + Tcl_Close((Tcl_Interp *) NULL, (Tcl_Channel) chanPtr); + } + } +} + +/* + *---------------------------------------------------------------------- + * + * GetChannelTable -- + * + * Gets and potentially initializes the channel table for an + * interpreter. If it is initializing the table it also inserts + * channels for stdin, stdout and stderr if the interpreter is + * trusted. + * + * Results: + * A pointer to the hash table created, for use by the caller. + * + * Side effects: + * Initializes the channel table for an interpreter. May create + * channels for stdin, stdout and stderr. + * + *---------------------------------------------------------------------- + */ + +static Tcl_HashTable * +GetChannelTable(interp) + Tcl_Interp *interp; +{ + Tcl_HashTable *hTblPtr; /* Hash table of channels. */ + Tcl_Channel stdinChannel, stdoutChannel, stderrChannel; + + hTblPtr = (Tcl_HashTable *) Tcl_GetAssocData(interp, "tclIO", NULL); + if (hTblPtr == (Tcl_HashTable *) NULL) { + hTblPtr = (Tcl_HashTable *) ckalloc((unsigned) sizeof(Tcl_HashTable)); + Tcl_InitHashTable(hTblPtr, TCL_STRING_KEYS); + + (void) Tcl_SetAssocData(interp, "tclIO", + (Tcl_InterpDeleteProc *) DeleteChannelTable, + (ClientData) hTblPtr); + + /* + * If the interpreter is trusted (not "safe"), insert channels + * for stdin, stdout and stderr (possibly creating them in the + * process). + */ + + if (Tcl_IsSafe(interp) == 0) { + stdinChannel = Tcl_GetStdChannel(TCL_STDIN); + if (stdinChannel != NULL) { + Tcl_RegisterChannel(interp, stdinChannel); + } + stdoutChannel = Tcl_GetStdChannel(TCL_STDOUT); + if (stdoutChannel != NULL) { + Tcl_RegisterChannel(interp, stdoutChannel); + } + stderrChannel = Tcl_GetStdChannel(TCL_STDERR); + if (stderrChannel != NULL) { + Tcl_RegisterChannel(interp, stderrChannel); + } + } + + } + return hTblPtr; +} + +/* + *---------------------------------------------------------------------- + * + * DeleteChannelTable -- + * + * Deletes the channel table for an interpreter, closing any open + * channels whose refcount reaches zero. This procedure is invoked + * when an interpreter is deleted, via the AssocData cleanup + * mechanism. + * + * Results: + * None. + * + * Side effects: + * Deletes the hash table of channels. May close channels. May flush + * output on closed channels. Removes any channeEvent handlers that were + * registered in this interpreter. + * + *---------------------------------------------------------------------- + */ + +static void +DeleteChannelTable(clientData, interp) + ClientData clientData; /* The per-interpreter data structure. */ + Tcl_Interp *interp; /* The interpreter being deleted. */ +{ + Tcl_HashTable *hTblPtr; /* The hash table. */ + Tcl_HashSearch hSearch; /* Search variable. */ + Tcl_HashEntry *hPtr; /* Search variable. */ + Channel *chanPtr; /* Channel being deleted. */ + EventScriptRecord *sPtr, *prevPtr, *nextPtr; + /* Variables to loop over all channel events + * registered, to delete the ones that refer + * to the interpreter being deleted. */ + + /* + * Delete all the registered channels - this will close channels whose + * refcount reaches zero. + */ + + hTblPtr = (Tcl_HashTable *) clientData; + for (hPtr = Tcl_FirstHashEntry(hTblPtr, &hSearch); + hPtr != (Tcl_HashEntry *) NULL; + hPtr = Tcl_FirstHashEntry(hTblPtr, &hSearch)) { + + chanPtr = (Channel *) Tcl_GetHashValue(hPtr); + + /* + * Remove any fileevents registered in this interpreter. + */ + + for (sPtr = chanPtr->scriptRecordPtr, + prevPtr = (EventScriptRecord *) NULL; + sPtr != (EventScriptRecord *) NULL; + sPtr = nextPtr) { + nextPtr = sPtr->nextPtr; + if (sPtr->interp == interp) { + if (prevPtr == (EventScriptRecord *) NULL) { + chanPtr->scriptRecordPtr = nextPtr; + } else { + prevPtr->nextPtr = nextPtr; + } + + Tcl_DeleteChannelHandler((Tcl_Channel) chanPtr, + ChannelEventScriptInvoker, (ClientData) sPtr); + + Tcl_EventuallyFree((ClientData) sPtr->script, TCL_DYNAMIC); + ckfree((char *) sPtr); + } else { + prevPtr = sPtr; + } + } + + /* + * Cannot call Tcl_UnregisterChannel because that procedure calls + * Tcl_GetAssocData to get the channel table, which might already + * be inaccessible from the interpreter structure. Instead, we + * emulate the behavior of Tcl_UnregisterChannel directly here. + */ + + Tcl_DeleteHashEntry(hPtr); + chanPtr->refCount--; + if (chanPtr->refCount <= 0) { + chanPtr->flags |= CHANNEL_CLOSED; + if (!(chanPtr->flags & BG_FLUSH_SCHEDULED)) { + Tcl_Close(interp, (Tcl_Channel) chanPtr); + } + } + } + Tcl_DeleteHashTable(hTblPtr); + ckfree((char *) hTblPtr); +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_UnregisterChannel -- + * + * Deletes the hash entry for a channel associated with an interpreter. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * Deletes the hash entry for a channel associated with an interpreter. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_UnregisterChannel(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. */ + + chanPtr = (Channel *) chan; + hTblPtr = (Tcl_HashTable *) Tcl_GetAssocData(interp, "tclIO", NULL); + if (hTblPtr == (Tcl_HashTable *) NULL) { + return TCL_OK; + } + hPtr = Tcl_FindHashEntry(hTblPtr, chanPtr->channelName); + if (hPtr == (Tcl_HashEntry *) NULL) { + return TCL_OK; + } + if ((Channel *) Tcl_GetHashValue(hPtr) != chanPtr) { + return TCL_OK; + } + Tcl_DeleteHashEntry(hPtr); + chanPtr->refCount--; + if (chanPtr->refCount <= 0) { + chanPtr->flags |= CHANNEL_CLOSED; + if (!(chanPtr->flags & BG_FLUSH_SCHEDULED)) { + if (Tcl_Close(interp, chan) != TCL_OK) { + return TCL_ERROR; + } + } + } + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_RegisterChannel -- + * + * Adds an already-open channel to the channel table of an interpreter. + * + * Results: + * None. + * + * Side effects: + * May increment the reference count of a channel. + * + *---------------------------------------------------------------------- + */ + +void +Tcl_RegisterChannel(interp, chan) + Tcl_Interp *interp; /* Interpreter in which to add the channel. */ + Tcl_Channel chan; /* The channel to add to this interpreter + * channel table. */ +{ + Tcl_HashTable *hTblPtr; /* Hash table of channels. */ + Tcl_HashEntry *hPtr; /* Search variable. */ + int new; /* Is the hash entry new or does it exist? */ + Channel *chanPtr; /* The actual channel. */ + + chanPtr = (Channel *) chan; + + if (chanPtr->channelName == (char *) NULL) { + panic("Tcl_RegisterChannel: channel without name"); + } + hTblPtr = GetChannelTable(interp); + hPtr = Tcl_CreateHashEntry(hTblPtr, chanPtr->channelName, &new); + if (new == 0) { + if (chan == (Tcl_Channel) Tcl_GetHashValue(hPtr)) { + return; + } + panic("Tcl_RegisterChannel: duplicate channel names"); + } + Tcl_SetHashValue(hPtr, (ClientData) chanPtr); + chanPtr->refCount++; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_GetChannel -- + * + * Finds an existing Tcl_Channel structure by name in a given + * interpreter. This function is public because it is used by + * channel-type-specific functions. + * + * Results: + * A Tcl_Channel or NULL on failure. If failed, interp->result + * contains an error message. It also returns, in modePtr, the + * modes in which the channel is opened. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +Tcl_Channel +Tcl_GetChannel(interp, chanName, modePtr) + Tcl_Interp *interp; /* Interpreter in which to find or create + * the channel. */ + 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 + * TCL_WRITABLE, if non-NULL. */ +{ + Channel *chanPtr; /* The actual channel. */ + Tcl_HashTable *hTblPtr; /* Hash table of channels. */ + Tcl_HashEntry *hPtr; /* Search variable. */ + char *name; /* Translated name. */ + + /* + * Substitute "stdin", etc. Note that even though we immediately + * find the channel using Tcl_GetStdChannel, we still need to look + * it up in the specified interpreter to ensure that it is present + * in the channel table. Otherwise, safe interpreters would always + * have access to the standard channels. + */ + + name = chanName; + if ((chanName[0] == 's') && (chanName[1] == 't')) { + chanPtr = NULL; + if (strcmp(chanName, "stdin") == 0) { + chanPtr = (Channel *)Tcl_GetStdChannel(TCL_STDIN); + } else if (strcmp(chanName, "stdout") == 0) { + chanPtr = (Channel *)Tcl_GetStdChannel(TCL_STDOUT); + } else if (strcmp(chanName, "stderr") == 0) { + chanPtr = (Channel *)Tcl_GetStdChannel(TCL_STDERR); + } + if (chanPtr != NULL) { + name = chanPtr->channelName; + } + } + + hTblPtr = GetChannelTable(interp); + hPtr = Tcl_FindHashEntry(hTblPtr, name); + if (hPtr == (Tcl_HashEntry *) NULL) { + Tcl_AppendResult(interp, "can not find channel named \"", + chanName, "\"", (char *) NULL); + return NULL; + } + + chanPtr = (Channel *) Tcl_GetHashValue(hPtr); + if (modePtr != NULL) { + *modePtr = (chanPtr->flags & (TCL_READABLE|TCL_WRITABLE)); + } + + return (Tcl_Channel) chanPtr; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_CreateChannel -- + * + * Creates a new entry in the hash table for a Tcl_Channel + * record. + * + * Results: + * Returns the new Tcl_Channel. + * + * Side effects: + * Creates a new Tcl_Channel instance and inserts it into the + * hash table. + * + *---------------------------------------------------------------------- + */ + +Tcl_Channel +Tcl_CreateChannel(typePtr, chanName, inFile, outFile, instanceData) + Tcl_ChannelType *typePtr; /* The channel type record. */ + char *chanName; /* Name of channel to record. */ + Tcl_File inFile; /* File to use for input, or NULL. */ + Tcl_File outFile; /* File to use for output, or NULL. */ + ClientData instanceData; /* Instance specific data. */ +{ + Channel *chanPtr; /* The channel structure newly created. */ + + chanPtr = (Channel *) ckalloc((unsigned) sizeof(Channel)); + + if (chanName != (char *) NULL) { + chanPtr->channelName = ckalloc((unsigned) (strlen(chanName) + 1)); + strcpy(chanPtr->channelName, chanName); + } else { + panic("Tcl_CreateChannel: NULL channel name"); + } + + chanPtr->flags = 0; + if (inFile != (Tcl_File) NULL) { + chanPtr->flags |= TCL_READABLE; + } + if (outFile != (Tcl_File) NULL) { + chanPtr->flags |= TCL_WRITABLE; + } + + /* + * Set the channel up initially in AUTO input translation mode to + * accept "\n", "\r" and "\r\n". Output translation mode is set to + * a platform specific default value. The eofChar is set to 0 for both + * input and output, so that Tcl does not look for an in-file EOF + * indicator (e.g. ^Z) and does not append an EOF indicator to files. + */ + + chanPtr->inputTranslation = TCL_TRANSLATE_AUTO; + chanPtr->outputTranslation = TCL_PLATFORM_TRANSLATION; + chanPtr->inEofChar = 0; + chanPtr->outEofChar = 0; + + chanPtr->unreportedError = 0; + chanPtr->instanceData = instanceData; + chanPtr->inFile = inFile; + chanPtr->outFile = outFile; + chanPtr->typePtr = typePtr; + chanPtr->refCount = 0; + chanPtr->closeCbPtr = (CloseCallback *) NULL; + chanPtr->curOutPtr = (ChannelBuffer *) NULL; + chanPtr->outQueueHead = (ChannelBuffer *) NULL; + chanPtr->outQueueTail = (ChannelBuffer *) NULL; + chanPtr->saveInBufPtr = (ChannelBuffer *) NULL; + chanPtr->inQueueHead = (ChannelBuffer *) NULL; + chanPtr->inQueueTail = (ChannelBuffer *) NULL; + chanPtr->chPtr = (ChannelHandler *) NULL; + chanPtr->interestMask = 0; + chanPtr->scriptRecordPtr = (EventScriptRecord *) NULL; + chanPtr->bufSize = CHANNELBUFFER_DEFAULT_SIZE; + + /* + * 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. + */ + + chanPtr->nextChanPtr = firstChanPtr; + firstChanPtr = chanPtr; + + if (!channelExitHandlerCreated) { + channelExitHandlerCreated = 1; + Tcl_CreateExitHandler(CloseChannelsOnExit, (ClientData) NULL); + } + + /* + * Install this channel in the first empty standard channel slot. + */ + + if (Tcl_GetStdChannel(TCL_STDIN) == NULL) { + Tcl_SetStdChannel((Tcl_Channel)chanPtr, TCL_STDIN); + } else if (Tcl_GetStdChannel(TCL_STDOUT) == NULL) { + Tcl_SetStdChannel((Tcl_Channel)chanPtr, TCL_STDOUT); + } else if (Tcl_GetStdChannel(TCL_STDERR) == NULL) { + Tcl_SetStdChannel((Tcl_Channel)chanPtr, TCL_STDERR); + } + + return (Tcl_Channel) chanPtr; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_GetChannelName -- + * + * Returns the string identifying the channel name. + * + * Results: + * The string containing the channel name. This memory is + * owned by the generic layer and should not be modified by + * the caller. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +char * +Tcl_GetChannelName(chan) + Tcl_Channel chan; /* The channel for which to return the name. */ +{ + Channel *chanPtr; /* The actual channel. */ + + chanPtr = (Channel *) chan; + return chanPtr->channelName; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_GetChannelType -- + * + * Given a channel structure, returns the channel type structure. + * + * Results: + * Returns a pointer to the channel type structure. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +Tcl_ChannelType * +Tcl_GetChannelType(chan) + Tcl_Channel chan; /* The channel to return type for. */ +{ + Channel *chanPtr; /* The actual channel. */ + + chanPtr = (Channel *) chan; + return chanPtr->typePtr; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_GetChannelFile -- + * + * Returns a file associated with a channel. + * + * Results: + * The file or NULL if failed (e.g. the channel is not open for the + * requested direction). + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +Tcl_File +Tcl_GetChannelFile(chan, direction) + Tcl_Channel chan; /* The channel to get file from. */ + int direction; /* TCL_WRITABLE or TCL_READABLE. */ +{ + Channel *chanPtr; /* The actual channel. */ + + chanPtr = (Channel *) chan; + switch (direction) { + case TCL_WRITABLE: + return chanPtr->outFile; + case TCL_READABLE: + return chanPtr->inFile; + default: + return NULL; + } +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_GetChannelInstanceData -- + * + * Returns the client data associated with a channel. + * + * Results: + * The client data. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +ClientData +Tcl_GetChannelInstanceData(chan) + Tcl_Channel chan; /* Channel for which to return client data. */ +{ + Channel *chanPtr; /* The actual channel. */ + + chanPtr = (Channel *) chan; + return chanPtr->instanceData; +} + +/* + *---------------------------------------------------------------------- + * + * RecycleBuffer -- + * + * Helper function to recycle input and output buffers. Ensures + * that two input buffers are saved (one in the input queue and + * another in the saveInBufPtr field) and that curOutPtr is set + * to a buffer. Only if these conditions are met is the buffer + * freed to the OS. + * + * Results: + * None. + * + * Side effects: + * May free a buffer to the OS. + * + *---------------------------------------------------------------------- + */ + +static void +RecycleBuffer(chanPtr, bufPtr, mustDiscard) + Channel *chanPtr; /* Channel for which to recycle buffers. */ + ChannelBuffer *bufPtr; /* The buffer to recycle. */ + int mustDiscard; /* If nonzero, free the buffer to the + * OS, always. */ +{ + /* + * Do we have to free the buffer to the OS? + */ + + if (mustDiscard) { + ckfree((char *) bufPtr); + return; + } + + /* + * Only save buffers for the input queue if the channel is readable. + */ + + if (chanPtr->flags & TCL_READABLE) { + if (chanPtr->inQueueHead == (ChannelBuffer *) NULL) { + chanPtr->inQueueHead = bufPtr; + chanPtr->inQueueTail = bufPtr; + goto keepit; + } + if (chanPtr->saveInBufPtr == (ChannelBuffer *) NULL) { + chanPtr->saveInBufPtr = bufPtr; + goto keepit; + } + } + + /* + * Only save buffers for the output queue if the channel is writable. + */ + + if (chanPtr->flags & TCL_WRITABLE) { + if (chanPtr->curOutPtr == (ChannelBuffer *) NULL) { + chanPtr->curOutPtr = bufPtr; + goto keepit; + } + } + + /* + * If we reached this code we return the buffer to the OS. + */ + + ckfree((char *) bufPtr); + return; + +keepit: + bufPtr->nextRemoved = 0; + bufPtr->nextAdded = 0; + bufPtr->nextPtr = (ChannelBuffer *) NULL; +} + +/* + *---------------------------------------------------------------------- + * + * DiscardOutputQueued -- + * + * Discards all output queued in the output queue of a channel. + * + * Results: + * None. + * + * Side effects: + * Recycles buffers. + * + *---------------------------------------------------------------------- + */ + +static void +DiscardOutputQueued(chanPtr) + Channel *chanPtr; /* The channel for which to discard output. */ +{ + ChannelBuffer *bufPtr; + + while (chanPtr->outQueueHead != (ChannelBuffer *) NULL) { + bufPtr = chanPtr->outQueueHead; + chanPtr->outQueueHead = bufPtr->nextPtr; + RecycleBuffer(chanPtr, bufPtr, 0); + } + chanPtr->outQueueHead = (ChannelBuffer *) NULL; + chanPtr->outQueueTail = (ChannelBuffer *) NULL; +} + +/* + *---------------------------------------------------------------------- + * + * FlushChannel -- + * + * This function flushes as much of the queued output as is possible + * now. If calledFromAsyncFlush is nonzero, it is being called in an + * event handler to flush channel output asynchronously. + * + * Results: + * 0 if successful, else the error code that was returned by the + * channel type operation. + * + * Side effects: + * May produce output on a channel. May block indefinitely if the + * channel is synchronous. May schedule an async flush on the channel. + * May recycle memory for buffers in the output queue. + * + *---------------------------------------------------------------------- + */ + +static int +FlushChannel(interp, chanPtr, calledFromAsyncFlush) + Tcl_Interp *interp; /* For error reporting during close. */ + Channel *chanPtr; /* The channel to flush on. */ + int calledFromAsyncFlush; /* If nonzero then we are being + * called from an asynchronous + * flush callback. */ +{ + ChannelBuffer *bufPtr; /* Iterates over buffered output + * queue. */ + int toWrite; /* Amount of output data in current + * buffer available to be written. */ + int written; /* Amount of output data actually + * written in current round. */ + int errorCode; /* Stores POSIX error codes from + * channel driver operations. */ + + errorCode = 0; + + /* + * Loop over the queued buffers and attempt to flush as + * much as possible of the queued output to the channel. + */ + + while (1) { + + /* + * If the queue is empty and there is a ready current buffer, OR if + * the current buffer is full, then move the current buffer to the + * queue. + */ + + if (((chanPtr->curOutPtr != (ChannelBuffer *) NULL) && + (chanPtr->curOutPtr->nextAdded == chanPtr->curOutPtr->bufSize)) + || ((chanPtr->flags & BUFFER_READY) && + (chanPtr->outQueueHead == (ChannelBuffer *) NULL))) { + chanPtr->flags &= (~(BUFFER_READY)); + chanPtr->curOutPtr->nextPtr = (ChannelBuffer *) NULL; + if (chanPtr->outQueueHead == (ChannelBuffer *) NULL) { + chanPtr->outQueueHead = chanPtr->curOutPtr; + } else { + chanPtr->outQueueTail->nextPtr = chanPtr->curOutPtr; + } + chanPtr->outQueueTail = chanPtr->curOutPtr; + chanPtr->curOutPtr = (ChannelBuffer *) NULL; + } + bufPtr = chanPtr->outQueueHead; + + /* + * If we are not being called from an async flush and an async + * flush is active, we just return without producing any output. + */ + + if ((!calledFromAsyncFlush) && + (chanPtr->flags & BG_FLUSH_SCHEDULED)) { + return 0; + } + + /* + * If the output queue is still empty, break out of the while loop. + */ + + if (bufPtr == (ChannelBuffer *) NULL) { + break; /* Out of the "while (1)". */ + } + + /* + * Produce the output on the channel. + */ + + toWrite = bufPtr->nextAdded - bufPtr->nextRemoved; + written = (chanPtr->typePtr->outputProc) (chanPtr->instanceData, + chanPtr->outFile, bufPtr->buf + bufPtr->nextRemoved, + toWrite, &errorCode); + + /* + * If the write failed completely attempt to start the asynchronous + * flush mechanism and break out of this loop - do not attempt to + * write any more output at this time. + */ + + if (written < 0) { + + /* + * If the last attempt to write was interrupted, simply retry. + */ + + if (errorCode == EINTR) { + continue; + } + + /* + * If we would have blocked, attempt to set up an asynchronous + * background flushing for this channel if the channel is + * nonblocking, or block until more output can be written if + * the channel is blocking. + */ + + if ((errorCode == EWOULDBLOCK) || (errorCode == EAGAIN)) { + if (chanPtr->flags & CHANNEL_NONBLOCKING) { + if (!(chanPtr->flags & BG_FLUSH_SCHEDULED)) { + Tcl_CreateFileHandler(chanPtr->outFile, + TCL_WRITABLE, FlushEventProc, + (ClientData) chanPtr); + } + chanPtr->flags |= BG_FLUSH_SCHEDULED; + errorCode = 0; + break; /* Out of the "while (1)" loop. */ + } else { + + /* + * If the device driver did not emulate blocking behavior + * then we must do it it here. + */ + + TclWaitForFile(chanPtr->outFile, TCL_WRITABLE, -1); + continue; + } + } + + /* + * Decide whether to report the error upwards or defer it. If + * we got an error during async flush we discard all queued + * output. + */ + + if (calledFromAsyncFlush) { + if (chanPtr->unreportedError == 0) { + chanPtr->unreportedError = errorCode; + } + } else { + Tcl_SetErrno(errorCode); + } + + /* + * When we get an error we throw away all the output + * currently queued. + */ + + DiscardOutputQueued(chanPtr); + continue; + } + + bufPtr->nextRemoved += written; + + /* + * If this buffer is now empty, recycle it. + */ + + if (bufPtr->nextRemoved == bufPtr->nextAdded) { + chanPtr->outQueueHead = bufPtr->nextPtr; + if (chanPtr->outQueueHead == (ChannelBuffer *) NULL) { + chanPtr->outQueueTail = (ChannelBuffer *) NULL; + } + RecycleBuffer(chanPtr, bufPtr, 0); + } + } /* Closes "while (1)". */ + + /* + * If the queue became empty and we have an asynchronous flushing + * mechanism active, cancel the asynchronous flushing. + */ + + if ((chanPtr->outQueueHead == (ChannelBuffer *) NULL) && + (chanPtr->flags & BG_FLUSH_SCHEDULED)) { + chanPtr->flags &= (~(BG_FLUSH_SCHEDULED)); + if (chanPtr->outFile != (Tcl_File) NULL) { + Tcl_DeleteFileHandler(chanPtr->outFile); + } + } + + /* + * If the channel is flagged as closed, delete it when the refcount + * drops to zero, the output queue is empty and there is no output + * in the current output buffer. + */ + + if ((chanPtr->flags & CHANNEL_CLOSED) && (chanPtr->refCount <= 0) && + (chanPtr->outQueueHead == (ChannelBuffer *) NULL) && + ((chanPtr->curOutPtr == (ChannelBuffer *) NULL) || + (chanPtr->curOutPtr->nextAdded == + chanPtr->curOutPtr->nextRemoved))) { + return CloseChannel(interp, chanPtr, errorCode); + } + return errorCode; +} + +/* + *---------------------------------------------------------------------- + * + * CloseChannel -- + * + * Utility procedure to close a channel and free its associated + * resources. + * + * Results: + * 0 on success or a POSIX error code if the operation failed. + * + * Side effects: + * May close the actual channel; may free memory. + * + *---------------------------------------------------------------------- + */ + +static int +CloseChannel(interp, chanPtr, errorCode) + Tcl_Interp *interp; /* For error reporting. */ + Channel *chanPtr; /* The channel to close. */ + int errorCode; /* Status of operation so far. */ +{ + int result; /* Of calling driver close + * operation. */ + Channel *prevChanPtr; /* Preceding channel in list of + * all channels - used to splice a + * channel out of the list on close. */ + + /* + * No more input can be consumed so discard any leftover input. + */ + + DiscardInputQueued(chanPtr, 1); + + /* + * Discard a leftover buffer in the current output buffer field. + */ + + if (chanPtr->curOutPtr != (ChannelBuffer *) NULL) { + ckfree((char *) chanPtr->curOutPtr); + chanPtr->curOutPtr = (ChannelBuffer *) NULL; + } + + /* + * The caller guarantees that there are no more buffers + * queued for output. + */ + + if (chanPtr->outQueueHead != (ChannelBuffer *) NULL) { + panic("TclFlush, closed channel: queued output left"); + } + + /* + * If the EOF character is set in the channel, append that to the + * output device. + */ + + if ((chanPtr->outEofChar != 0) && (chanPtr->outFile != NULL)) { + int dummy; + char c; + + c = (char) chanPtr->outEofChar; + (chanPtr->typePtr->outputProc) (chanPtr->instanceData, + chanPtr->outFile, &c, 1, &dummy); + } + + /* + * Remove TCL_READABLE and TCL_WRITABLE from chanPtr->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. + */ + + chanPtr->flags &= (~(TCL_READABLE|TCL_WRITABLE)); + + /* + * Splice this channel out of the list of all channels. + */ + + if (chanPtr == firstChanPtr) { + firstChanPtr = chanPtr->nextChanPtr; + } else { + for (prevChanPtr = firstChanPtr; + (prevChanPtr != (Channel *) NULL) && + (prevChanPtr->nextChanPtr != chanPtr); + prevChanPtr = prevChanPtr->nextChanPtr) { + /* Empty loop body. */ + } + if (prevChanPtr == (Channel *) NULL) { + panic("FlushChannel: damaged channel list"); + } + prevChanPtr->nextChanPtr = chanPtr->nextChanPtr; + } + + if (chanPtr->channelName != (char *) NULL) { + ckfree(chanPtr->channelName); + } + + /* + * OK, close the channel itself. + */ + + result = (chanPtr->typePtr->closeProc) (chanPtr->instanceData, interp, + chanPtr->inFile, chanPtr->outFile); + + /* + * If we are being called synchronously, report either + * any latent error on the channel or the current error. + */ + + if (chanPtr->unreportedError != 0) { + errorCode = chanPtr->unreportedError; + } + if (errorCode == 0) { + errorCode = result; + if (errorCode != 0) { + Tcl_SetErrno(errorCode); + } + } + + Tcl_EventuallyFree((ClientData) chanPtr, TCL_DYNAMIC); + + return errorCode; +} + +/* + *---------------------------------------------------------------------- + * + * 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. + * + *---------------------------------------------------------------------- + */ + + /* 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. */ +{ + 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. */ + int result; /* Of calling FlushChannel. */ + + chanPtr = (Channel *) chan; + + if (chanPtr->refCount > 0) { + panic("called Tcl_Close on channel with refcount > 0"); + } + + /* + * Remove the channel from the standard channel table. + */ + + if (Tcl_GetStdChannel(TCL_STDIN) == chan) { + Tcl_SetStdChannel(NULL, TCL_STDIN); + } else if (Tcl_GetStdChannel(TCL_STDOUT) == chan) { + Tcl_SetStdChannel(NULL, TCL_STDOUT); + } else if (Tcl_GetStdChannel(TCL_STDERR) == chan) { + Tcl_SetStdChannel(NULL, TCL_STDERR); + } + + /* + * Remove all the channel handler records attached to the channel + * itself. + */ + + for (chPtr = chanPtr->chPtr; + chPtr != (ChannelHandler *) NULL; + chPtr = chNext) { + chNext = chPtr->nextPtr; + ckfree((char *) chPtr); + } + chanPtr->chPtr = (ChannelHandler *) NULL; + + /* + * 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. + */ + + chanPtr->interestMask = 0; + + /* + * Remove any EventScript records for this channel. + */ + + for (ePtr = chanPtr->scriptRecordPtr; + ePtr != (EventScriptRecord *) NULL; + ePtr = eNextPtr) { + eNextPtr = ePtr->nextPtr; + Tcl_EventuallyFree((ClientData)ePtr->script, TCL_DYNAMIC); + ckfree((char *) ePtr); + } + chanPtr->scriptRecordPtr = (EventScriptRecord *) NULL; + + /* + * Invoke the registered close callbacks and delete their records. + */ + + while (chanPtr->closeCbPtr != (CloseCallback *) NULL) { + cbPtr = chanPtr->closeCbPtr; + chanPtr->closeCbPtr = cbPtr->nextPtr; + (cbPtr->proc) (cbPtr->clientData); + ckfree((char *) cbPtr); + } + + /* + * And remove any events for this channel from the event queue. + */ + + Tcl_DeleteEvents(ChannelEventDeleteProc, (ClientData) chanPtr); + + /* + * Ensure that the last output buffer will be flushed. + */ + + if ((chanPtr->curOutPtr != (ChannelBuffer *) NULL) && + (chanPtr->curOutPtr->nextAdded > chanPtr->curOutPtr->nextRemoved)) { + chanPtr->flags |= BUFFER_READY; + } + + /* + * The call to FlushChannel will flush any queued output and invoke + * the close function of the channel driver, or it will set up the + * channel to be flushed and closed asynchronously. + */ + + chanPtr->flags |= CHANNEL_CLOSED; + result = FlushChannel(interp, chanPtr, 0); + if (result != 0) { + return TCL_ERROR; + } + + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * ChannelEventDeleteProc -- + * + * This procedure returns 1 if the event passed in is for the + * channel passed in as the second argument. This procedure is + * used as a filter for events to delete in a call to + * Tcl_DeleteEvents in CloseChannel. + * + * Results: + * 1 if matching, 0 otherwise. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static int +ChannelEventDeleteProc(evPtr, clientData) + Tcl_Event *evPtr; /* The event to check for a match. */ + ClientData clientData; /* The channel to check for. */ +{ + ChannelHandlerEvent *cEvPtr; + Channel *chanPtr; + + if (evPtr->proc != ChannelHandlerEventProc) { + return 0; + } + cEvPtr = (ChannelHandlerEvent *) evPtr; + chanPtr = (Channel *) clientData; + if (cEvPtr->chanPtr != chanPtr) { + return 0; + } + return 1; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_Write -- + * + * Puts a sequence of characters 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. + * + * 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. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_Write(chan, srcPtr, slen) + Tcl_Channel chan; /* The channel to buffer output for. */ + char *srcPtr; /* Output to buffer. */ + int slen; /* Its length. Negative means + * the output is null terminated + * and we must compute its length. */ +{ + Channel *chanPtr; /* The actual channel. */ + ChannelBuffer *outBufPtr; /* Current output buffer. */ + int foundNewline; /* Did we find a newline in output? */ + char *dPtr, *sPtr; /* Search variables for newline. */ + int crsent; /* In CRLF eol translation mode, + * remember the fact that a CR was + * output to the channel without + * its following NL. */ + int i; /* Loop index for newline search. */ + int destCopied; /* How many bytes were used in this + * destination buffer to hold the + * output? */ + int totalDestCopied; /* How many bytes total were + * copied to the channel buffer? */ + int srcCopied; /* How many bytes were copied from + * the source string? */ + char *destPtr; /* Where in line to copy to? */ + + chanPtr = (Channel *) chan; + + /* + * Check for unreported error. + */ + + if (chanPtr->unreportedError != 0) { + Tcl_SetErrno(chanPtr->unreportedError); + chanPtr->unreportedError = 0; + return -1; + } + + /* + * If the channel is not open for writing punt. + */ + + if (!(chanPtr->flags & TCL_WRITABLE)) { + Tcl_SetErrno(EACCES); + return -1; + } + + /* + * If length passed is negative, assume that the output is null terminated + * and compute its length. + */ + + if (slen < 0) { + slen = strlen(srcPtr); + } + + /* + * If we are in network (or windows) translation mode, record the fact + * that we have not yet sent a CR to the channel. + */ + + crsent = 0; + + /* + * Loop filling buffers and flushing them until all output has been + * consumed. + */ + + srcCopied = 0; + totalDestCopied = 0; + + while (slen > 0) { + + /* + * Make sure there is a current output buffer to accept output. + */ + + if (chanPtr->curOutPtr == (ChannelBuffer *) NULL) { + chanPtr->curOutPtr = (ChannelBuffer *) ckalloc((unsigned) + (CHANNELBUFFER_HEADER_SIZE + chanPtr->bufSize)); + chanPtr->curOutPtr->nextAdded = 0; + chanPtr->curOutPtr->nextRemoved = 0; + chanPtr->curOutPtr->bufSize = chanPtr->bufSize; + chanPtr->curOutPtr->nextPtr = (ChannelBuffer *) NULL; + } + + outBufPtr = chanPtr->curOutPtr; + + destCopied = outBufPtr->bufSize - outBufPtr->nextAdded; + if (destCopied > slen) { + destCopied = slen; + } + + destPtr = outBufPtr->buf + outBufPtr->nextAdded; + switch (chanPtr->outputTranslation) { + case TCL_TRANSLATE_LF: + srcCopied = destCopied; + memcpy((VOID *) destPtr, (VOID *) srcPtr, (size_t) destCopied); + break; + case TCL_TRANSLATE_CR: + srcCopied = destCopied; + memcpy((VOID *) destPtr, (VOID *) srcPtr, (size_t) destCopied); + for (dPtr = destPtr; dPtr < destPtr + destCopied; dPtr++) { + if (*dPtr == '\n') { + *dPtr = '\r'; + } + } + break; + case TCL_TRANSLATE_CRLF: + for (srcCopied = 0, dPtr = destPtr, sPtr = srcPtr; + dPtr < destPtr + destCopied; + dPtr++, sPtr++, srcCopied++) { + if (*sPtr == '\n') { + if (crsent) { + *dPtr = '\n'; + crsent = 0; + } else { + *dPtr = '\r'; + crsent = 1; + sPtr--, srcCopied--; + } + } else { + *dPtr = *sPtr; + } + } + break; + case TCL_TRANSLATE_AUTO: + panic("Tcl_Write: AUTO output translation mode not supported"); + default: + panic("Tcl_Write: unknown output translation mode"); + } + + /* + * The current buffer is ready for output if it is full, or if it + * contains a newline and this channel is line-buffered, or if it + * contains any output and this channel is unbuffered. + */ + + outBufPtr->nextAdded += destCopied; + if (!(chanPtr->flags & BUFFER_READY)) { + if (outBufPtr->nextAdded == outBufPtr->bufSize) { + chanPtr->flags |= BUFFER_READY; + } else if (chanPtr->flags & CHANNEL_LINEBUFFERED) { + for (sPtr = srcPtr, i = 0, foundNewline = 0; + (i < srcCopied) && (!foundNewline); + i++, sPtr++) { + if (*sPtr == '\n') { + foundNewline = 1; + break; + } + } + if (foundNewline) { + chanPtr->flags |= BUFFER_READY; + } + } else if (chanPtr->flags & CHANNEL_UNBUFFERED) { + chanPtr->flags |= BUFFER_READY; + } + } + + totalDestCopied += srcCopied; + srcPtr += srcCopied; + slen -= srcCopied; + + if (chanPtr->flags & BUFFER_READY) { + if (FlushChannel(NULL, chanPtr, 0) != 0) { + return -1; + } + } + } /* Closes "while" */ + + return totalDestCopied; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_Flush -- + * + * Flushes output data on a channel. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * May flush output queued on this channel. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_Flush(chan) + Tcl_Channel chan; /* The Channel to flush. */ +{ + int result; /* Of calling FlushChannel. */ + Channel *chanPtr; /* The actual channel. */ + + chanPtr = (Channel *) chan; + + /* + * Check for unreported error. + */ + + if (chanPtr->unreportedError != 0) { + Tcl_SetErrno(chanPtr->unreportedError); + chanPtr->unreportedError = 0; + return TCL_ERROR; + } + + /* + * If the channel is not open for writing punt. + */ + + if (!(chanPtr->flags & TCL_WRITABLE)) { + Tcl_SetErrno(EACCES); + return TCL_ERROR; + } + + /* + * Force current output buffer to be output also. + */ + + if ((chanPtr->curOutPtr != (ChannelBuffer *) NULL) && + (chanPtr->curOutPtr->nextAdded > 0)) { + chanPtr->flags |= BUFFER_READY; + } + + result = FlushChannel(NULL, chanPtr, 0); + if (result != 0) { + return TCL_ERROR; + } + + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * DiscardInputQueued -- + * + * Discards any input read from the channel but not yet consumed + * by Tcl reading commands. + * + * Results: + * None. + * + * Side effects: + * May discard input from the channel. If discardLastBuffer is zero, + * leaves one buffer in place for back-filling. + * + *---------------------------------------------------------------------- + */ + +static void +DiscardInputQueued(chanPtr, discardSavedBuffers) + Channel *chanPtr; /* Channel on which to discard + * the queued input. */ + int discardSavedBuffers; /* If non-zero, discard all buffers including + * last one. */ +{ + ChannelBuffer *bufPtr, *nxtPtr; /* Loop variables. */ + + bufPtr = chanPtr->inQueueHead; + chanPtr->inQueueHead = (ChannelBuffer *) NULL; + chanPtr->inQueueTail = (ChannelBuffer *) NULL; + for (; bufPtr != (ChannelBuffer *) NULL; bufPtr = nxtPtr) { + nxtPtr = bufPtr->nextPtr; + RecycleBuffer(chanPtr, bufPtr, discardSavedBuffers); + } + + /* + * If discardSavedBuffers is nonzero, must also discard any previously + * saved buffer in the saveInBufPtr field. + */ + + if (discardSavedBuffers) { + if (chanPtr->saveInBufPtr != (ChannelBuffer *) NULL) { + ckfree((char *) chanPtr->saveInBufPtr); + chanPtr->saveInBufPtr = (ChannelBuffer *) NULL; + } + } +} + +/* + *---------------------------------------------------------------------- + * + * GetInput -- + * + * Reads input data from a device or file into an input buffer. + * + * Results: + * A Posix error code or 0. + * + * Side effects: + * Reads from the underlying device. + * + *---------------------------------------------------------------------- + */ + +static int +GetInput(chanPtr) + Channel *chanPtr; /* Channel to read input from. */ +{ + int toRead; /* How much to read? */ + int result; /* Of calling driver. */ + int nread; /* How much was read from channel? */ + ChannelBuffer *bufPtr; /* New buffer to add to input queue. */ + + /* + * See if we can fill an existing buffer. If we can, read only + * as much as will fit in it. Otherwise allocate a new buffer, + * add it to the input queue and attempt to fill it to the max. + */ + + if ((chanPtr->inQueueTail != (ChannelBuffer *) NULL) && + (chanPtr->inQueueTail->nextAdded < chanPtr->inQueueTail->bufSize)) { + bufPtr = chanPtr->inQueueTail; + toRead = bufPtr->bufSize - bufPtr->nextAdded; + } else { + if (chanPtr->saveInBufPtr != (ChannelBuffer *) NULL) { + bufPtr = chanPtr->saveInBufPtr; + chanPtr->saveInBufPtr = (ChannelBuffer *) NULL; + } else { + bufPtr = (ChannelBuffer *) ckalloc( + ((unsigned) CHANNELBUFFER_HEADER_SIZE + chanPtr->bufSize)); + bufPtr->bufSize = chanPtr->bufSize; + } + bufPtr->nextRemoved = 0; + bufPtr->nextAdded = 0; + toRead = bufPtr->bufSize; + if (chanPtr->inQueueTail == (ChannelBuffer *) NULL) { + chanPtr->inQueueHead = bufPtr; + } else { + chanPtr->inQueueTail->nextPtr = bufPtr; + } + chanPtr->inQueueTail = bufPtr; + bufPtr->nextPtr = (ChannelBuffer *) NULL; + } + + while (1) { + + /* + * If EOF is set, we should avoid calling the driver because on some + * platforms it is impossible to read from a device after EOF. + */ + + if (chanPtr->flags & CHANNEL_EOF) { + break; + } + nread = (chanPtr->typePtr->inputProc) (chanPtr->instanceData, + chanPtr->inFile, bufPtr->buf + bufPtr->nextAdded, + toRead, &result); + if (nread == 0) { + chanPtr->flags |= CHANNEL_EOF; + break; + } else if (nread < 0) { + if ((result == EWOULDBLOCK) || (result == EAGAIN)) { + chanPtr->flags |= CHANNEL_BLOCKED; + result = EAGAIN; + if (chanPtr->flags & CHANNEL_NONBLOCKING) { + Tcl_SetErrno(result); + return result; + } else { + + /* + * If the device driver did not emulate blocking behavior + * then we have to do it here. + */ + + TclWaitForFile(chanPtr->inFile, TCL_READABLE, -1); + } + } else { + Tcl_SetErrno(result); + return result; + } + } else { + bufPtr->nextAdded += nread; + + /* + * If we get a short read, signal up that we may be BLOCKED. We + * should avoid calling the driver because on some platforms we + * will block in the low level reading code even though the + * channel is set into nonblocking mode. + */ + + if (nread < toRead) { + chanPtr->flags |= CHANNEL_BLOCKED; + } + break; + } + } + + return 0; +} + +/* + *---------------------------------------------------------------------- + * + * CopyAndTranslateBuffer -- + * + * Copy at most one buffer of input to the result space, doing + * eol translations according to mode in effect currently. + * + * Results: + * Number of characters (as opposed to bytes) copied. May return + * zero if no input is available to be translated. + * + * Side effects: + * Consumes buffered input. May deallocate one buffer. + * + *---------------------------------------------------------------------- + */ + +static int +CopyAndTranslateBuffer(chanPtr, result, space) + Channel *chanPtr; /* The channel from which to read input. */ + char *result; /* Where to store the copied input. */ + int space; /* How many bytes are available in result + * to store the copied input? */ +{ + int bytesInBuffer; /* How many bytes are available to be + * copied in the current input buffer? */ + int copied; /* How many characters were already copied + * into the destination space? */ + ChannelBuffer *bufPtr; /* The buffer from which to copy bytes. */ + char curByte; /* The byte we are currently translating. */ + int i; /* Iterates over the copied input looking + * for the input eofChar. */ + + /* + * If there is no input at all, return zero. The invariant is that either + * there is no buffer in the queue, or if the first buffer is empty, it + * is also the last buffer (and thus there is no input in the queue). + * Note also that if the buffer is empty, we leave it in the queue. + */ + + if (chanPtr->inQueueHead == (ChannelBuffer *) NULL) { + return 0; + } + bufPtr = chanPtr->inQueueHead; + bytesInBuffer = bufPtr->nextAdded - bufPtr->nextRemoved; + if (bytesInBuffer < space) { + space = bytesInBuffer; + } + copied = 0; + switch (chanPtr->inputTranslation) { + case TCL_TRANSLATE_LF: + + if (space == 0) { + return 0; + } + + /* + * Copy the current chunk into the result buffer. + */ + + memcpy((VOID *) result, + (VOID *)(bufPtr->buf + bufPtr->nextRemoved), + (size_t) space); + bufPtr->nextRemoved += space; + copied = space; + break; + + case TCL_TRANSLATE_CR: + + if (space == 0) { + return 0; + } + + /* + * Copy the current chunk into the result buffer, then + * replace all \r with \n. + */ + + memcpy((VOID *) result, + (VOID *)(bufPtr->buf + bufPtr->nextRemoved), + (size_t) space); + bufPtr->nextRemoved += space; + for (copied = 0; copied < space; copied++) { + if (result[copied] == '\r') { + result[copied] = '\n'; + } + } + break; + + case TCL_TRANSLATE_CRLF: + + /* + * If there is a held-back "\r" at EOF, produce it now. + */ + + if (space == 0) { + if ((chanPtr->flags & (INPUT_SAW_CR | CHANNEL_EOF)) == + (INPUT_SAW_CR | CHANNEL_EOF)) { + result[0] = '\r'; + chanPtr->flags &= (~(INPUT_SAW_CR)); + return 1; + } + return 0; + } + + /* + * Copy the current chunk and replace "\r\n" with "\n" + * (but not standalone "\r"!). + */ + + for (copied = 0; + (copied < space) && + (bufPtr->nextRemoved < bufPtr->nextAdded); + copied++) { + curByte = bufPtr->buf[bufPtr->nextRemoved]; + bufPtr->nextRemoved++; + if (curByte == '\r') { + if (chanPtr->flags & INPUT_SAW_CR) { + result[copied] = '\r'; + } else { + chanPtr->flags |= INPUT_SAW_CR; + copied--; + } + } else if (curByte == '\n') { + chanPtr->flags &= (~(INPUT_SAW_CR)); + result[copied] = '\n'; + } else { + if (chanPtr->flags & INPUT_SAW_CR) { + chanPtr->flags &= (~(INPUT_SAW_CR)); + result[copied] = '\r'; + copied++; + } + result[copied] = curByte; + } + } + break; + + case TCL_TRANSLATE_AUTO: + + if (space == 0) { + return 0; + } + + /* + * Loop over the current buffer, converting "\r" and "\r\n" + * to "\n". + */ + + for (copied = 0; + (copied < space) && + (bufPtr->nextRemoved < bufPtr->nextAdded); ) { + curByte = bufPtr->buf[bufPtr->nextRemoved]; + bufPtr->nextRemoved++; + if (curByte == '\r') { + result[copied] = '\n'; + copied++; + if (bufPtr->nextRemoved < bufPtr->nextAdded) { + if (bufPtr->buf[bufPtr->nextRemoved] == '\n') { + bufPtr->nextRemoved++; + } + chanPtr->flags &= (~(INPUT_SAW_CR)); + } else { + chanPtr->flags |= INPUT_SAW_CR; + } + } else { + if (curByte == '\n') { + if (!(chanPtr->flags & INPUT_SAW_CR)) { + result[copied] = '\n'; + copied++; + } + } else { + result[copied] = curByte; + copied++; + } + chanPtr->flags &= (~(INPUT_SAW_CR)); + } + } + break; + + default: + panic("unknown eol translation mode"); + } + + /* + * If an in-stream EOF character is set for this channel,, check that + * the input we copied so far does not contain the EOF char. If it does, + * copy only up to and excluding that character. + */ + + if (chanPtr->inEofChar != 0) { + for (i = 0; i < copied; i++) { + if (result[i] == (char) chanPtr->inEofChar) { + break; + } + } + if (i < copied) { + + /* + * Set sticky EOF so that no further input is presented + * to the caller. + */ + + chanPtr->flags |= (CHANNEL_EOF | CHANNEL_STICKY_EOF); + + /* + * Reset the start of valid data in the input buffer to the + * position of the eofChar, so that subsequent reads will + * encounter it immediately. First we set it to the position + * of the last byte consumed if all result bytes were the + * product of one input byte; since it is possible that "\r\n" + * contracted to "\n" in the result, we have to search back + * from that position until we find the eofChar, because it + * is possible that its actual position in the buffer is n + * bytes further back (n is the number of "\r\n" sequences + * that were contracted to "\n" in the result). + */ + + bufPtr->nextRemoved -= (copied - i); + while ((bufPtr->nextRemoved > 0) && + (bufPtr->buf[bufPtr->nextRemoved] != + (char) chanPtr->inEofChar)) { + bufPtr->nextRemoved--; + } + copied = i; + } + } + + /* + * If the current buffer is empty recycle it. + */ + + if (bufPtr->nextRemoved == bufPtr->nextAdded) { + chanPtr->inQueueHead = bufPtr->nextPtr; + if (chanPtr->inQueueHead == (ChannelBuffer *) NULL) { + chanPtr->inQueueTail = (ChannelBuffer *) NULL; + } + RecycleBuffer(chanPtr, bufPtr, 0); + } + + /* + * Return the number of characters copied into the result buffer. + * This may be different from the number of bytes consumed, because + * of EOL translations. + */ + + return copied; +} + +/* + *---------------------------------------------------------------------- + * + * ScanBufferForEOL -- + * + * Scans one buffer for EOL according to the specified EOL + * translation mode. If it sees the input eofChar for the channel + * it stops also. + * + * Results: + * TRUE if EOL is found, FALSE otherwise. Also sets output parameter + * bytesToEOLPtr to the number of bytes so far to EOL, and crSeenPtr + * to whether a "\r" was seen. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static int +ScanBufferForEOL(chanPtr, bufPtr, translation, eofChar, bytesToEOLPtr, + crSeenPtr) + Channel *chanPtr; + ChannelBuffer *bufPtr; /* Buffer to scan for EOL. */ + Tcl_EolTranslation translation; /* Translation mode to use. */ + int eofChar; /* EOF char to look for. */ + int *bytesToEOLPtr; /* Running counter. */ + int *crSeenPtr; /* Has "\r" been seen? */ +{ + char *rPtr; /* Iterates over input string. */ + char *sPtr; /* Where to stop search? */ + int EOLFound; + int bytesToEOL; + + for (EOLFound = 0, rPtr = bufPtr->buf + bufPtr->nextRemoved, + sPtr = bufPtr->buf + bufPtr->nextAdded, + bytesToEOL = *bytesToEOLPtr; + (!EOLFound) && (rPtr < sPtr); + rPtr++) { + switch (translation) { + case TCL_TRANSLATE_AUTO: + if ((*rPtr == (char) eofChar) && (eofChar != 0)) { + chanPtr->flags |= (CHANNEL_EOF | CHANNEL_STICKY_EOF); + EOLFound = 1; + } else if (*rPtr == '\n') { + + /* + * CopyAndTranslateBuffer wants to know the length + * of the result, not the input. The input is one + * larger because "\r\n" shrinks to "\n". + */ + + if (!(*crSeenPtr)) { + bytesToEOL++; + EOLFound = 1; + } else { + + /* + * This is a lf at the begining of a buffer + * where the previous buffer ended in a cr. + * Consume this lf because we've already emitted + * the newline for this crlf sequence. ALSO, if + * bytesToEOL is 0 (which means that we are at the + * first character of the scan), unset the + * INPUT_SAW_CR flag in the channel, because we + * already handled it; leaving it set would cause + * CopyAndTranslateBuffer to potentially consume + * another lf if one follows the current byte. + */ + + bufPtr->nextRemoved++; + *crSeenPtr = 0; + chanPtr->flags &= (~(INPUT_SAW_CR)); + } + } else if (*rPtr == '\r') { + bytesToEOL++; + EOLFound = 1; + } else { + *crSeenPtr = 0; + bytesToEOL++; + } + break; + case TCL_TRANSLATE_LF: + if ((*rPtr == (char) eofChar) && (eofChar != 0)) { + chanPtr->flags |= (CHANNEL_EOF | CHANNEL_STICKY_EOF); + EOLFound = 1; + } else { + if (*rPtr == '\n') { + EOLFound = 1; + } + bytesToEOL++; + } + break; + case TCL_TRANSLATE_CR: + if ((*rPtr == (char) eofChar) && (eofChar != 0)) { + chanPtr->flags |= (CHANNEL_EOF | CHANNEL_STICKY_EOF); + EOLFound = 1; + } else { + if (*rPtr == '\r') { + EOLFound = 1; + } + bytesToEOL++; + } + break; + case TCL_TRANSLATE_CRLF: + if ((*rPtr == (char) eofChar) && (eofChar != 0)) { + chanPtr->flags |= (CHANNEL_EOF | CHANNEL_STICKY_EOF); + EOLFound = 1; + } else if (*rPtr == '\n') { + + /* + * CopyAndTranslateBuffer wants to know the length + * of the result, not the input. The input is one + * larger because crlf shrinks to lf. + */ + + if (*crSeenPtr) { + EOLFound = 1; + } else { + bytesToEOL++; + } + } else { + if (*rPtr == '\r') { + *crSeenPtr = 1; + } else { + *crSeenPtr = 0; + } + bytesToEOL++; + } + break; + default: + panic("unknown eol translation mode"); + } + } + + *bytesToEOLPtr = bytesToEOL; + return EOLFound; +} + +/* + *---------------------------------------------------------------------- + * + * ScanInputForEOL -- + * + * Scans queued input for chanPtr for an end of line (according to the + * current EOL translation mode) and returns the number of bytes + * upto and including the end of line, or -1 if none was found. + * + * Results: + * Count of bytes upto and including the end of line if one is present + * or -1 if none was found. Also returns in an output parameter the + * number of bytes queued if no end of line was found. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static int +ScanInputForEOL(chanPtr, bytesQueuedPtr) + Channel *chanPtr; /* Channel for which to scan queued + * input for end of line. */ + int *bytesQueuedPtr; /* Where to store the number of bytes + * currently queued if no end of line + * was found. */ +{ + ChannelBuffer *bufPtr; /* Iterates over queued buffers. */ + int bytesToEOL; /* How many bytes to end of line? */ + int EOLFound; /* Did we find an end of line? */ + int crSeen; /* Did we see a "\r" in CRLF mode? */ + + *bytesQueuedPtr = 0; + bytesToEOL = 0; + EOLFound = 0; + for (bufPtr = chanPtr->inQueueHead, + crSeen = (chanPtr->flags & INPUT_SAW_CR) ? 1 : 0; + (!EOLFound) && (bufPtr != (ChannelBuffer *) NULL); + bufPtr = bufPtr->nextPtr) { + EOLFound = ScanBufferForEOL(chanPtr, bufPtr, chanPtr->inputTranslation, + chanPtr->inEofChar, &bytesToEOL, &crSeen); + } + + if (EOLFound == 0) { + *bytesQueuedPtr = bytesToEOL; + return -1; + } + return bytesToEOL; +} + +/* + *---------------------------------------------------------------------- + * + * GetEOL -- + * + * Accumulate input into the channel input buffer queue until an + * end of line has been seen. + * + * Results: + * Number of bytes buffered or -1 on failure. + * + * Side effects: + * Consumes input from the channel. + * + *---------------------------------------------------------------------- + */ + +static int +GetEOL(chanPtr) + Channel *chanPtr; /* Channel to queue input on. */ +{ + int result; /* Of getting another buffer from the + * channel. */ + int bytesToEOL; /* How many bytes in buffer up to and + * including the end of line? */ + int bytesQueued; /* How many bytes are queued currently + * in the input chain of the channel? */ + + while (1) { + bytesToEOL = ScanInputForEOL(chanPtr, &bytesQueued); + if (bytesToEOL > 0) { + chanPtr->flags &= (~(CHANNEL_BLOCKED)); + return bytesToEOL; + } + if (chanPtr->flags & CHANNEL_EOF) { + /* + * Boundary case where cr was at the end of the previous buffer + * and this buffer just has a newline. At EOF our caller wants + * to see -1 for the line length. + */ + return (bytesQueued == 0) ? -1 : bytesQueued ; + } + if (chanPtr->flags & CHANNEL_BLOCKED) { + if (chanPtr->flags & CHANNEL_NONBLOCKING) { + return -1; + } + chanPtr->flags &= (~(CHANNEL_BLOCKED)); + } + result = GetInput(chanPtr); + if (result != 0) { + if (result == EAGAIN) { + chanPtr->flags |= CHANNEL_BLOCKED; + } + return -1; + } + } +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_Read -- + * + * Reads a given number of characters from a channel. + * + * 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. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_Read(chan, bufPtr, toRead) + Tcl_Channel chan; /* The channel from which to read. */ + char *bufPtr; /* Where to store input read. */ + int toRead; /* Maximum number of characters to read. */ +{ + Channel *chanPtr; /* The real IO channel. */ + int copied; /* How many characters were copied into + * the result string? */ + int copiedNow; /* How many characters were copied from + * the current input buffer? */ + int result; /* Of calling GetInput. */ + + chanPtr = (Channel *) chan; + + /* + * Check for unreported error. + */ + + if (chanPtr->unreportedError != 0) { + Tcl_SetErrno(chanPtr->unreportedError); + chanPtr->unreportedError = 0; + return -1; + } + + /* + * Punt if the channel is not opened for reading. + */ + + if (!(chanPtr->flags & TCL_READABLE)) { + Tcl_SetErrno(EACCES); + return -1; + } + + /* + * If we have not encountered a sticky EOF, clear the EOF bit. Either + * way clear the BLOCKED bit. We want to discover these anew during + * each operation. + */ + + if (!(chanPtr->flags & CHANNEL_STICKY_EOF)) { + chanPtr->flags &= (~(CHANNEL_EOF)); + } + chanPtr->flags &= (~(CHANNEL_BLOCKED)); + + for (copied = 0; copied < toRead; copied += copiedNow) { + copiedNow = CopyAndTranslateBuffer(chanPtr, bufPtr + copied, + toRead - copied); + if (copiedNow == 0) { + if (chanPtr->flags & CHANNEL_EOF) { + return copied; + } + if (chanPtr->flags & CHANNEL_BLOCKED) { + if (chanPtr->flags & CHANNEL_NONBLOCKING) { + return copied; + } + chanPtr->flags &= (~(CHANNEL_BLOCKED)); + } + result = GetInput(chanPtr); + if (result != 0) { + if (result == EAGAIN) { + return copied; + } + return -1; + } + } + } + chanPtr->flags &= (~(CHANNEL_BLOCKED)); + return copied; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_Gets -- + * + * Reads a complete line of input from the channel. + * + * Results: + * Length of line read or -1 if error, EOF or blocked. If -1, use + * Tcl_GetErrno() to retrieve the POSIX error code for the + * error or condition that occurred. + * + * Side effects: + * May flush output on the channel. May cause input to be + * consumed from the channel. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_Gets(chan, lineRead) + Tcl_Channel chan; /* Channel from which to read. */ + Tcl_DString *lineRead; /* The characters of the line read + * (excluding the terminating newline if + * present) will be appended to this + * DString. The caller must have initialized + * it and is responsible for managing the + * storage. */ +{ + Channel *chanPtr; /* The channel to read from. */ + char *buf; /* Points into DString where data + * will be stored. */ + int offset; /* Offset from start of DString at + * which to append the line just read. */ + int copiedTotal; /* Accumulates total length of input copied. */ + int copiedNow; /* How many bytes were copied from the + * current input buffer? */ + int lineLen; /* Length of line read, including the + * translated newline. If this is zero + * and neither EOF nor BLOCKED is set, + * the current line is empty. */ + + chanPtr = (Channel *) chan; + + /* + * Check for unreported error. + */ + + if (chanPtr->unreportedError != 0) { + Tcl_SetErrno(chanPtr->unreportedError); + chanPtr->unreportedError = 0; + return -1; + } + + /* + * Punt if the channel is not opened for reading. + */ + + if (!(chanPtr->flags & TCL_READABLE)) { + Tcl_SetErrno(EACCES); + return -1; + } + + /* + * If we have not encountered a sticky EOF, clear the EOF bit + * (sticky EOF is set if we have seen the input eofChar, to prevent + * reading beyond the eofChar). Also, always clear the BLOCKED bit. + * We want to discover these conditions anew in each operation. + */ + + if (!(chanPtr->flags & CHANNEL_STICKY_EOF)) { + chanPtr->flags &= (~(CHANNEL_EOF)); + } + chanPtr->flags &= (~(CHANNEL_BLOCKED)); + lineLen = GetEOL(chanPtr); + if (lineLen < 0) { + return -1; + } + if (lineLen == 0) { + if (chanPtr->flags & (CHANNEL_EOF | CHANNEL_BLOCKED)) { + return -1; + } + return 0; + } + offset = Tcl_DStringLength(lineRead); + Tcl_DStringSetLength(lineRead, lineLen + offset); + buf = Tcl_DStringValue(lineRead) + offset; + + for (copiedTotal = 0; copiedTotal < lineLen; copiedTotal += copiedNow) { + copiedNow = CopyAndTranslateBuffer(chanPtr, buf + copiedTotal, + lineLen - copiedTotal); + } + if ((copiedTotal > 0) && (buf[copiedTotal - 1] == '\n')) { + copiedTotal--; + } + Tcl_DStringSetLength(lineRead, copiedTotal + offset); + return copiedTotal; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_Seek -- + * + * Implements seeking on Tcl Channels. This is a public function + * so that other C facilities may be implemented on top of it. + * + * Results: + * The new access point or -1 on error. If error, use Tcl_GetErrno() + * to retrieve the POSIX error code for the error that occurred. + * + * Side effects: + * May flush output on the channel. May discard queued input. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_Seek(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? */ +{ + Channel *chanPtr; /* The real IO channel. */ + ChannelBuffer *bufPtr; /* Iterates over queued input + * and output buffers. */ + int inputBuffered, outputBuffered; + int result; /* Of device driver operations. */ + int 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. */ + + chanPtr = (Channel *) chan; + + /* + * Check for unreported error. + */ + + if (chanPtr->unreportedError != 0) { + Tcl_SetErrno(chanPtr->unreportedError); + chanPtr->unreportedError = 0; + return -1; + } + + /* + * Disallow seek on channels that are open for neither writing nor + * reading (e.g. socket server channels). + */ + + if (!(chanPtr->flags & (TCL_WRITABLE|TCL_READABLE))) { + Tcl_SetErrno(EACCES); + return -1; + } + + /* + * Disallow seek on channels whose type does not have a seek procedure + * defined. This means that the channel does not support seeking. + */ + + if (chanPtr->typePtr->seekProc == (Tcl_DriverSeekProc *) NULL) { + Tcl_SetErrno(EINVAL); + return -1; + } + + /* + * Compute how much input and output is buffered. If both input and + * output is buffered, cannot compute the current position. + */ + + for (bufPtr = chanPtr->inQueueHead, inputBuffered = 0; + bufPtr != (ChannelBuffer *) NULL; + bufPtr = bufPtr->nextPtr) { + inputBuffered += (bufPtr->nextAdded - bufPtr->nextRemoved); + } + for (bufPtr = chanPtr->outQueueHead, outputBuffered = 0; + bufPtr != (ChannelBuffer *) NULL; + bufPtr = bufPtr->nextPtr) { + outputBuffered += (bufPtr->nextAdded - bufPtr->nextRemoved); + } + if ((chanPtr->curOutPtr != (ChannelBuffer *) NULL) && + (chanPtr->curOutPtr->nextAdded > chanPtr->curOutPtr->nextRemoved)) { + chanPtr->flags |= BUFFER_READY; + outputBuffered += + (chanPtr->curOutPtr->nextAdded - chanPtr->curOutPtr->nextRemoved); + } + if ((inputBuffered != 0) && (outputBuffered != 0)) { + Tcl_SetErrno(EFAULT); + return -1; + } + + /* + * If we are seeking relative to the current position, compute the + * corrected offset taking into account the amount of unread input. + */ + + if (mode == SEEK_CUR) { + offset -= inputBuffered; + } + + /* + * Discard any queued input - this input should not be read after + * the seek. + */ + + DiscardInputQueued(chanPtr, 0); + + /* + * Reset EOF and BLOCKED flags. We invalidate them by moving the + * access point. Also clear CR related flags. + */ + + chanPtr->flags &= + (~(CHANNEL_EOF | CHANNEL_STICKY_EOF | CHANNEL_BLOCKED | INPUT_SAW_CR)); + + /* + * If the channel is in asynchronous output mode, switch it back + * to synchronous mode and cancel any async flush that may be + * scheduled. After the flush, the channel will be put back into + * asynchronous output mode. + */ + + wasAsync = 0; + if (chanPtr->flags & CHANNEL_NONBLOCKING) { + wasAsync = 1; + result = 0; + if (chanPtr->typePtr->blockModeProc != NULL) { + result = (chanPtr->typePtr->blockModeProc) (chanPtr->instanceData, + chanPtr->inFile, chanPtr->outFile, TCL_MODE_BLOCKING); + } + if (result != 0) { + Tcl_SetErrno(result); + return -1; + } + chanPtr->flags &= (~(CHANNEL_NONBLOCKING)); + if (chanPtr->flags & BG_FLUSH_SCHEDULED) { + Tcl_DeleteFileHandler(chanPtr->outFile); + chanPtr->flags &= (~(BG_FLUSH_SCHEDULED)); + } + } + + /* + * If the flush fails we cannot recover the original position. In + * that case the seek is not attempted because we do not know where + * the access position is - instead we return the error. FlushChannel + * has already called Tcl_SetErrno() to report the error upwards. + * If the flush succeeds we do the seek also. + */ + + if (FlushChannel(NULL, chanPtr, 0) != 0) { + curPos = -1; + } else { + + /* + * Now seek to the new position in the channel as requested by the + * caller. + */ + + curPos = (chanPtr->typePtr->seekProc) (chanPtr->instanceData, + chanPtr->inFile, chanPtr->outFile, (long) offset, + mode, &result); + if (curPos == -1) { + Tcl_SetErrno(result); + } + } + + /* + * Restore to nonblocking mode if that was the previous behavior. + * + * NOTE: Even if there was an async flush active we do not restore + * it now because we already flushed all the queued output, above. + */ + + if (wasAsync) { + chanPtr->flags |= CHANNEL_NONBLOCKING; + result = 0; + if (chanPtr->typePtr->blockModeProc != NULL) { + result = (chanPtr->typePtr->blockModeProc) (chanPtr->instanceData, + chanPtr->inFile, chanPtr->outFile, TCL_MODE_NONBLOCKING); + } + if (result != 0) { + Tcl_SetErrno(result); + return -1; + } + } + + return curPos; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_Tell -- + * + * Returns the position of the next character to be read/written on + * this channel. + * + * Results: + * A nonnegative integer on success, -1 on failure. If failed, + * use Tcl_GetErrno() to retrieve the POSIX error code for the + * error that occurred. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_Tell(chan) + Tcl_Channel chan; /* The channel to return pos for. */ +{ + Channel *chanPtr; /* The actual channel to tell on. */ + ChannelBuffer *bufPtr; /* Iterates over queued input + * and output buffers. */ + int inputBuffered, outputBuffered; + int result; /* Of calling device driver. */ + int curPos; /* Position on device. */ + + chanPtr = (Channel *) chan; + + /* + * Check for unreported error. + */ + + if (chanPtr->unreportedError != 0) { + Tcl_SetErrno(chanPtr->unreportedError); + chanPtr->unreportedError = 0; + return -1; + } + + /* + * Disallow tell on channels that are open for neither + * writing nor reading (e.g. socket server channels). + */ + + if (!(chanPtr->flags & (TCL_WRITABLE|TCL_READABLE))) { + Tcl_SetErrno(EACCES); + return -1; + } + + /* + * Disallow tell on channels whose type does not have a seek procedure + * defined. This means that the channel does not support seeking. + */ + + if (chanPtr->typePtr->seekProc == (Tcl_DriverSeekProc *) NULL) { + Tcl_SetErrno(EINVAL); + return -1; + } + + /* + * Compute how much input and output is buffered. If both input and + * output is buffered, cannot compute the current position. + */ + + for (bufPtr = chanPtr->inQueueHead, inputBuffered = 0; + bufPtr != (ChannelBuffer *) NULL; + bufPtr = bufPtr->nextPtr) { + inputBuffered += (bufPtr->nextAdded - bufPtr->nextRemoved); + } + for (bufPtr = chanPtr->outQueueHead, outputBuffered = 0; + bufPtr != (ChannelBuffer *) NULL; + bufPtr = bufPtr->nextPtr) { + outputBuffered += (bufPtr->nextAdded - bufPtr->nextRemoved); + } + if (chanPtr->curOutPtr != (ChannelBuffer *) NULL) { + outputBuffered += + (chanPtr->curOutPtr->nextAdded - chanPtr->curOutPtr->nextRemoved); + } + if ((inputBuffered != 0) && (outputBuffered != 0)) { + Tcl_SetErrno(EFAULT); + return -1; + } + + /* + * Get the current position in the device and compute the position + * where the next character will be read or written. + */ + + curPos = (chanPtr->typePtr->seekProc) (chanPtr->instanceData, + chanPtr->inFile, chanPtr->outFile, (long) 0, SEEK_CUR, &result); + if (curPos == -1) { + Tcl_SetErrno(result); + return -1; + } + if (inputBuffered != 0) { + return (curPos - inputBuffered); + } + return (curPos + outputBuffered); +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_Eof -- + * + * Returns 1 if the channel is at EOF, 0 otherwise. + * + * Results: + * 1 or 0, always. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_Eof(chan) + Tcl_Channel chan; /* Does this channel have EOF? */ +{ + Channel *chanPtr; /* The real channel structure. */ + + chanPtr = (Channel *) chan; + return ((chanPtr->flags & CHANNEL_STICKY_EOF) || + ((chanPtr->flags & CHANNEL_EOF) && (Tcl_InputBuffered(chan) == 0))) + ? 1 : 0; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_InputBlocked -- + * + * Returns 1 if input is blocked on this channel, 0 otherwise. + * + * Results: + * 0 or 1, always. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_InputBlocked(chan) + Tcl_Channel chan; /* Is this channel blocked? */ +{ + Channel *chanPtr; /* The real channel structure. */ + + chanPtr = (Channel *) chan; + return (chanPtr->flags & CHANNEL_BLOCKED) ? 1 : 0; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_InputBuffered -- + * + * Returns the number of bytes of input currently buffered in the + * internal buffer of a channel. + * + * Results: + * The number of input bytes buffered, or zero if the channel is not + * open for reading. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_InputBuffered(chan) + Tcl_Channel chan; /* The channel to query. */ +{ + Channel *chanPtr; + int bytesBuffered; + ChannelBuffer *bufPtr; + + chanPtr = (Channel *) chan; + for (bytesBuffered = 0, bufPtr = chanPtr->inQueueHead; + bufPtr != (ChannelBuffer *) NULL; + bufPtr = bufPtr->nextPtr) { + bytesBuffered += (bufPtr->nextAdded - bufPtr->nextRemoved); + } + return bytesBuffered; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_SetChannelBufferSize -- + * + * Sets the size of buffers to allocate to store input or output + * in the channel. The size must be between 10 bytes and 1 MByte. + * + * Results: + * None. + * + * Side effects: + * Sets the size of buffers subsequently allocated for this channel. + * + *---------------------------------------------------------------------- + */ + +void +Tcl_SetChannelBufferSize(chan, sz) + Tcl_Channel chan; /* The channel whose buffer size + * to set. */ + int sz; /* The size to set. */ +{ + Channel *chanPtr; + + if (sz < 10) { + sz = CHANNELBUFFER_DEFAULT_SIZE; + } + + /* + * Allow only buffers that are smaller than one megabyte. + */ + + if (sz > (1024 * 1024)) { + sz = CHANNELBUFFER_DEFAULT_SIZE; + } + + chanPtr = (Channel *) chan; + chanPtr->bufSize = sz; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_GetChannelBufferSize -- + * + * Retrieves the size of buffers to allocate for this channel. + * + * Results: + * The size. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_GetChannelBufferSize(chan) + Tcl_Channel chan; /* The channel for which to find the + * buffer size. */ +{ + Channel *chanPtr; + + chanPtr = (Channel *) chan; + return chanPtr->bufSize; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_GetChannelOption -- + * + * Gets a mode associated with an IO channel. If the optionName arg + * is non NULL, retrieves the value of that option. If the optionName + * arg is NULL, retrieves a list of alternating option names and + * values for the given channel. + * + * Results: + * A standard Tcl result. Also sets the supplied DString to the + * string value of the option(s) returned. + * + * Side effects: + * The string returned by this function is in static storage and + * may be reused at any time subsequent to the call. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_GetChannelOption(chan, optionName, dsPtr) + Tcl_Channel chan; /* Channel on which to get option. */ + char *optionName; /* Option to get. */ + Tcl_DString *dsPtr; /* Where to store value(s). */ +{ + Channel *chanPtr; /* The real IO channel. */ + size_t len; /* Length of optionName string. */ + + chanPtr = (Channel *) chan; + + /* + * If the optionName is NULL it means that we want a list of all + * options and values. + */ + + if (optionName == (char *) NULL) { + len = 0; + } else { + len = strlen(optionName); + } + + if ((len == 0) || ((len > 2) && (optionName[1] == 'b') && + (strncmp(optionName, "-blocking", len) == 0))) { + if (len == 0) { + Tcl_DStringAppendElement(dsPtr, "-blocking"); + } + Tcl_DStringAppendElement(dsPtr, + (chanPtr->flags & CHANNEL_NONBLOCKING) ? "0" : "1"); + if (len > 0) { + return TCL_OK; + } + } + if ((len == 0) || ((len > 7) && (optionName[1] == 'b') && + (strncmp(optionName, "-buffering", len) == 0))) { + if (len == 0) { + Tcl_DStringAppendElement(dsPtr, "-buffering"); + } + if (chanPtr->flags & CHANNEL_LINEBUFFERED) { + Tcl_DStringAppendElement(dsPtr, "line"); + } else if (chanPtr->flags & CHANNEL_UNBUFFERED) { + Tcl_DStringAppendElement(dsPtr, "none"); + } else { + Tcl_DStringAppendElement(dsPtr, "full"); + } + if (len > 0) { + return TCL_OK; + } + } + if ((len == 0) || ((len > 7) && (optionName[1] == 'b') && + (strncmp(optionName, "-buffersize", len) == 0))) { + if (len == 0) { + Tcl_DStringAppendElement(dsPtr, "-buffersize"); + } + sprintf(optionVal, "%d", chanPtr->bufSize); + Tcl_DStringAppendElement(dsPtr, optionVal); + if (len > 0) { + return TCL_OK; + } + } + if ((len == 0) || + ((len > 1) && (optionName[1] == 'e') && + (strncmp(optionName, "-eofchar", len) == 0))) { + if (len == 0) { + Tcl_DStringAppendElement(dsPtr, "-eofchar"); + } + if ((chanPtr->flags & (TCL_READABLE|TCL_WRITABLE)) == + (TCL_READABLE|TCL_WRITABLE)) { + Tcl_DStringStartSublist(dsPtr); + } + if (chanPtr->flags & TCL_READABLE) { + if (chanPtr->inEofChar == 0) { + Tcl_DStringAppendElement(dsPtr, ""); + } else { + char buf[4]; + + sprintf(buf, "%c", chanPtr->inEofChar); + Tcl_DStringAppendElement(dsPtr, buf); + } + } + if (chanPtr->flags & TCL_WRITABLE) { + if (chanPtr->outEofChar == 0) { + Tcl_DStringAppendElement(dsPtr, ""); + } else { + char buf[4]; + + sprintf(buf, "%c", chanPtr->outEofChar); + Tcl_DStringAppendElement(dsPtr, buf); + } + } + if ((chanPtr->flags & (TCL_READABLE|TCL_WRITABLE)) == + (TCL_READABLE|TCL_WRITABLE)) { + Tcl_DStringEndSublist(dsPtr); + } + if (len > 0) { + return TCL_OK; + } + } + if ((len == 0) || + ((len > 1) && (optionName[1] == 't') && + (strncmp(optionName, "-translation", len) == 0))) { + if (len == 0) { + Tcl_DStringAppendElement(dsPtr, "-translation"); + } + if ((chanPtr->flags & (TCL_READABLE|TCL_WRITABLE)) == + (TCL_READABLE|TCL_WRITABLE)) { + Tcl_DStringStartSublist(dsPtr); + } + if (chanPtr->flags & TCL_READABLE) { + if (chanPtr->inputTranslation == TCL_TRANSLATE_AUTO) { + Tcl_DStringAppendElement(dsPtr, "auto"); + } else if (chanPtr->inputTranslation == TCL_TRANSLATE_CR) { + Tcl_DStringAppendElement(dsPtr, "cr"); + } else if (chanPtr->inputTranslation == TCL_TRANSLATE_CRLF) { + Tcl_DStringAppendElement(dsPtr, "crlf"); + } else { + Tcl_DStringAppendElement(dsPtr, "lf"); + } + } + if (chanPtr->flags & TCL_WRITABLE) { + if (chanPtr->outputTranslation == TCL_TRANSLATE_AUTO) { + Tcl_DStringAppendElement(dsPtr, "auto"); + } else if (chanPtr->outputTranslation == TCL_TRANSLATE_CR) { + Tcl_DStringAppendElement(dsPtr, "cr"); + } else if (chanPtr->outputTranslation == TCL_TRANSLATE_CRLF) { + Tcl_DStringAppendElement(dsPtr, "crlf"); + } else { + Tcl_DStringAppendElement(dsPtr, "lf"); + } + } + if ((chanPtr->flags & (TCL_READABLE|TCL_WRITABLE)) == + (TCL_READABLE|TCL_WRITABLE)) { + Tcl_DStringEndSublist(dsPtr); + } + if (len > 0) { + return TCL_OK; + } + } + if (chanPtr->typePtr->getOptionProc != (Tcl_DriverGetOptionProc *) NULL) { + return (chanPtr->typePtr->getOptionProc) (chanPtr->instanceData, + optionName, dsPtr); + } + if (len == 0) { + return TCL_OK; + } + Tcl_SetErrno(EINVAL); + return TCL_ERROR; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_SetChannelOption -- + * + * Sets an option on a channel. + * + * Results: + * A standard Tcl result. Also sets interp->result on error if + * interp is not NULL. + * + * Side effects: + * May modify an option on a device. + * + *---------------------------------------------------------------------- + */ + +int +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. */ +{ + int result; /* Result of channel type operation. */ + int newMode; /* New (numeric) mode to sert. */ + Channel *chanPtr; /* The real IO channel. */ + size_t len; /* Length of optionName string. */ + int argc; + char **argv; + + chanPtr = (Channel *) chan; + + len = strlen(optionName); + + if ((len > 2) && (optionName[1] == 'b') && + (strncmp(optionName, "-blocking", len) == 0)) { + if (Tcl_GetBoolean(interp, newValue, &newMode) == TCL_ERROR) { + return TCL_ERROR; + } + if (newMode) { + newMode = TCL_MODE_BLOCKING; + } else { + newMode = TCL_MODE_NONBLOCKING; + } + result = 0; + if (chanPtr->typePtr->blockModeProc != NULL) { + result = (chanPtr->typePtr->blockModeProc) (chanPtr->instanceData, + chanPtr->inFile, chanPtr->outFile, newMode); + } + if (result != 0) { + Tcl_SetErrno(result); + if (interp != (Tcl_Interp *) NULL) { + Tcl_AppendResult(interp, "error setting blocking mode: ", + Tcl_PosixError(interp), (char *) NULL); + } + return TCL_ERROR; + } + if (newMode == TCL_MODE_BLOCKING) { + chanPtr->flags &= (~(CHANNEL_NONBLOCKING)); + if (chanPtr->outFile != (Tcl_File) NULL) { + Tcl_DeleteFileHandler(chanPtr->outFile); + chanPtr->flags &= (~(BG_FLUSH_SCHEDULED)); + } + } else { + chanPtr->flags |= CHANNEL_NONBLOCKING; + } + return TCL_OK; + } + + if ((len > 7) && (optionName[1] == 'b') && + (strncmp(optionName, "-buffering", len) == 0)) { + len = strlen(newValue); + if ((newValue[0] == 'f') && (strncmp(newValue, "full", len) == 0)) { + chanPtr->flags &= + (~(CHANNEL_UNBUFFERED|CHANNEL_LINEBUFFERED)); + } else if ((newValue[0] == 'l') && + (strncmp(newValue, "line", len) == 0)) { + chanPtr->flags &= (~(CHANNEL_UNBUFFERED)); + chanPtr->flags |= CHANNEL_LINEBUFFERED; + } else if ((newValue[0] == 'n') && + (strncmp(newValue, "none", len) == 0)) { + chanPtr->flags &= (~(CHANNEL_LINEBUFFERED)); + chanPtr->flags |= CHANNEL_UNBUFFERED; + } else { + if (interp != (Tcl_Interp *) NULL) { + Tcl_AppendResult(interp, "bad value for -buffering: ", + "must be one of full, line, or none", + (char *) NULL); + return TCL_ERROR; + } + } + return TCL_OK; + } + + if ((len > 7) && (optionName[1] == 'b') && + (strncmp(optionName, "-buffersize", len) == 0)) { + chanPtr->bufSize = atoi(newValue); + if ((chanPtr->bufSize < 10) || (chanPtr->bufSize > (1024 * 1024))) { + chanPtr->bufSize = CHANNELBUFFER_DEFAULT_SIZE; + } + return TCL_OK; + } + + if ((len > 1) && (optionName[1] == 'e') && + (strncmp(optionName, "-eofchar", len) == 0)) { + if (Tcl_SplitList(interp, newValue, &argc, &argv) == TCL_ERROR) { + return TCL_ERROR; + } + if (argc == 0) { + chanPtr->inEofChar = 0; + chanPtr->outEofChar = 0; + } else if (argc == 1) { + if (chanPtr->flags & TCL_WRITABLE) { + chanPtr->outEofChar = (int) argv[0][0]; + } + if (chanPtr->flags & TCL_READABLE) { + chanPtr->inEofChar = (int) argv[0][0]; + } + } else if (argc != 2) { + if (interp != (Tcl_Interp *) NULL) { + Tcl_AppendResult(interp, + "bad value for -eofchar: should be a list of one or", + " two elements", (char *) NULL); + } + ckfree((char *) argv); + return TCL_ERROR; + } else { + if (chanPtr->flags & TCL_READABLE) { + chanPtr->inEofChar = (int) argv[0][0]; + } + if (chanPtr->flags & TCL_WRITABLE) { + chanPtr->outEofChar = (int) argv[1][0]; + } + } + if (argv != (char **) NULL) { + ckfree((char *) argv); + } + return TCL_OK; + } + + if ((len > 1) && (optionName[1] == 't') && + (strncmp(optionName, "-translation", len) == 0)) { + if (Tcl_SplitList(interp, newValue, &argc, &argv) == TCL_ERROR) { + return TCL_ERROR; + } + if (argc == 1) { + if (chanPtr->flags & TCL_READABLE) { + chanPtr->flags &= (~(INPUT_SAW_CR)); + if (strcmp(argv[0], "auto") == 0) { + chanPtr->inputTranslation = TCL_TRANSLATE_AUTO; + } else if (strcmp(argv[0], "binary") == 0) { + chanPtr->inEofChar = 0; + chanPtr->inputTranslation = TCL_TRANSLATE_LF; + } else if (strcmp(argv[0], "lf") == 0) { + chanPtr->inputTranslation = TCL_TRANSLATE_LF; + } else if (strcmp(argv[0], "cr") == 0) { + chanPtr->inputTranslation = TCL_TRANSLATE_CR; + } else if (strcmp(argv[0], "crlf") == 0) { + chanPtr->inputTranslation = TCL_TRANSLATE_CRLF; + } else if (strcmp(argv[0], "platform") == 0) { + chanPtr->inputTranslation = TCL_PLATFORM_TRANSLATION; + } else { + if (interp != (Tcl_Interp *) NULL) { + Tcl_AppendResult(interp, + "bad value for -translation: ", + "must be one of auto, binary, cr, lf, crlf,", + " or platform", (char *) NULL); + } + ckfree((char *) argv); + return TCL_ERROR; + } + } + if (chanPtr->flags & TCL_WRITABLE) { + if (strcmp(argv[0], "auto") == 0) { + /* + * This is a hack to get TCP sockets to produce output + * in CRLF mode if they are being set into AUTO mode. + * A better solution for achieving this effect will be + * coded later. + */ + + if (strcmp(chanPtr->typePtr->typeName, "tcp") == 0) { + chanPtr->outputTranslation = TCL_TRANSLATE_CRLF; + } else { + chanPtr->outputTranslation = TCL_PLATFORM_TRANSLATION; + } + } else if (strcmp(argv[0], "binary") == 0) { + chanPtr->outEofChar = 0; + chanPtr->outputTranslation = TCL_TRANSLATE_LF; + } else if (strcmp(argv[0], "lf") == 0) { + chanPtr->outputTranslation = TCL_TRANSLATE_LF; + } else if (strcmp(argv[0], "cr") == 0) { + chanPtr->outputTranslation = TCL_TRANSLATE_CR; + } else if (strcmp(argv[0], "crlf") == 0) { + chanPtr->outputTranslation = TCL_TRANSLATE_CRLF; + } else if (strcmp(argv[0], "platform") == 0) { + chanPtr->outputTranslation = TCL_PLATFORM_TRANSLATION; + } else { + if (interp != (Tcl_Interp *) NULL) { + Tcl_AppendResult(interp, + "bad value for -translation: ", + "must be one of auto, binary, cr, lf, crlf,", + " or platform", (char *) NULL); + } + ckfree((char *) argv); + return TCL_ERROR; + } + } + } else if (argc != 2) { + if (interp != (Tcl_Interp *) NULL) { + Tcl_AppendResult(interp, + "bad value for -translation: must be a one or two", + " element list", (char *) NULL); + } + ckfree((char *) argv); + return TCL_ERROR; + } else { + if (chanPtr->flags & TCL_READABLE) { + if (argv[0][0] == '\0') { + /* Empty body. */ + } else if (strcmp(argv[0], "auto") == 0) { + chanPtr->flags &= (~(INPUT_SAW_CR)); + chanPtr->inputTranslation = TCL_TRANSLATE_AUTO; + } else if (strcmp(argv[0], "binary") == 0) { + chanPtr->inEofChar = 0; + chanPtr->flags &= (~(INPUT_SAW_CR)); + chanPtr->inputTranslation = TCL_TRANSLATE_LF; + } else if (strcmp(argv[0], "lf") == 0) { + chanPtr->flags &= (~(INPUT_SAW_CR)); + chanPtr->inputTranslation = TCL_TRANSLATE_LF; + } else if (strcmp(argv[0], "cr") == 0) { + chanPtr->flags &= (~(INPUT_SAW_CR)); + chanPtr->inputTranslation = TCL_TRANSLATE_CR; + } else if (strcmp(argv[0], "crlf") == 0) { + chanPtr->flags &= (~(INPUT_SAW_CR)); + chanPtr->inputTranslation = TCL_TRANSLATE_CRLF; + } else if (strcmp(argv[0], "platform") == 0) { + chanPtr->flags &= (~(INPUT_SAW_CR)); + chanPtr->inputTranslation = TCL_PLATFORM_TRANSLATION; + } else { + if (interp != (Tcl_Interp *) NULL) { + Tcl_AppendResult(interp, + "bad value for -translation: ", + "must be one of auto, binary, cr, lf, crlf,", + " or platform", (char *) NULL); + } + ckfree((char *) argv); + return TCL_ERROR; + } + } + if (chanPtr->flags & TCL_WRITABLE) { + if (argv[1][0] == '\0') { + /* Empty body. */ + } else if (strcmp(argv[1], "auto") == 0) { + /* + * This is a hack to get TCP sockets to produce output + * in CRLF mode if they are being set into AUTO mode. + * A better solution for achieving this effect will be + * coded later. + */ + + if (strcmp(chanPtr->typePtr->typeName, "tcp") == 0) { + chanPtr->outputTranslation = TCL_TRANSLATE_CRLF; + } else { + chanPtr->outputTranslation = TCL_PLATFORM_TRANSLATION; + } + } else if (strcmp(argv[1], "binary") == 0) { + chanPtr->outEofChar = 0; + chanPtr->outputTranslation = TCL_TRANSLATE_LF; + } else if (strcmp(argv[1], "lf") == 0) { + chanPtr->outputTranslation = TCL_TRANSLATE_LF; + } else if (strcmp(argv[1], "cr") == 0) { + chanPtr->outputTranslation = TCL_TRANSLATE_CR; + } else if (strcmp(argv[1], "crlf") == 0) { + chanPtr->outputTranslation = TCL_TRANSLATE_CRLF; + } else if (strcmp(argv[1], "platform") == 0) { + chanPtr->outputTranslation = TCL_PLATFORM_TRANSLATION; + } else { + if (interp != (Tcl_Interp *) NULL) { + Tcl_AppendResult(interp, + "bad value for -translation: ", + "must be one of auto, binary, cr, lf, crlf,", + " or platform", (char *) NULL); + } + ckfree((char *) argv); + return TCL_ERROR; + } + } + } + ckfree((char *) argv); + return TCL_OK; + } + + if (chanPtr->typePtr->setOptionProc != (Tcl_DriverSetOptionProc *) NULL) { + return (chanPtr->typePtr->setOptionProc) (chanPtr->instanceData, + interp, optionName, newValue); + } + + if (interp != (Tcl_Interp *) NULL) { + Tcl_AppendResult(interp, "bad option \"", optionName, + "\": should be -blocking, -buffering, -buffersize, ", + "-eofchar, -translation, ", + "or channel type specific option", + (char *) NULL); + } + + return TCL_ERROR; +} + +/* + *---------------------------------------------------------------------- + * + * ChannelEventSourceExitProc -- + * + * This procedure is called during exit cleanup to delete the channel + * event source. It deletes the event source for channels. + * + * Results: + * None. + * + * Side effects: + * Destroys the channel event source. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +static void +ChannelEventSourceExitProc(clientData) + ClientData clientData; /* Not used. */ +{ + Tcl_DeleteEventSource(ChannelHandlerSetupProc, ChannelHandlerCheckProc, + (ClientData) NULL); + channelEventSourceCreated = 0; +} + +/* + *---------------------------------------------------------------------- + * + * ChannelHandlerSetupProc -- + * + * This procedure is part of the event source for channel handlers. + * It is invoked by Tcl_DoOneEvent before it waits for events. The + * job of this procedure is to provide information to Tcl_DoOneEvent + * on how to wait for events (what files to watch). + * + * Results: + * None. + * + * Side effects: + * Tells the notifier what channels to watch. + * + *---------------------------------------------------------------------- + */ + +static void +ChannelHandlerSetupProc(clientData, flags) + ClientData clientData; /* Not used. */ + int flags; /* Flags passed to Tk_DoOneEvent: + * if it doesn't include + * TCL_FILE_EVENTS then we do + * nothing. */ +{ + Tcl_Time dontBlock; + Channel *chanPtr, *nextChanPtr; + + if (!(flags & TCL_FILE_EVENTS)) { + return; + } + + dontBlock.sec = 0; dontBlock.usec = 0; + + for (chanPtr = firstChanPtr; chanPtr != (Channel *) NULL; + chanPtr = nextChanPtr) { + nextChanPtr = chanPtr->nextChanPtr; + if (chanPtr->interestMask & TCL_READABLE) { + if ((!(chanPtr->flags & CHANNEL_BLOCKED)) && + (chanPtr->inQueueHead != (ChannelBuffer *) NULL) && + (chanPtr->inQueueHead->nextRemoved < + chanPtr->inQueueHead->nextAdded)) { + Tcl_SetMaxBlockTime(&dontBlock); + } else if (chanPtr->inFile != (Tcl_File) NULL) { + Tcl_WatchFile(chanPtr->inFile, TCL_READABLE); + } + } + if (chanPtr->interestMask & TCL_WRITABLE) { + if (chanPtr->outFile != (Tcl_File) NULL) { + Tcl_WatchFile(chanPtr->outFile, TCL_WRITABLE); + } + } + if (chanPtr->interestMask & TCL_EXCEPTION) { + if (chanPtr->inFile != (Tcl_File) NULL) { + Tcl_WatchFile(chanPtr->inFile, TCL_EXCEPTION); + } + if (chanPtr->outFile != (Tcl_File) NULL) { + Tcl_WatchFile(chanPtr->outFile, TCL_EXCEPTION); + } + } + } +} + +/* + *---------------------------------------------------------------------- + * + * ChannelHandlerCheckProc -- + * + * This procedure is the second part (of three) of the event source + * for channels. It is invoked by Tcl_DoOneEvent after the wait for + * events is over. The job of this procedure is to test each channel + * to see if it is ready now, and if so, to create events and put them + * on the Tcl event queue. + * + * Results: + * None. + * + * Side effects: + * Makes entries on the Tcl event queue for each channel that is + * ready now. + * + *---------------------------------------------------------------------- + */ + +static void +ChannelHandlerCheckProc(clientData, flags) + ClientData clientData; /* Not used. */ + int flags; /* Flags passed to Tk_DoOneEvent: + * if it doesn't include + * TCL_FILE_EVENTS then we do + * nothing. */ +{ + Channel *chanPtr, *nextChanPtr; + ChannelHandlerEvent *ePtr; + int readyMask; + + if (!(flags & TCL_FILE_EVENTS)) { + return; + } + + for (chanPtr = firstChanPtr; + chanPtr != (Channel *) NULL; + chanPtr = nextChanPtr) { + nextChanPtr = chanPtr->nextChanPtr; + + readyMask = 0; + + /* + * Check for readability. + */ + + if (chanPtr->interestMask & TCL_READABLE) { + + /* + * The channel is considered ready for reading if there is input + * buffered AND the last attempt to read from the channel did not + * return EWOULDBLOCK, OR if the underlying file is ready. + * + * NOTE that the input queue may contain empty buffers, hence the + * special check to see if the first input buffer is empty. The + * invariant is that if there is an empty buffer in the queue + * there is only one buffer in the queue, hence an empty first + * buffer indicates that there is no input queued. + */ + + if ((!(chanPtr->flags & CHANNEL_BLOCKED)) && + ((chanPtr->inQueueHead != (ChannelBuffer *) NULL) && + (chanPtr->inQueueHead->nextRemoved < + chanPtr->inQueueHead->nextAdded))) { + readyMask |= TCL_READABLE; + } else if (chanPtr->inFile != (Tcl_File) NULL) { + readyMask |= + Tcl_FileReady(chanPtr->inFile, TCL_READABLE); + } + } + + /* + * Check for writability. + */ + + if (chanPtr->interestMask & TCL_WRITABLE) { + + /* + * The channel is considered ready for writing if there is no + * output buffered waiting to be written to the device, AND the + * underlying file is ready. + */ + + if ((chanPtr->outQueueHead == (ChannelBuffer *) NULL) && + (chanPtr->outFile != (Tcl_File) NULL)) { + readyMask |= + Tcl_FileReady(chanPtr->outFile, TCL_WRITABLE); + } + } + + /* + * Check for exceptions. + */ + + if (chanPtr->interestMask & TCL_EXCEPTION) { + if (chanPtr->inFile != (Tcl_File) NULL) { + readyMask |= + Tcl_FileReady(chanPtr->inFile, TCL_EXCEPTION); + } + if (chanPtr->outFile != (Tcl_File) NULL) { + readyMask |= + Tcl_FileReady(chanPtr->outFile, TCL_EXCEPTION); + } + } + + /* + * If there are any events for this channel, put a notice into the + * Tcl event queue. + */ + + if (readyMask != 0) { + ePtr = (ChannelHandlerEvent *) ckalloc((unsigned) + sizeof(ChannelHandlerEvent)); + ePtr->header.proc = ChannelHandlerEventProc; + ePtr->chanPtr = chanPtr; + ePtr->readyMask = readyMask; + Tcl_QueueEvent((Tcl_Event *) ePtr, TCL_QUEUE_TAIL); + } + } +} + +/* + *---------------------------------------------------------------------- + * + * FlushEventProc -- + * + * This routine dispatches a background flush event. + * + * Errors that occur during the write operation are stored + * inside the channel structure for future reporting by the next + * operation that uses this channel. + * + * Results: + * None. + * + * Side effects: + * Causes production of output on a channel. + * + *---------------------------------------------------------------------- + */ + +static void +FlushEventProc(clientData, mask) + ClientData clientData; /* Channel to produce output on. */ + int mask; /* Not used. */ +{ + (void) FlushChannel(NULL, (Channel *) clientData, 1); +} + +/* + *---------------------------------------------------------------------- + * + * ChannelHandlerEventProc -- + * + * This procedure is called by Tcl_DoOneEvent when a channel event + * reaches the front of the event queue. This procedure is responsible + * for actually handling the event by invoking the callback for the + * channel handler. + * + * Results: + * Returns 1 if the event was handled, meaning that it should be + * removed from the queue. Returns 0 if the event was not handled + * meaning that it should stay in the queue. The only time the event + * will not be handled is if the TCL_FILE_EVENTS flag bit is not + * set in the flags passed. + * + * NOTE: If the handler is deleted between the time the event is added + * to the queue and the time it reaches the head of the queue, the + * event is silently discarded (i.e. we return 1). + * + * Side effects: + * Whatever the channel handler callback procedure does. + * + *---------------------------------------------------------------------- + */ + +static int +ChannelHandlerEventProc(evPtr, flags) + Tcl_Event *evPtr; /* Event to service. */ + int flags; /* Flags that indicate what events to + * handle, such as TCL_FILE_EVENTS. */ +{ + Channel *chanPtr; + ChannelHandler *chPtr; + ChannelHandlerEvent *ePtr; + NextChannelHandler nh; + + if (!(flags & TCL_FILE_EVENTS)) { + return 0; + } + + ePtr = (ChannelHandlerEvent *) evPtr; + chanPtr = ePtr->chanPtr; + + /* + * Add this invocation to the list of recursive invocations of + * ChannelHandlerEventProc. + */ + + nh.nextHandlerPtr = (ChannelHandler *) NULL; + nh.nestedHandlerPtr = nestedHandlerPtr; + nestedHandlerPtr = &nh; + + for (chPtr = chanPtr->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 & ePtr->readyMask) != 0) { + nh.nextHandlerPtr = chPtr->nextPtr; + (*(chPtr->proc))(chPtr->clientData, ePtr->readyMask); + chPtr = nh.nextHandlerPtr; + } else { + chPtr = chPtr->nextPtr; + } + } + + nestedHandlerPtr = nh.nestedHandlerPtr; + + return 1; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_CreateChannelHandler -- + * + * Arrange for a given procedure to be invoked whenever the + * channel indicated by the chanPtr arg becomes readable or + * writable. + * + * Results: + * None. + * + * Side effects: + * From now on, whenever the I/O channel given by chanPtr becomes + * ready in the way indicated by mask, proc will be invoked. + * See the manual entry for details on the calling sequence + * to proc. If there is already an event handler for chan, proc + * and clientData, then the mask will be updated. + * + *---------------------------------------------------------------------- + */ + +void +Tcl_CreateChannelHandler(chan, mask, proc, clientData) + Tcl_Channel chan; /* The channel to create the handler for. */ + int mask; /* OR'ed combination of TCL_READABLE, + * TCL_WRITABLE, and TCL_EXCEPTION: + * indicates conditions under which + * proc should be called. Use 0 to + * disable a registered handler. */ + Tcl_ChannelProc *proc; /* Procedure to call for each + * selected event. */ + ClientData clientData; /* Arbitrary data to pass to proc. */ +{ + ChannelHandler *chPtr; + Channel *chanPtr; + + chanPtr = (Channel *) chan; + + /* + * Ensure that the channel event source is registered with the Tcl + * notification mechanism. + */ + + if (!channelEventSourceCreated) { + channelEventSourceCreated = 1; + Tcl_CreateEventSource(ChannelHandlerSetupProc, ChannelHandlerCheckProc, + (ClientData) NULL); + Tcl_CreateExitHandler(ChannelEventSourceExitProc, (ClientData) NULL); + } + + /* + * Check whether this channel handler is not already registered. If + * it is not, create a new record, else reuse existing record (smash + * current values). + */ + + for (chPtr = chanPtr->chPtr; + chPtr != (ChannelHandler *) NULL; + chPtr = chPtr->nextPtr) { + if ((chPtr->chanPtr == chanPtr) && (chPtr->proc == proc) && + (chPtr->clientData == clientData)) { + break; + } + } + if (chPtr == (ChannelHandler *) NULL) { + chPtr = (ChannelHandler *) ckalloc((unsigned) sizeof(ChannelHandler)); + chPtr->mask = 0; + chPtr->proc = proc; + chPtr->clientData = clientData; + chPtr->chanPtr = chanPtr; + chPtr->nextPtr = chanPtr->chPtr; + chanPtr->chPtr = chPtr; + } + + /* + * The remainder of the initialization below is done regardless of + * whether or not this is a new record or a modification of an old + * one. + */ + + chPtr->mask = mask; + + /* + * Recompute the interest mask for the channel - this call may actually + * be disabling an existing handler.. + */ + + chanPtr->interestMask = 0; + for (chPtr = chanPtr->chPtr; + chPtr != (ChannelHandler *) NULL; + chPtr = chPtr->nextPtr) { + chanPtr->interestMask |= chPtr->mask; + } +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_DeleteChannelHandler -- + * + * Cancel a previously arranged callback arrangement for an IO + * channel. + * + * Results: + * None. + * + * Side effects: + * If a callback was previously registered for this chan, proc and + * clientData , it is removed and the callback will no longer be called + * when the channel becomes ready for IO. + * + *---------------------------------------------------------------------- + */ + +void +Tcl_DeleteChannelHandler(chan, proc, clientData) + Tcl_Channel chan; /* The channel for which to remove the + * callback. */ + Tcl_ChannelProc *proc; /* The procedure in the callback to delete. */ + ClientData clientData; /* The client data in the callback + * to delete. */ + +{ + ChannelHandler *chPtr, *prevChPtr; + Channel *chanPtr; + NextChannelHandler *nhPtr; + + chanPtr = (Channel *) chan; + + /* + * Find the entry and the previous one in the list. + */ + + for (prevChPtr = (ChannelHandler *) NULL, chPtr = chanPtr->chPtr; + chPtr != (ChannelHandler *) NULL; + chPtr = chPtr->nextPtr) { + if ((chPtr->chanPtr == chanPtr) && (chPtr->clientData == clientData) + && (chPtr->proc == proc)) { + break; + } + prevChPtr = chPtr; + } + + /* + * If ChannelHandlerEventProc is about to process this handler, tell it to + * process the next one instead - we are going to delete *this* one. + */ + + for (nhPtr = nestedHandlerPtr; + nhPtr != (NextChannelHandler *) NULL; + nhPtr = nhPtr->nestedHandlerPtr) { + if (nhPtr->nextHandlerPtr == chPtr) { + nhPtr->nextHandlerPtr = chPtr->nextPtr; + } + } + + /* + * If found, splice the entry out of the list. + */ + + if (chPtr == (ChannelHandler *) NULL) { + return; + } + + if (prevChPtr == (ChannelHandler *) NULL) { + chanPtr->chPtr = chPtr->nextPtr; + } else { + prevChPtr->nextPtr = chPtr->nextPtr; + } + ckfree((char *) chPtr); + + /* + * Recompute the interest list for the channel, so that infinite loops + * will not result if Tcl_DeleteChanelHandler is called inside an event. + */ + + chanPtr->interestMask = 0; + for (chPtr = chanPtr->chPtr; + chPtr != (ChannelHandler *) NULL; + chPtr = chPtr->nextPtr) { + chanPtr->interestMask |= chPtr->mask; + } +} + +/* + *---------------------------------------------------------------------- + * + * ReturnScriptRecord -- + * + * Get a script stored for this channel with this interpreter. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * Sets interp->result to the script. + * + *---------------------------------------------------------------------- + */ + +static void +ReturnScriptRecord(interp, chanPtr, mask) + Tcl_Interp *interp; /* The interpreter in which the script + * is to be executed. */ + Channel *chanPtr; /* The channel for which the script is + * stored. */ + int mask; /* Events in mask must overlap with events + * for which this script is stored. */ +{ + EventScriptRecord *esPtr; + + for (esPtr = chanPtr->scriptRecordPtr; + esPtr != (EventScriptRecord *) NULL; + esPtr = esPtr->nextPtr) { + if ((esPtr->interp == interp) && (esPtr->mask == mask)) { + interp->result = esPtr->script; + return; + } + } +} + +/* + *---------------------------------------------------------------------- + * + * DeleteScriptRecord -- + * + * Delete a script record for this combination of channel, interp + * and mask. + * + * Results: + * None. + * + * Side effects: + * Deletes a script record and cancels a channel event handler. + * + *---------------------------------------------------------------------- + */ + +static void +DeleteScriptRecord(interp, chanPtr, mask) + Tcl_Interp *interp; /* Interpreter in which script was to be + * executed. */ + Channel *chanPtr; /* The channel for which to delete the + * script record (if any). */ + int mask; /* Events in mask must exactly match mask + * of script to delete. */ +{ + EventScriptRecord *esPtr, *prevEsPtr; + + for (esPtr = chanPtr->scriptRecordPtr, + prevEsPtr = (EventScriptRecord *) NULL; + esPtr != (EventScriptRecord *) NULL; + prevEsPtr = esPtr, esPtr = esPtr->nextPtr) { + if ((esPtr->interp == interp) && (esPtr->mask == mask)) { + if (esPtr == chanPtr->scriptRecordPtr) { + chanPtr->scriptRecordPtr = esPtr->nextPtr; + } else { + prevEsPtr->nextPtr = esPtr->nextPtr; + } + + Tcl_DeleteChannelHandler((Tcl_Channel) chanPtr, + ChannelEventScriptInvoker, (ClientData) esPtr); + + Tcl_EventuallyFree((ClientData)esPtr->script, TCL_DYNAMIC); + ckfree((char *) esPtr); + + break; + } + } +} + +/* + *---------------------------------------------------------------------- + * + * CreateScriptRecord -- + * + * Creates a record to store a script to be executed when a specific + * event fires on a specific channel. + * + * Results: + * None. + * + * Side effects: + * Causes the script to be stored for later execution. + * + *---------------------------------------------------------------------- + */ + +static void +CreateScriptRecord(interp, chanPtr, mask, script) + Tcl_Interp *interp; /* Interpreter in which to execute + * the stored script. */ + Channel *chanPtr; /* Channel for which script is to + * be stored. */ + int mask; /* Set of events for which script + * will be invoked. */ + char *script; /* A copy of this script is stored + * in the newly created record. */ +{ + EventScriptRecord *esPtr; + + for (esPtr = chanPtr->scriptRecordPtr; + esPtr != (EventScriptRecord *) NULL; + esPtr = esPtr->nextPtr) { + if ((esPtr->interp == interp) && (esPtr->mask == mask)) { + Tcl_EventuallyFree((ClientData)esPtr->script, TCL_DYNAMIC); + esPtr->script = (char *) NULL; + break; + } + } + if (esPtr == (EventScriptRecord *) NULL) { + esPtr = (EventScriptRecord *) ckalloc((unsigned) + sizeof(EventScriptRecord)); + Tcl_CreateChannelHandler((Tcl_Channel) chanPtr, mask, + ChannelEventScriptInvoker, (ClientData) esPtr); + esPtr->nextPtr = chanPtr->scriptRecordPtr; + chanPtr->scriptRecordPtr = esPtr; + } + esPtr->chanPtr = chanPtr; + esPtr->interp = interp; + esPtr->mask = mask; + esPtr->script = ckalloc((unsigned) (strlen(script) + 1)); + strcpy(esPtr->script, script); +} + +/* + *---------------------------------------------------------------------- + * + * ChannelEventScriptInvoker -- + * + * Invokes a script scheduled by "fileevent" for when the channel + * becomes ready for IO. This function is invoked by the channel + * handler which was created by the Tcl "fileevent" command. + * + * Results: + * None. + * + * Side effects: + * Whatever the script does. + * + *---------------------------------------------------------------------- + */ + +static void +ChannelEventScriptInvoker(clientData, mask) + ClientData clientData; /* The script+interp record. */ + int mask; /* Not used. */ +{ + Tcl_Interp *interp; /* Interpreter in which to eval the script. */ + Channel *chanPtr; /* The channel for which this handler is + * registered. */ + char *script; /* Script to eval. */ + EventScriptRecord *esPtr; /* The event script + interpreter to eval it + * in. */ + int result; /* Result of call to eval script. */ + + esPtr = (EventScriptRecord *) clientData; + + chanPtr = esPtr->chanPtr; + mask = esPtr->mask; + interp = esPtr->interp; + script = esPtr->script; + + /* + * We must preserve the channel, script and interpreter because each of + * these may be deleted in the evaluation. If an error later occurs, we + * want to have the relevant data around for error reporting and so we + * can safely delete it. + */ + + Tcl_Preserve((ClientData) chanPtr); + Tcl_Preserve((ClientData) script); + Tcl_Preserve((ClientData) interp); + result = Tcl_GlobalEval(esPtr->interp, script); + + /* + * On error, cause a background error and remove the channel handler + * and the script record. + */ + + if (result != TCL_OK) { + Tcl_BackgroundError(interp); + DeleteScriptRecord(interp, chanPtr, mask); + } + Tcl_Release((ClientData) chanPtr); + Tcl_Release((ClientData) script); + Tcl_Release((ClientData) interp); +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_FileEventCmd -- + * + * This procedure implements the "fileevent" Tcl command. See the + * user documentation for details on what it does. This command is + * based on the Tk command "fileevent" which in turn is based on work + * contributed by Mark Diekhans. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * May create a channel handler for the specified channel. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +int +Tcl_FileEventCmd(clientData, interp, argc, argv) + ClientData clientData; /* Not used. */ + Tcl_Interp *interp; /* Interpreter in which the channel + * for which to create the handler + * is found. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ + Channel *chanPtr; /* The channel to create + * the handler for. */ + Tcl_Channel chan; /* The opaque type for the channel. */ + int c; /* First char of mode argument. */ + int mask; /* Mask for events of interest. */ + size_t length; /* Length of mode argument. */ + + /* + * Parse arguments. + */ + + if ((argc != 3) && (argc != 4)) { + Tcl_AppendResult(interp, "wrong # args: must be \"", argv[0], + " channelId event ?script?", (char *) NULL); + return TCL_ERROR; + } + c = argv[2][0]; + length = strlen(argv[2]); + if ((c == 'r') && (strncmp(argv[2], "readable", length) == 0)) { + mask = TCL_READABLE; + } else if ((c == 'w') && (strncmp(argv[2], "writable", length) == 0)) { + mask = TCL_WRITABLE; + } else { + Tcl_AppendResult(interp, "bad event name \"", argv[2], + "\": must be readable or writable", (char *) NULL); + return TCL_ERROR; + } + chan = Tcl_GetChannel(interp, argv[1], NULL); + if (chan == (Tcl_Channel) NULL) { + return TCL_ERROR; + } + + chanPtr = (Channel *) chan; + if ((chanPtr->flags & mask) == 0) { + Tcl_AppendResult(interp, "channel is not ", + (mask == TCL_READABLE) ? "readable" : "writable", + (char *) NULL); + return TCL_ERROR; + } + + /* + * If we are supposed to return the script, do so. + */ + + if (argc == 3) { + ReturnScriptRecord(interp, chanPtr, mask); + return TCL_OK; + } + + /* + * If we are supposed to delete a stored script, do so. + */ + + if (argv[3][0] == 0) { + DeleteScriptRecord(interp, chanPtr, mask); + return TCL_OK; + } + + /* + * Make the script record that will link between the event and the + * script to invoke. This also creates a channel event handler which + * will evaluate the script in the supplied interpreter. + */ + + CreateScriptRecord(interp, chanPtr, mask, argv[3]); + + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * TclTestChannelCmd -- + * + * Implements the Tcl "testchannel" debugging command and its + * subcommands. This is part of the testing environment but must be + * in this file instead of tclTest.c because it needs access to the + * fields of struct Channel. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +int +TclTestChannelCmd(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. */ +{ + char *cmdName; /* Sub command. */ + Tcl_HashTable *hTblPtr; /* Hash table of channels. */ + Tcl_HashSearch hSearch; /* Search variable. */ + Tcl_HashEntry *hPtr; /* Search variable. */ + Channel *chanPtr; /* The actual channel. */ + Tcl_Channel chan; /* The opaque type. */ + size_t len; /* Length of subcommand string. */ + int IOQueued; /* How much IO is queued inside channel? */ + ChannelBuffer *bufPtr; /* For iterating over queued IO. */ + char buf[128]; /* For sprintf. */ + + if (argc < 2) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " subcommand ?additional args..?\"", (char *) NULL); + return TCL_ERROR; + } + cmdName = argv[1]; + len = strlen(cmdName); + + chanPtr = (Channel *) NULL; + if (argc > 2) { + chan = Tcl_GetChannel(interp, argv[2], NULL); + if (chan == (Tcl_Channel) NULL) { + return TCL_ERROR; + } + chanPtr = (Channel *) chan; + } + + if ((cmdName[0] == 'i') && (strncmp(cmdName, "info", len) == 0)) { + if (argc != 3) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " info channelName\"", (char *) NULL); + return TCL_ERROR; + } + Tcl_AppendElement(interp, argv[2]); + Tcl_AppendElement(interp, chanPtr->typePtr->typeName); + if (chanPtr->flags & TCL_READABLE) { + Tcl_AppendElement(interp, "read"); + } else { + Tcl_AppendElement(interp, ""); + } + if (chanPtr->flags & TCL_WRITABLE) { + Tcl_AppendElement(interp, "write"); + } else { + Tcl_AppendElement(interp, ""); + } + if (chanPtr->flags & CHANNEL_NONBLOCKING) { + Tcl_AppendElement(interp, "nonblocking"); + } else { + Tcl_AppendElement(interp, "blocking"); + } + if (chanPtr->flags & CHANNEL_LINEBUFFERED) { + Tcl_AppendElement(interp, "line"); + } else if (chanPtr->flags & CHANNEL_UNBUFFERED) { + Tcl_AppendElement(interp, "none"); + } else { + Tcl_AppendElement(interp, "full"); + } + if (chanPtr->flags & BG_FLUSH_SCHEDULED) { + Tcl_AppendElement(interp, "async_flush"); + } else { + Tcl_AppendElement(interp, ""); + } + if (chanPtr->flags & CHANNEL_EOF) { + Tcl_AppendElement(interp, "eof"); + } else { + Tcl_AppendElement(interp, ""); + } + if (chanPtr->flags & CHANNEL_BLOCKED) { + Tcl_AppendElement(interp, "blocked"); + } else { + Tcl_AppendElement(interp, "unblocked"); + } + if (chanPtr->inputTranslation == TCL_TRANSLATE_AUTO) { + Tcl_AppendElement(interp, "auto"); + if (chanPtr->flags & INPUT_SAW_CR) { + Tcl_AppendElement(interp, "saw_cr"); + } else { + Tcl_AppendElement(interp, ""); + } + } else if (chanPtr->inputTranslation == TCL_TRANSLATE_LF) { + Tcl_AppendElement(interp, "lf"); + Tcl_AppendElement(interp, ""); + } else if (chanPtr->inputTranslation == TCL_TRANSLATE_CR) { + Tcl_AppendElement(interp, "cr"); + Tcl_AppendElement(interp, ""); + } else if (chanPtr->inputTranslation == TCL_TRANSLATE_CRLF) { + Tcl_AppendElement(interp, "crlf"); + if (chanPtr->flags & INPUT_SAW_CR) { + Tcl_AppendElement(interp, "queued_cr"); + } else { + Tcl_AppendElement(interp, ""); + } + } + if (chanPtr->outputTranslation == TCL_TRANSLATE_AUTO) { + Tcl_AppendElement(interp, "auto"); + } else if (chanPtr->outputTranslation == TCL_TRANSLATE_LF) { + Tcl_AppendElement(interp, "lf"); + } else if (chanPtr->outputTranslation == TCL_TRANSLATE_CR) { + Tcl_AppendElement(interp, "cr"); + } else if (chanPtr->outputTranslation == TCL_TRANSLATE_CRLF) { + Tcl_AppendElement(interp, "crlf"); + } + for (IOQueued = 0, bufPtr = chanPtr->inQueueHead; + bufPtr != (ChannelBuffer *) NULL; + bufPtr = bufPtr->nextPtr) { + IOQueued += bufPtr->nextAdded - bufPtr->nextRemoved; + } + sprintf(buf, "%d", IOQueued); + Tcl_AppendElement(interp, buf); + + IOQueued = 0; + if (chanPtr->curOutPtr != (ChannelBuffer *) NULL) { + IOQueued = chanPtr->curOutPtr->nextAdded - + chanPtr->curOutPtr->nextRemoved; + } + for (bufPtr = chanPtr->outQueueHead; + bufPtr != (ChannelBuffer *) NULL; + bufPtr = bufPtr->nextPtr) { + IOQueued += (bufPtr->nextAdded - bufPtr->nextRemoved); + } + sprintf(buf, "%d", IOQueued); + Tcl_AppendElement(interp, buf); + + sprintf(buf, "%d", Tcl_Tell((Tcl_Channel) chanPtr)); + Tcl_AppendElement(interp, buf); + + sprintf(buf, "%d", chanPtr->refCount); + Tcl_AppendElement(interp, buf); + + return TCL_OK; + } + + if ((cmdName[0] == 'i') && + (strncmp(cmdName, "inputbuffered", len) == 0)) { + if (argc != 3) { + Tcl_AppendResult(interp, "channel name required", + (char *) NULL); + return TCL_ERROR; + } + + for (IOQueued = 0, bufPtr = chanPtr->inQueueHead; + bufPtr != (ChannelBuffer *) NULL; + bufPtr = bufPtr->nextPtr) { + IOQueued += bufPtr->nextAdded - bufPtr->nextRemoved; + } + sprintf(buf, "%d", IOQueued); + 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", + (char *) NULL); + return TCL_ERROR; + } + + if (chanPtr->flags & TCL_READABLE) { + Tcl_AppendElement(interp, "read"); + } else { + Tcl_AppendElement(interp, ""); + } + if (chanPtr->flags & TCL_WRITABLE) { + Tcl_AppendElement(interp, "write"); + } else { + Tcl_AppendElement(interp, ""); + } + return TCL_OK; + } + + if ((cmdName[0] == 'n') && (strncmp(cmdName, "name", len) == 0)) { + if (argc != 3) { + Tcl_AppendResult(interp, "channel name required", + (char *) NULL); + return TCL_ERROR; + } + Tcl_AppendResult(interp, chanPtr->channelName, (char *) NULL); + return TCL_OK; + } + + if ((cmdName[0] == 'o') && (strncmp(cmdName, "open", len) == 0)) { + hTblPtr = (Tcl_HashTable *) Tcl_GetAssocData(interp, "tclIO", NULL); + if (hTblPtr == (Tcl_HashTable *) NULL) { + return TCL_OK; + } + for (hPtr = Tcl_FirstHashEntry(hTblPtr, &hSearch); + hPtr != (Tcl_HashEntry *) NULL; + hPtr = Tcl_NextHashEntry(&hSearch)) { + Tcl_AppendElement(interp, Tcl_GetHashKey(hTblPtr, hPtr)); + } + return TCL_OK; + } + + if ((cmdName[0] == 'o') && + (strncmp(cmdName, "outputbuffered", len) == 0)) { + if (argc != 3) { + Tcl_AppendResult(interp, "channel name required", + (char *) NULL); + return TCL_ERROR; + } + + IOQueued = 0; + if (chanPtr->curOutPtr != (ChannelBuffer *) NULL) { + IOQueued = chanPtr->curOutPtr->nextAdded - + chanPtr->curOutPtr->nextRemoved; + } + for (bufPtr = chanPtr->outQueueHead; + bufPtr != (ChannelBuffer *) NULL; + bufPtr = bufPtr->nextPtr) { + IOQueued += (bufPtr->nextAdded - bufPtr->nextRemoved); + } + sprintf(buf, "%d", IOQueued); + Tcl_AppendResult(interp, buf, (char *) NULL); + return TCL_OK; + } + + if ((cmdName[0] == 'q') && + (strncmp(cmdName, "queuedcr", len) == 0)) { + if (argc != 3) { + Tcl_AppendResult(interp, "channel name required", + (char *) NULL); + return TCL_ERROR; + } + + Tcl_AppendResult(interp, + (chanPtr->flags & INPUT_SAW_CR) ? "1" : "0", + (char *) NULL); + return TCL_OK; + } + + if ((cmdName[0] == 'r') && (strncmp(cmdName, "readable", len) == 0)) { + hTblPtr = (Tcl_HashTable *) Tcl_GetAssocData(interp, "tclIO", NULL); + if (hTblPtr == (Tcl_HashTable *) NULL) { + return TCL_OK; + } + for (hPtr = Tcl_FirstHashEntry(hTblPtr, &hSearch); + hPtr != (Tcl_HashEntry *) NULL; + hPtr = Tcl_NextHashEntry(&hSearch)) { + chanPtr = (Channel *) Tcl_GetHashValue(hPtr); + if (chanPtr->flags & TCL_READABLE) { + Tcl_AppendElement(interp, Tcl_GetHashKey(hTblPtr, hPtr)); + } + } + return TCL_OK; + } + + if ((cmdName[0] == 'r') && (strncmp(cmdName, "refcount", len) == 0)) { + if (argc != 3) { + Tcl_AppendResult(interp, "channel name required", + (char *) NULL); + return TCL_ERROR; + } + + sprintf(buf, "%d", chanPtr->refCount); + Tcl_AppendResult(interp, buf, (char *) NULL); + 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, (char *) NULL); + return TCL_OK; + } + + if ((cmdName[0] == 'w') && (strncmp(cmdName, "writable", len) == 0)) { + hTblPtr = (Tcl_HashTable *) Tcl_GetAssocData(interp, "tclIO", NULL); + if (hTblPtr == (Tcl_HashTable *) NULL) { + return TCL_OK; + } + for (hPtr = Tcl_FirstHashEntry(hTblPtr, &hSearch); + hPtr != (Tcl_HashEntry *) NULL; + hPtr = Tcl_NextHashEntry(&hSearch)) { + chanPtr = (Channel *) Tcl_GetHashValue(hPtr); + if (chanPtr->flags & TCL_WRITABLE) { + Tcl_AppendElement(interp, Tcl_GetHashKey(hTblPtr, hPtr)); + } + } + return TCL_OK; + } + + Tcl_AppendResult(interp, "bad option \"", cmdName, "\": should be ", + "info, open, readable, or writable", + (char *) NULL); + return TCL_ERROR; +} + +/* + *---------------------------------------------------------------------- + * + * TclTestChannelEventCmd -- + * + * This procedure implements the "testchannelevent" command. It is + * used to test the Tcl channel event mechanism. It is present in + * this file instead of tclTest.c because it needs access to the + * internal structure of the channel. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * Creates, deletes and returns channel event handlers. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +int +TclTestChannelEventCmd(dummy, interp, argc, argv) + ClientData dummy; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ + Channel *chanPtr; + EventScriptRecord *esPtr, *prevEsPtr, *nextEsPtr; + char *cmd; + int index, i, mask, len; + + if ((argc < 3) || (argc > 5)) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " channelName cmd ?arg1? ?arg2?\"", (char *) NULL); + return TCL_ERROR; + } + chanPtr = (Channel *) Tcl_GetChannel(interp, argv[1], NULL); + if (chanPtr == (Channel *) NULL) { + return TCL_ERROR; + } + cmd = argv[2]; + len = strlen(cmd); + if ((cmd[0] == 'a') && (strncmp(cmd, "add", (unsigned) len) == 0)) { + if (argc != 5) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " channelName add eventSpec script\"", (char *) NULL); + return TCL_ERROR; + } + if (strcmp(argv[3], "readable") == 0) { + mask = TCL_READABLE; + } else if (strcmp(argv[3], "writable") == 0) { + mask = TCL_WRITABLE; + } else { + Tcl_AppendResult(interp, "bad event name \"", argv[3], + "\": must be readable or writable", (char *) NULL); + return TCL_ERROR; + } + + esPtr = (EventScriptRecord *) ckalloc((unsigned) + sizeof(EventScriptRecord)); + esPtr->nextPtr = chanPtr->scriptRecordPtr; + chanPtr->scriptRecordPtr = esPtr; + + esPtr->chanPtr = chanPtr; + esPtr->interp = interp; + esPtr->mask = mask; + esPtr->script = ckalloc((unsigned) (strlen(argv[4]) + 1)); + strcpy(esPtr->script, argv[4]); + + Tcl_CreateChannelHandler((Tcl_Channel) chanPtr, mask, + ChannelEventScriptInvoker, (ClientData) esPtr); + + return TCL_OK; + } + + if ((cmd[0] == 'd') && (strncmp(cmd, "delete", (unsigned) len) == 0)) { + if (argc != 4) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " channelName delete index\"", (char *) NULL); + return TCL_ERROR; + } + if (Tcl_GetInt(interp, argv[3], &index) == TCL_ERROR) { + return TCL_ERROR; + } + if (index < 0) { + Tcl_AppendResult(interp, "bad event index: ", argv[3], + ": must be nonnegative", (char *) NULL); + return TCL_ERROR; + } + for (i = 0, esPtr = chanPtr->scriptRecordPtr; + (i < index) && (esPtr != (EventScriptRecord *) NULL); + i++, esPtr = esPtr->nextPtr) { + /* Empty loop body. */ + } + if (esPtr == (EventScriptRecord *) NULL) { + Tcl_AppendResult(interp, "bad event index ", argv[3], + ": out of range", (char *) NULL); + return TCL_ERROR; + } + if (esPtr == chanPtr->scriptRecordPtr) { + chanPtr->scriptRecordPtr = esPtr->nextPtr; + } else { + for (prevEsPtr = chanPtr->scriptRecordPtr; + (prevEsPtr != (EventScriptRecord *) NULL) && + (prevEsPtr->nextPtr != esPtr); + prevEsPtr = prevEsPtr->nextPtr) { + /* Empty loop body. */ + } + if (prevEsPtr == (EventScriptRecord *) NULL) { + panic("TclTestChannelEventCmd: damaged event script list"); + } + prevEsPtr->nextPtr = esPtr->nextPtr; + } + Tcl_DeleteChannelHandler((Tcl_Channel) chanPtr, + ChannelEventScriptInvoker, (ClientData) esPtr); + Tcl_EventuallyFree((ClientData)esPtr->script, TCL_DYNAMIC); + ckfree((char *) esPtr); + + return TCL_OK; + } + + if ((cmd[0] == 'l') && (strncmp(cmd, "list", (unsigned) len) == 0)) { + if (argc != 3) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " channelName list\"", (char *) NULL); + return TCL_ERROR; + } + for (esPtr = chanPtr->scriptRecordPtr; + esPtr != (EventScriptRecord *) NULL; + esPtr = esPtr->nextPtr) { + Tcl_AppendElement(interp, + esPtr->mask == TCL_READABLE ? "readable" : "writable"); + Tcl_AppendElement(interp, esPtr->script); + } + return TCL_OK; + } + + if ((cmd[0] == 'r') && (strncmp(cmd, "removeall", (unsigned) len) == 0)) { + if (argc != 3) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " channelName removeall\"", (char *) NULL); + return TCL_ERROR; + } + for (esPtr = chanPtr->scriptRecordPtr; + esPtr != (EventScriptRecord *) NULL; + esPtr = nextEsPtr) { + nextEsPtr = esPtr->nextPtr; + Tcl_DeleteChannelHandler((Tcl_Channel) chanPtr, + ChannelEventScriptInvoker, (ClientData) esPtr); + Tcl_EventuallyFree((ClientData)esPtr->script, TCL_DYNAMIC); + ckfree((char *) esPtr); + } + chanPtr->scriptRecordPtr = (EventScriptRecord *) NULL; + return TCL_OK; + } + + Tcl_AppendResult(interp, "bad command ", cmd, ", must be one of ", + "add, delete, list, or removeall", (char *) NULL); + return TCL_ERROR; + +} diff --git a/contrib/tcl/generic/tclIOCmd.c b/contrib/tcl/generic/tclIOCmd.c new file mode 100644 index 0000000..d852388 --- /dev/null +++ b/contrib/tcl/generic/tclIOCmd.c @@ -0,0 +1,1510 @@ +/* + * tclIOCmd.c -- + * + * Contains the definitions of most of the Tcl commands relating to IO. + * + * Copyright (c) 1995-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: @(#) tclIOCmd.c 1.94 96/04/15 06:40:02 + */ + +#include "tclInt.h" +#include "tclPort.h" + +/* + * Return at most this number of bytes in one call to Tcl_Read: + */ + +#define TCL_READ_CHUNK_SIZE 4096 + +/* + * Callback structure for accept callback in a TCP server. + */ + +typedef struct AcceptCallback { + char *script; /* Script to invoke. */ + Tcl_Interp *interp; /* Interpreter in which to run it. */ +} AcceptCallback; + +/* + * Static functions for this file: + */ + +static void AcceptCallbackProc _ANSI_ARGS_((ClientData callbackData, + Tcl_Channel chan, char *address, int port)); +static void RegisterTcpServerInterpCleanup _ANSI_ARGS_((Tcl_Interp *interp, + AcceptCallback *acceptCallbackPtr)); +static void TcpAcceptCallbacksDeleteProc _ANSI_ARGS_(( + ClientData clientData, Tcl_Interp *interp)); +static void TcpServerCloseProc _ANSI_ARGS_((ClientData callbackData)); +static void UnregisterTcpServerInterpCleanupProc _ANSI_ARGS_(( + Tcl_Interp *interp, AcceptCallback *acceptCallbackPtr)); + +/* + *---------------------------------------------------------------------- + * + * Tcl_PutsCmd -- + * + * This procedure is invoked to process the "puts" Tcl command. + * See the user documentation for details on what it does. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * Produces output on a channel. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +int +Tcl_PutsCmd(clientData, interp, argc, argv) + ClientData clientData; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ + Tcl_Channel chan; /* The channel to puts on. */ + int i; /* Counter. */ + 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. */ + + i = 1; + newline = 1; + if ((argc >= 2) && (strcmp(argv[1], "-nonewline") == 0)) { + newline = 0; + i++; + } + if ((i < (argc-3)) || (i >= argc)) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " ?-nonewline? ?channelId? string\"", (char *) NULL); + return TCL_ERROR; + } + + /* + * The code below provides backwards compatibility with an old + * form of the command that is no longer recommended or documented. + */ + + if (i == (argc-3)) { + if (strncmp(argv[i+2], "nonewline", strlen(argv[i+2])) != 0) { + Tcl_AppendResult(interp, "bad argument \"", argv[i+2], + "\": should be \"nonewline\"", (char *) NULL); + return TCL_ERROR; + } + newline = 0; + } + if (i == (argc-1)) { + channelId = "stdout"; + } else { + channelId = argv[i]; + i++; + } + chan = Tcl_GetChannel(interp, channelId, &mode); + if (chan == (Tcl_Channel) NULL) { + return TCL_ERROR; + } + if ((mode & TCL_WRITABLE) == 0) { + Tcl_AppendResult(interp, "channel \"", channelId, + "\" wasn't opened for writing", (char *) NULL); + return TCL_ERROR; + } + + result = Tcl_Write(chan, argv[i], -1); + if (result < 0) { + goto error; + } + if (newline != 0) { + result = Tcl_Write(chan, "\n", 1); + if (result < 0) { + goto error; + } + } + return TCL_OK; +error: + Tcl_AppendResult(interp, "error writing \"", Tcl_GetChannelName(chan), + "\": ", Tcl_PosixError(interp), (char *) NULL); + return TCL_ERROR; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_FlushCmd -- + * + * This procedure is called to process the Tcl "flush" command. + * See the user documentation for details on what it does. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * May cause output to appear on the specified channel. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +int +Tcl_FlushCmd(clientData, interp, argc, argv) + ClientData clientData; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ + Tcl_Channel chan; /* The channel to flush on. */ + int result; /* Result of call to channel + * level function. */ + int mode; /* Mode in which channel is opened. */ + + if (argc != 2) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " channelId\"", (char *) NULL); + return TCL_ERROR; + } + chan = Tcl_GetChannel(interp, argv[1], &mode); + if (chan == (Tcl_Channel) NULL) { + return TCL_ERROR; + } + if ((mode & TCL_WRITABLE) == 0) { + Tcl_AppendResult(interp, "channel \"", argv[1], + "\" wasn't opened for writing", (char *) NULL); + return TCL_ERROR; + } + + result = Tcl_Flush(chan); + if (result != TCL_OK) { + Tcl_AppendResult(interp, "error flushing \"", Tcl_GetChannelName(chan), + "\": ", Tcl_PosixError(interp), (char *) NULL); + } + return result; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_GetsCmd -- + * + * This procedure is called to process the Tcl "gets" command. + * See the user documentation for details on what it does. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * May consume input from channel. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +int +Tcl_GetsCmd(clientData, interp, argc, argv) + ClientData clientData; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ + Tcl_Channel chan; /* The channel to read from. */ + char *varName; /* Assign to this variable? */ + char buf[128]; /* Buffer to store string + * representation of how long + * a line was read. */ + Tcl_DString ds; /* Dynamic string to hold the + * buffer for the line just read. */ + int lineLen; /* Length of line just read. */ + int mode; /* Mode in which channel is opened. */ + + if ((argc != 2) && (argc != 3)) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " channelId ?varName?\"", (char *) NULL); + return TCL_ERROR; + } + chan = Tcl_GetChannel(interp, argv[1], &mode); + if (chan == (Tcl_Channel) NULL) { + return TCL_ERROR; + } + if ((mode & TCL_READABLE) == 0) { + Tcl_AppendResult(interp, "channel \"", argv[1], + "\" wasn't opened for reading", (char *) NULL); + return TCL_ERROR; + } + + if (argc != 3) { + varName = (char *) NULL; + } else { + varName = argv[2]; + } + Tcl_DStringInit(&ds); + lineLen = Tcl_Gets(chan, &ds); + if (lineLen < 0) { + if (!Tcl_Eof(chan) && !Tcl_InputBlocked(chan)) { + Tcl_DStringFree(&ds); + Tcl_AppendResult(interp, "error reading \"", + Tcl_GetChannelName(chan), "\": ", Tcl_PosixError(interp), + (char *) NULL); + return TCL_ERROR; + } + lineLen = -1; + } + if (varName == (char *) NULL) { + Tcl_DStringResult(interp, &ds); + } else { + if (Tcl_SetVar(interp, varName, Tcl_DStringValue(&ds), + TCL_LEAVE_ERR_MSG) == NULL) { + Tcl_DStringFree(&ds); + return TCL_ERROR; + } + Tcl_ResetResult(interp); + sprintf(buf, "%d", lineLen); + Tcl_AppendResult(interp, buf, (char *) NULL); + } + Tcl_DStringFree(&ds); + + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_ReadCmd -- + * + * This procedure is invoked to process the Tcl "read" command. + * See the user documentation for details on what it does. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * May consume input from channel. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +int +Tcl_ReadCmd(clientData, interp, argc, argv) + ClientData clientData; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ + Tcl_Channel chan; /* The channel to read from. */ + int newline, i; /* Discard newline at end? */ + int toRead; /* How many bytes to read? */ + int toReadNow; /* How many bytes to attempt to + * read in the current iteration? */ + int charactersRead; /* How many characters were read? */ + int charactersReadNow; /* How many characters were read + * in this iteration? */ + int mode; /* Mode in which channel is opened. */ + Tcl_DString ds; /* Used to accumulate the data + * read by Tcl_Read. */ + int bufSize; /* Channel buffer size; used to decide + * in what chunk sizes to read from + * the channel. */ + + if ((argc != 2) && (argc != 3)) { +argerror: + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " channelId ?numBytes?\" or \"", argv[0], + " ?-nonewline? channelId\"", (char *) NULL); + return TCL_ERROR; + } + i = 1; + newline = 0; + if (strcmp(argv[i], "-nonewline") == 0) { + newline = 1; + i++; + } + + if (i == argc) { + goto argerror; + } + + chan = Tcl_GetChannel(interp, argv[i], &mode); + if (chan == (Tcl_Channel) NULL) { + return TCL_ERROR; + } + if ((mode & TCL_READABLE) == 0) { + Tcl_AppendResult(interp, "channel \"", argv[i], + "\" wasn't opened for reading", (char *) NULL); + return TCL_ERROR; + } + + i++; /* Consumed channel name. */ + + /* + * Compute how many bytes to read, and see whether the final + * newline should be dropped. + */ + + toRead = INT_MAX; + if (i < argc) { + if (isdigit((unsigned char) (argv[i][0]))) { + if (Tcl_GetInt(interp, argv[i], &toRead) != TCL_OK) { + return TCL_ERROR; + } + } else if (strcmp(argv[i], "nonewline") == 0) { + newline = 1; + } else { + Tcl_AppendResult(interp, "bad argument \"", argv[i], + "\": should be \"nonewline\"", (char *) NULL); + return TCL_ERROR; + } + } + + bufSize = Tcl_GetChannelBufferSize(chan); + Tcl_DStringInit(&ds); + for (charactersRead = 0; charactersRead < toRead; ) { + toReadNow = toRead - charactersRead; + if (toReadNow > bufSize) { + toReadNow = bufSize; + } + Tcl_DStringSetLength(&ds, charactersRead + toReadNow); + charactersReadNow = + Tcl_Read(chan, Tcl_DStringValue(&ds) + charactersRead, toReadNow); + if (charactersReadNow < 0) { + Tcl_DStringFree(&ds); + Tcl_AppendResult(interp, "error reading \"", + Tcl_GetChannelName(chan), "\": ", + Tcl_PosixError(interp), (char *) NULL); + return TCL_ERROR; + } + + /* + * If we had a short read it means that we have either EOF + * or BLOCKED on the channel, so break out. + */ + + charactersRead += charactersReadNow; + if (charactersReadNow < toReadNow) { + break; /* Out of "for" loop. */ + } + } + + /* + * Tcl_Read does not put a NULL at the end of the string, so we must + * do it here. + */ + + Tcl_DStringSetLength(&ds, charactersRead); + Tcl_DStringResult(interp, &ds); + Tcl_DStringFree(&ds); + + /* + * If requested, remove the last newline in the channel if at EOF. + */ + + if ((charactersRead > 0) && (newline) && + (interp->result[charactersRead-1] == '\n')) { + interp->result[charactersRead-1] = '\0'; + } + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * TclUnsupported0Cmd -- + * + * This procedure is invoked to process the Tcl "unsupported0" command. + * See the user documentation for details on what it does. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * May copy a chunk from one channel to another. + * + *---------------------------------------------------------------------- + */ + +int +TclUnsupported0Cmd(clientData, interp, argc, argv) + ClientData clientData; /* Not used. */ + Tcl_Interp *interp; /* Interpreter in which both channels + * are defined. */ + int argc; /* How many arguments? */ + char **argv; /* The argument strings. */ +{ + Tcl_Channel inChan, outChan; + int requested; + char *bufPtr; + int actuallyRead, actuallyWritten, totalRead, toReadNow, mode; + + /* + * Assume we want to copy the entire channel. + */ + + requested = INT_MAX; + + if ((argc < 3) || (argc > 4)) { + Tcl_AppendResult(interp, "wrong # args: should be \"", + argv[0], " inChanId outChanId ?chunkSize?\"", (char *) NULL); + return TCL_ERROR; + } + inChan = Tcl_GetChannel(interp, argv[1], &mode); + if (inChan == (Tcl_Channel) NULL) { + return TCL_ERROR; + } + if ((mode & TCL_READABLE) == 0) { + Tcl_AppendResult(interp, "channel \"", argv[1], + "\" wasn't opened for reading", (char *) NULL); + return TCL_ERROR; + } + outChan = Tcl_GetChannel(interp, argv[2], &mode); + if (outChan == (Tcl_Channel) NULL) { + return TCL_ERROR; + } + if ((mode & TCL_WRITABLE) == 0) { + Tcl_AppendResult(interp, "channel \"", argv[2], + "\" wasn't opened for writing", (char *) NULL); + return TCL_ERROR; + } + + if (argc == 4) { + if (Tcl_GetInt(interp, argv[3], &requested) != TCL_OK) { + return TCL_ERROR; + } + if (requested < 0) { + requested = INT_MAX; + } + } + + bufPtr = ckalloc((unsigned) TCL_READ_CHUNK_SIZE); + for (totalRead = 0; + requested > 0; + totalRead += actuallyRead, requested -= actuallyRead) { + toReadNow = requested; + if (toReadNow > TCL_READ_CHUNK_SIZE) { + toReadNow = TCL_READ_CHUNK_SIZE; + } + actuallyRead = Tcl_Read(inChan, bufPtr, toReadNow); + if (actuallyRead < 0) { + ckfree(bufPtr); + Tcl_AppendResult(interp, argv[0], ": ", Tcl_GetChannelName(inChan), + Tcl_PosixError(interp), (char *) NULL); + return TCL_ERROR; + } + if (actuallyRead == 0) { + ckfree(bufPtr); + sprintf(interp->result, "%d", totalRead); + return TCL_OK; + } + actuallyWritten = Tcl_Write(outChan, bufPtr, actuallyRead); + if (actuallyWritten < 0) { + ckfree(bufPtr); + Tcl_AppendResult(interp, argv[0], ": ", Tcl_GetChannelName(outChan), + Tcl_PosixError(interp), (char *) NULL); + return TCL_ERROR; + } + } + ckfree(bufPtr); + + sprintf(interp->result, "%d", totalRead); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_SeekCmd -- + * + * This procedure is invoked to process the Tcl "seek" command. See + * the user documentation for details on what it does. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * Moves the position of the access point on the specified channel. + * May flush queued output. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +int +Tcl_SeekCmd(clientData, interp, argc, argv) + ClientData clientData; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ + Tcl_Channel chan; /* The channel to tell on. */ + int offset, mode; /* Where to seek? */ + int result; /* Of calling Tcl_Seek. */ + + if ((argc != 3) && (argc != 4)) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " channelId offset ?origin?\"", (char *) NULL); + return TCL_ERROR; + } + chan = Tcl_GetChannel(interp, argv[1], NULL); + if (chan == (Tcl_Channel) NULL) { + return TCL_ERROR; + } + if (Tcl_GetInt(interp, argv[2], &offset) != TCL_OK) { + return TCL_ERROR; + } + mode = SEEK_SET; + if (argc == 4) { + size_t length; + int c; + + length = strlen(argv[3]); + c = argv[3][0]; + if ((c == 's') && (strncmp(argv[3], "start", length) == 0)) { + mode = SEEK_SET; + } else if ((c == 'c') && (strncmp(argv[3], "current", length) == 0)) { + mode = SEEK_CUR; + } else if ((c == 'e') && (strncmp(argv[3], "end", length) == 0)) { + mode = SEEK_END; + } else { + Tcl_AppendResult(interp, "bad origin \"", argv[3], + "\": should be start, current, or end", (char *) NULL); + return TCL_ERROR; + } + } + + result = Tcl_Seek(chan, offset, mode); + if (result < 0) { + Tcl_AppendResult(interp, "error during seek on \"", + Tcl_GetChannelName(chan), "\": ", + Tcl_PosixError(interp), (char *) NULL); + return TCL_ERROR; + } + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_TellCmd -- + * + * This procedure is invoked to process the Tcl "tell" command. + * See the user documentation for details on what it does. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +int +Tcl_TellCmd(clientData, interp, argc, argv) + ClientData clientData; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ + Tcl_Channel chan; /* The channel to tell on. */ + + if (argc != 2) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " channelId\"", (char *) NULL); + return TCL_ERROR; + } + /* + * Try to find a channel with the right name and permissions in + * the IO channel table of this interpreter. + */ + + chan = Tcl_GetChannel(interp, argv[1], NULL); + if (chan == (Tcl_Channel) NULL) { + return TCL_ERROR; + } + sprintf(interp->result, "%d", Tcl_Tell(chan)); + + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_CloseCmd -- + * + * This procedure is invoked to process the Tcl "close" command. + * See the user documentation for details on what it does. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * May discard queued input; may flush queued output. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +int +Tcl_CloseCmd(clientData, interp, argc, argv) + ClientData clientData; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ + Tcl_Channel chan; /* The channel to close. */ + int len; /* Length of error output. */ + + if (argc != 2) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " channelId\"", (char *) NULL); + return TCL_ERROR; + } + chan = Tcl_GetChannel(interp, argv[1], NULL); + if (chan == (Tcl_Channel) NULL) { + return TCL_ERROR; + } + if (Tcl_UnregisterChannel(interp, chan) != TCL_OK) { + + /* + * If there is an error message and it ends with a newline, remove + * the newline. This is done for command pipeline channels where the + * error output from the subprocesses is stored in interp->result. + * + * NOTE: This is likely to not have any effect on regular error + * messages produced by drivers during the closing of a channel, + * because the Tcl convention is that such error messages do not + * have a terminating newline. + */ + + len = strlen(interp->result); + if ((len > 0) && (interp->result[len - 1] == '\n')) { + interp->result[len - 1] = '\0'; + } + + return TCL_ERROR; + } + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_FconfigureCmd -- + * + * This procedure is invoked to process the Tcl "fconfigure" command. + * See the user documentation for details on what it does. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * May modify the behavior of an IO channel. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +int +Tcl_FconfigureCmd(clientData, interp, argc, argv) + ClientData clientData; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ + Tcl_Channel chan; /* The channel to set a mode on. */ + int result; /* Of Tcl_Set/GetChannelOption. */ + int i; /* Iterate over arg-value pairs. */ + Tcl_DString ds; /* DString to hold result of + * calling Tcl_GetChannelOption. */ + + if ((argc < 2) || (((argc % 2) == 1) && (argc != 3))) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " channelId ?optionName? ?value? ?optionName value?...\"", + (char *) NULL); + return TCL_ERROR; + } + chan = Tcl_GetChannel(interp, argv[1], NULL); + if (chan == (Tcl_Channel) NULL) { + return TCL_ERROR; + } + if (argc == 2) { + Tcl_DStringInit(&ds); + if (Tcl_GetChannelOption(chan, (char *) NULL, &ds) != TCL_OK) { + Tcl_AppendResult(interp, "option retrieval failed", + (char *) NULL); + return TCL_ERROR; + } + Tcl_DStringResult(interp, &ds); + Tcl_DStringFree(&ds); + return TCL_OK; + } + if (argc == 3) { + Tcl_DStringInit(&ds); + if (Tcl_GetChannelOption(chan, argv[2], &ds) != TCL_OK) { + Tcl_DStringFree(&ds); + Tcl_AppendResult(interp, "bad option \"", argv[2], + "\": must be -blocking, -buffering, -buffersize, ", + "-eofchar, -translation, ", + "or a channel type specific option", (char *) NULL); + return TCL_ERROR; + } + Tcl_DStringResult(interp, &ds); + Tcl_DStringFree(&ds); + return TCL_OK; + } + for (i = 3; i < argc; i += 2) { + result = Tcl_SetChannelOption(interp, chan, argv[i-1], argv[i]); + if (result != TCL_OK) { + return result; + } + } + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_EofCmd -- + * + * This procedure is invoked to process the Tcl "eof" command. + * See the user documentation for details on what it does. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * Sets interp->result to "0" or "1" depending on whether the + * specified channel has an EOF condition. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +int +Tcl_EofCmd(unused, interp, argc, argv) + ClientData unused; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ + Tcl_Channel chan; /* The channel to query for EOF. */ + int mode; /* Mode in which channel is opened. */ + + if (argc != 2) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " channelId\"", (char *) NULL); + return TCL_ERROR; + } + chan = Tcl_GetChannel(interp, argv[1], &mode); + if (chan == (Tcl_Channel) NULL) { + return TCL_ERROR; + } + sprintf(interp->result, "%d", Tcl_Eof(chan) ? 1 : 0); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_ExecCmd -- + * + * This procedure is invoked to process the "exec" Tcl command. + * See the user documentation for details on what it does. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * See the user documentation. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +int +Tcl_ExecCmd(dummy, interp, argc, argv) + ClientData dummy; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ +#ifdef MAC_TCL + Tcl_AppendResult(interp, "exec not implemented under Mac OS", + (char *)NULL); + return TCL_ERROR; +#else /* !MAC_TCL */ + int keepNewline, firstWord, background, length, result; + Tcl_Channel chan; + Tcl_DString ds; + int readSoFar, readNow, bufSize; + + /* + * Check for a leading "-keepnewline" argument. + */ + + keepNewline = 0; + for (firstWord = 1; (firstWord < argc) && (argv[firstWord][0] == '-'); + firstWord++) { + if (strcmp(argv[firstWord], "-keepnewline") == 0) { + keepNewline = 1; + } else if (strcmp(argv[firstWord], "--") == 0) { + firstWord++; + break; + } else { + Tcl_AppendResult(interp, "bad switch \"", argv[firstWord], + "\": must be -keepnewline or --", (char *) NULL); + return TCL_ERROR; + } + } + + if (argc <= firstWord) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " ?switches? arg ?arg ...?\"", (char *) NULL); + return TCL_ERROR; + } + + /* + * See if the command is to be run in background. + */ + + background = 0; + if ((argv[argc-1][0] == '&') && (argv[argc-1][1] == 0)) { + argc--; + argv[argc] = NULL; + background = 1; + } + + chan = Tcl_OpenCommandChannel(interp, argc-firstWord, + argv+firstWord, + (background ? 0 : TCL_STDOUT | TCL_STDERR)); + + if (chan == (Tcl_Channel) NULL) { + return TCL_ERROR; + } + + if (background) { + + /* + * Get the list of PIDs from the pipeline into interp->result and + * detach the PIDs (instead of waiting for them). + */ + + TclGetAndDetachPids(interp, chan); + + if (Tcl_Close(interp, chan) != TCL_OK) { + return TCL_ERROR; + } + return TCL_OK; + } + + if (Tcl_GetChannelFile(chan, TCL_READABLE) != NULL) { +#define EXEC_BUFFER_SIZE 4096 + + Tcl_DStringInit(&ds); + readSoFar = 0; bufSize = 0; + while (1) { + bufSize += EXEC_BUFFER_SIZE; + Tcl_DStringSetLength(&ds, bufSize); + readNow = Tcl_Read(chan, Tcl_DStringValue(&ds) + readSoFar, + EXEC_BUFFER_SIZE); + if (readNow < 0) { + Tcl_DStringFree(&ds); + Tcl_AppendResult(interp, + "error reading output from command: ", + Tcl_PosixError(interp), (char *) NULL); + return TCL_ERROR; + } + readSoFar += readNow; + if (readNow < EXEC_BUFFER_SIZE) { + break; /* Out of "while (1)" loop. */ + } + } + Tcl_DStringSetLength(&ds, readSoFar); + Tcl_DStringResult(interp, &ds); + Tcl_DStringFree(&ds); + } + + result = Tcl_Close(interp, chan); + + /* + * If the last character of interp->result is a newline, then remove + * the newline character (the newline would just confuse things). + * Special hack: must replace the old terminating null character + * as a signal to Tcl_AppendResult et al. that we've mucked with + * the string. + */ + + length = strlen(interp->result); + if (!keepNewline && (length > 0) && + (interp->result[length-1] == '\n')) { + interp->result[length-1] = '\0'; + interp->result[length] = 'x'; + } + + return result; +#endif /* !MAC_TCL */ +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_FblockedCmd -- + * + * This procedure is invoked to process the Tcl "fblocked" command. + * See the user documentation for details on what it does. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * Sets interp->result to "0" or "1" depending on whether the + * a preceding input operation on the channel would have blocked. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +int +Tcl_FblockedCmd(unused, interp, argc, argv) + ClientData unused; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ + Tcl_Channel chan; /* The channel to query for blocked. */ + int mode; /* Mode in which channel was opened. */ + + if (argc != 2) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " channelId\"", (char *) NULL); + return TCL_ERROR; + } + chan = Tcl_GetChannel(interp, argv[1], &mode); + if (chan == (Tcl_Channel) NULL) { + return TCL_ERROR; + } + if ((mode & TCL_READABLE) == 0) { + Tcl_AppendResult(interp, "channel \"", argv[1], + "\" wasn't opened for reading", (char *) NULL); + return TCL_ERROR; + } + + sprintf(interp->result, "%d", Tcl_InputBlocked(chan) ? 1 : 0); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_OpenCmd -- + * + * This procedure is invoked to process the "open" Tcl command. + * See the user documentation for details on what it does. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * See the user documentation. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +int +Tcl_OpenCmd(notUsed, interp, argc, argv) + ClientData notUsed; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ + int pipeline, prot; + char *modeString; + Tcl_Channel chan; + + if ((argc < 2) || (argc > 4)) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " fileName ?access? ?permissions?\"", (char *) NULL); + return TCL_ERROR; + } + prot = 0666; + if (argc == 2) { + modeString = "r"; + } else { + modeString = argv[2]; + if (argc == 4) { + if (Tcl_GetInt(interp, argv[3], &prot) != TCL_OK) { + return TCL_ERROR; + } + } + } + + pipeline = 0; + if (argv[1][0] == '|') { + pipeline = 1; + } + + /* + * Open the file or create a process pipeline. + */ + + if (!pipeline) { + chan = Tcl_OpenFileChannel(interp, argv[1], modeString, prot); + } else { + int mode, seekFlag, cmdArgc; + char **cmdArgv; + + if (Tcl_SplitList(interp, argv[1]+1, &cmdArgc, &cmdArgv) != TCL_OK) { + return TCL_ERROR; + } + + mode = TclGetOpenMode(interp, modeString, &seekFlag); + if (mode == -1) { + chan = NULL; + } else { + int flags = TCL_STDERR | TCL_ENFORCE_MODE; + switch (mode & (O_RDONLY | O_WRONLY | O_RDWR)) { + case O_RDONLY: + flags |= TCL_STDOUT; + break; + case O_WRONLY: + flags |= TCL_STDIN; + break; + case O_RDWR: + flags |= (TCL_STDIN | TCL_STDOUT); + break; + default: + panic("Tcl_OpenCmd: invalid mode value"); + break; + } + chan = Tcl_OpenCommandChannel(interp, cmdArgc, cmdArgv, flags); + } + ckfree((char *) cmdArgv); + } + if (chan == (Tcl_Channel) NULL) { + return TCL_ERROR; + } + Tcl_RegisterChannel(interp, chan); + Tcl_AppendResult(interp, Tcl_GetChannelName(chan), (char *) NULL); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * TcpAcceptCallbacksDeleteProc -- + * + * Assocdata cleanup routine called when an interpreter is being + * deleted to set the interp field of all the accept callback records + * registered with the interpreter to NULL. This will prevent the + * interpreter from being used in the future to eval accept scripts. + * + * Results: + * None. + * + * Side effects: + * Deallocates memory and sets the interp field of all the accept + * callback records to NULL to prevent this interpreter from being + * used subsequently to eval accept scripts. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +static void +TcpAcceptCallbacksDeleteProc(clientData, interp) + ClientData clientData; /* Data which was passed when the assocdata + * was registered. */ + Tcl_Interp *interp; /* Interpreter being deleted - not used. */ +{ + Tcl_HashTable *hTblPtr; + Tcl_HashEntry *hPtr; + Tcl_HashSearch hSearch; + AcceptCallback *acceptCallbackPtr; + + hTblPtr = (Tcl_HashTable *) clientData; + for (hPtr = Tcl_FirstHashEntry(hTblPtr, &hSearch); + hPtr != (Tcl_HashEntry *) NULL; + hPtr = Tcl_NextHashEntry(&hSearch)) { + acceptCallbackPtr = (AcceptCallback *) Tcl_GetHashValue(hPtr); + acceptCallbackPtr->interp = (Tcl_Interp *) NULL; + } + Tcl_DeleteHashTable(hTblPtr); + ckfree((char *) hTblPtr); +} + +/* + *---------------------------------------------------------------------- + * + * RegisterTcpServerInterpCleanup -- + * + * Registers an accept callback record to have its interp + * field set to NULL when the interpreter is deleted. + * + * Results: + * None. + * + * Side effects: + * When, in the future, the interpreter is deleted, the interp + * field of the accept callback data structure will be set to + * NULL. This will prevent attempts to eval the accept script + * in a deleted interpreter. + * + *---------------------------------------------------------------------- + */ + +static void +RegisterTcpServerInterpCleanup(interp, acceptCallbackPtr) + Tcl_Interp *interp; /* Interpreter for which we want to be + * informed of deletion. */ + AcceptCallback *acceptCallbackPtr; + /* The accept callback record whose + * interp field we want set to NULL when + * the interpreter is deleted. */ +{ + Tcl_HashTable *hTblPtr; /* Hash table for accept callback + * records to smash when the interpreter + * will be deleted. */ + Tcl_HashEntry *hPtr; /* Entry for this record. */ + int new; /* Is the entry new? */ + + hTblPtr = (Tcl_HashTable *) Tcl_GetAssocData(interp, + "tclTCPAcceptCallbacks", + NULL); + if (hTblPtr == (Tcl_HashTable *) NULL) { + hTblPtr = (Tcl_HashTable *) ckalloc((unsigned) sizeof(Tcl_HashTable)); + Tcl_InitHashTable(hTblPtr, TCL_ONE_WORD_KEYS); + (void) Tcl_SetAssocData(interp, "tclTCPAcceptCallbacks", + TcpAcceptCallbacksDeleteProc, (ClientData) hTblPtr); + } + hPtr = Tcl_CreateHashEntry(hTblPtr, (char *) acceptCallbackPtr, &new); + if (!new) { + panic("RegisterTcpServerCleanup: damaged accept record table"); + } + Tcl_SetHashValue(hPtr, (ClientData) acceptCallbackPtr); +} + +/* + *---------------------------------------------------------------------- + * + * UnregisterTcpServerInterpCleanupProc -- + * + * Unregister a previously registered accept callback record. The + * interp field of this record will no longer be set to NULL in + * the future when the interpreter is deleted. + * + * Results: + * None. + * + * Side effects: + * Prevents the interp field of the accept callback record from + * being set to NULL in the future when the interpreter is deleted. + * + *---------------------------------------------------------------------- + */ + +static void +UnregisterTcpServerInterpCleanupProc(interp, acceptCallbackPtr) + Tcl_Interp *interp; /* Interpreter in which the accept callback + * record was registered. */ + AcceptCallback *acceptCallbackPtr; + /* The record for which to delete the + * registration. */ +{ + Tcl_HashTable *hTblPtr; + Tcl_HashEntry *hPtr; + + hTblPtr = (Tcl_HashTable *) Tcl_GetAssocData(interp, + "tclTCPAcceptCallbacks", NULL); + if (hTblPtr == (Tcl_HashTable *) NULL) { + return; + } + hPtr = Tcl_FindHashEntry(hTblPtr, (char *) acceptCallbackPtr); + if (hPtr == (Tcl_HashEntry *) NULL) { + return; + } + Tcl_DeleteHashEntry(hPtr); +} + +/* + *---------------------------------------------------------------------- + * + * AcceptCallbackProc -- + * + * This callback is invoked by the TCP channel driver when it + * accepts a new connection from a client on a server socket. + * + * Results: + * None. + * + * Side effects: + * Whatever the script does. + * + *---------------------------------------------------------------------- + */ + +static void +AcceptCallbackProc(callbackData, chan, address, port) + ClientData callbackData; /* The data stored when the callback + * was created in the call to + * Tcl_OpenTcpServer. */ + Tcl_Channel chan; /* Channel for the newly accepted + * connection. */ + char *address; /* Address of client that was + * accepted. */ + int port; /* Port of client that was accepted. */ +{ + AcceptCallback *acceptCallbackPtr; + Tcl_Interp *interp; + char *script; + char portBuf[10]; + int result; + + acceptCallbackPtr = (AcceptCallback *) callbackData; + + /* + * Check if the callback is still valid; the interpreter may have gone + * away, this is signalled by setting the interp field of the callback + * data to NULL. + */ + + if (acceptCallbackPtr->interp != (Tcl_Interp *) NULL) { + + script = acceptCallbackPtr->script; + interp = acceptCallbackPtr->interp; + + Tcl_Preserve((ClientData) script); + Tcl_Preserve((ClientData) interp); + + sprintf(portBuf, "%d", port); + Tcl_RegisterChannel(interp, chan); + result = Tcl_VarEval(interp, script, " ", Tcl_GetChannelName(chan), + " ", address, " ", portBuf, (char *) NULL); + if (result != TCL_OK) { + Tcl_BackgroundError(interp); + Tcl_UnregisterChannel(interp, chan); + } + Tcl_Release((ClientData) interp); + Tcl_Release((ClientData) script); + } else { + + /* + * The interpreter has been deleted, so there is no useful + * way to utilize the client socket - just close it. + */ + + Tcl_Close((Tcl_Interp *) NULL, chan); + } +} + +/* + *---------------------------------------------------------------------- + * + * TcpServerCloseProc -- + * + * This callback is called when the TCP server channel for which it + * was registered is being closed. It informs the interpreter in + * which the accept script is evaluated (if that interpreter still + * exists) that this channel no longer needs to be informed if the + * interpreter is deleted. + * + * Results: + * None. + * + * Side effects: + * In the future, if the interpreter is deleted this channel will + * no longer be informed. + * + *---------------------------------------------------------------------- + */ + +static void +TcpServerCloseProc(callbackData) + ClientData callbackData; /* The data passed in the call to + * Tcl_CreateCloseHandler. */ +{ + AcceptCallback *acceptCallbackPtr; + /* The actual data. */ + + acceptCallbackPtr = (AcceptCallback *) callbackData; + if (acceptCallbackPtr->interp != (Tcl_Interp *) NULL) { + UnregisterTcpServerInterpCleanupProc(acceptCallbackPtr->interp, + acceptCallbackPtr); + } + Tcl_EventuallyFree((ClientData) acceptCallbackPtr->script, TCL_DYNAMIC); + ckfree((char *) acceptCallbackPtr); +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_SocketCmd -- + * + * This procedure is invoked to process the "socket" Tcl command. + * See the user documentation for details on what it does. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * Creates a socket based channel. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_SocketCmd(notUsed, interp, argc, argv) + ClientData notUsed; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ + int a, server, port; + char *arg, *copyScript, *host, *script; + char *myaddr = NULL; + int myport = 0; + int async = 0; + Tcl_Channel chan; + AcceptCallback *acceptCallbackPtr; + + server = 0; + script = NULL; + + if (TclHasSockets(interp) != TCL_OK) { + return TCL_ERROR; + } + + for (a = 1; a < argc; a++) { + arg = argv[a]; + if (arg[0] == '-') { + if (strcmp(arg, "-server") == 0) { + if (async == 1) { + Tcl_AppendResult(interp, + "cannot set -async option for server sockets", + (char *) NULL); + return TCL_ERROR; + } + server = 1; + a++; + if (a >= argc) { + Tcl_AppendResult(interp, + "no argument given for -server option", + (char *) NULL); + return TCL_ERROR; + } + script = argv[a]; + } else if (strcmp(arg, "-myaddr") == 0) { + a++; + if (a >= argc) { + Tcl_AppendResult(interp, + "no argument given for -myaddr option", + (char *) NULL); + return TCL_ERROR; + } + myaddr = argv[a]; + } else if (strcmp(arg, "-myport") == 0) { + a++; + if (a >= argc) { + Tcl_AppendResult(interp, + "no argument given for -myport option", + (char *) NULL); + return TCL_ERROR; + } + if (TclSockGetPort(interp, argv[a], "tcp", &myport) + != TCL_OK) { + return TCL_ERROR; + } + } else if (strcmp(arg, "-async") == 0) { + if (server == 1) { + Tcl_AppendResult(interp, + "cannot set -async option for server sockets", + (char *) NULL); + return TCL_ERROR; + } + async = 1; + } else { + Tcl_AppendResult(interp, "bad option \"", arg, + "\", must be -async, -myaddr, -myport, or -server", + (char *) NULL); + return TCL_ERROR; + } + } else { + break; + } + } + if (server) { + host = myaddr; /* NULL implies INADDR_ANY */ + if (myport != 0) { + Tcl_AppendResult(interp, "Option -myport is not valid for servers", + NULL); + return TCL_ERROR; + } + } else if (a < argc) { + host = argv[a]; + a++; + } else { +wrongNumArgs: + Tcl_AppendResult(interp, "wrong # args: should be either:\n", + argv[0], + " ?-myaddr addr? ?-myport myport? ?-async? host port\n", + argv[0], + " -server command ?-myaddr addr? port", + (char *) NULL); + return TCL_ERROR; + } + + if (a == argc-1) { + if (TclSockGetPort(interp, argv[a], "tcp", &port) != TCL_OK) { + return TCL_ERROR; + } + } else { + goto wrongNumArgs; + } + + if (server) { + acceptCallbackPtr = (AcceptCallback *) ckalloc((unsigned) + sizeof(AcceptCallback)); + copyScript = ckalloc((unsigned) strlen(script) + 1); + strcpy(copyScript, script); + acceptCallbackPtr->script = copyScript; + acceptCallbackPtr->interp = interp; + chan = Tcl_OpenTcpServer(interp, port, host, AcceptCallbackProc, + (ClientData) acceptCallbackPtr); + if (chan == (Tcl_Channel) NULL) { + ckfree(copyScript); + ckfree((char *) acceptCallbackPtr); + return TCL_ERROR; + } + + /* + * Register with the interpreter to let us know when the + * interpreter is deleted (by having the callback set the + * acceptCallbackPtr->interp field to NULL). This is to + * avoid trying to eval the script in a deleted interpreter. + */ + + RegisterTcpServerInterpCleanup(interp, acceptCallbackPtr); + + /* + * Register a close callback. This callback will inform the + * interpreter (if it still exists) that this channel does not + * need to be informed when the interpreter is deleted. + */ + + Tcl_CreateCloseHandler(chan, TcpServerCloseProc, + (ClientData) acceptCallbackPtr); + } else { + chan = Tcl_OpenTcpClient(interp, port, host, myaddr, myport, async); + if (chan == (Tcl_Channel) NULL) { + return TCL_ERROR; + } + } + Tcl_RegisterChannel(interp, chan); + Tcl_AppendResult(interp, Tcl_GetChannelName(chan), (char *) NULL); + + return TCL_OK; +} diff --git a/contrib/tcl/generic/tclIOSock.c b/contrib/tcl/generic/tclIOSock.c new file mode 100644 index 0000000..8285037 --- /dev/null +++ b/contrib/tcl/generic/tclIOSock.c @@ -0,0 +1,96 @@ +/* + * tclIOSock.c -- + * + * Common routines used by all socket based channel types. + * + * 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: @(#) tclIOSock.c 1.16 96/03/12 07:04:33 + */ + +#include "tclInt.h" +#include "tclPort.h" + +/* + *---------------------------------------------------------------------- + * + * TclSockGetPort -- + * + * Maps from a string, which could be a service name, to a port. + * Used by socket creation code to get port numbers and resolve + * registered service names to port numbers. + * + * Results: + * A standard Tcl result. On success, the port number is + * returned in portPtr. On failure, an error message is left in + * interp->result. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +int +TclSockGetPort(interp, string, proto, portPtr) + Tcl_Interp *interp; + char *string; /* Integer or service name */ + char *proto; /* "tcp" or "udp", typically */ + int *portPtr; /* Return port number */ +{ + struct servent *sp = getservbyname(string, proto); + if (sp != NULL) { + *portPtr = ntohs((unsigned short) sp->s_port); + return TCL_OK; + } + if (Tcl_GetInt(interp, string, portPtr) != TCL_OK) { + return TCL_ERROR; + } + if (*portPtr > 0xFFFF) { + Tcl_AppendResult(interp, "couldn't open socket: port number too high", + (char *) NULL); + return TCL_ERROR; + } + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * TclSockMinimumBuffers -- + * + * Ensure minimum buffer sizes (non zero). + * + * Results: + * A standard Tcl result. + * + * Side effects: + * Sets SO_SNDBUF and SO_RCVBUF sizes. + * + *---------------------------------------------------------------------- + */ + +int +TclSockMinimumBuffers(sock, size) + int sock; /* Socket file descriptor */ + int size; /* Minimum buffer size */ +{ + int current; + int len = sizeof(int); + + getsockopt(sock, SOL_SOCKET, SO_SNDBUF, (char *) ¤t, &len); + if (current < size) { + len = sizeof(int); + setsockopt(sock, SOL_SOCKET, SO_SNDBUF, (char *) &size, len); + } + len = sizeof(int); + getsockopt(sock, SOL_SOCKET, SO_RCVBUF, (char *) ¤t, &len); + if (current < size) { + len = sizeof(int); + setsockopt(sock, SOL_SOCKET, SO_RCVBUF, (char *) &size, len); + } + return TCL_OK; +} diff --git a/contrib/tcl/generic/tclIOUtil.c b/contrib/tcl/generic/tclIOUtil.c new file mode 100644 index 0000000..16f97acb --- /dev/null +++ b/contrib/tcl/generic/tclIOUtil.c @@ -0,0 +1,1287 @@ +/* + * tclIOUtil.c -- + * + * This file contains a collection of utility procedures that + * are shared by the platform specific IO drivers. + * + * Parts of this file are based on code contributed by Karl + * Lehenbauer, Mark Diekhans and Peter da Silva. + * + * Copyright (c) 1991-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: @(#) tclIOUtil.c 1.122 96/04/02 18:46:40 + */ + +#include "tclInt.h" +#include "tclPort.h" + +/* + * A linked list of the following structures is used to keep track + * of child processes that have been detached but haven't exited + * yet, so we can make sure that they're properly "reaped" (officially + * waited for) and don't lie around as zombies cluttering the + * system. + */ + +typedef struct Detached { + int pid; /* Id of process that's been detached + * but isn't known to have exited. */ + struct Detached *nextPtr; /* Next in list of all detached + * processes. */ +} Detached; + +static Detached *detList = NULL; /* List of all detached proceses. */ + +/* + * Declarations for local procedures defined in this file: + */ + +static Tcl_File FileForRedirect _ANSI_ARGS_((Tcl_Interp *interp, + char *spec, int atOk, char *arg, int flags, + char *nextArg, int *skipPtr, int *closePtr)); + +/* + *---------------------------------------------------------------------- + * + * FileForRedirect -- + * + * This procedure does much of the work of parsing redirection + * operators. It handles "@" if specified and allowed, and a file + * name, and opens the file if necessary. + * + * Results: + * The return value is the descriptor number for the file. If an + * error occurs then NULL is returned and an error message is left + * in interp->result. Several arguments are side-effected; see + * the argument list below for details. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static Tcl_File +FileForRedirect(interp, spec, atOk, arg, flags, nextArg, skipPtr, closePtr) + Tcl_Interp *interp; /* Intepreter to use for error + * reporting. */ + register char *spec; /* Points to character just after + * redirection character. */ + int atOk; /* Non-zero means '@' notation is + * OK, zero means it isn't. */ + char *arg; /* Pointer to entire argument + * containing spec: used for error + * reporting. */ + int flags; /* Flags to use for opening file. */ + char *nextArg; /* Next argument in argc/argv + * array, if needed for file name. + * May be NULL. */ + int *skipPtr; /* This value is incremented if + * nextArg is used for redirection + * spec. */ + int *closePtr; /* This value is set to 1 if the file + * that's returned must be closed, 0 + * if it was specified with "@" so + * it must be left open. */ +{ + int writing = (flags & O_WRONLY); + Tcl_Channel chan; + Tcl_File file; + + if (atOk && (*spec == '@')) { + spec++; + if (*spec == 0) { + spec = nextArg; + if (spec == NULL) { + goto badLastArg; + } + *skipPtr += 1; + } + chan = Tcl_GetChannel(interp, spec, NULL); + if (chan == (Tcl_Channel) NULL) { + return NULL; + } + *closePtr = 0; + file = Tcl_GetChannelFile(chan, writing ? TCL_WRITABLE : TCL_READABLE); + if (file == NULL) { + Tcl_AppendResult(interp, + "channel \"", + Tcl_GetChannelName(chan), + "\" wasn't opened for ", + writing ? "writing" : "reading", (char *) NULL); + return NULL; + } + if (writing) { + + /* + * Be sure to flush output to the file, so that anything + * written by the child appears after stuff we've already + * written. + */ + + Tcl_Flush(chan); + } + } else { + Tcl_DString buffer; + char *name; + + if (*spec == 0) { + spec = nextArg; + if (spec == NULL) { + goto badLastArg; + } + *skipPtr += 1; + } + name = Tcl_TranslateFileName(interp, spec, &buffer); + if (name) { + file = TclOpenFile(name, flags); + } else { + file = NULL; + } + Tcl_DStringFree(&buffer); + if (file == NULL) { + Tcl_AppendResult(interp, "couldn't ", + (writing) ? "write" : "read", " file \"", spec, "\": ", + Tcl_PosixError(interp), (char *) NULL); + return NULL; + } + *closePtr = 1; + } + return file; + + badLastArg: + Tcl_AppendResult(interp, "can't specify \"", arg, + "\" as last word in command", (char *) NULL); + return NULL; +} + +/* + *---------------------------------------------------------------------- + * + * 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 + * returns -1 and if interp is not NULL, sets interp->result 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. */ + 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. + */ + + *seekFlagPtr = 0; + mode = 0; + if (islower(UCHAR(string[0]))) { + 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; + gotRW = 1; + } else if ((c == 'A') && (strcmp(flag, "APPEND") == 0)) { + mode |= O_APPEND; + *seekFlagPtr = 1; + } else if ((c == 'C') && (strcmp(flag, "CREAT") == 0)) { + mode |= O_CREAT; + } else if ((c == 'E') && (strcmp(flag, "EXCL") == 0)) { + mode |= O_EXCL; + } else if ((c == 'N') && (strcmp(flag, "NOCTTY") == 0)) { +#ifdef O_NOCTTY + mode |= O_NOCTTY; +#else + if (interp != (Tcl_Interp *) NULL) { + Tcl_AppendResult(interp, "access mode \"", flag, + "\" not supported by this system", (char *) NULL); + } + ckfree((char *) modeArgv); + return -1; +#endif + } else if ((c == 'N') && (strcmp(flag, "NONBLOCK") == 0)) { +#if defined(O_NDELAY) || defined(O_NONBLOCK) +# ifdef O_NONBLOCK + mode |= O_NONBLOCK; +# else + mode |= O_NDELAY; +# endif +#else + if (interp != (Tcl_Interp *) NULL) { + Tcl_AppendResult(interp, "access mode \"", flag, + "\" not supported by this system", (char *) NULL); + } + ckfree((char *) modeArgv); + return -1; +#endif + } else if ((c == 'T') && (strcmp(flag, "TRUNC") == 0)) { + mode |= O_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; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_EvalFile -- + * + * 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. + * + *---------------------------------------------------------------------- + */ + +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. */ +{ + int result; + struct stat statBuf; + char *cmdBuffer = (char *) NULL; + char *oldScriptFile = (char *) NULL; + Interp *iPtr = (Interp *) interp; + Tcl_DString buffer; + char *nativeName = (char *) NULL; + Tcl_Channel chan = (Tcl_Channel) NULL; + + Tcl_ResetResult(interp); + oldScriptFile = iPtr->scriptFile; + iPtr->scriptFile = fileName; + Tcl_DStringInit(&buffer); + nativeName = Tcl_TranslateFileName(interp, fileName, &buffer); + if (nativeName == NULL) { + goto error; + } + + /* + * If Tcl_TranslateFileName didn't already copy the file name, do it + * here. This way we don't depend on fileName staying constant + * throughout the execution of the script (e.g., what if it happens + * to point to a Tcl variable that the script could change?). + */ + + if (nativeName != Tcl_DStringValue(&buffer)) { + Tcl_DStringSetLength(&buffer, 0); + Tcl_DStringAppend(&buffer, nativeName, -1); + nativeName = Tcl_DStringValue(&buffer); + } + if (stat(nativeName, &statBuf) == -1) { + Tcl_SetErrno(errno); + Tcl_AppendResult(interp, "couldn't read file \"", fileName, + "\": ", Tcl_PosixError(interp), (char *) NULL); + goto error; + } + chan = Tcl_OpenFileChannel(interp, nativeName, "r", 0644); + if (chan == (Tcl_Channel) NULL) { + Tcl_ResetResult(interp); + Tcl_AppendResult(interp, "couldn't read file \"", fileName, + "\": ", Tcl_PosixError(interp), (char *) NULL); + goto error; + } + cmdBuffer = (char *) ckalloc((unsigned) statBuf.st_size+1); + result = Tcl_Read(chan, cmdBuffer, statBuf.st_size); + if (result < 0) { + Tcl_Close(interp, chan); + Tcl_AppendResult(interp, "couldn't read file \"", fileName, + "\": ", Tcl_PosixError(interp), (char *) NULL); + goto error; + } + cmdBuffer[result] = 0; + if (Tcl_Close(interp, chan) != TCL_OK) { + goto error; + } + + result = Tcl_Eval(interp, cmdBuffer); + if (result == TCL_RETURN) { + result = TclUpdateReturnInfo(iPtr); + } else if (result == TCL_ERROR) { + char msg[200]; + + /* + * Record information telling where the error occurred. + */ + + sprintf(msg, "\n (file \"%.150s\" line %d)", fileName, + interp->errorLine); + Tcl_AddErrorInfo(interp, msg); + } + iPtr->scriptFile = oldScriptFile; + ckfree(cmdBuffer); + Tcl_DStringFree(&buffer); + return result; + +error: + if (cmdBuffer != (char *) NULL) { + ckfree(cmdBuffer); + } + iPtr->scriptFile = oldScriptFile; + Tcl_DStringFree(&buffer); + return TCL_ERROR; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_DetachPids -- + * + * This procedure is called to indicate that one or more child + * processes have been placed in background and will never be + * waited for; they should eventually be reaped by + * Tcl_ReapDetachedProcs. + * + * Results: + * None. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +void +Tcl_DetachPids(numPids, pidPtr) + int numPids; /* Number of pids to detach: gives size + * of array pointed to by pidPtr. */ + int *pidPtr; /* Array of pids to detach. */ +{ + register Detached *detPtr; + int i; + + for (i = 0; i < numPids; i++) { + detPtr = (Detached *) ckalloc(sizeof(Detached)); + detPtr->pid = pidPtr[i]; + detPtr->nextPtr = detList; + detList = detPtr; + } +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_ReapDetachedProcs -- + * + * This procedure checks to see if any detached processes have + * exited and, if so, it "reaps" them by officially waiting on + * them. It should be called "occasionally" to make sure that + * all detached processes are eventually reaped. + * + * Results: + * None. + * + * Side effects: + * Processes are waited on, so that they can be reaped by the + * system. + * + *---------------------------------------------------------------------- + */ + +void +Tcl_ReapDetachedProcs() +{ + register Detached *detPtr; + Detached *nextPtr, *prevPtr; + int status; + pid_t pid; + + for (detPtr = detList, prevPtr = NULL; detPtr != NULL; ) { + pid = Tcl_WaitPid(detPtr->pid, &status, WNOHANG); + if ((pid == 0) || ((pid == -1) && (errno != ECHILD))) { + prevPtr = detPtr; + detPtr = detPtr->nextPtr; + continue; + } + nextPtr = detPtr->nextPtr; + if (prevPtr == NULL) { + detList = detPtr->nextPtr; + } else { + prevPtr->nextPtr = detPtr->nextPtr; + } + ckfree((char *) detPtr); + detPtr = nextPtr; + } +} + +/* + *---------------------------------------------------------------------- + * + * TclCleanupChildren -- + * + * This is a utility procedure used to wait for child processes + * to exit, record information about abnormal exits, and then + * collect any stderr output generated by them. + * + * Results: + * The return value is a standard Tcl result. If anything at + * weird happened with the child processes, TCL_ERROR is returned + * and a message is left in interp->result. + * + * Side effects: + * If the last character of interp->result is a newline, then it + * is removed unless keepNewline is non-zero. File errorId gets + * closed, and pidPtr is freed back to the storage allocator. + * + *---------------------------------------------------------------------- + */ + +int +TclCleanupChildren(interp, numPids, pidPtr, errorChan) + Tcl_Interp *interp; /* Used for error messages. */ + int numPids; /* Number of entries in pidPtr array. */ + int *pidPtr; /* Array of process ids of children. */ + Tcl_Channel errorChan; /* Channel for file containing stderr output + * from pipeline. NULL means there isn't any + * stderr output. */ +{ + int result = TCL_OK; + int i, pid, abnormalExit, anyErrorInfo; + WAIT_STATUS_TYPE waitStatus; + char *msg; + + abnormalExit = 0; + for (i = 0; i < numPids; i++) { + pid = (int) Tcl_WaitPid(pidPtr[i], (int *) &waitStatus, 0); + if (pid == -1) { + result = TCL_ERROR; + if (interp != (Tcl_Interp *) NULL) { + msg = Tcl_PosixError(interp); + if (errno == ECHILD) { + /* + * This changeup in message suggested by Mark Diekhans + * to remind people that ECHILD errors can occur on + * some systems if SIGCHLD isn't in its default state. + */ + + msg = + "child process lost (is SIGCHLD ignored or trapped?)"; + } + Tcl_AppendResult(interp, "error waiting for process to exit: ", + msg, (char *) NULL); + } + continue; + } + + /* + * Create error messages for unusual process exits. An + * extra newline gets appended to each error message, but + * it gets removed below (in the same fashion that an + * extra newline in the command's output is removed). + */ + + if (!WIFEXITED(waitStatus) || (WEXITSTATUS(waitStatus) != 0)) { + char msg1[20], msg2[20]; + + result = TCL_ERROR; + sprintf(msg1, "%d", pid); + if (WIFEXITED(waitStatus)) { + if (interp != (Tcl_Interp *) NULL) { + sprintf(msg2, "%d", WEXITSTATUS(waitStatus)); + Tcl_SetErrorCode(interp, "CHILDSTATUS", msg1, msg2, + (char *) NULL); + } + abnormalExit = 1; + } else if (WIFSIGNALED(waitStatus)) { + if (interp != (Tcl_Interp *) NULL) { + char *p; + + p = Tcl_SignalMsg((int) (WTERMSIG(waitStatus))); + Tcl_SetErrorCode(interp, "CHILDKILLED", msg1, + Tcl_SignalId((int) (WTERMSIG(waitStatus))), p, + (char *) NULL); + Tcl_AppendResult(interp, "child killed: ", p, "\n", + (char *) NULL); + } + } else if (WIFSTOPPED(waitStatus)) { + if (interp != (Tcl_Interp *) NULL) { + char *p; + + p = Tcl_SignalMsg((int) (WSTOPSIG(waitStatus))); + Tcl_SetErrorCode(interp, "CHILDSUSP", msg1, + Tcl_SignalId((int) (WSTOPSIG(waitStatus))), + p, (char *) NULL); + Tcl_AppendResult(interp, "child suspended: ", p, "\n", + (char *) NULL); + } + } else { + if (interp != (Tcl_Interp *) NULL) { + Tcl_AppendResult(interp, + "child wait status didn't make sense\n", + (char *) NULL); + } + } + } + } + + /* + * Read the standard error file. If there's anything there, + * then return an error and add the file's contents to the result + * string. + */ + + anyErrorInfo = 0; + if (errorChan != NULL) { + + /* + * Make sure we start at the beginning of the file. + */ + + Tcl_Seek(errorChan, 0L, SEEK_SET); + + if (interp != (Tcl_Interp *) NULL) { + while (1) { +#define BUFFER_SIZE 1000 + char buffer[BUFFER_SIZE+1]; + int count; + + count = Tcl_Read(errorChan, buffer, BUFFER_SIZE); + if (count == 0) { + break; + } + result = TCL_ERROR; + if (count < 0) { + Tcl_AppendResult(interp, + "error reading stderr output file: ", + Tcl_PosixError(interp), (char *) NULL); + break; /* out of the "while (1)" loop. */ + } + buffer[count] = 0; + Tcl_AppendResult(interp, buffer, (char *) NULL); + anyErrorInfo = 1; + } + } + + Tcl_Close(NULL, errorChan); + } + + /* + * If a child exited abnormally but didn't output any error information + * at all, generate an error message here. + */ + + if (abnormalExit && !anyErrorInfo && (interp != (Tcl_Interp *) NULL)) { + Tcl_AppendResult(interp, "child process exited abnormally", + (char *) NULL); + } + + return result; +} + +/* + *---------------------------------------------------------------------- + * + * TclCreatePipeline -- + * + * Given an argc/argv array, instantiate a pipeline of processes + * as described by the argv. + * + * Results: + * The return value is a count of the number of new processes + * created, or -1 if an error occurred while creating the pipeline. + * *pidArrayPtr is filled in with the address of a dynamically + * allocated array giving the ids of all of the processes. It + * is up to the caller to free this array when it isn't needed + * anymore. If inPipePtr is non-NULL, *inPipePtr is filled in + * with the file id for the input pipe for the pipeline (if any): + * the caller must eventually close this file. If outPipePtr + * isn't NULL, then *outPipePtr is filled in with the file id + * for the output pipe from the pipeline: the caller must close + * this file. If errFilePtr isn't NULL, then *errFilePtr is filled + * with a file id that may be used to read error output after the + * pipeline completes. + * + * Side effects: + * Processes and pipes are created. + * + *---------------------------------------------------------------------- + */ + +int +TclCreatePipeline(interp, argc, argv, pidArrayPtr, inPipePtr, + 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 + * pipeline plus I/O redirection with <, + * <<, >, etc. Argv[argc] must be NULL. */ + int **pidArrayPtr; /* Word at *pidArrayPtr gets filled in with + * address of array of pids for processes + * in pipeline (first pid is first process + * in pipeline). */ + Tcl_File *inPipePtr; /* If non-NULL, input to the pipeline comes + * from a pipe (unless overridden by + * redirection in the command). The file + * id with which to write to this pipe is + * stored at *inPipePtr. NULL means command + * specified its own input source. */ + Tcl_File *outPipePtr; /* If non-NULL, output to the pipeline goes + * to a pipe, unless overriden by redirection + * in the command. The file id with which to + * read frome this pipe is stored at + * *outPipePtr. NULL means command specified + * its own output sink. */ + Tcl_File *errFilePtr; /* If non-NULL, all stderr output from the + * pipeline will go to a temporary file + * created here, and a descriptor to read + * the file will be left at *errFilePtr. + * The file will be removed already, so + * closing this descriptor will be the end + * of the file. If this is NULL, then + * all stderr output goes to our stderr. + * If the pipeline specifies redirection + * then the file will still be created + * but it will never get any data. */ +{ +#if defined( MAC_TCL ) + Tcl_AppendResult(interp, + "command pipelines not supported on Macintosh OS", NULL); + return -1; +#else /* !MAC_TCL */ + int *pidPtr = NULL; /* Points to malloc-ed array holding all + * the pids of child processes. */ + int numPids = 0; /* Actual number of processes that exist + * at *pidPtr right now. */ + int cmdCount; /* Count of number of distinct commands + * found in argc/argv. */ + char *input = 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. */ + Tcl_File inputFile = NULL; + /* If != NULL, gives file to use as input for + * first process in pipeline (specified via < + * or <@). */ + int closeInput = 0; /* If non-zero, then must close inputId + * when cleaning up (zero means the file needs + * to stay open for some other reason). */ + Tcl_File outputFile = NULL; + /* Writable file for output from last command + * in pipeline (could be file or pipe). NULL + * means use stdout. */ + int closeOutput = 0; /* Non-zero means must close outputId when + * cleaning up (similar to closeInput). */ + Tcl_File errorFile = NULL; + /* Writable file for error output from all + * commands in pipeline. NULL means use + * stderr. */ + int closeError = 0; /* Non-zero means must close errorId when + * cleaning up. */ + int skip; /* Number of arguments to skip (because they + * specify redirection). */ + int lastBar; + int i, j; + char *p; + int hasPipes = TclHasPipes(); + char finalOut[L_tmpnam]; + char intIn[L_tmpnam]; + + finalOut[0] = '\0'; + intIn[0] = '\0'; + + if (inPipePtr != NULL) { + *inPipePtr = NULL; + } + if (outPipePtr != NULL) { + *outPipePtr = NULL; + } + if (errFilePtr != NULL) { + *errFilePtr = NULL; + } + + /* + * First, scan through all the arguments to figure out the structure + * of the pipeline. Process all of the input and output redirection + * arguments and remove them from the argument list in the pipeline. + * Count the number of distinct processes (it's the number of "|" + * arguments plus one) but don't remove the "|" arguments. + */ + + cmdCount = 1; + lastBar = -1; + for (i = 0; i < argc; i++) { + if ((argv[i][0] == '|') && (((argv[i][1] == 0)) + || ((argv[i][1] == '&') && (argv[i][2] == 0)))) { + if ((i == (lastBar+1)) || (i == (argc-1))) { + interp->result = "illegal use of | or |& in command"; + return -1; + } + lastBar = i; + cmdCount++; + continue; + } else if (argv[i][0] == '<') { + if ((inputFile != NULL) && closeInput) { + TclCloseFile(inputFile); + } + inputFile = NULL; + skip = 1; + if (argv[i][1] == '<') { + input = argv[i]+2; + if (*input == 0) { + input = argv[i+1]; + if (input == 0) { + Tcl_AppendResult(interp, "can't specify \"", argv[i], + "\" as last word in command", (char *) NULL); + goto error; + } + skip = 2; + } + } else { + input = 0; + inputFile = FileForRedirect(interp, argv[i]+1, 1, argv[i], + O_RDONLY, argv[i+1], &skip, &closeInput); + if (inputFile == NULL) { + goto error; + } + + /* When Win32s dies out, this code can be removed */ + if (!hasPipes) { + if (!closeInput) { + Tcl_AppendResult(interp, "redirection with '@'", + " notation is not supported on this system", + (char *) NULL); + goto error; + } + strcpy(intIn, skip == 1 ? argv[i]+1 : argv[i+1]); + } + } + } else if (argv[i][0] == '>') { + int append, useForStdErr, useForStdOut, mustClose, atOk, flags; + Tcl_File file; + + skip = atOk = 1; + append = useForStdErr = 0; + useForStdOut = 1; + if (argv[i][1] == '>') { + p = argv[i] + 2; + append = 1; + atOk = 0; + flags = O_WRONLY|O_CREAT; + } else { + p = argv[i] + 1; + flags = O_WRONLY|O_CREAT|O_TRUNC; + } + if (*p == '&') { + useForStdErr = 1; + p++; + } + file = FileForRedirect(interp, p, atOk, argv[i], flags, argv[i+1], + &skip, &mustClose); + if (file == NULL) { + goto error; + } + + /* When Win32s dies out, this code can be removed */ + if (!hasPipes) { + if (!mustClose) { + Tcl_AppendResult(interp, "redirection with '@'", + " notation is not supported on this system", + (char *) NULL); + goto error; + } + strcpy(finalOut, skip == 1 ? p : argv[i+1]); + } + + if (hasPipes && append) { + TclSeekFile(file, 0L, 2); + } + + /* + * Got the file descriptor. Now use it for standard output, + * standard error, or both, depending on the redirection. + */ + + if (useForStdOut) { + if ((outputFile != NULL) && closeOutput) { + TclCloseFile(outputFile); + } + outputFile = file; + closeOutput = mustClose; + } + if (useForStdErr) { + if ((errorFile != NULL) && closeError) { + TclCloseFile(errorFile); + } + errorFile = file; + closeError = (useForStdOut) ? 0 : mustClose; + } + } else if ((argv[i][0] == '2') && (argv[i][1] == '>')) { + int append, atOk, flags; + + if ((errorFile != NULL) && closeError) { + TclCloseFile(errorFile); + } + skip = 1; + p = argv[i] + 2; + if (*p == '>') { + p++; + append = 1; + atOk = 0; + flags = O_WRONLY|O_CREAT; + } else { + append = 0; + atOk = 1; + flags = O_WRONLY|O_CREAT|O_TRUNC; + } + errorFile = FileForRedirect(interp, p, atOk, argv[i], flags, + argv[i+1], &skip, &closeError); + if (errorFile == NULL) { + goto error; + } + if (hasPipes && append) { + TclSeekFile(errorFile, 0L, 2); + } + } else { + continue; + } + for (j = i+skip; j < argc; j++) { + argv[j-skip] = argv[j]; + } + argc -= skip; + i -= 1; /* Process next arg from same position. */ + } + if (argc == 0) { + interp->result = "didn't specify command to execute"; + return -1; + } + + if ((hasPipes && inputFile == NULL) || (!hasPipes && intIn[0] == '\0')) { + if (input != NULL) { + + /* + * The input for the first process is immediate data coming from + * Tcl. Create a temporary file for it and put the data into the + * file. + */ + + inputFile = TclCreateTempFile(input); + closeInput = 1; + if (inputFile == NULL) { + Tcl_AppendResult(interp, + "couldn't create input file for command: ", + Tcl_PosixError(interp), (char *) NULL); + goto error; + } + } else if (inPipePtr != NULL) { + Tcl_File inPipe, outPipe; + /* + * The input for the first process in the pipeline is to + * come from a pipe that can be written from this end. + */ + + if (!hasPipes || TclCreatePipe(&inPipe, &outPipe) == 0) { + Tcl_AppendResult(interp, + "couldn't create input pipe for command: ", + Tcl_PosixError(interp), (char *) NULL); + goto error; + } + inputFile = inPipe; + closeInput = 1; + *inPipePtr = outPipe; + } + } + + /* + * Set up a pipe to receive output from the pipeline, if no other + * output sink has been specified. + */ + + if ((outputFile == NULL) && (outPipePtr != NULL)) { + if (!hasPipes) { + tmpnam(finalOut); + } else { + Tcl_File inPipe, outPipe; + if (TclCreatePipe(&inPipe, &outPipe) == 0) { + Tcl_AppendResult(interp, + "couldn't create output pipe for command: ", + Tcl_PosixError(interp), (char *) NULL); + goto error; + } + outputFile = outPipe; + closeOutput = 1; + *outPipePtr = inPipe; + } + } + + /* + * Set up the standard error output sink for the pipeline, if + * requested. Use a temporary file which is opened, then deleted. + * Could potentially just use pipe, but if it filled up it could + * cause the pipeline to deadlock: we'd be waiting for processes + * to complete before reading stderr, and processes couldn't complete + * because stderr was backed up. + */ + + if (errFilePtr && !errorFile) { + *errFilePtr = TclCreateTempFile(NULL); + if (*errFilePtr == NULL) { + Tcl_AppendResult(interp, + "couldn't create error file for command: ", + Tcl_PosixError(interp), (char *) NULL); + goto error; + } + errorFile = *errFilePtr; + closeError = 0; + } + + /* + * Scan through the argc array, forking off a process for each + * group of arguments between "|" arguments. + */ + + pidPtr = (int *) ckalloc((unsigned) (cmdCount * sizeof(int))); + Tcl_ReapDetachedProcs(); + + if (TclSpawnPipeline(interp, pidPtr, &numPids, argc, argv, + inputFile, outputFile, errorFile, intIn, finalOut) == 0) { + goto error; + } + *pidArrayPtr = pidPtr; + + /* + * All done. Cleanup open files lying around and then return. + */ + +cleanup: + if ((inputFile != NULL) && closeInput) { + TclCloseFile(inputFile); + } + if ((outputFile != NULL) && closeOutput) { + TclCloseFile(outputFile); + } + if ((errorFile != NULL) && closeError) { + TclCloseFile(errorFile); + } + return numPids; + + /* + * An error occurred. There could have been extra files open, such + * as pipes between children. Clean them all up. Detach any child + * processes that have been created. + */ + +error: + if ((inPipePtr != NULL) && (*inPipePtr != NULL)) { + TclCloseFile(*inPipePtr); + *inPipePtr = NULL; + } + if ((outPipePtr != NULL) && (*outPipePtr != NULL)) { + TclCloseFile(*outPipePtr); + *outPipePtr = NULL; + } + if ((errFilePtr != NULL) && (*errFilePtr != NULL)) { + TclCloseFile(*errFilePtr); + *errFilePtr = NULL; + } + if (pidPtr != NULL) { + for (i = 0; i < numPids; i++) { + if (pidPtr[i] != -1) { + Tcl_DetachPids(1, &pidPtr[i]); + } + } + ckfree((char *) pidPtr); + } + numPids = -1; + goto cleanup; +#endif /* !MAC_TCL */ +} + +/* + *---------------------------------------------------------------------- + * + * 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; +} + +/* + *---------------------------------------------------------------------- + * + * 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; +} + +/* + *---------------------------------------------------------------------- + * + * 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. + * + *---------------------------------------------------------------------- + */ + +char * +Tcl_PosixError(interp) + Tcl_Interp *interp; /* Interpreter whose $errorCode variable + * is to be changed. */ +{ + char *id, *msg; + + msg = Tcl_ErrnoMsg(errno); + id = Tcl_ErrnoId(); + Tcl_SetErrorCode(interp, "POSIX", id, msg, (char *) NULL); + return msg; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_OpenCommandChannel -- + * + * Opens an I/O channel to one or more subprocesses specified + * by argc and argv. The flags argument determines the + * disposition of the stdio handles. If the TCL_STDIN flag is + * set then the standard input for the first subprocess will + * be tied to the channel: writing to the channel will provide + * input to the subprocess. If TCL_STDIN is not set, then + * standard input for the first subprocess will be the same as + * this application's standard input. If TCL_STDOUT is set then + * standard output from the last subprocess can be read from the + * channel; otherwise it goes to this application's standard + * output. If TCL_STDERR is set, standard error output for all + * subprocesses is returned to the channel and results in an error + * when the channel is closed; otherwise it goes to this + * application's standard error. If TCL_ENFORCE_MODE is not set, + * then argc and argv can redirect the stdio handles to override + * TCL_STDIN, TCL_STDOUT, and TCL_STDERR; if it is set, then it + * is an error for argc and argv to override stdio channels for + * which TCL_STDIN, TCL_STDOUT, and TCL_STDERR have been set. + * + * Results: + * A new command channel, or NULL on failure with an error + * message left in interp. + * + * Side effects: + * Creates processes, opens pipes. + * + *---------------------------------------------------------------------- + */ + +Tcl_Channel +Tcl_OpenCommandChannel(interp, argc, argv, flags) + Tcl_Interp *interp; /* Interpreter for error reporting. Can + * NOT be NULL. */ + int argc; /* How many arguments. */ + char **argv; /* Array of arguments for command pipe. */ + int flags; /* Or'ed combination of TCL_STDIN, TCL_STDOUT, + * TCL_STDERR, and TCL_ENFORCE_MODE. */ +{ + Tcl_File *inPipePtr, *outPipePtr, *errFilePtr; + Tcl_File inPipe, outPipe, errFile; + int numPids, *pidPtr; + Tcl_Channel channel; + + inPipe = outPipe = errFile = NULL; + + inPipePtr = (flags & TCL_STDIN) ? &inPipe : NULL; + outPipePtr = (flags & TCL_STDOUT) ? &outPipe : NULL; + errFilePtr = (flags & TCL_STDERR) ? &errFile : NULL; + + numPids = TclCreatePipeline(interp, argc, argv, &pidPtr, inPipePtr, + outPipePtr, errFilePtr); + + if (numPids < 0) { + goto error; + } + + /* + * Verify that the pipes that were created satisfy the + * readable/writable constraints. + */ + + if (flags & TCL_ENFORCE_MODE) { + if ((flags & TCL_STDOUT) && (outPipe == NULL)) { + Tcl_AppendResult(interp, "can't read output from command:", + " standard output was redirected", (char *) NULL); + goto error; + } + if ((flags & TCL_STDIN) && (inPipe == NULL)) { + Tcl_AppendResult(interp, "can't write input to command:", + " standard input was redirected", (char *) NULL); + goto error; + } + } + + channel = TclCreateCommandChannel(outPipe, inPipe, errFile, + numPids, pidPtr); + + if (channel == (Tcl_Channel) NULL) { + Tcl_AppendResult(interp, "pipe for command could not be created", + (char *) NULL); + goto error; + } + return channel; + +error: + if (numPids > 0) { + Tcl_DetachPids(numPids, pidPtr); + ckfree((char *) pidPtr); + } + if (inPipe != NULL) { + TclClosePipeFile(inPipe); + } + if (outPipe != NULL) { + TclClosePipeFile(outPipe); + } + if (errFile != NULL) { + TclClosePipeFile(errFile); + } + return NULL; +} diff --git a/contrib/tcl/generic/tclInt.h b/contrib/tcl/generic/tclInt.h new file mode 100644 index 0000000..079f916 --- /dev/null +++ b/contrib/tcl/generic/tclInt.h @@ -0,0 +1,1075 @@ +/* + * tclInt.h -- + * + * Declarations of things used internally by the Tcl interpreter. + * + * Copyright (c) 1987-1993 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: @(#) tclInt.h 1.200 96/04/11 17:24:12 + */ + +#ifndef _TCLINT +#define _TCLINT + +/* + * Common include files needed by most of the Tcl source files are + * included here, so that system-dependent personalizations for the + * include files only have to be made in once place. This results + * in a few extra includes, but greater modularity. The order of + * the three groups of #includes is important. For example, stdio.h + * is needed by tcl.h, and the _ANSI_ARGS_ declaration in tcl.h is + * needed by stdlib.h in some configurations. + */ + +#include <stdio.h> + +#ifndef _TCL +#include "tcl.h" +#endif +#ifndef _REGEXP +#include "tclRegexp.h" +#endif + +#include <ctype.h> +#ifdef NO_LIMITS_H +# include "../compat/limits.h" +#else +# include <limits.h> +#endif +#ifdef NO_STDLIB_H +# include "../compat/stdlib.h" +#else +# include <stdlib.h> +#endif +#ifdef NO_STRING_H +#include "../compat/string.h" +#else +#include <string.h> +#endif +#if defined(__STDC__) || defined(HAS_STDARG) +# include <stdarg.h> +#else +# include <varargs.h> +#endif + +/* + *---------------------------------------------------------------- + * Data structures related to variables. These are used primarily + * in tclVar.c + *---------------------------------------------------------------- + */ + +/* + * The following structure defines a variable trace, which is used to + * invoke a specific C procedure whenever certain operations are performed + * on a variable. + */ + +typedef struct VarTrace { + Tcl_VarTraceProc *traceProc;/* Procedure to call when operations given + * by flags are performed on variable. */ + ClientData clientData; /* Argument to pass to proc. */ + int flags; /* What events the trace procedure is + * interested in: OR-ed combination of + * TCL_TRACE_READS, TCL_TRACE_WRITES, and + * TCL_TRACE_UNSETS. */ + struct VarTrace *nextPtr; /* Next in list of traces associated with + * a particular variable. */ +} VarTrace; + +/* + * 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 + * the structure is needed in order for Tcl to behave reasonably + * if traces are deleted while traces are active. + */ + +typedef struct ActiveVarTrace { + struct Var *varPtr; /* Variable that's being traced. */ + struct ActiveVarTrace *nextPtr; + /* Next in list of all active variable + * traces for the interpreter, or NULL + * if no more. */ + VarTrace *nextTracePtr; /* Next trace to check after current + * trace procedure returns; if this + * trace gets deleted, must update pointer + * to avoid using free'd memory. */ +} ActiveVarTrace; + +/* + * The following structure describes an enumerative search in progress on + * an array variable; this are invoked with options to the "array" + * command. + */ + +typedef struct ArraySearch { + int id; /* Integer id used to distinguish among + * multiple concurrent searches for the + * same array. */ + struct Var *varPtr; /* Pointer to array variable that's being + * searched. */ + Tcl_HashSearch search; /* Info kept by the hash module about + * progress through the array. */ + Tcl_HashEntry *nextEntry; /* Non-null means this is the next element + * to be enumerated (it's leftover from + * the Tcl_FirstHashEntry call or from + * an "array anymore" command). NULL + * means must call Tcl_NextHashEntry + * to get value to return. */ + struct ArraySearch *nextPtr;/* Next in list of all active searches + * for this variable, or NULL if this is + * the last one. */ +} ArraySearch; + +/* + * The structure below defines a variable, which associates a string name + * with a string value. Pointers to these structures are kept as the + * values of hash table entries, and the name of each variable is stored + * in the hash entry. + */ + +typedef struct Var { + int valueLength; /* Holds the number of non-null bytes + * actually occupied by the variable's + * current value in value.string (extra + * space is sometimes left for expansion). + * For array and global variables this is + * meaningless. */ + int valueSpace; /* Total number of bytes of space allocated + * at value.string. 0 means there is no + * space allocated. */ + union { + char *string; /* String value of variable, used for scalar + * variables and array elements. Malloc-ed. */ + Tcl_HashTable *tablePtr;/* For array variables, this points to + * information about the hash table used + * to implement the associative array. + * Points to malloc-ed data. */ + struct Var *upvarPtr; /* If this is a global variable being + * referred to in a procedure, or a variable + * created by "upvar", this field points to + * the record for the higher-level variable. */ + } value; + Tcl_HashEntry *hPtr; /* Hash table entry that refers to this + * variable, or NULL if the variable has + * been detached from its hash table (e.g. + * an array is deleted, but some of its + * elements are still referred to in upvars). */ + int refCount; /* Counts number of active uses of this + * variable, not including its main hash + * table entry: 1 for each additional variable + * whose upVarPtr points here, 1 for each + * nested trace active on variable. This + * record can't be deleted until refCount + * becomes 0. */ + VarTrace *tracePtr; /* First in list of all traces set for this + * variable. */ + ArraySearch *searchPtr; /* First in list of all searches active + * for this variable, or NULL if none. */ + int flags; /* Miscellaneous bits of information about + * variable. See below for definitions. */ +} Var; + +/* + * Flag bits for variables: + * + * VAR_ARRAY - 1 means this is an array variable rather + * than a scalar variable. + * VAR_UPVAR - 1 means this variable just contains a + * pointer to another variable that has the + * real value. Variables like this come + * about through the "upvar" and "global" + * commands. + * VAR_UNDEFINED - 1 means that the variable is currently + * undefined. Undefined variables usually + * go away completely, but if an undefined + * variable has a trace on it, or if it is + * a global variable being used by a procedure, + * then it stays around even when undefined. + * VAR_TRACE_ACTIVE - 1 means that trace processing is currently + * underway for a read or write access, so + * new read or write accesses should not cause + * trace procedures to be called and the + * variable can't be deleted. + */ + +#define VAR_ARRAY 1 +#define VAR_UPVAR 2 +#define VAR_UNDEFINED 4 +#define VAR_TRACE_ACTIVE 0x10 + +/* + *---------------------------------------------------------------- + * Data structures related to procedures. These are used primarily + * in tclProc.c + *---------------------------------------------------------------- + */ + +/* + * The structure below defines an argument to a procedure, which + * consists of a name and an (optional) default value. + */ + +typedef struct Arg { + struct Arg *nextPtr; /* Next argument for this procedure, + * or NULL if this is the last argument. */ + char *defValue; /* Pointer to arg's default value, or NULL + * if no default value. */ + char name[4]; /* Name of argument starts here. The name + * is followed by space for the default, + * if there is one. The actual size of this + * field will be as large as necessary to + * hold both name and default value. THIS + * MUST BE THE LAST FIELD IN THE STRUCTURE!! */ +} Arg; + +/* + * The structure below defines a command procedure, which consists of + * a collection of Tcl commands plus information about arguments and + * variables. + */ + +typedef struct Proc { + struct Interp *iPtr; /* Interpreter for which this command + * is defined. */ + int refCount; /* Reference count: 1 if still present + * in command table plus 1 for each call + * to the procedure that is currently + * active. This structure can be freed + * when refCount becomes zero. */ + char *command; /* Command that constitutes the body of + * the procedure (dynamically allocated). */ + Arg *argPtr; /* Pointer to first of procedure's formal + * arguments, or NULL if none. */ +} Proc; + +/* + * The structure below defines a command trace. This is used to allow Tcl + * clients to find out whenever a command is about to be executed. + */ + +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. */ + ClientData clientData; /* Arbitrary value to pass to proc. */ + struct Trace *nextPtr; /* Next in list of traces for this interp. */ +} Trace; + +/* + * 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 + * a user-defined piece of data. + */ + +typedef struct AssocData { + Tcl_InterpDeleteProc *proc; /* Proc to call when deleting. */ + ClientData clientData; /* Value to pass to proc. */ +} AssocData; + +/* + * The structure below defines a frame, which is a procedure invocation. + * These structures exist only while procedures are being executed, and + * provide a sort of call stack. + */ + +typedef struct CallFrame { + Tcl_HashTable varTable; /* Hash table containing all of procedure's + * local variables. */ + int level; /* Level of this procedure, for "uplevel" + * purposes (i.e. corresponds to nesting of + * callerVarPtr's, not callerPtr's). 1 means + * outer-most procedure, 0 means top-level. */ + int argc; /* This and argv below describe name and + * arguments for this procedure invocation. */ + char **argv; /* Array of arguments. */ + struct CallFrame *callerPtr; + /* Value of interp->framePtr when this + * procedure was invoked (i.e. next in + * stack of all active procedures). */ + struct CallFrame *callerVarPtr; + /* Value of interp->varFramePtr when this + * procedure was invoked (i.e. determines + * variable scoping within caller; same + * as callerPtr unless an "uplevel" command + * or something equivalent was active in + * the caller). */ +} CallFrame; + +/* + * The structure below defines one history event (a previously-executed + * command that can be re-executed in whole or in part). + */ + +typedef struct { + char *command; /* String containing previously-executed + * command. */ + int bytesAvl; /* Total # of bytes available at *event (not + * all are necessarily in use now). */ +} HistoryEvent; + +/* + *---------------------------------------------------------------- + * Data structures related to history. These are used primarily + * in tclHistory.c + *---------------------------------------------------------------- + */ + +/* + * The structure below defines a pending revision to the most recent + * history event. Changes are linked together into a list and applied + * during the next call to Tcl_RecordHistory. See the comments at the + * beginning of tclHistory.c for information on revisions. + */ + +typedef struct HistoryRev { + int firstIndex; /* Index of the first byte to replace in + * current history event. */ + int lastIndex; /* Index of last byte to replace in + * current history event. */ + int newSize; /* Number of bytes in newBytes. */ + char *newBytes; /* Replacement for the range given by + * firstIndex and lastIndex (malloced). */ + struct HistoryRev *nextPtr; /* Next in chain of revisions to apply, or + * NULL for end of list. */ +} HistoryRev; + +/* + *---------------------------------------------------------------- + * Data structures related to expressions. These are used only in + * tclExpr.c. + *---------------------------------------------------------------- + */ + +/* + * The data structure below defines a math function (e.g. sin or hypot) + * for use in Tcl expressions. + */ + +#define MAX_MATH_ARGS 5 +typedef struct MathFunc { + 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. */ +} MathFunc; + +/* + *---------------------------------------------------------------- + * One of the following structures exists for each command in + * an interpreter. The Tcl_Command opaque type actually refers + * to these structures. + *---------------------------------------------------------------- + */ + +typedef struct Command { + Tcl_HashEntry *hPtr; /* Pointer to the hash table entry in + * interp->commandTable that refers to + * this command. Used to get a command's + * name from its Tcl_Command handle. NULL + * means that the hash table entry has + * been removed already (this can happen + * if deleteProc causes the command to be + * deleted or recreated). */ + Tcl_CmdProc *proc; /* Procedure to process command. */ + ClientData clientData; /* Arbitrary value to pass to proc. */ + Tcl_CmdDeleteProc *deleteProc; + /* Procedure to invoke when deleting + * command. */ + ClientData deleteData; /* Arbitrary value to pass to deleteProc + * (usually the same as clientData). */ + int deleted; /* Means that the command is in the process + * of being deleted (its deleteProc is + * currently executing). Any other attempts + * to delete the command should be ignored. */ +} Command; + +/* + *---------------------------------------------------------------- + * This structure defines an interpreter, which is a collection of + * commands plus other state information related to interpreting + * commands, such as variable storage. Primary responsibility for + * this data structure is in tclBasic.c, but almost every Tcl + * source file uses something in here. + *---------------------------------------------------------------- + */ + +typedef struct Interp { + + /* + * Note: the first three fields must match exactly the fields in + * a Tcl_Interp struct (see tcl.h). If you change one, be sure to + * change the other. + */ + + char *result; /* Points to result returned by last + * command. */ + Tcl_FreeProc *freeProc; /* Zero means result is statically allocated. + * TCL_DYNAMIC means result was allocated with + * ckalloc and should be freed with ckfree. + * Other values give address of procedure + * to invoke to free the result. Must be + * freed by Tcl_Eval before executing next + * command. */ + int errorLine; /* When TCL_ERROR is returned, this gives + * the line number within the command where + * the error occurred (1 means first line). */ + Tcl_HashTable commandTable; /* Contains all of the commands currently + * registered in this interpreter. Indexed + * by strings; values have type (Command *). */ + Tcl_HashTable mathFuncTable;/* Contains all of the math functions currently + * defined for the interpreter. Indexed by + * strings (function names); values have + * type (MathFunc *). */ + + /* + * Information related to procedures and variables. See tclProc.c + * and tclvar.c for usage. + */ + + Tcl_HashTable globalTable; /* Contains all global variables for + * interpreter. */ + int numLevels; /* Keeps track of how many nested calls to + * Tcl_Eval are in progress for this + * interpreter. It's used to delay deletion + * of the table until all Tcl_Eval invocations + * are completed. */ + int maxNestingDepth; /* If numLevels exceeds this value then Tcl + * assumes that infinite recursion has + * occurred and it generates an error. */ + CallFrame *framePtr; /* Points to top-most in stack of all nested + * procedure invocations. NULL means there + * are no active procedures. */ + CallFrame *varFramePtr; /* Points to the call frame whose variables + * are currently in use (same as framePtr + * unless an "uplevel" command is being + * executed). NULL means no procedure is + * active or "uplevel 0" is being exec'ed. */ + ActiveVarTrace *activeTracePtr; + /* First in list of active traces for interp, + * or NULL if no active traces. */ + int returnCode; /* Completion code to return if current + * procedure exits with a TCL_RETURN code. */ + char *errorInfo; /* Value to store in errorInfo if returnCode + * is TCL_ERROR. Malloc'ed, may be NULL */ + char *errorCode; /* Value to store in errorCode if returnCode + * is TCL_ERROR. Malloc'ed, may be NULL */ + + /* + * Information related to history: + */ + + int numEvents; /* Number of previously-executed commands + * to retain. */ + HistoryEvent *events; /* Array containing numEvents entries + * (dynamically allocated). */ + int curEvent; /* Index into events of place where current + * (or most recent) command is recorded. */ + int curEventNum; /* Event number associated with the slot + * given by curEvent. */ + HistoryRev *revPtr; /* First in list of pending revisions. */ + char *historyFirst; /* First char. of current command executed + * from history module or NULL if none. */ + int revDisables; /* 0 means history revision OK; > 0 gives + * a count of number of times revision has + * been disabled. */ + char *evalFirst; /* If TCL_RECORD_BOUNDS flag set, Tcl_Eval + * sets this field to point to the first + * char. of text from which the current + * command came. Otherwise Tcl_Eval sets + * this to NULL. */ + char *evalLast; /* Similar to evalFirst, except points to + * last character of current command. */ + + /* + * Information used by Tcl_AppendResult to keep track of partial + * results. See Tcl_AppendResult code for details. + */ + + char *appendResult; /* Storage space for results generated + * by Tcl_AppendResult. Malloc-ed. NULL + * means not yet allocated. */ + int appendAvl; /* Total amount of space available at + * partialResult. */ + int appendUsed; /* Number of non-null bytes currently + * stored at partialResult. */ + + /* + * A cache of compiled regular expressions. See Tcl_RegExpCompile + * in tclUtil.c for details. + */ + +#define NUM_REGEXPS 5 + char *patterns[NUM_REGEXPS];/* Strings corresponding to compiled + * regular expression patterns. NULL + * means that this slot isn't used. + * Malloc-ed. */ + int patLengths[NUM_REGEXPS];/* Number of non-null characters in + * corresponding entry in patterns. + * -1 means entry isn't used. */ + regexp *regexps[NUM_REGEXPS]; + /* Compiled forms of above strings. Also + * malloc-ed, or NULL if not in use yet. */ + + /* + * Information about packages. Used only in tclPkg.c. + */ + + Tcl_HashTable packageTable; /* Describes all of the packages loaded + * in or available to this interpreter. + * Keys are package names, values are + * (Package *) pointers. */ + char *packageUnknown; /* Command to invoke during "package + * require" commands for packages that + * aren't described in packageTable. + * Malloc'ed, may be NULL. */ + + /* + * Information used by Tcl_PrintDouble: + */ + + char pdFormat[10]; /* Format string used by Tcl_PrintDouble. */ + int pdPrec; /* Current precision (used to restore the + * the tcl_precision variable after a bogus + * value has been put into it). */ + + /* + * Miscellaneous information: + */ + + int cmdCount; /* Total number of times a command procedure + * has been called for this interpreter. */ + int noEval; /* Non-zero means no commands should actually + * be executed: just parse only. Used in + * expressions when the result is already + * determined. */ + int evalFlags; /* Flags to control next call to Tcl_Eval. + * Normally zero, but may be set before + * calling Tcl_Eval. See below for valid + * values. */ + char *termPtr; /* Character just after the last one in + * a command. Set by Tcl_Eval before + * returning. */ + char *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. */ + int flags; /* Various flag bits. See below. */ + Trace *tracePtr; /* List of traces for this interpreter. */ + Tcl_HashTable *assocData; /* Hash table for associating data with + * this interpreter. Cleaned up when + * this interpreter is deleted. */ + char resultSpace[TCL_RESULT_SIZE+1]; + /* Static space for storing small results. */ +} Interp; + +/* + * EvalFlag bits for Interp structures: + * + * TCL_BRACKET_TERM 1 means that the current script is terminated by + * a close bracket rather than the end of the string. + * TCL_RECORD_BOUNDS Tells Tcl_Eval to record information in the + * evalFirst and evalLast fields for each command + * executed directly from the string (top-level + * commands and those from command substitution). + * TCL_ALLOW_EXCEPTIONS 1 means it's OK for the script to terminate with + * a code other than TCL_OK or TCL_ERROR; 0 means + * codes other than these should be turned into errors. + */ + +#define TCL_BRACKET_TERM 1 +#define TCL_RECORD_BOUNDS 2 +#define TCL_ALLOW_EXCEPTIONS 4 + +/* + * Flag bits for Interp structures: + * + * DELETED: Non-zero means the interpreter has been deleted: + * don't process any more commands for it, and destroy + * the structure as soon as all nested invocations of + * Tcl_Eval are done. + * ERR_IN_PROGRESS: Non-zero means an error unwind is already in progress. + * Zero means a command proc has been invoked since last + * error occured. + * ERR_ALREADY_LOGGED: Non-zero means information has already been logged + * in $errorInfo for the current Tcl_Eval instance, + * so Tcl_Eval needn't log it (used to implement the + * "error message log" command). + * ERROR_CODE_SET: Non-zero means that Tcl_SetErrorCode has been + * called to record information for the current + * error. Zero means Tcl_Eval must clear the + * errorCode variable if an error is returned. + * EXPR_INITIALIZED: 1 means initialization specific to expressions has + * been carried out. + */ + +#define DELETED 1 +#define ERR_IN_PROGRESS 2 +#define ERR_ALREADY_LOGGED 4 +#define ERROR_CODE_SET 8 +#define EXPR_INITIALIZED 0x10 + +/* + * Default value for the pdPrec and pdFormat fields of interpreters: + */ + +#define DEFAULT_PD_PREC 6 +#define DEFAULT_PD_FORMAT "%g" + +/* + *---------------------------------------------------------------- + * Data structures related to command parsing. These are used in + * tclParse.c and its clients. + *---------------------------------------------------------------- + */ + +/* + * The following data structure is used by various parsing procedures + * to hold information about where to store the results of parsing + * (e.g. the substituted contents of a quoted argument, or the result + * of a nested command). At any given time, the space available + * for output is fixed, but a procedure may be called to expand the + * space available if the current space runs out. + */ + +typedef struct ParseValue { + char *buffer; /* Address of first character in + * output buffer. */ + char *next; /* Place to store next character in + * output buffer. */ + char *end; /* Address of the last usable character + * in the buffer. */ + void (*expandProc) _ANSI_ARGS_((struct ParseValue *pvPtr, int needed)); + /* Procedure to call when space runs out; + * it will make more space. */ + ClientData clientData; /* Arbitrary information for use of + * expandProc. */ +} ParseValue; + +/* + * A table used to classify input characters to assist in parsing + * Tcl commands. The table should be indexed with a signed character + * using the CHAR_TYPE macro. The character may have a negative + * value. + */ + +extern char tclTypeTable[]; +#define CHAR_TYPE(c) (tclTypeTable+128)[c] + +/* + * Possible values returned by CHAR_TYPE: + * + * TCL_NORMAL - All characters that don't have special significance + * to the Tcl language. + * TCL_SPACE - Character is space, tab, or return. + * TCL_COMMAND_END - Character is newline or null or semicolon or + * close-bracket. + * TCL_QUOTE - Character is a double-quote. + * TCL_OPEN_BRACKET - Character is a "[". + * TCL_OPEN_BRACE - Character is a "{". + * TCL_CLOSE_BRACE - Character is a "}". + * TCL_BACKSLASH - Character is a "\". + * TCL_DOLLAR - Character is a "$". + */ + +#define TCL_NORMAL 0 +#define TCL_SPACE 1 +#define TCL_COMMAND_END 2 +#define TCL_QUOTE 3 +#define TCL_OPEN_BRACKET 4 +#define TCL_OPEN_BRACE 5 +#define TCL_CLOSE_BRACE 6 +#define TCL_BACKSLASH 7 +#define TCL_DOLLAR 8 + +/* + * Maximum number of levels of nesting permitted in Tcl commands (used + * to catch infinite recursion). + */ + +#define MAX_NESTING_DEPTH 1000 + +/* + * The macro below is used to modify a "char" value (e.g. by casting + * it to an unsigned character) so that it can be used safely with + * macros such as isspace. + */ + +#define UCHAR(c) ((unsigned char) (c)) + +/* + * Given a size or address, the macro below "aligns" it to the machine's + * memory unit size (e.g. an 8-byte boundary) so that anything can be + * placed at the aligned address without fear of an alignment error. + */ + +#define TCL_ALIGN(x) ((x + 7) & ~7) + +/* + * For each event source (created with Tcl_CreateEventSource) there + * is a structure of the following type: + */ + +typedef struct TclEventSource { + Tcl_EventSetupProc *setupProc; /* This procedure is called by + * Tcl_DoOneEvent to set up information + * for the wait operation, such as + * files to wait for or maximum + * timeout. */ + Tcl_EventCheckProc *checkProc; /* This procedure is called by + * Tcl_DoOneEvent after its wait + * operation to see what events + * are ready and queue them. */ + ClientData clientData; /* Arbitrary one-word argument to pass + * to setupProc and checkProc. */ + struct TclEventSource *nextPtr; /* Next in list of all event sources + * defined for applicaton. */ +} TclEventSource; + +/* + * The following macros are used to specify the runtime platform + * setting of the tclPlatform variable. + */ + +typedef enum { + TCL_PLATFORM_UNIX, /* Any Unix-like OS. */ + TCL_PLATFORM_MAC, /* MacOS. */ + TCL_PLATFORM_WINDOWS /* Any Microsoft Windows OS. */ +} TclPlatformType; + +/* + *---------------------------------------------------------------- + * Variables shared among Tcl modules but not used by the outside + * world: + *---------------------------------------------------------------- + */ + +extern Tcl_Time tclBlockTime; +extern int tclBlockTimeSet; +extern char * tclExecutableName; +extern TclEventSource * tclFirstEventSourcePtr; +extern Tcl_ChannelType tclFileChannelType; +extern char * tclMemDumpFileName; +extern TclPlatformType tclPlatform; + +/* + *---------------------------------------------------------------- + * Procedures shared among Tcl modules but not used by the outside + * world: + *---------------------------------------------------------------- + */ + +EXTERN void panic(); +EXTERN int TclCleanupChildren _ANSI_ARGS_((Tcl_Interp *interp, + int numPids, int *pidPtr, Tcl_Channel errorChan)); +EXTERN int TclCloseFile _ANSI_ARGS_((Tcl_File file)); +EXTERN char * TclConvertToNative _ANSI_ARGS_((Tcl_Interp *interp, + char *name, Tcl_DString *bufferPtr)); +EXTERN char * TclConvertToNetwork _ANSI_ARGS_((Tcl_Interp *interp, + char *name, Tcl_DString *bufferPtr)); +EXTERN void TclCopyAndCollapse _ANSI_ARGS_((int count, char *src, + char *dst)); +EXTERN int TclChdir _ANSI_ARGS_((Tcl_Interp *interp, + char *dirName)); +EXTERN void TclClosePipeFile _ANSI_ARGS_((Tcl_File file)); +EXTERN Tcl_Channel TclCreateCommandChannel _ANSI_ARGS_(( + Tcl_File readFile, Tcl_File writeFile, + Tcl_File errorFile, int numPids, int *pidPtr)); +EXTERN int TclCreatePipe _ANSI_ARGS_((Tcl_File *readPipe, + Tcl_File *writePipe)); +EXTERN int TclCreatePipeline _ANSI_ARGS_((Tcl_Interp *interp, + int argc, char **argv, int **pidArrayPtr, + Tcl_File *inPipePtr, + Tcl_File *outPipePtr, + Tcl_File *errFilePtr)); +EXTERN Tcl_File TclCreateTempFile _ANSI_ARGS_((char *contents)); +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)); +EXTERN void TclExpandParseValue _ANSI_ARGS_((ParseValue *pvPtr, + int needed)); +EXTERN void TclExprFloatError _ANSI_ARGS_((Tcl_Interp *interp, + double value)); +EXTERN int TclFindElement _ANSI_ARGS_((Tcl_Interp *interp, + char *list, char **elementPtr, char **nextPtr, + int *sizePtr, int *bracePtr)); +EXTERN Proc * TclFindProc _ANSI_ARGS_((Interp *iPtr, + char *procName)); +EXTERN void TclFreePackageInfo _ANSI_ARGS_((Interp *iPtr)); +EXTERN char * TclGetCwd _ANSI_ARGS_((Tcl_Interp *interp)); +EXTERN unsigned long TclGetClicks _ANSI_ARGS_((void)); +EXTERN char * TclGetExtension _ANSI_ARGS_((char *name)); +EXTERN void TclGetAndDetachPids _ANSI_ARGS_((Tcl_Interp *interp, + Tcl_Channel chan)); +EXTERN int TclGetDate _ANSI_ARGS_((char *p, + unsigned long now, long zone, + unsigned long *timePtr)); +EXTERN Tcl_Channel TclGetDefaultStdChannel _ANSI_ARGS_((int type)); +EXTERN char * TclGetEnv _ANSI_ARGS_((char *name)); +EXTERN int TclGetFrame _ANSI_ARGS_((Tcl_Interp *interp, + char *string, CallFrame **framePtrPtr)); +EXTERN int TclGetOpenMode _ANSI_ARGS_((Tcl_Interp *interp, + char *string, int *seekFlagPtr)); +EXTERN unsigned long TclGetSeconds _ANSI_ARGS_((void)); +EXTERN void TclGetTime _ANSI_ARGS_((Tcl_Time *time)); +EXTERN int TclGetTimeZone _ANSI_ARGS_((unsigned long time)); +EXTERN char * TclGetUserHome _ANSI_ARGS_((char *name, + Tcl_DString *bufferPtr)); +EXTERN int TclGetListIndex _ANSI_ARGS_((Tcl_Interp *interp, + char *string, int *indexPtr)); +EXTERN int TclGetLoadedPackages _ANSI_ARGS_((Tcl_Interp *interp, + char *targetName)); +EXTERN char * TclGetUserHome _ANSI_ARGS_((char *name, + Tcl_DString *bufferPtr)); +EXTERN int TclGuessPackageName _ANSI_ARGS_((char *fileName, + Tcl_DString *bufPtr)); +EXTERN int TclHasPipes _ANSI_ARGS_((void)); +EXTERN int TclHasSockets _ANSI_ARGS_((Tcl_Interp *interp)); +EXTERN int TclIdlePending _ANSI_ARGS_((void)); +EXTERN int TclInterpInit _ANSI_ARGS_((Tcl_Interp *interp)); +EXTERN Proc * TclIsProc _ANSI_ARGS_((Command *cmdPtr)); +EXTERN int TclLoadFile _ANSI_ARGS_((Tcl_Interp *interp, + char *fileName, char *sym1, char *sym2, + Tcl_PackageInitProc **proc1Ptr, + Tcl_PackageInitProc **proc2Ptr)); +EXTERN int TclMakeFileTable _ANSI_ARGS_((Tcl_Interp *interp, + int noStdio)); +EXTERN int TclMatchFiles _ANSI_ARGS_((Tcl_Interp *interp, + char *separators, Tcl_DString *dirPtr, + char *pattern, char *tail)); +EXTERN int TclNeedSpace _ANSI_ARGS_((char *start, char *end)); +EXTERN Tcl_File TclOpenFile _ANSI_ARGS_((char *fname, int mode)); +EXTERN int TclParseBraces _ANSI_ARGS_((Tcl_Interp *interp, + char *string, char **termPtr, ParseValue *pvPtr)); +EXTERN int TclParseNestedCmd _ANSI_ARGS_((Tcl_Interp *interp, + char *string, int flags, char **termPtr, + ParseValue *pvPtr)); +EXTERN int TclParseQuotes _ANSI_ARGS_((Tcl_Interp *interp, + char *string, int termChar, int flags, + char **termPtr, ParseValue *pvPtr)); +EXTERN int TclParseWords _ANSI_ARGS_((Tcl_Interp *interp, + char *string, int flags, int maxWords, + char **termPtr, int *argcPtr, char **argv, + ParseValue *pvPtr)); +EXTERN void TclPlatformExit _ANSI_ARGS_((int status)); +EXTERN void TclPlatformInit _ANSI_ARGS_((Tcl_Interp *interp)); +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, char *cmdName, + Tcl_CmdProc *proc, ClientData clientData)); +EXTERN int TclReadFile _ANSI_ARGS_((Tcl_File file, + int shouldBlock, char *buf, int toRead)); +EXTERN int TclSeekFile _ANSI_ARGS_((Tcl_File file, + int offset, int whence)); +EXTERN int TclServiceIdle _ANSI_ARGS_((void)); +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 TclSpawnPipeline _ANSI_ARGS_((Tcl_Interp *interp, + int *pidPtr, int *numPids, int argc, char **argv, + Tcl_File inputFile, + Tcl_File outputFile, + Tcl_File errorFile, + char *intIn, char *finalOut)); +EXTERN int TclTestChannelCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int argc, char **argv)); +EXTERN int TclTestChannelEventCmd _ANSI_ARGS_(( + ClientData clientData, Tcl_Interp *interp, + int argc, char **argv)); +EXTERN int TclUpdateReturnInfo _ANSI_ARGS_((Interp *iPtr)); +EXTERN int TclWaitForFile _ANSI_ARGS_((Tcl_File file, + int mask, int timeout)); +EXTERN char * TclWordEnd _ANSI_ARGS_((char *start, int nested, + int *semiPtr)); +EXTERN int TclWriteFile _ANSI_ARGS_((Tcl_File file, + int shouldBlock, char *buf, int toWrite)); + +/* + *---------------------------------------------------------------- + * Command procedures in the generic core: + *---------------------------------------------------------------- + */ + +EXTERN int Tcl_AfterCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int argc, char **argv)); +EXTERN int Tcl_AppendCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int argc, char **argv)); +EXTERN int Tcl_ArrayCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int argc, char **argv)); +EXTERN int Tcl_BreakCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int argc, char **argv)); +EXTERN int Tcl_CaseCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int argc, char **argv)); +EXTERN int Tcl_CatchCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int argc, char **argv)); +EXTERN int Tcl_CdCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int argc, char **argv)); +EXTERN int Tcl_ClockCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int argc, char **argv)); +EXTERN int Tcl_CloseCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int argc, char **argv)); +EXTERN int Tcl_ConcatCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int argc, char **argv)); +EXTERN int Tcl_ContinueCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int argc, char **argv)); +EXTERN int Tcl_CpCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int argc, char **argv)); +EXTERN int Tcl_EchoCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int argc, char **argv)); +EXTERN int Tcl_EofCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int argc, char **argv)); +EXTERN int Tcl_ErrorCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int argc, char **argv)); +EXTERN int Tcl_EvalCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int argc, char **argv)); +EXTERN int Tcl_ExecCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int argc, char **argv)); +EXTERN int Tcl_ExitCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int argc, char **argv)); +EXTERN int Tcl_ExprCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int argc, char **argv)); +EXTERN int Tcl_FblockedCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int argc, char **argv)); +EXTERN int Tcl_FconfigureCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int argc, char **argv)); +EXTERN int Tcl_FileCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int argc, char **argv)); +EXTERN int Tcl_FileEventCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int argc, char **argv)); +EXTERN int Tcl_FlushCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int argc, char **argv)); +EXTERN int Tcl_ForCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int argc, char **argv)); +EXTERN int Tcl_ForeachCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int argc, char **argv)); +EXTERN int Tcl_FormatCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int argc, char **argv)); +EXTERN int Tcl_GetsCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int argc, char **argv)); +EXTERN int Tcl_GlobalCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int argc, char **argv)); +EXTERN int Tcl_GlobCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int argc, char **argv)); +EXTERN int Tcl_HistoryCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int argc, char **argv)); +EXTERN int Tcl_IfCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int argc, char **argv)); +EXTERN int Tcl_IncrCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int argc, char **argv)); +EXTERN int Tcl_InfoCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int argc, char **argv)); +EXTERN int Tcl_InterpCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int argc, char **argv)); +EXTERN int Tcl_JoinCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int argc, char **argv)); +EXTERN int Tcl_LappendCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int argc, char **argv)); +EXTERN int Tcl_LindexCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int argc, char **argv)); +EXTERN int Tcl_LinsertCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int argc, char **argv)); +EXTERN int Tcl_LlengthCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int argc, char **argv)); +EXTERN int Tcl_ListCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int argc, char **argv)); +EXTERN int Tcl_LoadCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int argc, char **argv)); +EXTERN int Tcl_LrangeCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int argc, char **argv)); +EXTERN int Tcl_LreplaceCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int argc, char **argv)); +EXTERN int Tcl_LsCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int argc, char **argv)); +EXTERN int Tcl_LsearchCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int argc, char **argv)); +EXTERN int Tcl_LsortCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int argc, char **argv)); +EXTERN int Tcl_MacBeepCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int argc, char **argv)); +EXTERN int Tcl_MacSourceCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int argc, char **argv)); +EXTERN int Tcl_MkdirCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int argc, char **argv)); +EXTERN int Tcl_MvCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int argc, char **argv)); +EXTERN int Tcl_OpenCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int argc, char **argv)); +EXTERN int Tcl_PackageCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int argc, char **argv)); +EXTERN int Tcl_PidCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int argc, char **argv)); +EXTERN int Tcl_ProcCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int argc, char **argv)); +EXTERN int Tcl_PutsCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int argc, char **argv)); +EXTERN int Tcl_PwdCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int argc, char **argv)); +EXTERN int Tcl_ReadCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int argc, char **argv)); +EXTERN int Tcl_RegexpCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int argc, char **argv)); +EXTERN int Tcl_RegsubCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int argc, char **argv)); +EXTERN int Tcl_RenameCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int argc, char **argv)); +EXTERN int Tcl_ReturnCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int argc, char **argv)); +EXTERN int Tcl_RmCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int argc, char **argv)); +EXTERN int Tcl_RmdirCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int argc, char **argv)); +EXTERN int Tcl_ScanCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int argc, char **argv)); +EXTERN int Tcl_SeekCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int argc, char **argv)); +EXTERN int Tcl_SetCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int argc, char **argv)); +EXTERN int Tcl_SplitCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int argc, char **argv)); +EXTERN int Tcl_SocketCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int argc, char **argv)); +EXTERN int Tcl_SourceCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int argc, char **argv)); +EXTERN int Tcl_StringCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int argc, char **argv)); +EXTERN int Tcl_SubstCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int argc, char **argv)); +EXTERN int Tcl_SwitchCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int argc, char **argv)); +EXTERN int Tcl_TellCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int argc, char **argv)); +EXTERN int Tcl_TimeCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int argc, char **argv)); +EXTERN int Tcl_TraceCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int argc, char **argv)); +EXTERN int Tcl_UnsetCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int argc, char **argv)); +EXTERN int Tcl_UpdateCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int argc, char **argv)); +EXTERN int Tcl_UplevelCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int argc, char **argv)); +EXTERN int Tcl_UpvarCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int argc, char **argv)); +EXTERN int Tcl_VwaitCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int argc, char **argv)); +EXTERN int Tcl_WhileCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int argc, char **argv)); +EXTERN int TclUnsupported0Cmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int argc, char **argv)); + +#endif /* _TCLINT */ diff --git a/contrib/tcl/generic/tclInterp.c b/contrib/tcl/generic/tclInterp.c new file mode 100644 index 0000000..a791fd5 --- /dev/null +++ b/contrib/tcl/generic/tclInterp.c @@ -0,0 +1,2385 @@ +/* + * tclInterp.c -- + * + * This file implements the "interp" command which allows creation + * and manipulation of Tcl interpreters from within Tcl scripts. + * + * 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: @(#) tclInterp.c 1.66 96/04/15 17:26:10 + */ + +#include <stdio.h> +#include "tclInt.h" +#include "tclPort.h" + +/* + * Counter for how many aliases were created (global) + */ + +static int aliasCounter = 0; + +/* + * + * struct Slave: + * + * Used by the "interp" command to record and find information about slave + * interpreters. Maps from a command name in the master to information about + * a slave interpreter, e.g. what aliases are defined in it. + */ + +typedef struct { + Tcl_Interp *masterInterp; /* Master interpreter for this slave. */ + Tcl_HashEntry *slaveEntry; /* Hash entry in masters slave table for + * this slave interpreter. Used to find + * this record, and used when deleting the + * slave interpreter to delete it from the + * masters table. */ + Tcl_Interp *slaveInterp; /* The slave interpreter. */ + Tcl_Command interpCmd; /* Interpreter object command. */ + Tcl_HashTable aliasTable; /* Table which maps from names of commands + * in slave interpreter to struct Alias + * defined below. */ +} Slave; + +/* + * struct Alias: + * + * Stores information about an alias. Is stored in the slave interpreter + * and used by the source command to find the target command in the master + * when the source command is invoked. + */ + +typedef struct { + char *aliasName; /* Name of alias command. */ + char *targetName; /* Name of target command in master interp. */ + Tcl_Interp *targetInterp; /* Master interpreter. */ + int argc; /* Count of additional args to pass. */ + char **argv; /* Actual additional args to pass. */ + Tcl_HashEntry *aliasEntry; /* Entry for the alias hash table in slave. + * This is used by alias deletion to remove + * the alias from the slave interpreter + * alias table. */ + Tcl_HashEntry *targetEntry; /* Entry for target command in master. + * This is used in the master interpreter to + * map back from the target command to aliases + * redirecting to it. Random access to this + * hash table is never required - we are using + * a hash table only for convenience. */ + Tcl_Command slaveCmd; /* Source command in slave interpreter. */ +} Alias; + +/* + * struct Target: + * + * Maps from master interpreter commands back to the source commands in slave + * interpreters. This is needed because aliases can be created between sibling + * interpreters and must be deleted when the target interpreter is deleted. In + * case they would not be deleted the source interpreter would be left with a + * "dangling pointer". One such record is stored in the Master record of the + * master interpreter (in the targetTable hashtable, see below) with the + * master for each alias which directs to a command in the master. These + * records are used to remove the source command for an from a slave if/when + * the master is deleted. + */ + +typedef struct { + Tcl_Command slaveCmd; /* Command for alias in slave interp. */ + Tcl_Interp *slaveInterp; /* Slave Interpreter. */ +} Target; + +/* + * struct Master: + * + * This record is used for three purposes: First, slaveTable (a hashtable) + * maps from names of commands to slave interpreters. This hashtable is + * used to store information about slave interpreters of this interpreter, + * to map over all slaves, etc. The second purpose is to store information + * about all aliases in slaves (or siblings) which direct to target commands + * in this interpreter (using the targetTable hashtable). The third field in + * the record, isSafe, denotes whether the interpreter is safe or not. Safe + * interpreters have restricted functionality, can only create safe slave + * interpreters and can only load safe extensions. + */ + +typedef struct { + Tcl_HashTable slaveTable; /* Hash table for slave interpreters. + * Maps from command names to Slave records. */ + int isSafe; /* Am I a "safe" interpreter? */ + Tcl_HashTable targetTable; /* Hash table for Target Records. Contains + * all Target records which denote aliases + * from slaves or sibling interpreters that + * direct to commands in this interpreter. This + * table is used to remove dangling pointers + * from the slave (or sibling) interpreters + * when this interpreter is deleted. */ +} Master; + +/* + * Prototypes for local static procedures: + */ + +static int AliasCmd _ANSI_ARGS_((ClientData dummy, + Tcl_Interp *currentInterp, int argc, char **argv)); +static void AliasCmdDeleteProc _ANSI_ARGS_(( + ClientData clientData)); +static int AliasHelper _ANSI_ARGS_((Tcl_Interp *curInterp, + Tcl_Interp *slaveInterp, Tcl_Interp *masterInterp, + Master *masterPtr, char *aliasName, + char *targetName, int argc, char **argv)); +static int CreateInterpObject _ANSI_ARGS_((Tcl_Interp *interp, + int argc, char **argv)); +static Tcl_Interp *CreateSlave _ANSI_ARGS_((Tcl_Interp *interp, + char *slavePath, int safe)); +static int DeleteAlias _ANSI_ARGS_((Tcl_Interp *interp, + Tcl_Interp *slaveInterp, char *aliasName)); +static int DescribeAlias _ANSI_ARGS_((Tcl_Interp *interp, + Tcl_Interp *slaveInterp, char *aliasName)); +static int DeleteInterpObject _ANSI_ARGS_((Tcl_Interp *interp, + int argc, char **argv)); +static int DeleteOneInterpObject _ANSI_ARGS_((Tcl_Interp *interp, + char *path)); +static Tcl_Interp *GetInterp _ANSI_ARGS_((Tcl_Interp *interp, + Master *masterPtr, char *path, + Master **masterPtrPtr)); +static int GetTarget _ANSI_ARGS_((Tcl_Interp *interp, char *path, + char *aliasName)); +static void MasterRecordDeleteProc _ANSI_ARGS_(( + ClientData clientData, Tcl_Interp *interp)); +static int MakeSafe _ANSI_ARGS_((Tcl_Interp *interp)); +static int SlaveAliasHelper _ANSI_ARGS_((Tcl_Interp *interp, + int argc, char **argv)); +static int SlaveObjectCmd _ANSI_ARGS_((ClientData dummy, + Tcl_Interp *interp, int argc, char **argv)); +static void SlaveObjectDeleteProc _ANSI_ARGS_(( + ClientData clientData)); +static void SlaveRecordDeleteProc _ANSI_ARGS_(( + ClientData clientData, Tcl_Interp *interp)); + +/* + * These are all the Tcl core commands which are available in a safe + * interpeter: + */ + +static char *TclCommandsToKeep[] = { + "after", "append", "array", + "break", + "case", "catch", "clock", "close", "concat", "continue", + "eof", "error", "eval", "expr", + "fblocked", "fconfigure", "flush", "for", "foreach", "format", + "gets", "global", + "history", + "if", "incr", "info", "interp", + "join", + "lappend", "lindex", "linsert", "list", "llength", "lower", "lrange", + "lreplace", "lsearch", "lsort", + "package", "pid", "proc", "puts", + "read", "regexp", "regsub", "rename", "return", + "scan", "seek", "set", "split", "string", "switch", + "tell", "trace", + "unset", "update", "uplevel", "upvar", + "vwait", + "while", + NULL}; +static int TclCommandsToKeepCt = + (sizeof (TclCommandsToKeep) / sizeof (char *)) -1 ; + +/* + *---------------------------------------------------------------------- + * + * TclPreventAliasLoop -- + * + * When defining an alias or renaming a command, prevent an alias + * loop from being formed. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * If TCL_ERROR is returned, the function also sets interp->result + * to an error message. + * + * NOTE: + * This function is public internal (instead of being static to + * this file) because it is also used from Tcl_RenameCmd. + * + *---------------------------------------------------------------------- + */ + +int +TclPreventAliasLoop(interp, cmdInterp, cmdName, proc, clientData) + Tcl_Interp *interp; /* Interp in which to report errors. */ + Tcl_Interp *cmdInterp; /* Interp in which the command is + * being defined. */ + char *cmdName; /* Name of Tcl command we are + * attempting to define. */ + Tcl_CmdProc *proc; /* The command procedure for the + * command being created. */ + ClientData clientData; /* The client data associated with the + * command to be created. */ +{ + Alias *aliasPtr, *nextAliasPtr; + Tcl_CmdInfo cmdInfo; + + /* + * If we are not creating or renaming an alias, then it is + * always OK to create or rename the command. + */ + + if (proc != AliasCmd) { + return TCL_OK; + } + + /* + * OK, we are dealing with an alias, so traverse the chain of aliases. + * If we encounter the alias we are defining (or renaming to) any in + * the chain then we have a loop. + */ + + aliasPtr = (Alias *) clientData; + nextAliasPtr = aliasPtr; + while (1) { + + /* + * If the target of the next alias in the chain is the same as the + * source alias, we have a loop. + */ + + if ((strcmp(nextAliasPtr->targetName, cmdName) == 0) && + (nextAliasPtr->targetInterp == cmdInterp)) { + Tcl_AppendResult(interp, "cannot define or rename alias \"", + aliasPtr->aliasName, "\": would create a loop", + (char *) NULL); + return TCL_ERROR; + } + + /* + * Otherwise, follow the chain one step further. If the target + * command is undefined then there is no loop. + */ + + if (Tcl_GetCommandInfo(nextAliasPtr->targetInterp, + nextAliasPtr->targetName, &cmdInfo) == 0) { + return TCL_OK; + } + + /* + * See if the target command is an alias - if so, follow the + * loop to its target command. Otherwise we do not have a loop. + */ + + if (cmdInfo.proc != AliasCmd) { + return TCL_OK; + } + nextAliasPtr = (Alias *) cmdInfo.clientData; + } + + /* NOTREACHED */ +} + +/* + *---------------------------------------------------------------------- + * + * MakeSafe -- + * + * Makes its argument interpreter contain only functionality that is + * defined to be part of Safe Tcl. + * + * Results: + * None. + * + * Side effects: + * Removes commands from its argument interpreter. + * + *---------------------------------------------------------------------- + */ + +static int +MakeSafe(interp) + Tcl_Interp *interp; /* Interpreter to be made safe. */ +{ + char **argv; /* Args for Tcl_Eval. */ + int argc, keep, i, j; /* Loop indices. */ + char *cmdGetGlobalCmds = "info commands"; /* What command to run. */ + char *cmdNoEnv = "unset env"; /* How to get rid of env. */ + Master *masterPtr; /* Master record of interp + * to be made safe. */ + Tcl_Channel chan; /* Channel to remove from + * safe interpreter. */ + + /* + * Below, Tcl_Eval sets interp->result, so we do not. + */ + + Tcl_ResetResult(interp); + if ((Tcl_Eval(interp, cmdGetGlobalCmds) == TCL_ERROR) || + (Tcl_SplitList(interp, interp->result, &argc, &argv) != TCL_OK)) { + return TCL_ERROR; + } + for (i = 0; i < argc; i++) { + for (keep = 0, j = 0; j < TclCommandsToKeepCt; j++) { + if (strcmp(TclCommandsToKeep[j], argv[i]) == 0) { + keep = 1; + break; + } + } + if (keep == 0) { + (void) Tcl_DeleteCommand(interp, argv[i]); + } + } + ckfree((char *) argv); + masterPtr = (Master *) Tcl_GetAssocData(interp, "tclMasterRecord", + NULL); + if (masterPtr == (Master *) NULL) { + panic("MakeSafe: could not find master record"); + } + masterPtr->isSafe = 1; + if (Tcl_Eval(interp, cmdNoEnv) == TCL_ERROR) { + return TCL_ERROR; + } + + /* + * Remove the standard channels from the interpreter; safe interpreters + * do not ordinarily have access to stdin, stdout and stderr. + */ + + chan = Tcl_GetStdChannel(TCL_STDIN); + if (chan != (Tcl_Channel) NULL) { + Tcl_UnregisterChannel(interp, chan); + } + chan = Tcl_GetStdChannel(TCL_STDOUT); + if (chan != (Tcl_Channel) NULL) { + Tcl_UnregisterChannel(interp, chan); + } + chan = Tcl_GetStdChannel(TCL_STDERR); + if (chan != (Tcl_Channel) NULL) { + Tcl_UnregisterChannel(interp, chan); + } + + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * GetInterp -- + * + * Helper function to find a slave interpreter given a pathname. + * + * Results: + * Returns the slave interpreter known by that name in the calling + * interpreter, or NULL if no interpreter known by that name exists. + * + * Side effects: + * Assigns to the pointer variable passed in, if not NULL. + * + *---------------------------------------------------------------------- + */ + +static Tcl_Interp * +GetInterp(interp, masterPtr, path, masterPtrPtr) + Tcl_Interp *interp; /* Interp. to start search from. */ + Master *masterPtr; /* Its master record. */ + char *path; /* The path (name) of interp. to be found. */ + Master **masterPtrPtr; /* (Return) its master record. */ +{ + Tcl_HashEntry *hPtr; /* Search element. */ + Slave *slavePtr; /* Interim slave record. */ + char **argv; /* Split-up path (name) for interp to find. */ + int argc, i; /* Loop indices. */ + Tcl_Interp *searchInterp; /* Interim storage for interp. to find. */ + + if (masterPtrPtr != (Master **) NULL) *masterPtrPtr = masterPtr; + + if (Tcl_SplitList(interp, path, &argc, &argv) != TCL_OK) { + return (Tcl_Interp *) NULL; + } + + for (searchInterp = interp, i = 0; i < argc; i++) { + + hPtr = Tcl_FindHashEntry(&(masterPtr->slaveTable), argv[i]); + if (hPtr == (Tcl_HashEntry *) NULL) { + ckfree((char *) argv); + return (Tcl_Interp *) NULL; + } + slavePtr = (Slave *) Tcl_GetHashValue(hPtr); + searchInterp = slavePtr->slaveInterp; + if (searchInterp == (Tcl_Interp *) NULL) { + ckfree((char *) argv); + return (Tcl_Interp *) NULL; + } + masterPtr = (Master *) Tcl_GetAssocData(searchInterp, + "tclMasterRecord", NULL); + if (masterPtrPtr != (Master **) NULL) *masterPtrPtr = masterPtr; + if (masterPtr == (Master *) NULL) { + ckfree((char *) argv); + return (Tcl_Interp *) NULL; + } + } + ckfree((char *) argv); + return searchInterp; +} + +/* + *---------------------------------------------------------------------- + * + * CreateSlave -- + * + * Helper function to do the actual work of creating a slave interp + * and new object command. Also optionally makes the new slave + * interpreter "safe". + * + * Results: + * Returns the new Tcl_Interp * if successful or NULL if not. If failed, + * the result of the invoking interpreter contains an error message. + * + * Side effects: + * Creates a new slave interpreter and a new object command. + * + *---------------------------------------------------------------------- + */ + +static Tcl_Interp * +CreateSlave(interp, slavePath, safe) + Tcl_Interp *interp; /* Interp. to start search from. */ + char *slavePath; /* Path (name) of slave to create. */ + int safe; /* Should we make it "safe"? */ +{ + Master *masterPtr; /* Master record. */ + Tcl_Interp *slaveInterp; /* Ptr to slave interpreter. */ + Tcl_Interp *masterInterp; /* Ptr to master interp for slave. */ + Slave *slavePtr; /* Slave record. */ + Tcl_HashEntry *hPtr; /* Entry into interp hashtable. */ + int new; /* Indicates whether new entry. */ + int argc; /* Count of elements in slavePath. */ + char **argv; /* Elements in slavePath. */ + char *masterPath; /* Path to its master. */ + + masterPtr = (Master *) Tcl_GetAssocData(interp, "tclMasterRecord", + NULL); + if (masterPtr == (Master *) NULL) { + panic("CreatSlave: could not find master record"); + } + + if (Tcl_SplitList(interp, slavePath, &argc, &argv) != TCL_OK) { + return (Tcl_Interp *) NULL; + } + + if (argc < 2) { + masterInterp = interp; + if (argc == 1) { + slavePath = argv[0]; + } + } else { + masterPath = Tcl_Merge(argc-1, argv); + masterInterp = GetInterp(interp, masterPtr, masterPath, &masterPtr); + if (masterInterp == (Tcl_Interp *) NULL) { + Tcl_AppendResult(interp, "interpreter named \"", masterPath, + "\" not found", (char *) NULL); + ckfree((char *) argv); + ckfree((char *) masterPath); + return (Tcl_Interp *) NULL; + } + ckfree((char *) masterPath); + slavePath = argv[argc-1]; + if (!safe) { + safe = masterPtr->isSafe; + } + } + hPtr = Tcl_CreateHashEntry(&(masterPtr->slaveTable), slavePath, &new); + if (new == 0) { + Tcl_AppendResult(interp, "interpreter named \"", slavePath, + "\" already exists, cannot create", (char *) NULL); + ckfree((char *) argv); + return (Tcl_Interp *) NULL; + } + slaveInterp = Tcl_CreateInterp(); + if (slaveInterp == (Tcl_Interp *) NULL) { + panic("CreateSlave: out of memory while creating a new interpreter"); + } + slavePtr = (Slave *) ckalloc((unsigned) sizeof(Slave)); + slavePtr->masterInterp = masterInterp; + slavePtr->slaveEntry = hPtr; + slavePtr->slaveInterp = slaveInterp; + slavePtr->interpCmd = Tcl_CreateCommand(masterInterp, slavePath, + SlaveObjectCmd, (ClientData) slaveInterp, SlaveObjectDeleteProc); + Tcl_InitHashTable(&(slavePtr->aliasTable), TCL_STRING_KEYS); + (void) Tcl_SetAssocData(slaveInterp, "tclSlaveRecord", + SlaveRecordDeleteProc, (ClientData) slavePtr); + Tcl_SetHashValue(hPtr, (ClientData) slavePtr); + Tcl_SetVar(slaveInterp, "tcl_interactive", "0", TCL_GLOBAL_ONLY); + + if (((safe) && (MakeSafe(slaveInterp) == TCL_ERROR)) || + ((!safe) && (Tcl_Init(slaveInterp) == TCL_ERROR))) { + Tcl_ResetResult(interp); + Tcl_AddErrorInfo(interp, Tcl_GetVar2(slaveInterp, "errorInfo", (char *) + NULL, TCL_GLOBAL_ONLY)); + Tcl_SetVar2(interp, "errorCode", (char *) NULL, + Tcl_GetVar2(slaveInterp, "errorCode", (char *) NULL, + TCL_GLOBAL_ONLY), + TCL_GLOBAL_ONLY); + if (slaveInterp->freeProc != NULL) { + interp->result = slaveInterp->result; + interp->freeProc = slaveInterp->freeProc; + slaveInterp->freeProc = 0; + } else { + Tcl_SetResult(interp, slaveInterp->result, TCL_VOLATILE); + } + Tcl_ResetResult(slaveInterp); + (void) Tcl_DeleteCommand(masterInterp, slavePath); + slaveInterp = (Tcl_Interp *) NULL; + } + ckfree((char *) argv); + return slaveInterp; +} + +/* + *---------------------------------------------------------------------- + * + * CreateInterpObject - + * + * Helper function to do the actual work of creating a new interpreter + * and an object command. + * + * Results: + * A Tcl result. + * + * Side effects: + * See user documentation for details. + * + *---------------------------------------------------------------------- + */ + +static int +CreateInterpObject(interp, argc, argv) + Tcl_Interp *interp; /* Invoking interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ + int safe; /* Create a safe interpreter? */ + Master *masterPtr; /* Master record. */ + int moreFlags; /* Expecting more flag args? */ + char *slavePath; /* Name of slave. */ + char localSlaveName[200]; /* Local area for creating names. */ + int i; /* Loop counter. */ + size_t len; /* Length of option argument. */ + static int interpCounter = 0; /* Unique id for created names. */ + + masterPtr = (Master *) Tcl_GetAssocData(interp, "tclMasterRecord", NULL); + if (masterPtr == (Master *) NULL) { + panic("CreateInterpObject: could not find master record"); + } + moreFlags = 1; + slavePath = NULL; + safe = masterPtr->isSafe; + + if (argc < 2 || argc > 5) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " create ?-safe? ?--? ?path?\"", (char *) NULL); + return TCL_ERROR; + } + for (i = 2; i < argc; i++) { + len = strlen(argv[i]); + if ((argv[i][0] == '-') && (moreFlags != 0)) { + if ((argv[i][1] == 's') && (strncmp(argv[i], "-safe", len) == 0) + && (len > 1)){ + safe = 1; + } else if ((strncmp(argv[i], "--", len) == 0) && (len > 1)) { + moreFlags = 0; + } else { + Tcl_AppendResult(interp, "bad option \"", argv[i], + "\": should be -safe", (char *) NULL); + return TCL_ERROR; + } + } else { + slavePath = argv[i]; + } + } + if (slavePath == (char *) NULL) { + sprintf(localSlaveName, "interp%d", interpCounter); + interpCounter++; + slavePath = localSlaveName; + } + if (CreateSlave(interp, slavePath, safe) != NULL) { + Tcl_AppendResult(interp, slavePath, (char *) NULL); + return TCL_OK; + } else { + /* + * CreateSlave already set interp->result if there was an error, + * so we do not do it here. + */ + return TCL_ERROR; + } +} + +/* + *---------------------------------------------------------------------- + * + * DeleteOneInterpObject -- + * + * Helper function for DeleteInterpObject. It deals with deleting one + * interpreter at a time. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * Deletes an interpreter and its interpreter object command. + * + *---------------------------------------------------------------------- + */ + +static int +DeleteOneInterpObject(interp, path) + Tcl_Interp *interp; /* Interpreter for reporting errors. */ + char *path; /* Path of interpreter to delete. */ +{ + Master *masterPtr; /* Interim storage for master record.*/ + Slave *slavePtr; /* Interim storage for slave record. */ + Tcl_Interp *masterInterp; /* Master of interp. to delete. */ + Tcl_HashEntry *hPtr; /* Search element. */ + int localArgc; /* Local copy of count of elements in + * path (name) of interp. to delete. */ + char **localArgv; /* Local copy of path. */ + char *slaveName; /* Last component in path. */ + char *masterPath; /* One-before-last component in path.*/ + + masterPtr = (Master *) Tcl_GetAssocData(interp, "tclMasterRecord", NULL); + if (masterPtr == (Master *) NULL) { + panic("DeleteInterpObject: could not find master record"); + } + if (Tcl_SplitList(interp, path, &localArgc, &localArgv) != TCL_OK) { + Tcl_AppendResult(interp, "bad interpreter path \"", path, + "\"", (char *) NULL); + return TCL_ERROR; + } + if (localArgc < 2) { + masterInterp = interp; + if (localArgc == 0) { + slaveName = ""; + } else { + slaveName = localArgv[0]; + } + } else { + masterPath = Tcl_Merge(localArgc-1, localArgv); + masterInterp = GetInterp(interp, masterPtr, masterPath, &masterPtr); + if (masterInterp == (Tcl_Interp *) NULL) { + Tcl_AppendResult(interp, "interpreter named \"", masterPath, + "\" not found", (char *) NULL); + ckfree((char *) localArgv); + ckfree((char *) masterPath); + return TCL_ERROR; + } + ckfree((char *) masterPath); + slaveName = localArgv[localArgc-1]; + } + hPtr = Tcl_FindHashEntry(&(masterPtr->slaveTable), slaveName); + if (hPtr == (Tcl_HashEntry *) NULL) { + ckfree((char *) localArgv); + Tcl_AppendResult(interp, "interpreter named \"", path, + "\" not found", (char *) NULL); + return TCL_ERROR; + } + slavePtr = (Slave *) Tcl_GetHashValue(hPtr); + slaveName = Tcl_GetCommandName(masterInterp, slavePtr->interpCmd); + if (Tcl_DeleteCommand(masterInterp, slaveName) != 0) { + ckfree((char *) localArgv); + Tcl_AppendResult(interp, "interpreter named \"", path, + "\" not found", (char *) NULL); + return TCL_ERROR; + } + ckfree((char *) localArgv); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * DeleteInterpObject -- + * + * Helper function to do the work of deleting zero or more + * interpreters and their interpreter object commands. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * Deletes interpreters and their interpreter object command. + * + *---------------------------------------------------------------------- + */ + +static int +DeleteInterpObject(interp, argc, argv) + Tcl_Interp *interp; /* Interpreter start search from. */ + int argc; /* Number of arguments in vector. */ + char **argv; /* Contains path to interps to + * delete. */ +{ + int i; + + for (i = 2; i < argc; i++) { + if (DeleteOneInterpObject(interp, argv[i]) != TCL_OK) { + return TCL_ERROR; + } + } + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * AliasHelper -- + * + * Helper function to do the work to actually create an alias or + * delete an alias. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * An alias command is created and entered into the alias table + * for the slave interpreter. + * + *---------------------------------------------------------------------- + */ + +static int +AliasHelper(curInterp, slaveInterp, masterInterp, masterPtr, + aliasName, targetName, argc, argv) + Tcl_Interp *curInterp; /* Interp that invoked this proc. */ + Tcl_Interp *slaveInterp; /* Interp where alias cmd will live + * or from which alias will be + * deleted. */ + Tcl_Interp *masterInterp; /* Interp where target cmd will be. */ + Master *masterPtr; /* Master record for target interp. */ + char *aliasName; /* Name of alias cmd. */ + char *targetName; /* Name of target cmd. */ + int argc; /* Additional arguments to store */ + char **argv; /* with alias. */ +{ + Alias *aliasPtr; /* Storage for alias data. */ + Alias *tmpAliasPtr; /* Temp storage for alias to delete. */ + Tcl_HashEntry *hPtr; /* Entry into interp hashtable. */ + int i; /* Loop index. */ + int new; /* Is it a new hash entry? */ + Target *targetPtr; /* Maps from target command in master + * to source command in slave. */ + Slave *slavePtr; /* Maps from source command in slave + * to target command in master. */ + + slavePtr = (Slave *) Tcl_GetAssocData(slaveInterp, "tclSlaveRecord", NULL); + + /* + * Fix it up if there is no slave record. This can happen if someone + * uses "" as the source for an alias. + */ + + if (slavePtr == (Slave *) NULL) { + slavePtr = (Slave *) ckalloc((unsigned) sizeof(Slave)); + slavePtr->masterInterp = (Tcl_Interp *) NULL; + slavePtr->slaveEntry = (Tcl_HashEntry *) NULL; + slavePtr->slaveInterp = slaveInterp; + slavePtr->interpCmd = (Tcl_Command) NULL; + Tcl_InitHashTable(&(slavePtr->aliasTable), TCL_STRING_KEYS); + (void) Tcl_SetAssocData(slaveInterp, "tclSlaveRecord", + SlaveRecordDeleteProc, (ClientData) slavePtr); + } + + if ((targetName == (char *) NULL) || (targetName[0] == '\0')) { + if (argc != 0) { + Tcl_AppendResult(curInterp, "malformed command: should be", + " \"alias ", aliasName, " {}\"", (char *) NULL); + return TCL_ERROR; + } + + return DeleteAlias(curInterp, slaveInterp, aliasName); + } + + aliasPtr = (Alias *) ckalloc((unsigned) sizeof(Alias)); + aliasPtr->aliasName = (char *) ckalloc((unsigned) strlen(aliasName)+1); + aliasPtr->targetName = (char *) ckalloc((unsigned) strlen(targetName)+1); + strcpy(aliasPtr->aliasName, aliasName); + strcpy(aliasPtr->targetName, targetName); + aliasPtr->targetInterp = masterInterp; + + aliasPtr->argv = (char **) NULL; + aliasPtr->argc = argc; + if (aliasPtr->argc > 0) { + aliasPtr->argv = (char **) ckalloc((unsigned) sizeof(char *) * + aliasPtr->argc); + for (i = 0; i < argc; i++) { + aliasPtr->argv[i] = (char *) ckalloc((unsigned) strlen(argv[i])+1); + strcpy(aliasPtr->argv[i], argv[i]); + } + } + + if (TclPreventAliasLoop(curInterp, slaveInterp, aliasName, AliasCmd, + (ClientData) aliasPtr) != TCL_OK) { + for (i = 0; i < argc; i++) { + ckfree(aliasPtr->argv[i]); + } + if (aliasPtr->argv != (char **) NULL) { + ckfree((char *) aliasPtr->argv); + } + ckfree(aliasPtr->aliasName); + ckfree(aliasPtr->targetName); + ckfree((char *) aliasPtr); + + return TCL_ERROR; + } + + aliasPtr->slaveCmd = Tcl_CreateCommand(slaveInterp, aliasName, AliasCmd, + (ClientData) aliasPtr, AliasCmdDeleteProc); + + /* + * Make an entry in the alias table. If it already exists delete + * the alias command. Then retry. + */ + + do { + hPtr = Tcl_CreateHashEntry(&(slavePtr->aliasTable), aliasName, &new); + if (new == 0) { + tmpAliasPtr = (Alias *) Tcl_GetHashValue(hPtr); + (void) Tcl_DeleteCommand(slaveInterp, tmpAliasPtr->aliasName); + Tcl_DeleteHashEntry(hPtr); + } + } while (new == 0); + aliasPtr->aliasEntry = hPtr; + Tcl_SetHashValue(hPtr, (ClientData) aliasPtr); + + targetPtr = (Target *) ckalloc((unsigned) sizeof(Target)); + targetPtr->slaveCmd = aliasPtr->slaveCmd; + targetPtr->slaveInterp = slaveInterp; + + do { + hPtr = Tcl_CreateHashEntry(&(masterPtr->targetTable), + (char *) aliasCounter, &new); + aliasCounter++; + } while (new == 0); + + Tcl_SetHashValue(hPtr, (ClientData) targetPtr); + + aliasPtr->targetEntry = hPtr; + + curInterp->result = aliasPtr->aliasName; + + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * SlaveAliasHelper - + * + * Handles the different forms of the "interp alias" command: + * - interp alias slavePath aliasName + * Describes an alias. + * - interp alias slavePath aliasName {} + * Deletes an alias. + * - interp alias slavePath srcCmd masterPath targetCmd args... + * Creates an alias. + * + * Results: + * A Tcl result. + * + * Side effects: + * See user documentation for details. + * + *---------------------------------------------------------------------- + */ + +static int +SlaveAliasHelper(interp, argc, argv) + Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ + Master *masterPtr; /* Master record for current interp. */ + Tcl_Interp *slaveInterp, /* Interpreters used when */ + *masterInterp; /* creating an alias btn siblings. */ + Master *masterMasterPtr; /* Master record for master interp. */ + + masterPtr = (Master *) Tcl_GetAssocData(interp, "tclMasterRecord", NULL); + if (masterPtr == (Master *) NULL) { + panic("SlaveAliasHelper: could not find master record"); + } + if (argc < 4) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " alias slavePath slaveCmd masterPath masterCmd ?args ..?\"", + (char *) NULL); + return TCL_ERROR; + } + slaveInterp = GetInterp(interp, masterPtr, argv[2], NULL); + if (slaveInterp == (Tcl_Interp *) NULL) { + Tcl_AppendResult(interp, "could not find interpreter \"", + argv[2], "\"", (char *) NULL); + return TCL_ERROR; + } + if (argc == 4) { + return DescribeAlias(interp, slaveInterp, argv[3]); + } + if (argc == 5 && strcmp(argv[4], "") == 0) { + return DeleteAlias(interp, slaveInterp, argv[3]); + } + if (argc < 6) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " alias slavePath slaveCmd masterPath masterCmd ?args ..?\"", + (char *) NULL); + return TCL_ERROR; + } + masterInterp = GetInterp(interp, masterPtr, argv[4], &masterMasterPtr); + if (masterInterp == (Tcl_Interp *) NULL) { + Tcl_AppendResult(interp, "could not find interpreter \"", + argv[4], "\"", (char *) NULL); + return TCL_ERROR; + } + return AliasHelper(interp, slaveInterp, masterInterp, masterMasterPtr, + argv[3], argv[5], argc-6, argv+6); +} + +/* + *---------------------------------------------------------------------- + * + * DescribeAlias -- + * + * Sets interp->result to a Tcl list describing the given alias in the + * given interpreter: its target command and the additional arguments + * to prepend to any invocation of the alias. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static int +DescribeAlias(interp, slaveInterp, aliasName) + Tcl_Interp *interp; /* Interpreter for result and errors. */ + Tcl_Interp *slaveInterp; /* Interpreter defining alias. */ + char *aliasName; /* Name of alias to describe. */ +{ + Slave *slavePtr; /* Slave record for slave interpreter. */ + Tcl_HashEntry *hPtr; /* Search variable. */ + Alias *aliasPtr; /* Structure describing alias. */ + int i; /* Loop variable. */ + + slavePtr = (Slave *) Tcl_GetAssocData(slaveInterp, "tclSlaveRecord", + NULL); + if (slavePtr == (Slave *) NULL) { + panic("DescribeAlias: could not find slave record"); + } + hPtr = Tcl_FindHashEntry(&(slavePtr->aliasTable), aliasName); + if (hPtr == (Tcl_HashEntry *) NULL) { + return TCL_OK; + } + aliasPtr = (Alias *) Tcl_GetHashValue(hPtr); + Tcl_AppendResult(interp, aliasPtr->targetName, (char *) NULL); + for (i = 0; i < aliasPtr->argc; i++) { + Tcl_AppendElement(interp, aliasPtr->argv[i]); + } + + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * DeleteAlias -- + * + * Deletes the given alias from the slave interpreter given. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * Deletes the alias from the slave interpreter. + * + *---------------------------------------------------------------------- + */ + +static int +DeleteAlias(interp, slaveInterp, aliasName) + Tcl_Interp *interp; /* Interpreter for result and errors. */ + Tcl_Interp *slaveInterp; /* Interpreter defining alias. */ + char *aliasName; /* Name of alias to delete. */ +{ + Slave *slavePtr; /* Slave record for slave interpreter. */ + Tcl_HashEntry *hPtr; /* Search variable. */ + Alias *aliasPtr; /* Structure describing alias to delete. */ + + slavePtr = (Slave *) Tcl_GetAssocData(slaveInterp, "tclSlaveRecord", + NULL); + if (slavePtr == (Slave *) NULL) { + panic("DeleteAlias: could not find slave record"); + } + + /* + * Get the alias from the alias table, determine the current + * true name of the alias (it may have been renamed!) and then + * delete the true command name. The deleteProc on the alias + * command will take care of removing the entry from the alias + * table. + */ + + hPtr = Tcl_FindHashEntry(&(slavePtr->aliasTable), aliasName); + if (hPtr == (Tcl_HashEntry *) NULL) { + Tcl_AppendResult(interp, "alias \"", aliasName, "\" not found", + (char *) NULL); + return TCL_ERROR; + } + aliasPtr = (Alias *) Tcl_GetHashValue(hPtr); + aliasName = Tcl_GetCommandName(slaveInterp, aliasPtr->slaveCmd); + + /* + * NOTE: The deleteProc for this command will delete the + * alias from the hash table. The deleteProc will also + * delete the target information from the master interpreter + * target table. + */ + + if (Tcl_DeleteCommand(slaveInterp, aliasName) != 0) { + panic("DeleteAlias: did not find alias to be deleted"); + } + + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_GetInterpPath -- + * + * Sets the result of the asking interpreter to a proper Tcl list + * containing the names of interpreters between the asking and + * target interpreters. The target interpreter must be either the + * same as the asking interpreter or one of its slaves (including + * recursively). + * + * Results: + * TCL_OK if the target interpreter is the same as, or a descendant + * of, the asking interpreter; TCL_ERROR else. This way one can + * distinguish between the case where the asking and target interps + * are the same (an empty list is the result, and TCL_OK is returned) + * and when the target is not a descendant of the asking interpreter + * (in which case the Tcl result is an error message and the function + * returns TCL_ERROR). + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_GetInterpPath(askingInterp, targetInterp) + Tcl_Interp *askingInterp; /* Interpreter to start search from. */ + Tcl_Interp *targetInterp; /* Interpreter to find. */ +{ + Master *masterPtr; /* Interim storage for Master record. */ + Slave *slavePtr; /* Interim storage for Slave record. */ + + if (targetInterp == askingInterp) { + return TCL_OK; + } + if (targetInterp == (Tcl_Interp *) NULL) { + return TCL_ERROR; + } + slavePtr = (Slave *) Tcl_GetAssocData(targetInterp, "tclSlaveRecord", + NULL); + if (slavePtr == (Slave *) NULL) { + return TCL_ERROR; + } + if (Tcl_GetInterpPath(askingInterp, slavePtr->masterInterp) == TCL_ERROR) { + /* + * AskingInterp->result was set by recursive call. + */ + return TCL_ERROR; + } + masterPtr = (Master *) Tcl_GetAssocData(slavePtr->masterInterp, + "tclMasterRecord", NULL); + if (masterPtr == (Master *) NULL) { + panic("Tcl_GetInterpPath: could not find master record"); + } + Tcl_AppendElement(askingInterp, Tcl_GetHashKey(&(masterPtr->slaveTable), + slavePtr->slaveEntry)); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * GetTarget -- + * + * Sets the result of the invoking interpreter to a path name for + * the target interpreter of an alias in one of the slaves. + * + * Results: + * TCL_OK if the target interpreter of the alias is a slave of the + * invoking interpreter, TCL_ERROR else. + * + * Side effects: + * Sets the result of the invoking interpreter. + * + *---------------------------------------------------------------------- + */ + +static int +GetTarget(askingInterp, path, aliasName) + Tcl_Interp *askingInterp; /* Interpreter to start search from. */ + char *path; /* The path of the interp to find. */ + char *aliasName; /* The target of this allias. */ +{ + Tcl_Interp *slaveInterp; /* Interim storage for slave. */ + Slave *slaveSlavePtr; /* Its Slave record. */ + Master *masterPtr; /* Interim storage for Master record. */ + Tcl_HashEntry *hPtr; /* Search element. */ + Alias *aliasPtr; /* Data describing the alias. */ + + Tcl_ResetResult(askingInterp); + + masterPtr = (Master *) Tcl_GetAssocData(askingInterp, "tclMasterRecord", + NULL); + if (masterPtr == (Master *) NULL) { + panic("GetTarget: could not find master record"); + } + slaveInterp = GetInterp(askingInterp, masterPtr, path, NULL); + if (slaveInterp == (Tcl_Interp *) NULL) { + Tcl_AppendResult(askingInterp, "could not find interpreter \"", + path, "\"", (char *) NULL); + return TCL_ERROR; + } + slaveSlavePtr = (Slave *) Tcl_GetAssocData(slaveInterp, "tclSlaveRecord", + NULL); + if (slaveSlavePtr == (Slave *) NULL) { + panic("GetTarget: could not find slave record"); + } + hPtr = Tcl_FindHashEntry(&(slaveSlavePtr->aliasTable), aliasName); + if (hPtr == (Tcl_HashEntry *) NULL) { + Tcl_AppendResult(askingInterp, "alias \"", aliasName, "\" in path \"", + path, "\" not found", (char *) NULL); + return TCL_ERROR; + } + aliasPtr = (Alias *) Tcl_GetHashValue(hPtr); + if (aliasPtr == (Alias *) NULL) { + panic("GetTarget: could not find alias record"); + } + if (Tcl_GetInterpPath(askingInterp, aliasPtr->targetInterp) == TCL_ERROR) { + Tcl_ResetResult(askingInterp); + Tcl_AppendResult(askingInterp, "target interpreter for alias \"", + aliasName, "\" in path \"", path, "\" is not my descendant", + (char *) NULL); + return TCL_ERROR; + } + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_InterpCmd -- + * + * This procedure is invoked to process the "interp" Tcl command. + * See the user documentation for details on what it does. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * See the user documentation. + * + *---------------------------------------------------------------------- + */ + /* ARGSUSED */ +int +Tcl_InterpCmd(clientData, interp, argc, argv) + ClientData clientData; /* Unused. */ + Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ + Tcl_Interp *slaveInterp; /* A slave. */ + Tcl_Interp *masterInterp; /* A master. */ + Master *masterPtr; /* Master record for current interp. */ + Slave *slavePtr; /* Record for slave interp. */ + Tcl_HashEntry *hPtr; + Tcl_HashSearch hSearch; + size_t len; /* Length of command name. */ + int result; /* Result of eval. */ + char *cmdName; /* Name of sub command to do. */ + char *cmd; /* Command to eval. */ + Tcl_Channel chan; /* Channel to share or transfer. */ + + if (argc < 2) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " cmd ?arg ...?\"", (char *) NULL); + return TCL_ERROR; + } + cmdName = argv[1]; + + masterPtr = (Master *) Tcl_GetAssocData(interp, "tclMasterRecord", NULL); + if (masterPtr == (Master *) NULL) { + panic("Tcl_InterpCmd: could not find master record"); + } + + len = strlen(cmdName); + + if (cmdName[0] == 'a') { + if ((strncmp(cmdName, "alias", len) == 0) && (len <= 5)) { + return SlaveAliasHelper(interp, argc, argv); + } + + if (strcmp(cmdName, "aliases") == 0) { + if (argc != 2 && argc != 3) { + Tcl_AppendResult(interp, "wrong # args: should be \"", + argv[0], " aliases ?path?\"", (char *) NULL); + return TCL_ERROR; + } + if (argc == 3) { + slaveInterp = GetInterp(interp, masterPtr, argv[2], NULL); + if (slaveInterp == (Tcl_Interp *) NULL) { + Tcl_AppendResult(interp, "interpreter \"", + argv[2], "\" not found", (char *) NULL); + return TCL_ERROR; + } + } else { + slaveInterp = interp; + } + slavePtr = (Slave *) Tcl_GetAssocData(slaveInterp, + "tclSlaveRecord", NULL); + if (slavePtr == (Slave *) NULL) { + return TCL_OK; + } + for (hPtr = Tcl_FirstHashEntry(&(slavePtr->aliasTable), &hSearch); + hPtr != NULL; + hPtr = Tcl_NextHashEntry(&hSearch)) { + Tcl_AppendElement(interp, + Tcl_GetHashKey(&(slavePtr->aliasTable), hPtr)); + } + return TCL_OK; + } + } + + if ((cmdName[0] == 'c') && (strncmp(cmdName, "create", len) == 0)) { + return CreateInterpObject(interp, argc, argv); + } + + if ((cmdName[0] == 'd') && (strncmp(cmdName, "delete", len) == 0)) { + return DeleteInterpObject(interp, argc, argv); + } + + if (cmdName[0] == 'e') { + if ((strncmp(cmdName, "exists", len) == 0) && (len > 1)) { + if (argc > 3) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " exists ?path?\"", (char *) NULL); + return TCL_ERROR; + } + if (argc == 3) { + if (GetInterp(interp, masterPtr, argv[2], NULL) == + (Tcl_Interp *) NULL) { + Tcl_AppendResult(interp, "0", (char *) NULL); + } else { + Tcl_AppendResult(interp, "1", (char *) NULL); + } + } else { + Tcl_AppendResult(interp, "1", (char *) NULL); + } + return TCL_OK; + } + if ((strncmp(cmdName, "eval", len) == 0) && (len > 1)) { + if (argc < 4) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " eval path arg ?arg ...?\"", (char *) NULL); + return TCL_ERROR; + } + slaveInterp = GetInterp(interp, masterPtr, argv[2], NULL); + if (slaveInterp == (Tcl_Interp *) NULL) { + Tcl_AppendResult(interp, "interpreter named \"", argv[2], + "\" not found", (char *) NULL); + return TCL_ERROR; + } + cmd = Tcl_Concat(argc-3, argv+3); + Tcl_Preserve((ClientData) slaveInterp); + result = Tcl_Eval(slaveInterp, cmd); + ckfree((char *) cmd); + + /* + * Now make the result and any error information accessible. We + * have to be careful because the slave interpreter and the current + * interpreter can be the same - do not destroy the result.. This + * can happen if an interpreter contains an alias which is directed + * at a target command in the same interpreter. + */ + + if (interp != slaveInterp) { + if (result == TCL_ERROR) { + + /* + * An error occurred, so transfer error information from + * the target interpreter back to our interpreter. Must + * clear interp's result before calling Tcl_AddErrorInfo, + * since Tcl_AddErrorInfo will store the interp's result in + * errorInfo before appending slaveInterp's $errorInfo; + * we've already got everything we need in the slave + * interpreter's $errorInfo. + */ + + Tcl_ResetResult(interp); + Tcl_AddErrorInfo(interp, Tcl_GetVar2(slaveInterp, + "errorInfo", (char *) NULL, TCL_GLOBAL_ONLY)); + Tcl_SetVar2(interp, "errorCode", (char *) NULL, + Tcl_GetVar2(slaveInterp, "errorCode", (char *) + NULL, TCL_GLOBAL_ONLY), + TCL_GLOBAL_ONLY); + } + if (slaveInterp->freeProc != NULL) { + interp->result = slaveInterp->result; + interp->freeProc = slaveInterp->freeProc; + slaveInterp->freeProc = 0; + } else { + Tcl_SetResult(interp, slaveInterp->result, TCL_VOLATILE); + } + Tcl_ResetResult(slaveInterp); + } + Tcl_Release((ClientData) slaveInterp); + return result; + } + } + + if ((cmdName[0] == 'i') && (strncmp(cmdName, "issafe", len) == 0)) { + if (argc > 3) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " issafe ?path?\"", (char *) NULL); + return TCL_ERROR; + } + if (argc == 3) { + slaveInterp = GetInterp(interp, masterPtr, argv[2], &masterPtr); + if (slaveInterp == (Tcl_Interp *) NULL) { + Tcl_AppendResult(interp, "interpreter \"", argv[2], + "\" not found", (char *) NULL); + return TCL_ERROR; + } + } + if (masterPtr->isSafe == 0) { + Tcl_AppendResult(interp, "0", (char *) NULL); + } else { + Tcl_AppendResult(interp, "1", (char *) NULL); + } + return TCL_OK; + } + + if (cmdName[0] == 's') { + if ((strncmp(cmdName, "slaves", len) == 0) && (len > 1)) { + if (argc != 2 && argc != 3) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " slaves ?path?\"", (char *) NULL); + return TCL_ERROR; + } + if (argc == 3) { + if (GetInterp(interp, masterPtr, argv[2], &masterPtr) == + (Tcl_Interp *) NULL) { + Tcl_AppendResult(interp, "interpreter \"", argv[2], + "\" not found", (char *) NULL); + return TCL_ERROR; + } + } + for (hPtr = Tcl_FirstHashEntry(&(masterPtr->slaveTable), &hSearch); + hPtr != NULL; + hPtr = Tcl_NextHashEntry(&hSearch)) { + Tcl_AppendElement(interp, + Tcl_GetHashKey(&(masterPtr->slaveTable), hPtr)); + } + return TCL_OK; + } + if ((strncmp(cmdName, "share", len) == 0) && (len > 1)) { + if (argc != 5) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " share srcPath channelId destPath\"", (char *) NULL); + return TCL_ERROR; + } + masterInterp = GetInterp(interp, masterPtr, argv[2], NULL); + if (masterInterp == (Tcl_Interp *) NULL) { + Tcl_AppendResult(interp, "interpreter \"", argv[2], + "\" not found", (char *) NULL); + return TCL_ERROR; + } + slaveInterp = GetInterp(interp, masterPtr, argv[4], NULL); + if (slaveInterp == (Tcl_Interp *) NULL) { + Tcl_AppendResult(interp, "interpreter \"", argv[4], + "\" not found", (char *) NULL); + return TCL_ERROR; + } + chan = Tcl_GetChannel(masterInterp, argv[3], NULL); + if (chan == (Tcl_Channel) NULL) { + if (interp != masterInterp) { + Tcl_AppendResult(interp, masterInterp->result, + (char *) NULL); + Tcl_ResetResult(masterInterp); + } + return TCL_ERROR; + } + Tcl_RegisterChannel(slaveInterp, chan); + return TCL_OK; + } + } + + if ((cmdName[0] == 't') && (strncmp(cmdName, "target", len) == 0)) { + if (argc != 4) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " target path alias\"", (char *) NULL); + return TCL_ERROR; + } + return GetTarget(interp, argv[2], argv[3]); + } + + if ((cmdName[0] == 't') && (strncmp(cmdName, "transfer", len) == 0)) { + if (argc != 5) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " transfer srcPath channelId destPath\"", (char *) NULL); + return TCL_ERROR; + } + masterInterp = GetInterp(interp, masterPtr, argv[2], NULL); + if (masterInterp == (Tcl_Interp *) NULL) { + Tcl_AppendResult(interp, "interpreter \"", argv[2], + "\" not found", (char *) NULL); + return TCL_ERROR; + } + slaveInterp = GetInterp(interp, masterPtr, argv[4], NULL); + if (slaveInterp == (Tcl_Interp *) NULL) { + Tcl_AppendResult(interp, "interpreter \"", argv[4], + "\" not found", (char *) NULL); + return TCL_ERROR; + } + chan = Tcl_GetChannel(masterInterp, argv[3], NULL); + if (chan == (Tcl_Channel) NULL) { + if (interp != masterInterp) { + Tcl_AppendResult(interp, masterInterp->result, (char *) NULL); + Tcl_ResetResult(masterInterp); + } + return TCL_ERROR; + } + Tcl_RegisterChannel(slaveInterp, chan); + if (Tcl_UnregisterChannel(masterInterp, chan) != TCL_OK) { + if (interp != masterInterp) { + Tcl_AppendResult(interp, masterInterp->result, (char *) NULL); + Tcl_ResetResult(masterInterp); + } + return TCL_ERROR; + } + + return TCL_OK; + } + + Tcl_AppendResult(interp, "bad option \"", argv[1], + "\": should be alias, aliases, create, delete, exists, eval, ", + "issafe, share, slaves, target or transfer", (char *) NULL); + return TCL_ERROR; +} + +/* + *---------------------------------------------------------------------- + * + * SlaveObjectCmd -- + * + * Command to manipulate an interpreter, e.g. to send commands to it + * to be evaluated. One such command exists for each slave interpreter. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * See user documentation for details. + * + *---------------------------------------------------------------------- + */ + +static int +SlaveObjectCmd(clientData, interp, argc, argv) + ClientData clientData; /* Slave interpreter. */ + Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ + Master *masterPtr; /* Master record for slave interp. */ + Slave *slavePtr; /* Slave record. */ + Tcl_Interp *slaveInterp; /* Slave interpreter. */ + char *cmdName; /* Name of command to do. */ + char *cmd; /* Command to evaluate in slave + * interpreter. */ + Alias *aliasPtr; /* Alias information. */ + Tcl_HashEntry *hPtr; /* For local searches. */ + Tcl_HashSearch hSearch; /* For local searches. */ + int result; /* Loop counter, status return. */ + size_t len; /* Length of command name. */ + + if (argc < 2) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " cmd ?arg ...?\"", (char *) NULL); + return TCL_ERROR; + } + + slaveInterp = (Tcl_Interp *) clientData; + if (slaveInterp == (Tcl_Interp *) NULL) { + Tcl_AppendResult(interp, "interpreter ", argv[0], " has been deleted", + (char *) NULL); + return TCL_ERROR; + } + + slavePtr = (Slave *) Tcl_GetAssocData(slaveInterp, + "tclSlaveRecord", NULL); + if (slavePtr == (Slave *) NULL) { + panic("SlaveObjectCmd: could not find slave record"); + } + + cmdName = argv[1]; + len = strlen(cmdName); + + if (cmdName[0] == 'a') { + if (strncmp(cmdName, "alias", len) == 0) { + switch (argc-2) { + case 0: + Tcl_AppendResult(interp, "wrong # args: should be \"", + argv[0], " alias aliasName ?targetName? ?args..?", + (char *) NULL); + return TCL_ERROR; + + case 1: + + /* + * Return the name of the command in the current + * interpreter for which the argument is an alias in the + * slave interpreter, and the list of saved arguments + */ + + return DescribeAlias(interp, slaveInterp, argv[2]); + + default: + masterPtr = (Master *) Tcl_GetAssocData(interp, + "tclMasterRecord", NULL); + if (masterPtr == (Master *) NULL) { + panic("SlaveObjectCmd: could not find master record"); + } + return AliasHelper(interp, slaveInterp, interp, masterPtr, + argv[2], argv[3], argc-4, argv+4); + } + } + + if (strncmp(cmdName, "aliases", len) == 0) { + + /* + * Return the names of all the aliases created in the + * slave interpreter. + */ + + for (hPtr = Tcl_FirstHashEntry(&(slavePtr->aliasTable), + &hSearch); + hPtr != (Tcl_HashEntry *) NULL; + hPtr = Tcl_NextHashEntry(&hSearch)) { + aliasPtr = (Alias *) Tcl_GetHashValue(hPtr); + Tcl_AppendElement(interp, aliasPtr->aliasName); + } + return TCL_OK; + } + } + + + if ((cmdName[0] == 'e') && (strncmp(cmdName, "eval", len) == 0)) { + if (argc < 3) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " eval arg ?arg ...?\"", (char *) NULL); + return TCL_ERROR; + } + + cmd = Tcl_Concat(argc-2, argv+2); + Tcl_Preserve((ClientData) slaveInterp); + result = Tcl_Eval(slaveInterp, cmd); + ckfree((char *) cmd); + + /* + * Now make the result and any error information accessible. We have + * to be careful because the slave interpreter and the current + * interpreter can be the same - do not destroy the result.. This + * can happen if an interpreter contains an alias which is directed + * at a target command in the same interpreter. + */ + + if (interp != slaveInterp) { + if (result == TCL_ERROR) { + + /* + * An error occurred, so transfer error information from the + * destination interpreter back to our interpreter. Must clear + * interp's result before calling Tcl_AddErrorInfo, since + * Tcl_AddErrorInfo will store the interp's result in errorInfo + * before appending slaveInterp's $errorInfo; + * we've already got everything we need in the slave + * interpreter's $errorInfo. + */ + + Tcl_ResetResult(interp); + Tcl_AddErrorInfo(interp, Tcl_GetVar2(slaveInterp, + "errorInfo", (char *) NULL, TCL_GLOBAL_ONLY)); + Tcl_SetVar2(interp, "errorCode", (char *) NULL, + Tcl_GetVar2(slaveInterp, "errorCode", (char *) NULL, + TCL_GLOBAL_ONLY), TCL_GLOBAL_ONLY); + } + if (slaveInterp->freeProc != NULL) { + interp->result = slaveInterp->result; + interp->freeProc = slaveInterp->freeProc; + slaveInterp->freeProc = 0; + } else { + Tcl_SetResult(interp, slaveInterp->result, TCL_VOLATILE); + } + Tcl_ResetResult(slaveInterp); + } + Tcl_Release((ClientData) slaveInterp); + return result; + } + + if ((cmdName[0] == 'i') && (strncmp(cmdName, "issafe", len) == 0)) { + if (argc > 2) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " issafe\"", (char *) NULL); + return TCL_ERROR; + } + masterPtr = (Master *) Tcl_GetAssocData(slaveInterp, + "tclMasterRecord", NULL); + if (masterPtr == (Master *) NULL) { + panic("SlaveObjectCmd: could not find master record"); + } + if (masterPtr->isSafe == 1) { + Tcl_AppendResult(interp, "1", (char *) NULL); + } else { + Tcl_AppendResult(interp, "0", (char *) NULL); + } + return TCL_OK; + } + + Tcl_AppendResult(interp, "bad option \"", argv[1], + "\": should be alias, aliases, eval or issafe", (char *) NULL); + return TCL_ERROR; +} + +/* + *---------------------------------------------------------------------- + * + * SlaveObjectDeleteProc -- + * + * Invoked when an object command for a slave interpreter is deleted; + * cleans up all state associated with the slave interpreter and destroys + * the slave interpreter. + * + * Results: + * None. + * + * Side effects: + * Cleans up all state associated with the slave interpreter and + * destroys the slave interpreter. + * + *---------------------------------------------------------------------- + */ + +static void +SlaveObjectDeleteProc(clientData) + ClientData clientData; /* The SlaveRecord for the command. */ +{ + Slave *slavePtr; /* Interim storage for Slave record. */ + Tcl_Interp *slaveInterp; /* And for a slave interp. */ + + slaveInterp = (Tcl_Interp *) clientData; + slavePtr = (Slave *) Tcl_GetAssocData(slaveInterp, "tclSlaveRecord",NULL); + if (slavePtr == (Slave *) NULL) { + panic("SlaveObjectDeleteProc: could not find slave record"); + } + + /* + * Delete the entry in the slave table in the master interpreter now. + * This is to avoid an infinite loop in the Master hash table cleanup in + * the master interpreter. This can happen if this slave is being deleted + * because the master is being deleted and the slave deletion is deferred + * because it is still active. + */ + + Tcl_DeleteHashEntry(slavePtr->slaveEntry); + + /* + * Set to NULL so that when the slave record is cleaned up in the slave + * it does not try to delete the command causing all sorts of grief. + * See SlaveRecordDeleteProc(). + */ + + slavePtr->interpCmd = NULL; + + /* + * Destroy the interpreter - this will cause all the deleteProcs for + * all commands (including aliases) to run. + * + * NOTE: WE ASSUME THAT THE INTERPRETER HAS NOT BEEN DELETED YET!! + */ + + Tcl_DeleteInterp(slavePtr->slaveInterp); +} + +/* + *---------------------------------------------------------------------- + * + * AliasCmd -- + * + * This is the procedure that services invocations of aliases in a + * slave interpreter. One such command exists for each alias. When + * invoked, this procedure redirects the invocation to the target + * command in the master interpreter as designated by the Alias + * record associated with this command. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * Causes forwarding of the invocation; all possible side effects + * may occur as a result of invoking the command to which the + * invocation is forwarded. + * + *---------------------------------------------------------------------- + */ + +static int +AliasCmd(clientData, interp, argc, argv) + ClientData clientData; /* Alias record. */ + Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ + Alias *aliasPtr; /* Describes the alias. */ + Tcl_CmdInfo cmdInfo; /* Info about target command. */ + int result; /* Result of execution. */ + int i, j, addArgc; /* Loop counters. */ + int localArgc; /* Local argument count. */ + char **localArgv; /* Local argument vector. */ + Interp *iPtr; /* The target interpreter. */ + + aliasPtr = (Alias *) clientData; + + result = Tcl_GetCommandInfo(aliasPtr->targetInterp, aliasPtr->targetName, + &cmdInfo); + if (result == 0) { + Tcl_AppendResult(interp, "aliased target \"", aliasPtr->targetName, + "\" for \"", argv[0], "\" not found", (char *) NULL); + return TCL_ERROR; + } + if (aliasPtr->argc <= 0) { + localArgv = argv; + localArgc = argc; + } else { + addArgc = aliasPtr->argc; + localArgc = argc + addArgc; + localArgv = (char **) ckalloc((unsigned) sizeof(char *) * localArgc); + localArgv[0] = argv[0]; + for (i = 0, j = 1; i < addArgc; i++, j++) { + localArgv[j] = aliasPtr->argv[i]; + } + for (i = 1; i < argc; i++, j++) { + localArgv[j] = argv[i]; + } + } + + /* + * Invoke the redirected command in the target interpreter. Note + * that we are not calling eval because of possible security holes with + * $ substitution and bracketed command evaluation. + * + * We duplicate some code here from Tcl_Eval to implement recursion + * level counting and correct deletion of the target interpreter if + * that was requested but delayed because of in-progress evaluations. + */ + + iPtr = (Interp *) aliasPtr->targetInterp; + iPtr->numLevels++; + Tcl_Preserve((ClientData) iPtr); + Tcl_ResetResult((Tcl_Interp *) iPtr); + result = (cmdInfo.proc)(cmdInfo.clientData, (Tcl_Interp *) iPtr, + localArgc, localArgv); + iPtr->numLevels--; + if (iPtr->numLevels == 0) { + if (result == TCL_RETURN) { + result = TclUpdateReturnInfo(iPtr); + } + if ((result != TCL_OK) && (result != TCL_ERROR)) { + Tcl_ResetResult((Tcl_Interp *) iPtr); + if (result == TCL_BREAK) { + iPtr->result = "invoked \"break\" outside of a loop"; + } else if (result == TCL_CONTINUE) { + iPtr->result = "invoked \"continue\" outside of a loop"; + } else { + iPtr->result = iPtr->resultSpace; + sprintf(iPtr->resultSpace, "command returned bad code: %d", + result); + } + result = TCL_ERROR; + } + } + + /* + * Clean up any locally allocated argument vector structure. + */ + + if (localArgv != argv) { + ckfree((char *) localArgv); + } + + /* + * + * NOTE: Need to be careful if the target interpreter and the current + * interpreter are the same - must not destroy result. This may happen + * if an alias is created which redirects to a command in the same + * interpreter as the one in which the source command will be defined. + * Also: We cannot use aliasPtr any more because the alias may have + * been deleted. + */ + + if (interp != (Tcl_Interp *) iPtr) { + if (result == TCL_ERROR) { + /* + * An error occurred, so transfer error information from the + * destination interpreter back to our interpreter. Some tricky + * points: + * 1. Must call Tcl_AddErrorInfo in destination interpreter to + * make sure that the errorInfo variable has been initialized + * (it's initialized lazily and might not have been initialized + * yet). + * 2. Must clear interp's result before calling Tcl_AddErrorInfo, + * since Tcl_AddErrorInfo will store the interp's result in + * errorInfo before appending aliasPtr->interp's $errorInfo; + * we've already got everything we need in the redirected + * interpreter's $errorInfo. + */ + + if (!(iPtr->flags & ERR_ALREADY_LOGGED)) { + Tcl_AddErrorInfo((Tcl_Interp *) iPtr, ""); + } + iPtr->flags &= ~ERR_ALREADY_LOGGED; + Tcl_ResetResult(interp); + Tcl_AddErrorInfo(interp, Tcl_GetVar2((Tcl_Interp *) iPtr, + "errorInfo", (char *) NULL, TCL_GLOBAL_ONLY)); + Tcl_SetVar2(interp, "errorCode", (char *) NULL, + Tcl_GetVar2((Tcl_Interp *) iPtr, "errorCode", + (char *) NULL, TCL_GLOBAL_ONLY), TCL_GLOBAL_ONLY); + } + if (iPtr->freeProc != NULL) { + interp->result = iPtr->result; + interp->freeProc = iPtr->freeProc; + iPtr->freeProc = 0; + } else { + Tcl_SetResult(interp, iPtr->result, TCL_VOLATILE); + } + Tcl_ResetResult((Tcl_Interp *) iPtr); + } + Tcl_Release((ClientData) iPtr); + return result; +} + +/* + *---------------------------------------------------------------------- + * + * AliasCmdDeleteProc -- + * + * Is invoked when an alias command is deleted in a slave. Cleans up + * all storage associated with this alias. + * + * Results: + * None. + * + * Side effects: + * Deletes the alias record and its entry in the alias table for + * the interpreter. + * + *---------------------------------------------------------------------- + */ + +static void +AliasCmdDeleteProc(clientData) + ClientData clientData; /* The alias record for this alias. */ +{ + Alias *aliasPtr; /* Alias record for alias to delete. */ + Target *targetPtr; /* Record for target of this alias. */ + int i; /* Loop counter. */ + + aliasPtr = (Alias *) clientData; + + targetPtr = (Target *) Tcl_GetHashValue(aliasPtr->targetEntry); + ckfree((char *) targetPtr); + Tcl_DeleteHashEntry(aliasPtr->targetEntry); + + ckfree((char *) aliasPtr->targetName); + ckfree((char *) aliasPtr->aliasName); + for (i = 0; i < aliasPtr->argc; i++) { + ckfree((char *) aliasPtr->argv[i]); + } + if (aliasPtr->argv != (char **) NULL) { + ckfree((char *) aliasPtr->argv); + } + + Tcl_DeleteHashEntry(aliasPtr->aliasEntry); + + ckfree((char *) aliasPtr); +} + +/* + *---------------------------------------------------------------------- + * + * MasterRecordDeleteProc - + * + * Is invoked when an interpreter (which is using the "interp" facility) + * is deleted, and it cleans up the storage associated with the + * "tclMasterRecord" assoc-data entry. + * + * Results: + * None. + * + * Side effects: + * Cleans up storage. + * + *---------------------------------------------------------------------- + */ + +static void +MasterRecordDeleteProc(clientData, interp) + ClientData clientData; /* Master record for deleted interp. */ + Tcl_Interp *interp; /* Interpreter being deleted. */ +{ + Target *targetPtr; /* Loop variable. */ + Tcl_HashEntry *hPtr; /* Search element. */ + Tcl_HashSearch hSearch; /* Search record (internal). */ + Slave *slavePtr; /* Loop variable. */ + char *cmdName; /* Name of command to delete. */ + Master *masterPtr; /* Interim storage. */ + + masterPtr = (Master *) clientData; + for (hPtr = Tcl_FirstHashEntry(&(masterPtr->slaveTable), &hSearch); + hPtr != NULL; + hPtr = Tcl_NextHashEntry(&hSearch)) { + slavePtr = (Slave *) Tcl_GetHashValue(hPtr); + cmdName = Tcl_GetCommandName(interp, slavePtr->interpCmd); + (void) Tcl_DeleteCommand(interp, cmdName); + } + Tcl_DeleteHashTable(&(masterPtr->slaveTable)); + + for (hPtr = Tcl_FirstHashEntry(&(masterPtr->targetTable), &hSearch); + hPtr != NULL; + hPtr = Tcl_FirstHashEntry(&(masterPtr->targetTable), &hSearch)) { + targetPtr = (Target *) Tcl_GetHashValue(hPtr); + cmdName = Tcl_GetCommandName(targetPtr->slaveInterp, + targetPtr->slaveCmd); + (void) Tcl_DeleteCommand(targetPtr->slaveInterp, cmdName); + } + Tcl_DeleteHashTable(&(masterPtr->targetTable)); + + ckfree((char *) masterPtr); +} + +/* + *---------------------------------------------------------------------- + * + * SlaveRecordDeleteProc -- + * + * Is invoked when an interpreter (which is using the interp facility) + * is deleted, and it cleans up the storage associated with the + * tclSlaveRecord assoc-data entry. + * + * Results: + * None + * + * Side effects: + * Cleans up storage. + * + *---------------------------------------------------------------------- + */ + +static void +SlaveRecordDeleteProc(clientData, interp) + ClientData clientData; /* Slave record for deleted interp. */ + Tcl_Interp *interp; /* Interpreter being deleted. */ +{ + Slave *slavePtr; /* Interim storage. */ + Alias *aliasPtr; + Tcl_HashTable *hTblPtr; + Tcl_HashEntry *hPtr; + Tcl_HashSearch hSearch; + + slavePtr = (Slave *) clientData; + + /* + * In every case that we call SetAssocData on "tclSlaveRecord", + * slavePtr is not NULL. Otherwise we panic. + */ + + if (slavePtr == NULL) { + panic("SlaveRecordDeleteProc: NULL slavePtr"); + } + + if (slavePtr->interpCmd != (Tcl_Command) NULL) { + Command *cmdPtr = (Command *) slavePtr->interpCmd; + + /* + * The interpCmd has not been deleted in the master yet, since + * it's callback sets interpCmd to NULL. + * + * Probably Tcl_DeleteInterp() was called on this interpreter directly, + * rather than via "interp delete", or equivalent (deletion of the + * command in the master). + * + * Perform the cleanup done by SlaveObjectDeleteProc() directly, + * and turn off the callback now (since we are about to free slavePtr + * and this interpreter is going away, while the deletion of commands + * in the master may be deferred). + */ + + Tcl_DeleteHashEntry(slavePtr->slaveEntry); + cmdPtr->clientData = NULL; + cmdPtr->deleteProc = NULL; + cmdPtr->deleteData = NULL; + + /* + * Get the command name from the master interpreter instead of + * relying on the stored name; the command may have been renamed. + */ + + Tcl_DeleteCommand(slavePtr->masterInterp, + Tcl_GetCommandName(slavePtr->masterInterp, + slavePtr->interpCmd)); + } + + /* + * If there are any aliases, delete those now. This removes any + * dependency on the order of deletion between commands and the + * slave record. + */ + + hTblPtr = (Tcl_HashTable *) &(slavePtr->aliasTable); + for (hPtr = Tcl_FirstHashEntry(hTblPtr, &hSearch); + hPtr != (Tcl_HashEntry *) NULL; + hPtr = Tcl_FirstHashEntry(hTblPtr, &hSearch)) { + aliasPtr = (Alias *) Tcl_GetHashValue(hPtr); + + /* + * The call to Tcl_DeleteCommand will release the storage + * occuppied by the hash entry and the alias record. + * NOTE that we cannot use the alias name directly because its + * storage will be deleted in the command deletion callback. Hence + * we must use the name for the command as stored in the hash table. + */ + + Tcl_DeleteCommand(interp, + Tcl_GetCommandName(interp, aliasPtr->slaveCmd)); + } + + /* + * Finally dispose of the slave record itself. + */ + + ckfree((char *) slavePtr); +} + +/* + *---------------------------------------------------------------------- + * + * TclInterpInit -- + * + * Initializes the invoking interpreter for using the "interp" + * facility. This is called from inside Tcl_Init. + * + * Results: + * None. + * + * Side effects: + * Adds the "interp" command to an interpreter and initializes several + * records in the associated data of the invoking interpreter. + * + *---------------------------------------------------------------------- + */ + +int +TclInterpInit(interp) + Tcl_Interp *interp; /* Interpreter to initialize. */ +{ + Master *masterPtr; /* Its Master record. */ + + masterPtr = (Master *) ckalloc((unsigned) sizeof(Master)); + masterPtr->isSafe = 0; + Tcl_InitHashTable(&(masterPtr->slaveTable), TCL_STRING_KEYS); + Tcl_InitHashTable(&(masterPtr->targetTable), TCL_ONE_WORD_KEYS); + + (void) Tcl_SetAssocData(interp, "tclMasterRecord", MasterRecordDeleteProc, + (ClientData) masterPtr); + + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_IsSafe -- + * + * Determines whether an interpreter is safe + * + * Results: + * 1 if it is safe, 0 if it is not. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_IsSafe(interp) + Tcl_Interp *interp; /* Is this interpreter "safe" ? */ +{ + Master *masterPtr; /* Its master record. */ + + if (interp == (Tcl_Interp *) NULL) { + return 0; + } + masterPtr = (Master *) Tcl_GetAssocData(interp, "tclMasterRecord", NULL); + if (masterPtr == (Master *) NULL) { + panic("Tcl_IsSafe: could not find master record"); + } + return masterPtr->isSafe; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_MakeSafe -- + * + * Makes an interpreter safe. + * + * Results: + * TCL_OK if it succeeds, TCL_ERROR else. + * + * Side effects: + * Removes functionality from an interpreter. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_MakeSafe(interp) + Tcl_Interp *interp; /* Make this interpreter "safe". */ +{ + if (interp == (Tcl_Interp *) NULL) { + return TCL_ERROR; + } + return MakeSafe(interp); +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_CreateSlave -- + * + * Creates a slave interpreter. The slavePath argument denotes the + * name of the new slave relative to the current interpreter; the + * slave is a direct descendant of the one-before-last component of + * the path, e.g. it is a descendant of the current interpreter if + * the slavePath argument contains only one component. Optionally makes + * the slave interpreter safe. + * + * Results: + * Returns the interpreter structure created, or NULL if an error + * occurred. + * + * Side effects: + * Creates a new interpreter and a new interpreter object command in + * the interpreter indicated by the slavePath argument. + * + *---------------------------------------------------------------------- + */ + +Tcl_Interp * +Tcl_CreateSlave(interp, slavePath, isSafe) + Tcl_Interp *interp; /* Interpreter to start search at. */ + char *slavePath; /* Name of slave to create. */ + int isSafe; /* Should new slave be "safe" ? */ +{ + if ((interp == (Tcl_Interp *) NULL) || (slavePath == (char *) NULL)) { + return NULL; + } + return CreateSlave(interp, slavePath, isSafe); +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_GetSlave -- + * + * Finds a slave interpreter by its path name. + * + * Results: + * Returns a Tcl_Interp * for the named interpreter or NULL if not + * found. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +Tcl_Interp * +Tcl_GetSlave(interp, slavePath) + Tcl_Interp *interp; /* Interpreter to start search from. */ + char *slavePath; /* Path of slave to find. */ +{ + Master *masterPtr; /* Interim storage for Master record. */ + + if ((interp == (Tcl_Interp *) NULL) || (slavePath == (char *) NULL)) { + return NULL; + } + masterPtr = (Master *) Tcl_GetAssocData(interp, "tclMasterRecord", NULL); + if (masterPtr == (Master *) NULL) { + panic("Tcl_GetSlave: could not find master record"); + } + return GetInterp(interp, masterPtr, slavePath, NULL); +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_GetMaster -- + * + * Finds the master interpreter of a slave interpreter. + * + * Results: + * Returns a Tcl_Interp * for the master interpreter or NULL if none. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +Tcl_Interp * +Tcl_GetMaster(interp) + Tcl_Interp *interp; /* Get the master of this interpreter. */ +{ + Slave *slavePtr; /* Slave record of this interpreter. */ + + if (interp == (Tcl_Interp *) NULL) { + return NULL; + } + slavePtr = (Slave *) Tcl_GetAssocData(interp, "tclSlaveRecord", NULL); + if (slavePtr == (Slave *) NULL) { + return NULL; + } + return slavePtr->masterInterp; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_CreateAlias -- + * + * Creates an alias between two interpreters. + * + * Results: + * TCL_OK if successful, TCL_ERROR if failed. If TCL_ERROR is returned + * the result of slaveInterp will contain an error message. + * + * Side effects: + * Creates a new alias, manipulates the result field of slaveInterp. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_CreateAlias(slaveInterp, slaveCmd, targetInterp, targetCmd, argc, argv) + Tcl_Interp *slaveInterp; /* Interpreter for source command. */ + char *slaveCmd; /* Command to install in slave. */ + Tcl_Interp *targetInterp; /* Interpreter for target command. */ + char *targetCmd; /* Name of target command. */ + int argc; /* How many additional arguments? */ + char **argv; /* These are the additional args. */ +{ + Master *masterPtr; /* Master record for target interp. */ + + if ((slaveInterp == (Tcl_Interp *) NULL) || + (targetInterp == (Tcl_Interp *) NULL) || + (slaveCmd == (char *) NULL) || + (targetCmd == (char *) NULL)) { + return TCL_ERROR; + } + masterPtr = (Master *) Tcl_GetAssocData(targetInterp, "tclMasterRecord", + NULL); + if (masterPtr == (Master *) NULL) { + panic("Tcl_CreateAlias: could not find master record"); + } + return AliasHelper(slaveInterp, slaveInterp, targetInterp, masterPtr, + slaveCmd, targetCmd, argc, argv); +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_GetAlias -- + * + * Gets information about an alias. + * + * Results: + * TCL_OK if successful, TCL_ERROR else. If TCL_ERROR is returned, the + * result field of the interpreter given as argument will contain an + * error message. + * + * Side effects: + * Manipulates the result field of the interpreter given as argument. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_GetAlias(interp, aliasName, targetInterpPtr, targetNamePtr, argcPtr, + argvPtr) + Tcl_Interp *interp; /* Interp to start search from. */ + char *aliasName; /* Name of alias to find. */ + Tcl_Interp **targetInterpPtr; /* (Return) target interpreter. */ + char **targetNamePtr; /* (Return) name of target command. */ + int *argcPtr; /* (Return) count of addnl args. */ + char ***argvPtr; /* (Return) additional arguments. */ +{ + Slave *slavePtr; /* Slave record for slave interp. */ + Tcl_HashEntry *hPtr; /* Search element. */ + Alias *aliasPtr; /* Storage for alias found. */ + + if ((interp == (Tcl_Interp *) NULL) || (aliasName == (char *) NULL)) { + return TCL_ERROR; + } + slavePtr = (Slave *) Tcl_GetAssocData(interp, "tclSlaveRecord", NULL); + if (slavePtr == (Slave *) NULL) { + panic("Tcl_GetAlias: could not find slave record"); + } + hPtr = Tcl_FindHashEntry(&(slavePtr->aliasTable), aliasName); + if (hPtr == (Tcl_HashEntry *) NULL) { + Tcl_AppendResult(interp, "alias \"", aliasName, "\" not found", + (char *) NULL); + return TCL_ERROR; + } + aliasPtr = (Alias *) Tcl_GetHashValue(hPtr); + if (targetInterpPtr != (Tcl_Interp **) NULL) { + *targetInterpPtr = aliasPtr->targetInterp; + } + if (targetNamePtr != (char **) NULL) { + *targetNamePtr = aliasPtr->targetName; + } + if (argcPtr != (int *) NULL) { + *argcPtr = aliasPtr->argc; + } + if (argvPtr != (char ***) NULL) { + *argvPtr = aliasPtr->argv; + } + return TCL_OK; +} diff --git a/contrib/tcl/generic/tclLink.c b/contrib/tcl/generic/tclLink.c new file mode 100644 index 0000000..1726c5d --- /dev/null +++ b/contrib/tcl/generic/tclLink.c @@ -0,0 +1,390 @@ +/* + * tclLink.c -- + * + * This file implements linked variables (a C variable that is + * tied to a Tcl variable). The idea of linked variables was + * first suggested by Andreas Stolcke and this implementation is + * based heavily on a prototype implementation provided by + * him. + * + * 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: @(#) tclLink.c 1.12 96/02/15 11:50:26 + */ + +#include "tclInt.h" + +/* + * For each linked variable there is a data structure of the following + * type, which describes the link and is the clientData for the trace + * set on the Tcl variable. + */ + +typedef struct Link { + Tcl_Interp *interp; /* Interpreter containing Tcl variable. */ + char *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. */ + char *addr; /* Location of C variable. */ + int type; /* Type of link (TCL_LINK_INT, etc.). */ + int writable; /* Zero means Tcl variable is read-only. */ + union { + int i; + double d; + } lastValue; /* Last known value of C variable; used to + * avoid string conversions. */ +} Link; + +/* + * Forward references to procedures defined later in this file: + */ + +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_LinkVar -- + * + * Link a C variable to a Tcl variable so that changes to either + * one causes the other to change. + * + * Results: + * The return value is TCL_OK if everything went well or TCL_ERROR + * if an error occurred (interp->result is also set after errors). + * + * Side effects: + * The value at *addr is linked to the Tcl variable "varName", + * using "type" to convert between string values for Tcl and + * binary values for *addr. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_LinkVar(interp, varName, addr, type) + Tcl_Interp *interp; /* Interpreter in which varName exists. */ + 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. */ +{ + 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->addr = addr; + linkPtr->type = type & ~TCL_LINK_READ_ONLY; + linkPtr->writable = (type & TCL_LINK_READ_ONLY) == 0; + if (Tcl_SetVar(interp, varName, StringValue(linkPtr, buffer), + TCL_GLOBAL_ONLY|TCL_LEAVE_ERR_MSG) == NULL) { + ckfree(linkPtr->varName); + ckfree((char *) linkPtr); + return TCL_ERROR; + } + code = Tcl_TraceVar(interp, varName, TCL_GLOBAL_ONLY|TCL_TRACE_READS + |TCL_TRACE_WRITES|TCL_TRACE_UNSETS, LinkTraceProc, + (ClientData) linkPtr); + if (code != TCL_OK) { + ckfree(linkPtr->varName); + ckfree((char *) linkPtr); + } + return code; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_UnlinkVar -- + * + * Destroy the link between a Tcl variable and a C variable. + * + * Results: + * None. + * + * Side effects: + * If "varName" was previously linked to a C variable, the link + * is broken to make the variable independent. If there was no + * previous link for "varName" then nothing happens. + * + *---------------------------------------------------------------------- + */ + +void +Tcl_UnlinkVar(interp, varName) + Tcl_Interp *interp; /* Interpreter containing variable to unlink. */ + char *varName; /* Global variable in interp to unlink. */ +{ + Link *linkPtr; + + linkPtr = (Link *) Tcl_VarTraceInfo(interp, varName, TCL_GLOBAL_ONLY, + LinkTraceProc, (ClientData) NULL); + if (linkPtr == NULL) { + return; + } + Tcl_UntraceVar(interp, varName, + TCL_GLOBAL_ONLY|TCL_TRACE_READS|TCL_TRACE_WRITES|TCL_TRACE_UNSETS, + LinkTraceProc, (ClientData) linkPtr); + ckfree(linkPtr->varName); + ckfree((char *) linkPtr); +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_UpdateLinkedVar -- + * + * This procedure is invoked after a linked variable has been + * changed by C code. It updates the Tcl variable so that + * traces on the variable will trigger. + * + * Results: + * None. + * + * Side effects: + * The Tcl variable "varName" is updated from its C value, + * causing traces on the variable to trigger. + * + *---------------------------------------------------------------------- + */ + +void +Tcl_UpdateLinkedVar(interp, varName) + Tcl_Interp *interp; /* Interpreter containing variable. */ + char *varName; /* Name of global variable that is linked. */ +{ + Link *linkPtr; + char buffer[TCL_DOUBLE_SPACE]; + + linkPtr = (Link *) Tcl_VarTraceInfo(interp, varName, TCL_GLOBAL_ONLY, + LinkTraceProc, (ClientData) NULL); + if (linkPtr == NULL) { + return; + } + Tcl_SetVar(interp, linkPtr->varName, StringValue(linkPtr, buffer), + TCL_GLOBAL_ONLY); +} + +/* + *---------------------------------------------------------------------- + * + * LinkTraceProc -- + * + * This procedure is invoked when a linked Tcl variable is read, + * written, or unset from Tcl. It's responsible for keeping the + * C variable in sync with the Tcl variable. + * + * Results: + * If all goes well, NULL is returned; otherwise an error message + * is returned. + * + * Side effects: + * The C variable may be updated to make it consistent with the + * Tcl variable, or the Tcl variable may be overwritten to reject + * a modification. + * + *---------------------------------------------------------------------- + */ + +static char * +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. */ + int flags; /* Miscellaneous additional information. */ +{ + Link *linkPtr = (Link *) clientData; + int changed; + char buffer[TCL_DOUBLE_SPACE]; + char *value, **pp; + Tcl_DString savedResult; + + /* + * If the variable is being unset, then just re-create it (with a + * trace) unless the whole interpreter is going away. + */ + + if (flags & TCL_TRACE_UNSETS) { + if (flags & TCL_INTERP_DESTROYED) { + ckfree(linkPtr->varName); + ckfree((char *) linkPtr); + } else if (flags & TCL_TRACE_DESTROYED) { + Tcl_SetVar(interp, linkPtr->varName, StringValue(linkPtr, buffer), + TCL_GLOBAL_ONLY); + Tcl_TraceVar(interp, linkPtr->varName, TCL_GLOBAL_ONLY + |TCL_TRACE_READS|TCL_TRACE_WRITES|TCL_TRACE_UNSETS, + LinkTraceProc, (ClientData) linkPtr); + } + return NULL; + } + + /* + * For read accesses, update the Tcl variable if the C variable + * has changed since the last time we updated the Tcl variable. + */ + + 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"; + } + if (changed) { + Tcl_SetVar(interp, linkPtr->varName, StringValue(linkPtr, buffer), + TCL_GLOBAL_ONLY); + } + return NULL; + } + + /* + * For writes, first make sure that the variable is writable. Then + * convert the Tcl value to C if possible. If the variable isn't + * writable or can't be converted, then restore the varaible's old + * value and return an error. Another tricky thing: we have to save + * and restore the interpreter's result, since the variable access + * could occur when the result has been partially set. + */ + + if (!linkPtr->writable) { + Tcl_SetVar(interp, linkPtr->varName, StringValue(linkPtr, buffer), + TCL_GLOBAL_ONLY); + return "linked variable is read-only"; + } + value = Tcl_GetVar(interp, linkPtr->varName, TCL_GLOBAL_ONLY); + if (value == NULL) { + /* + * This shouldn't ever happen. + */ + return "internal error: linked variable couldn't be read"; + } + Tcl_DStringInit(&savedResult); + Tcl_DStringAppend(&savedResult, interp->result, -1); + Tcl_ResetResult(interp); + switch (linkPtr->type) { + case TCL_LINK_INT: + if (Tcl_GetInt(interp, value, &linkPtr->lastValue.i) != TCL_OK) { + Tcl_DStringResult(interp, &savedResult); + Tcl_SetVar(interp, linkPtr->varName, + StringValue(linkPtr, buffer), TCL_GLOBAL_ONLY); + return "variable must have integer value"; + } + *(int *)(linkPtr->addr) = linkPtr->lastValue.i; + break; + case TCL_LINK_DOUBLE: + if (Tcl_GetDouble(interp, value, &linkPtr->lastValue.d) + != TCL_OK) { + Tcl_DStringResult(interp, &savedResult); + Tcl_SetVar(interp, linkPtr->varName, + StringValue(linkPtr, buffer), TCL_GLOBAL_ONLY); + return "variable must have real value"; + } + *(double *)(linkPtr->addr) = linkPtr->lastValue.d; + break; + case TCL_LINK_BOOLEAN: + if (Tcl_GetBoolean(interp, value, &linkPtr->lastValue.i) + != TCL_OK) { + Tcl_DStringResult(interp, &savedResult); + Tcl_SetVar(interp, linkPtr->varName, + StringValue(linkPtr, buffer), TCL_GLOBAL_ONLY); + return "variable must have boolean value"; + } + *(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"; + } + Tcl_DStringResult(interp, &savedResult); + return NULL; +} + +/* + *---------------------------------------------------------------------- + * + * StringValue -- + * + * Converts the value of a C variable to a string for use in a + * Tcl variable to which it is linked. + * + * Results: + * The return value is a pointer + to a string that represents + * the value of the C variable given by linkPtr. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static char * +StringValue(linkPtr, buffer) + 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); + sprintf(buffer, "%d", linkPtr->lastValue.i); + return buffer; + case TCL_LINK_DOUBLE: + linkPtr->lastValue.d = *(double *)(linkPtr->addr); + Tcl_PrintDouble(linkPtr->interp, 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; + } + + /* + * This code only gets executed if the link type is unknown + * (shouldn't ever happen). + */ + + return "??"; +} diff --git a/contrib/tcl/generic/tclLoad.c b/contrib/tcl/generic/tclLoad.c new file mode 100644 index 0000000..f14856b --- /dev/null +++ b/contrib/tcl/generic/tclLoad.c @@ -0,0 +1,600 @@ +/* + * tclLoad.c -- + * + * This file provides the generic portion (those that are the same + * on all platforms) of Tcl's dynamic loading facilities. + * + * 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: @(#) tclLoad.c 1.10 96/04/02 18:44:22 + */ + +#include "tclInt.h" + +/* + * The following structure describes a package that has been loaded + * either dynamically (with the "load" command) or statically (as + * indicated by a call to Tcl_PackageLoaded). All such packages + * are linked together into a single list for the process. Packages + * are never unloaded, so these structures are never freed. + */ + +typedef struct LoadedPackage { + char *fileName; /* Name of the file from which the + * package was loaded. An empty string + * means the package is loaded statically. + * Malloc-ed. */ + char *packageName; /* Name of package prefix for the package, + * properly capitalized (first letter UC, + * others LC), no "_", as in "Net". + * Malloc-ed. */ + Tcl_PackageInitProc *initProc; + /* Initialization procedure to call to + * incorporate this package into a trusted + * interpreter. */ + Tcl_PackageInitProc *safeInitProc; + /* Initialization procedure to call to + * incorporate this package into a safe + * interpreter (one that will execute + * untrusted scripts). NULL means the + * package can't be used in unsafe + * interpreters. */ + struct LoadedPackage *nextPtr; + /* Next in list of all packages loaded into + * this application process. NULL means + * end of list. */ +} LoadedPackage; + +static LoadedPackage *firstPackagePtr = NULL; + /* First in list of all packages loaded into + * this process. */ + +/* + * The following structure represents a particular package that has + * been incorporated into a particular interpreter (by calling its + * initialization procedure). There is a list of these structures for + * each interpreter, with an AssocData value (key "load") for the + * interpreter that points to the first package (if any). + */ + +typedef struct InterpPackage { + LoadedPackage *pkgPtr; /* Points to detailed information about + * package. */ + struct InterpPackage *nextPtr; + /* Next package in this interpreter, or + * NULL for end of list. */ +} InterpPackage; + +/* + * Prototypes for procedures that are private to this file: + */ + +static void LoadCleanupProc _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp)); +static void LoadExitProc _ANSI_ARGS_((ClientData clientData)); + +/* + *---------------------------------------------------------------------- + * + * Tcl_LoadCmd -- + * + * This procedure is invoked to process the "load" 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_LoadCmd(dummy, interp, argc, argv) + ClientData dummy; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ + Tcl_Interp *target; + LoadedPackage *pkgPtr; + Tcl_DString pkgName, initName, safeInitName, fileName; + Tcl_PackageInitProc *initProc, *safeInitProc; + InterpPackage *ipFirstPtr, *ipPtr; + int code, c, gotPkgName; + char *p, *fullFileName; + + if ((argc < 2) || (argc > 4)) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " fileName ?packageName? ?interp?\"", (char *) NULL); + return TCL_ERROR; + } + fullFileName = Tcl_TranslateFileName(interp, argv[1], &fileName); + if (fullFileName == NULL) { + return TCL_ERROR; + } + Tcl_DStringInit(&pkgName); + Tcl_DStringInit(&initName); + Tcl_DStringInit(&safeInitName); + if ((argc >= 3) && (argv[2][0] != 0)) { + gotPkgName = 1; + } else { + gotPkgName = 0; + } + if ((fullFileName[0] == 0) && !gotPkgName) { + interp->result = "must specify either file name or package name"; + code = TCL_ERROR; + goto done; + } + + /* + * Figure out which interpreter we're going to load the package into. + */ + + target = interp; + if (argc == 4) { + target = Tcl_GetSlave(interp, argv[3]); + if (target == NULL) { + Tcl_AppendResult(interp, "couldn't find slave interpreter named \"", + argv[3], "\"", (char *) NULL); + return TCL_ERROR; + } + } + + /* + * See if the desired file is already loaded. If so, its package + * name must agree with ours (if we have one). + */ + + for (pkgPtr = firstPackagePtr; pkgPtr != NULL; pkgPtr = pkgPtr->nextPtr) { + if (strcmp(pkgPtr->fileName, fullFileName) != 0) { + continue; + } + if (gotPkgName) { + char *p1, *p2; + for (p1 = argv[2], p2 = pkgPtr->packageName; ; p1++, p2++) { + if ((isupper(*p1) ? tolower(*p1) : *p1) + != (isupper(*p2) ? tolower(*p2) : *p2)) { + if (fullFileName[0] == 0) { + /* + * We're looking for a statically loaded package; + * the file name is basically irrelevant here, so + * don't get upset that there's some other package + * with the same (empty string) file name. Just + * skip this package and go on to the next. + */ + + goto nextPackage; + } + Tcl_AppendResult(interp, "file \"", fullFileName, + "\" is already loaded for package \"", + pkgPtr->packageName, "\"", (char *) NULL); + code = TCL_ERROR; + goto done; + } + if (*p1 == 0) { + goto gotPkg; + } + } + nextPackage: + continue; + } + break; + } + gotPkg: + + /* + * If the file is already loaded in the target interpreter then + * there's nothing for us to do. + */ + + ipFirstPtr = (InterpPackage *) Tcl_GetAssocData(target, "tclLoad", + (Tcl_InterpDeleteProc **) NULL); + if (pkgPtr != NULL) { + for (ipPtr = ipFirstPtr; ipPtr != NULL; ipPtr = ipPtr->nextPtr) { + if (ipPtr->pkgPtr == pkgPtr) { + code = TCL_OK; + goto done; + } + } + } + + if (pkgPtr == NULL) { + /* + * The desired file isn't currently loaded, so load it. It's an + * error if the desired package is a static one. + */ + + if (fullFileName[0] == 0) { + Tcl_AppendResult(interp, "package \"", argv[2], + "\" isn't loaded statically", (char *) NULL); + code = TCL_ERROR; + goto done; + } + + /* + * Figure out the module name if it wasn't provided explicitly. + */ + + if (gotPkgName) { + Tcl_DStringAppend(&pkgName, argv[2], -1); + } else { + if (!TclGuessPackageName(fullFileName, &pkgName)) { + int pargc; + char **pargv, *pkgGuess; + + /* + * The platform-specific code couldn't figure out the + * module name. Make a guess by taking the last element + * of the file name, stripping off any leading "lib", and + * then using all of the alphabetic characters that follow + * that. + */ + + Tcl_SplitPath(fullFileName, &pargc, &pargv); + pkgGuess = pargv[pargc-1]; + if ((pkgGuess[0] == 'l') && (pkgGuess[1] == 'i') + && (pkgGuess[2] == 'b')) { + pkgGuess += 3; + } + for (p = pkgGuess; isalpha(*p); p++) { + /* Empty loop body. */ + } + if (p == pkgGuess) { + ckfree((char *)pargv); + Tcl_AppendResult(interp, + "couldn't figure out package name for ", + fullFileName, (char *) NULL); + code = TCL_ERROR; + goto done; + } + Tcl_DStringAppend(&pkgName, pkgGuess, (p - pkgGuess)); + ckfree((char *)pargv); + } + } + + /* + * Fix the capitalization in the package name so that the first + * character is in caps but the others are all lower-case. + */ + + p = Tcl_DStringValue(&pkgName); + c = UCHAR(*p); + if (c != 0) { + if (islower(c)) { + *p = (char) toupper(c); + } + p++; + while (1) { + c = UCHAR(*p); + if (c == 0) { + break; + } + if (isupper(c)) { + *p = (char) tolower(c); + } + p++; + } + } + + /* + * Compute the names of the two initialization procedures, + * based on the package name. + */ + + Tcl_DStringAppend(&initName, Tcl_DStringValue(&pkgName), -1); + Tcl_DStringAppend(&initName, "_Init", 5); + Tcl_DStringAppend(&safeInitName, Tcl_DStringValue(&pkgName), -1); + Tcl_DStringAppend(&safeInitName, "_SafeInit", 9); + + /* + * Call platform-specific code to load the package and find the + * two initialization procedures. + */ + + code = TclLoadFile(interp, fullFileName, Tcl_DStringValue(&initName), + Tcl_DStringValue(&safeInitName), &initProc, &safeInitProc); + if (code != TCL_OK) { + goto done; + } + if (initProc == NULL) { + Tcl_AppendResult(interp, "couldn't find procedure ", + Tcl_DStringValue(&initName), (char *) NULL); + code = TCL_ERROR; + goto done; + } + + /* + * Create a new record to describe this package. + */ + + if (firstPackagePtr == NULL) { + Tcl_CreateExitHandler(LoadExitProc, (ClientData) NULL); + } + pkgPtr = (LoadedPackage *) ckalloc(sizeof(LoadedPackage)); + pkgPtr->fileName = (char *) ckalloc((unsigned) + (strlen(fullFileName) + 1)); + strcpy(pkgPtr->fileName, fullFileName); + pkgPtr->packageName = (char *) ckalloc((unsigned) + (Tcl_DStringLength(&pkgName) + 1)); + strcpy(pkgPtr->packageName, Tcl_DStringValue(&pkgName)); + pkgPtr->initProc = initProc; + pkgPtr->safeInitProc = safeInitProc; + pkgPtr->nextPtr = firstPackagePtr; + firstPackagePtr = pkgPtr; + } + + /* + * Invoke the package's initialization procedure (either the + * normal one or the safe one, depending on whether or not the + * interpreter is safe). + */ + + if (Tcl_IsSafe(target)) { + if (pkgPtr->safeInitProc != NULL) { + code = (*pkgPtr->safeInitProc)(target); + } else { + Tcl_AppendResult(interp, + "can't use package in a safe interpreter: ", + "no ", pkgPtr->packageName, "_SafeInit procedure", + (char *) NULL); + code = TCL_ERROR; + goto done; + } + } else { + code = (*pkgPtr->initProc)(target); + } + if ((code == TCL_ERROR) && (target != interp)) { + /* + * An error occurred, so transfer error information from the + * destination interpreter back to our interpreter. Must clear + * interp's result before calling Tcl_AddErrorInfo, since + * Tcl_AddErrorInfo will store the interp's result in errorInfo + * before appending target's $errorInfo; we've already got + * everything we need in target's $errorInfo. + */ + + Tcl_ResetResult(interp); + Tcl_AddErrorInfo(interp, Tcl_GetVar2(target, + "errorInfo", (char *) NULL, TCL_GLOBAL_ONLY)); + Tcl_SetVar2(interp, "errorCode", (char *) NULL, + Tcl_GetVar2(target, "errorCode", (char *) NULL, + TCL_GLOBAL_ONLY), TCL_GLOBAL_ONLY); + Tcl_SetResult(interp, target->result, TCL_VOLATILE); + } + + /* + * Record the fact that the package has been loaded in the + * target interpreter. + */ + + if (code == TCL_OK) { + ipPtr = (InterpPackage *) ckalloc(sizeof(InterpPackage)); + ipPtr->pkgPtr = pkgPtr; + ipPtr->nextPtr = ipFirstPtr; + Tcl_SetAssocData(target, "tclLoad", LoadCleanupProc, + (ClientData) ipPtr); + } + + done: + Tcl_DStringFree(&pkgName); + Tcl_DStringFree(&initName); + Tcl_DStringFree(&safeInitName); + Tcl_DStringFree(&fileName); + return code; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_StaticPackage -- + * + * This procedure is invoked to indicate that a particular + * package has been linked statically with an application. + * + * Results: + * None. + * + * Side effects: + * Once this procedure completes, the package becomes loadable + * via the "load" command with an empty file name. + * + *---------------------------------------------------------------------- + */ + +void +Tcl_StaticPackage(interp, pkgName, initProc, safeInitProc) + Tcl_Interp *interp; /* If not NULL, it means that the + * package has already been loaded + * into the given interpreter by + * calling the appropriate init proc. */ + char *pkgName; /* Name of package (must be properly + * capitalized: first letter upper + * case, others lower case). */ + Tcl_PackageInitProc *initProc; /* Procedure to call to incorporate + * this package into a trusted + * interpreter. */ + Tcl_PackageInitProc *safeInitProc; /* Procedure to call to incorporate + * this package into a safe interpreter + * (one that will execute untrusted + * scripts). NULL means the package + * can't be used in safe + * interpreters. */ +{ + LoadedPackage *pkgPtr; + InterpPackage *ipPtr, *ipFirstPtr; + + if (firstPackagePtr == NULL) { + Tcl_CreateExitHandler(LoadExitProc, (ClientData) NULL); + } + pkgPtr = (LoadedPackage *) ckalloc(sizeof(LoadedPackage)); + pkgPtr->fileName = (char *) ckalloc((unsigned) 1); + pkgPtr->fileName[0] = 0; + pkgPtr->packageName = (char *) ckalloc((unsigned) + (strlen(pkgName) + 1)); + strcpy(pkgPtr->packageName, pkgName); + pkgPtr->initProc = initProc; + pkgPtr->safeInitProc = safeInitProc; + pkgPtr->nextPtr = firstPackagePtr; + firstPackagePtr = pkgPtr; + + if (interp != NULL) { + ipFirstPtr = (InterpPackage *) Tcl_GetAssocData(interp, "tclLoad", + (Tcl_InterpDeleteProc **) NULL); + ipPtr = (InterpPackage *) ckalloc(sizeof(InterpPackage)); + ipPtr->pkgPtr = pkgPtr; + ipPtr->nextPtr = ipFirstPtr; + Tcl_SetAssocData(interp, "tclLoad", LoadCleanupProc, + (ClientData) ipPtr); + } +} + +/* + *---------------------------------------------------------------------- + * + * TclGetLoadedPackages -- + * + * This procedure returns information about all of the files + * that are loaded (either in a particular intepreter, or + * for all interpreters). + * + * Results: + * The return value is a standard Tcl completion code. If + * successful, a list of lists is placed in interp->result. + * Each sublist corresponds to one loaded file; its first + * element is the name of the file (or an empty string for + * something that's statically loaded) and the second element + * is the name of the package in that file. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +int +TclGetLoadedPackages(interp, targetName) + Tcl_Interp *interp; /* Interpreter in which to return + * information or error message. */ + char *targetName; /* Name of target interpreter or NULL. + * If NULL, return info about all interps; + * otherwise, just return info about this + * interpreter. */ +{ + Tcl_Interp *target; + LoadedPackage *pkgPtr; + InterpPackage *ipPtr; + char *prefix; + + if (targetName == NULL) { + /* + * Return information about all of the available packages. + */ + + prefix = "{"; + for (pkgPtr = firstPackagePtr; pkgPtr != NULL; + pkgPtr = pkgPtr->nextPtr) { + Tcl_AppendResult(interp, prefix, (char *) NULL); + Tcl_AppendElement(interp, pkgPtr->fileName); + Tcl_AppendElement(interp, pkgPtr->packageName); + Tcl_AppendResult(interp, "}", (char *) NULL); + prefix = " {"; + } + return TCL_OK; + } + + /* + * Return information about only the packages that are loaded in + * a given interpreter. + */ + + target = Tcl_GetSlave(interp, targetName); + if (target == NULL) { + Tcl_AppendResult(interp, "couldn't find slave interpreter named \"", + targetName, "\"", (char *) NULL); + return TCL_ERROR; + } + ipPtr = (InterpPackage *) Tcl_GetAssocData(target, "tclLoad", + (Tcl_InterpDeleteProc **) NULL); + prefix = "{"; + for ( ; ipPtr != NULL; ipPtr = ipPtr->nextPtr) { + pkgPtr = ipPtr->pkgPtr; + Tcl_AppendResult(interp, prefix, (char *) NULL); + Tcl_AppendElement(interp, pkgPtr->fileName); + Tcl_AppendElement(interp, pkgPtr->packageName); + Tcl_AppendResult(interp, "}", (char *) NULL); + prefix = " {"; + } + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * LoadCleanupProc -- + * + * This procedure is called to delete all of the InterpPackage + * structures for an interpreter when the interpreter is deleted. + * It gets invoked via the Tcl AssocData mechanism. + * + * Results: + * None. + * + * Side effects: + * Storage for all of the InterpPackage procedures for interp + * get deleted. + * + *---------------------------------------------------------------------- + */ + +static void +LoadCleanupProc(clientData, interp) + ClientData clientData; /* Pointer to first InterpPackage structure + * for interp. */ + Tcl_Interp *interp; /* Interpreter that is being deleted. */ +{ + InterpPackage *ipPtr, *nextPtr; + + ipPtr = (InterpPackage *) clientData; + while (ipPtr != NULL) { + nextPtr = ipPtr->nextPtr; + ckfree((char *) ipPtr); + ipPtr = nextPtr; + } +} + +/* + *---------------------------------------------------------------------- + * + * LoadExitProc -- + * + * This procedure is invoked just before the application exits. + * It frees all of the LoadedPackage structures. + * + * Results: + * None. + * + * Side effects: + * Memory is freed. + * + *---------------------------------------------------------------------- + */ + +static void +LoadExitProc(clientData) + ClientData clientData; /* Not used. */ +{ + LoadedPackage *pkgPtr; + + while (firstPackagePtr != NULL) { + pkgPtr = firstPackagePtr; + firstPackagePtr = pkgPtr->nextPtr; + ckfree(pkgPtr->fileName); + ckfree(pkgPtr->packageName); + ckfree((char *) pkgPtr); + } +} diff --git a/contrib/tcl/generic/tclLoadNone.c b/contrib/tcl/generic/tclLoadNone.c new file mode 100644 index 0000000..87b56e0 --- /dev/null +++ b/contrib/tcl/generic/tclLoadNone.c @@ -0,0 +1,81 @@ +/* + * tclLoadNone.c -- + * + * This procedure provides a version of the TclLoadFile for use + * in systems that don't support dynamic loading; it just returns + * an error. + * + * Copyright (c) 1995-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: @(#) tclLoadNone.c 1.5 96/02/15 11:43:01 + */ + +#include "tclInt.h" + +/* + *---------------------------------------------------------------------- + * + * TclLoadFile -- + * + * This procedure is called to carry out dynamic loading of binary + * code; it is intended for use only on systems that don't support + * dynamic loading (it returns an error). + * + * Results: + * The result is TCL_ERROR, and an error message is left in + * interp->result. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +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. */ +{ + interp->result = + "dynamic loading is not currently available on this system"; + return TCL_ERROR; +} + +/* + *---------------------------------------------------------------------- + * + * 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; +} diff --git a/contrib/tcl/generic/tclMain.c b/contrib/tcl/generic/tclMain.c new file mode 100644 index 0000000..d7b029d --- /dev/null +++ b/contrib/tcl/generic/tclMain.c @@ -0,0 +1,347 @@ +/* + * tclMain.c -- + * + * Main program for Tcl shells and other Tcl-based applications. + * + * Copyright (c) 1988-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: @(#) tclMain.c 1.50 96/04/10 16:40:57 + */ + +#include "tcl.h" +#include "tclInt.h" + +/* + * 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. + */ + +extern int isatty _ANSI_ARGS_((int fd)); +extern char * strcpy _ANSI_ARGS_((char *dst, CONST char *src)); + +static Tcl_Interp *interp; /* Interpreter for application. */ +static Tcl_DString command; /* Used to buffer incomplete commands being + * read from stdin. */ +#ifdef TCL_MEM_DEBUG +static char dumpFile[100]; /* Records where to dump memory allocation + * information. */ +static int quitFlag = 0; /* 1 means the "checkmem" command was + * invoked, 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 + +/* + *---------------------------------------------------------------------- + * + * Tcl_Main -- + * + * Main program for tclsh and most other Tcl-based applications. + * + * Results: + * None. This procedure never returns (it exits the process when + * it's done. + * + * Side effects: + * This procedure initializes the Tk world and then starts + * interpreting commands; almost anything could happen, depending + * on the script being interpreted. + * + *---------------------------------------------------------------------- + */ + +void +Tcl_Main(argc, argv, appInitProc) + int argc; /* Number of arguments. */ + char **argv; /* Array of argument strings. */ + Tcl_AppInitProc *appInitProc; /* Application-specific initialization + * procedure to call after most + * initialization but before starting + * to execute commands. */ +{ + char buffer[1000], *cmd, *args, *fileName; + int code, gotPartial, tty, length; + int exitCode = 0; + Tcl_Channel inChannel, outChannel, errChannel; + Tcl_DString temp; + + 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" + * and "argv". If the first argument doesn't start with a "-" then + * strip it off and use it as the name of a script file to process. + */ + + fileName = NULL; + if ((argc > 1) && (argv[1][0] != '-')) { + fileName = argv[1]; + argc--; + argv++; + } + args = Tcl_Merge(argc-1, argv+1); + Tcl_SetVar(interp, "argv", args, TCL_GLOBAL_ONLY); + ckfree(args); + sprintf(buffer, "%d", argc-1); + Tcl_SetVar(interp, "argc", buffer, TCL_GLOBAL_ONLY); + Tcl_SetVar(interp, "argv0", (fileName != NULL) ? fileName : argv[0], + TCL_GLOBAL_ONLY); + + /* + * Set the "tcl_interactive" variable. + */ + + tty = isatty(0); + Tcl_SetVar(interp, "tcl_interactive", + ((fileName == NULL) && tty) ? "1" : "0", TCL_GLOBAL_ONLY); + + /* + * Invoke application-specific initialization. + */ + + if ((*appInitProc)(interp) != TCL_OK) { + errChannel = Tcl_GetStdChannel(TCL_STDERR); + if (errChannel) { + Tcl_Write(errChannel, + "application-specific initialization failed: ", -1); + Tcl_Write(errChannel, interp->result, -1); + Tcl_Write(errChannel, "\n", 1); + } + } + + /* + * If a script file was specified then just source that file + * and quit. + */ + + if (fileName != NULL) { + code = Tcl_EvalFile(interp, fileName); + if (code != TCL_OK) { + errChannel = Tcl_GetStdChannel(TCL_STDERR); + if (errChannel) { + /* + * The following statement guarantees that the errorInfo + * variable is set properly. + */ + + Tcl_AddErrorInfo(interp, ""); + Tcl_Write(errChannel, + Tcl_GetVar(interp, "errorInfo", TCL_GLOBAL_ONLY), -1); + Tcl_Write(errChannel, "\n", 1); + } + exitCode = 1; + } + goto done; + } + + /* + * We're running interactively. Source a user-specific startup + * file if the application specified one and if the file exists. + */ + + fileName = Tcl_GetVar(interp, "tcl_rcFileName", TCL_GLOBAL_ONLY); + + if (fileName != NULL) { + Tcl_Channel c; + char *fullName; + + Tcl_DStringInit(&temp); + fullName = Tcl_TranslateFileName(interp, fileName, &temp); + if (fullName == NULL) { + errChannel = Tcl_GetStdChannel(TCL_STDERR); + if (errChannel) { + Tcl_Write(errChannel, interp->result, -1); + Tcl_Write(errChannel, "\n", 1); + } + } else { + + /* + * Test for the existence of the rc file before trying to read it. + */ + + c = Tcl_OpenFileChannel(NULL, fullName, "r", 0); + if (c != (Tcl_Channel) NULL) { + Tcl_Close(NULL, c); + if (Tcl_EvalFile(interp, fullName) != TCL_OK) { + errChannel = Tcl_GetStdChannel(TCL_STDERR); + if (errChannel) { + Tcl_Write(errChannel, interp->result, -1); + Tcl_Write(errChannel, "\n", 1); + } + } + } + } + Tcl_DStringFree(&temp); + } + + /* + * Process commands from stdin until there's an end-of-file. Note + * that we need to fetch the standard channels again after every + * eval, since they may have been changed. + */ + + gotPartial = 0; + Tcl_DStringInit(&command); + inChannel = Tcl_GetStdChannel(TCL_STDIN); + outChannel = Tcl_GetStdChannel(TCL_STDOUT); + while (1) { + if (tty) { + char *promptCmd; + + promptCmd = Tcl_GetVar(interp, + gotPartial ? "tcl_prompt2" : "tcl_prompt1", TCL_GLOBAL_ONLY); + if (promptCmd == NULL) { +defaultPrompt: + if (!gotPartial && outChannel) { + Tcl_Write(outChannel, "% ", 2); + } + } else { + code = Tcl_Eval(interp, promptCmd); + inChannel = Tcl_GetStdChannel(TCL_STDIN); + outChannel = Tcl_GetStdChannel(TCL_STDOUT); + errChannel = Tcl_GetStdChannel(TCL_STDERR); + if (code != TCL_OK) { + if (errChannel) { + Tcl_Write(errChannel, interp->result, -1); + Tcl_Write(errChannel, "\n", 1); + } + Tcl_AddErrorInfo(interp, + "\n (script that generates prompt)"); + goto defaultPrompt; + } + } + if (outChannel) { + Tcl_Flush(outChannel); + } + } + if (!inChannel) { + goto done; + } + length = Tcl_Gets(inChannel, &command); + if (length < 0) { + goto done; + } + if ((length == 0) && Tcl_Eof(inChannel) && (!gotPartial)) { + goto done; + } + + /* + * Add the newline removed by Tcl_Gets back to the string. + */ + + (void) Tcl_DStringAppend(&command, "\n", -1); + + cmd = Tcl_DStringValue(&command); + if (!Tcl_CommandComplete(cmd)) { + gotPartial = 1; + continue; + } + + gotPartial = 0; + code = Tcl_RecordAndEval(interp, cmd, 0); + inChannel = Tcl_GetStdChannel(TCL_STDIN); + outChannel = Tcl_GetStdChannel(TCL_STDOUT); + errChannel = Tcl_GetStdChannel(TCL_STDERR); + Tcl_DStringFree(&command); + if (code != TCL_OK) { + if (errChannel) { + Tcl_Write(errChannel, interp->result, -1); + Tcl_Write(errChannel, "\n", 1); + } + } else if (tty && (*interp->result != 0)) { + if (outChannel) { + Tcl_Write(outChannel, interp->result, -1); + Tcl_Write(outChannel, "\n", 1); + } + } +#ifdef TCL_MEM_DEBUG + if (quitFlag) { + Tcl_DeleteInterp(interp); + Tcl_Exit(0); + } +#endif + } + + /* + * 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: + sprintf(buffer, "exit %d", exitCode); + Tcl_Eval(interp, buffer); +} + +/* + *---------------------------------------------------------------------- + * + * 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 diff --git a/contrib/tcl/generic/tclNotify.c b/contrib/tcl/generic/tclNotify.c new file mode 100644 index 0000000..0745591 --- /dev/null +++ b/contrib/tcl/generic/tclNotify.c @@ -0,0 +1,578 @@ +/* + * tclNotify.c -- + * + * This file provides the parts of the Tcl event notifier that are + * the same on all platforms, plus a few other parts that are used + * on more than one platform but not all. + * + * The notifier is the lowest-level part of the event system. It + * manages an event queue that holds Tcl_Event structures and a list + * of event sources that can add events to the queue. It also + * contains the procedure Tcl_DoOneEvent that invokes the event + * sources and blocks to wait for new events, but Tcl_DoOneEvent + * is in the platform-specific part of the notifier (in files like + * tclUnixNotify.c). + * + * 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: @(#) tclNotify.c 1.6 96/02/29 09:20:10 + */ + +#include "tclInt.h" +#include "tclPort.h" + +/* + * The following variable records the address of the first event + * source in the list of all event sources for the application. + * This variable is accessed by the notifier to traverse the list + * and invoke each event source. + */ + +TclEventSource *tclFirstEventSourcePtr = NULL; + +/* + * The following variables indicate how long to block in the event + * notifier the next time it blocks (default: block forever). + */ + +static int blockTimeSet = 0; /* 0 means there is no maximum block + * time: block forever. */ +static Tcl_Time blockTime; /* If blockTimeSet is 1, gives the + * maximum elapsed time for the next block. */ + +/* + * The following variables keep track of the event queue. In addition + * to the first (next to be serviced) and last events in the queue, + * we keep track of a "marker" event. This provides a simple priority + * mechanism whereby events can be inserted at the front of the queue + * but behind all other high-priority events already in the queue (this + * is used for things like a sequence of Enter and Leave events generated + * during a grab in Tk). + */ + +static Tcl_Event *firstEventPtr = NULL; + /* First pending event, or NULL if none. */ +static Tcl_Event *lastEventPtr = NULL; + /* Last pending event, or NULL if none. */ +static Tcl_Event *markerEventPtr = NULL; + /* Last high-priority event in queue, or + * NULL if none. */ + +/* + * Prototypes for procedures used only in this file: + */ + +static int ServiceEvent _ANSI_ARGS_((int flags)); + +/* + *---------------------------------------------------------------------- + * + * Tcl_CreateEventSource -- + * + * This procedure is invoked to create a new source of events. + * The source is identified by a procedure that gets invoked + * during Tcl_DoOneEvent to check for events on that source + * and queue them. + * + * + * Results: + * None. + * + * Side effects: + * SetupProc and checkProc will be invoked each time that Tcl_DoOneEvent + * runs out of things to do. SetupProc will be invoked before + * Tcl_DoOneEvent calls select or whatever else it uses to wait + * for events. SetupProc typically calls functions like Tcl_WatchFile + * or Tcl_SetMaxBlockTime to indicate what to wait for. + * + * CheckProc is called after select or whatever operation was actually + * used to wait. It figures out whether anything interesting actually + * happened (e.g. by calling Tcl_FileReady), and then calls + * Tcl_QueueEvent to queue any events that are ready. + * + * Each of these procedures is passed two arguments, e.g. + * (*checkProc)(ClientData clientData, int flags)); + * ClientData is the same as the clientData argument here, and flags + * is a combination of things like TCL_FILE_EVENTS that indicates + * what events are of interest: setupProc and checkProc use flags + * to figure out whether their events are relevant or not. + * + *---------------------------------------------------------------------- + */ + +void +Tcl_CreateEventSource(setupProc, checkProc, clientData) + Tcl_EventSetupProc *setupProc; /* Procedure to invoke to figure out + * what to wait for. */ + Tcl_EventCheckProc *checkProc; /* Procedure to call after waiting + * to see what happened. */ + ClientData clientData; /* One-word argument to pass to + * setupProc and checkProc. */ +{ + TclEventSource *sourcePtr; + + sourcePtr = (TclEventSource *) ckalloc(sizeof(TclEventSource)); + sourcePtr->setupProc = setupProc; + sourcePtr->checkProc = checkProc; + sourcePtr->clientData = clientData; + sourcePtr->nextPtr = tclFirstEventSourcePtr; + tclFirstEventSourcePtr = sourcePtr; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_DeleteEventSource -- + * + * This procedure is invoked to delete the source of events + * given by proc and clientData. + * + * Results: + * None. + * + * Side effects: + * The given event source is cancelled, so its procedure will + * never again be called. If no such source exists, nothing + * happens. + * + *---------------------------------------------------------------------- + */ + +void +Tcl_DeleteEventSource(setupProc, checkProc, clientData) + Tcl_EventSetupProc *setupProc; /* Procedure to invoke to figure out + * what to wait for. */ + Tcl_EventCheckProc *checkProc; /* Procedure to call after waiting + * to see what happened. */ + ClientData clientData; /* One-word argument to pass to + * setupProc and checkProc. */ +{ + TclEventSource *sourcePtr, *prevPtr; + + for (sourcePtr = tclFirstEventSourcePtr, prevPtr = NULL; + sourcePtr != NULL; + prevPtr = sourcePtr, sourcePtr = sourcePtr->nextPtr) { + if ((sourcePtr->setupProc != setupProc) + || (sourcePtr->checkProc != checkProc) + || (sourcePtr->clientData != clientData)) { + continue; + } + if (prevPtr == NULL) { + tclFirstEventSourcePtr = sourcePtr->nextPtr; + } else { + prevPtr->nextPtr = sourcePtr->nextPtr; + } + ckfree((char *) sourcePtr); + return; + } +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_QueueEvent -- + * + * Insert an event into the Tk event queue at one of three + * positions: the head, the tail, or before a floating marker. + * Events inserted before the marker will be processed in + * first-in-first-out order, but before any events inserted at + * the tail of the queue. Events inserted at the head of the + * queue will be processed in last-in-first-out order. + * + * Results: + * None. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +void +Tcl_QueueEvent(evPtr, position) + Tcl_Event* evPtr; /* Event to add to queue. The storage + * space must have been allocated the caller + * with malloc (ckalloc), and it becomes + * the property of the event queue. It + * will be freed after the event has been + * handled. */ + Tcl_QueuePosition position; /* One of TCL_QUEUE_TAIL, TCL_QUEUE_HEAD, + * TCL_QUEUE_MARK. */ +{ + if (position == TCL_QUEUE_TAIL) { + /* + * Append the event on the end of the queue. + */ + + evPtr->nextPtr = NULL; + if (firstEventPtr == NULL) { + firstEventPtr = evPtr; + } else { + lastEventPtr->nextPtr = evPtr; + } + lastEventPtr = evPtr; + } else if (position == TCL_QUEUE_HEAD) { + /* + * Push the event on the head of the queue. + */ + + evPtr->nextPtr = firstEventPtr; + if (firstEventPtr == NULL) { + lastEventPtr = evPtr; + } + firstEventPtr = evPtr; + } else if (position == TCL_QUEUE_MARK) { + /* + * Insert the event after the current marker event and advance + * the marker to the new event. + */ + + if (markerEventPtr == NULL) { + evPtr->nextPtr = firstEventPtr; + firstEventPtr = evPtr; + } else { + evPtr->nextPtr = markerEventPtr->nextPtr; + markerEventPtr->nextPtr = evPtr; + } + markerEventPtr = evPtr; + if (evPtr->nextPtr == NULL) { + lastEventPtr = evPtr; + } + } +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_DeleteEvents -- + * + * Calls a procedure for each event in the queue and deletes those + * for which the procedure returns 1. Events for which the + * procedure returns 0 are left in the queue. + * + * Results: + * None. + * + * Side effects: + * Potentially removes one or more events from the event queue. + * + *---------------------------------------------------------------------- + */ + +void +Tcl_DeleteEvents(proc, clientData) + Tcl_EventDeleteProc *proc; /* The procedure to call. */ + ClientData clientData; /* type-specific data. */ +{ + Tcl_Event *evPtr, *prevPtr, *hold; + + for (prevPtr = (Tcl_Event *) NULL, evPtr = firstEventPtr; + evPtr != (Tcl_Event *) NULL; + ) { + if ((*proc) (evPtr, clientData) == 1) { + if (firstEventPtr == evPtr) { + firstEventPtr = evPtr->nextPtr; + if (evPtr->nextPtr == (Tcl_Event *) NULL) { + lastEventPtr = (Tcl_Event *) NULL; + } + } else { + prevPtr->nextPtr = evPtr->nextPtr; + } + hold = evPtr; + evPtr = evPtr->nextPtr; + ckfree((char *) hold); + } else { + prevPtr = evPtr; + evPtr = evPtr->nextPtr; + } + } +} + +/* + *---------------------------------------------------------------------- + * + * ServiceEvent -- + * + * Process one event from the event queue. This routine is called + * by the notifier whenever it wants Tk to process an event. + * + * Results: + * The return value is 1 if the procedure actually found an event + * to process. If no processing occurred, then 0 is returned. + * + * Side effects: + * Invokes all of the event handlers for the highest priority + * event in the event queue. May collapse some events into a + * single event or discard stale events. + * + *---------------------------------------------------------------------- + */ + +static int +ServiceEvent(flags) + int flags; /* Indicates what events should be processed. + * May be any combination of TCL_WINDOW_EVENTS + * TCL_FILE_EVENTS, TCL_TIMER_EVENTS, or other + * flags defined elsewhere. Events not + * matching this will be skipped for processing + * later. */ +{ + Tcl_Event *evPtr, *prevPtr; + Tcl_EventProc *proc; + + /* + * No event flags is equivalent to TCL_ALL_EVENTS. + */ + + if ((flags & TCL_ALL_EVENTS) == 0) { + flags |= TCL_ALL_EVENTS; + } + + /* + * Loop through all the events in the queue until we find one + * that can actually be handled. + */ + + for (evPtr = firstEventPtr; evPtr != NULL; evPtr = evPtr->nextPtr) { + /* + * Call the handler for the event. If it actually handles the + * event then free the storage for the event. There are two + * tricky things here, but stemming from the fact that the event + * code may be re-entered while servicing the event: + * + * 1. Set the "proc" field to NULL. This is a signal to ourselves + * that we shouldn't reexecute the handler if the event loop + * is re-entered. + * 2. When freeing the event, must search the queue again from the + * front to find it. This is because the event queue could + * change almost arbitrarily while handling the event, so we + * can't depend on pointers found now still being valid when + * the handler returns. + */ + + proc = evPtr->proc; + evPtr->proc = NULL; + if ((proc != NULL) && (*proc)(evPtr, flags)) { + if (firstEventPtr == evPtr) { + firstEventPtr = evPtr->nextPtr; + if (evPtr->nextPtr == NULL) { + lastEventPtr = NULL; + } + } else { + for (prevPtr = firstEventPtr; prevPtr->nextPtr != evPtr; + prevPtr = prevPtr->nextPtr) { + /* Empty loop body. */ + } + prevPtr->nextPtr = evPtr->nextPtr; + if (evPtr->nextPtr == NULL) { + lastEventPtr = prevPtr; + } + } + if (markerEventPtr == evPtr) { + markerEventPtr = NULL; + } + ckfree((char *) evPtr); + return 1; + } else { + /* + * The event wasn't actually handled, so we have to restore + * the proc field to allow the event to be attempted again. + */ + + evPtr->proc = proc; + } + + /* + * The handler for this event asked to defer it. Just go on to + * the next event. + */ + + continue; + } + return 0; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_SetMaxBlockTime -- + * + * This procedure is invoked by event sources to tell the notifier + * how long it may block the next time it blocks. The timePtr + * argument gives a maximum time; the actual time may be less if + * some other event source requested a smaller time. + * + * Results: + * None. + * + * Side effects: + * May reduce the length of the next sleep in the notifier. + * + *---------------------------------------------------------------------- + */ + +void +Tcl_SetMaxBlockTime(timePtr) + Tcl_Time *timePtr; /* Specifies a maximum elapsed time for + * the next blocking operation in the + * event notifier. */ +{ + if (!blockTimeSet || (timePtr->sec < blockTime.sec) + || ((timePtr->sec == blockTime.sec) + && (timePtr->usec < blockTime.usec))) { + blockTime = *timePtr; + blockTimeSet = 1; + } +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_DoOneEvent -- + * + * Process a single event of some sort. If there's no work to + * do, wait for an event to occur, then process it. + * + * Results: + * The return value is 1 if the procedure actually found an event + * to process. If no processing occurred, then 0 is returned (this + * can happen if the TCL_DONT_WAIT flag is set or if there are no + * event handlers to wait for in the set specified by flags). + * + * Side effects: + * May delay execution of process while waiting for an event, + * unless TCL_DONT_WAIT is set in the flags argument. Event + * sources are invoked to check for and queue events. Event + * handlers may produce arbitrary side effects. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_DoOneEvent(flags) + int flags; /* Miscellaneous flag values: may be any + * combination of TCL_DONT_WAIT, + * TCL_WINDOW_EVENTS, TCL_FILE_EVENTS, + * TCL_TIMER_EVENTS, TCL_IDLE_EVENTS, or + * others defined by event sources. */ +{ + TclEventSource *sourcePtr; + Tcl_Time *timePtr; + + /* + * No event flags is equivalent to TCL_ALL_EVENTS. + */ + + if ((flags & TCL_ALL_EVENTS) == 0) { + flags |= TCL_ALL_EVENTS; + } + + /* + * The core of this procedure is an infinite loop, even though + * we only service one event. The reason for this is that we + * might think we have an event ready (e.g. the connection to + * the server becomes readable), but then we might discover that + * there's nothing interesting on that connection, so no event + * was serviced. Or, the select operation could return prematurely + * due to a signal. The easiest thing in both these cases is + * just to loop back and try again. + */ + + while (1) { + + /* + * The first thing we do is to service any asynchronous event + * handlers. + */ + + if (Tcl_AsyncReady()) { + (void) Tcl_AsyncInvoke((Tcl_Interp *) NULL, 0); + return 1; + } + + /* + * If idle events are the only things to service, skip the + * main part of the loop and go directly to handle idle + * events (i.e. don't wait even if TCL_DONT_WAIT isn't set. + */ + + if (flags == TCL_IDLE_EVENTS) { + flags = TCL_IDLE_EVENTS|TCL_DONT_WAIT; + goto idleEvents; + } + + /* + * Ask Tk to service a queued event, if there are any. + */ + + if (ServiceEvent(flags)) { + return 1; + } + + /* + * There are no events already queued. Invoke all of the + * event sources to give them a chance to setup for the wait. + */ + + blockTimeSet = 0; + for (sourcePtr = tclFirstEventSourcePtr; sourcePtr != NULL; + sourcePtr = sourcePtr->nextPtr) { + (*sourcePtr->setupProc)(sourcePtr->clientData, flags); + } + if ((flags & TCL_DONT_WAIT) || + ((flags & TCL_IDLE_EVENTS) && TclIdlePending())) { + /* + * Don't block: there are idle events waiting, or we don't + * care about idle events anyway, or the caller asked us not + * to block. + */ + + blockTime.sec = 0; + blockTime.usec = 0; + timePtr = &blockTime; + } else if (blockTimeSet) { + timePtr = &blockTime; + } else { + timePtr = NULL; + } + + /* + * Wait until an event occurs or the timer expires. + */ + + if (Tcl_WaitForEvent(timePtr) == TCL_ERROR) { + return 0; + } + + /* + * Give each of the event sources a chance to queue events, + * then call ServiceEvent and give it another chance to + * service events. + */ + + for (sourcePtr = tclFirstEventSourcePtr; sourcePtr != NULL; + sourcePtr = sourcePtr->nextPtr) { + (*sourcePtr->checkProc)(sourcePtr->clientData, flags); + } + if (ServiceEvent(flags)) { + return 1; + } + + /* + * We've tried everything at this point, but nobody had anything + * to do. Check for idle events. If none, either quit or go back + * to the top and try again. + */ + + idleEvents: + if ((flags & TCL_IDLE_EVENTS) && TclServiceIdle()) { + return 1; + } + if (flags & TCL_DONT_WAIT) { + return 0; + } + } +} diff --git a/contrib/tcl/generic/tclParse.c b/contrib/tcl/generic/tclParse.c new file mode 100644 index 0000000..656e218 --- /dev/null +++ b/contrib/tcl/generic/tclParse.c @@ -0,0 +1,1386 @@ +/* + * tclParse.c -- + * + * This file contains a collection of procedures that are used + * to parse Tcl commands or parts of commands (like quoted + * strings or nested sub-commands). + * + * Copyright (c) 1987-1993 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: @(#) tclParse.c 1.50 96/03/02 14:46:55 + */ + +#include "tclInt.h" +#include "tclPort.h" + +/* + * The following table assigns a type to each character. Only types + * meaningful to Tcl parsing are represented here. The table is + * designed to be referenced with either signed or unsigned characters, + * so it has 384 entries. The first 128 entries correspond to negative + * character values, the next 256 correspond to positive character + * values. The last 128 entries are identical to the first 128. The + * table is always indexed with a 128-byte offset (the 128th entry + * corresponds to a 0 character value). + */ + +char tclTypeTable[] = { + /* + * Negative character values, from -128 to -1: + */ + + TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, + TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, + TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, + TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, + TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, + TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, + TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, + TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, + TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, + TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, + TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, + TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, + TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, + TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, + TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, + TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, + TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, + TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, + TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, + TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, + TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, + TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, + TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, + TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, + TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, + TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, + TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, + TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, + TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, + TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, + TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, + TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, + + /* + * Positive character values, from 0-127: + */ + + TCL_COMMAND_END, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, + TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, + TCL_NORMAL, TCL_SPACE, TCL_COMMAND_END, TCL_SPACE, + TCL_SPACE, TCL_SPACE, TCL_NORMAL, TCL_NORMAL, + TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, + TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, + TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, + TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, + TCL_SPACE, TCL_NORMAL, TCL_QUOTE, TCL_NORMAL, + TCL_DOLLAR, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, + TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, + TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, + TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, + TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, + TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_COMMAND_END, + TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, + TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, + TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, + TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, + TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, + TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, + TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, + TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_OPEN_BRACKET, + TCL_BACKSLASH, TCL_COMMAND_END, TCL_NORMAL, TCL_NORMAL, + TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, + TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, + TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, + TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, + TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, + TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, + TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_OPEN_BRACE, + TCL_NORMAL, TCL_CLOSE_BRACE, TCL_NORMAL, TCL_NORMAL, + + /* + * Large unsigned character values, from 128-255: + */ + + TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, + TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, + TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, + TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, + TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, + TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, + TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, + TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, + TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, + TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, + TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, + TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, + TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, + TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, + TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, + TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, + TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, + TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, + TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, + TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, + TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, + TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, + TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, + TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, + TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, + TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, + TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, + TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, + TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, + TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, + TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, + TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, +}; + +/* + * Function prototypes for procedures local to this file: + */ + +static char * QuoteEnd _ANSI_ARGS_((char *string, int term)); +static char * ScriptEnd _ANSI_ARGS_((char *p, int nested)); +static char * VarNameEnd _ANSI_ARGS_((char *string)); + +/* + *---------------------------------------------------------------------- + * + * Tcl_Backslash -- + * + * Figure out how to handle a backslash sequence. + * + * Results: + * The return value is the character that should be substituted + * in place of the backslash sequence that starts at src. If + * readPtr isn't NULL then it is filled in with a count of the + * number of characters in the backslash sequence. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +char +Tcl_Backslash(src, readPtr) + char *src; /* Points to the backslash character of + * a backslash sequence. */ + int *readPtr; /* Fill in with number of characters read + * from src, unless NULL. */ +{ + register char *p = src+1; + char result; + int count; + + count = 2; + + switch (*p) { + case 'a': + result = 0x7; /* Don't say '\a' here, since some compilers */ + break; /* don't support it. */ + case 'b': + result = '\b'; + break; + case 'f': + result = '\f'; + break; + case 'n': + result = '\n'; + break; + case 'r': + result = '\r'; + break; + case 't': + result = '\t'; + break; + case 'v': + result = '\v'; + break; + case 'x': + if (isxdigit(UCHAR(p[1]))) { + char *end; + + result = (char) strtoul(p+1, &end, 16); + count = end - src; + } else { + count = 2; + result = 'x'; + } + break; + case '\n': + do { + p++; + } while ((*p == ' ') || (*p == '\t')); + result = ' '; + count = p - src; + break; + case 0: + result = '\\'; + count = 1; + break; + default: + if (isdigit(UCHAR(*p))) { + result = (char)(*p - '0'); + p++; + if (!isdigit(UCHAR(*p))) { + break; + } + count = 3; + result = (char)((result << 3) + (*p - '0')); + p++; + if (!isdigit(UCHAR(*p))) { + break; + } + count = 4; + result = (char)((result << 3) + (*p - '0')); + break; + } + result = *p; + count = 2; + break; + } + + if (readPtr != NULL) { + *readPtr = count; + } + return result; +} + +/* + *-------------------------------------------------------------- + * + * TclParseQuotes -- + * + * This procedure parses a double-quoted string such as a + * quoted Tcl command argument or a quoted value in a Tcl + * expression. This procedure is also used to parse array + * element names within parentheses, or anything else that + * needs all the substitutions that happen in quotes. + * + * Results: + * The return value is a standard Tcl result, which is + * TCL_OK unless there was an error while parsing the + * quoted string. If an error occurs then interp->result + * contains a standard error message. *TermPtr is filled + * in with the address of the character just after the + * last one successfully processed; this is usually the + * character just after the matching close-quote. The + * fully-substituted contents of the quotes are stored in + * standard fashion in *pvPtr, null-terminated with + * pvPtr->next pointing to the terminating null character. + * + * Side effects: + * The buffer space in pvPtr may be enlarged by calling its + * expandProc. + * + *-------------------------------------------------------------- + */ + +int +TclParseQuotes(interp, string, termChar, flags, termPtr, pvPtr) + Tcl_Interp *interp; /* Interpreter to use for nested command + * evaluations and error messages. */ + char *string; /* Character just after opening double- + * quote. */ + int termChar; /* Character that terminates "quoted" string + * (usually double-quote, but sometimes + * right-paren or something else). */ + int flags; /* Flags to pass to nested Tcl_Eval calls. */ + char **termPtr; /* Store address of terminating character + * here. */ + ParseValue *pvPtr; /* Information about where to place + * fully-substituted result of parse. */ +{ + register char *src, *dst, c; + + src = string; + dst = pvPtr->next; + + while (1) { + if (dst == pvPtr->end) { + /* + * Target buffer space is about to run out. Make more space. + */ + + pvPtr->next = dst; + (*pvPtr->expandProc)(pvPtr, 1); + dst = pvPtr->next; + } + + c = *src; + src++; + if (c == termChar) { + *dst = '\0'; + pvPtr->next = dst; + *termPtr = src; + return TCL_OK; + } else if (CHAR_TYPE(c) == TCL_NORMAL) { + copy: + *dst = c; + dst++; + continue; + } else if (c == '$') { + int length; + char *value; + + value = Tcl_ParseVar(interp, src-1, termPtr); + if (value == NULL) { + return TCL_ERROR; + } + src = *termPtr; + length = strlen(value); + if ((pvPtr->end - dst) <= length) { + pvPtr->next = dst; + (*pvPtr->expandProc)(pvPtr, length); + dst = pvPtr->next; + } + strcpy(dst, value); + dst += length; + continue; + } else if (c == '[') { + int result; + + pvPtr->next = dst; + result = TclParseNestedCmd(interp, src, flags, termPtr, pvPtr); + if (result != TCL_OK) { + return result; + } + src = *termPtr; + dst = pvPtr->next; + continue; + } else if (c == '\\') { + int numRead; + + src--; + *dst = Tcl_Backslash(src, &numRead); + dst++; + src += numRead; + continue; + } else if (c == '\0') { + Tcl_ResetResult(interp); + sprintf(interp->result, "missing %c", termChar); + *termPtr = string-1; + return TCL_ERROR; + } else { + goto copy; + } + } +} + +/* + *-------------------------------------------------------------- + * + * TclParseNestedCmd -- + * + * This procedure parses a nested Tcl command between + * brackets, returning the result of the command. + * + * Results: + * The return value is a standard Tcl result, which is + * TCL_OK unless there was an error while executing the + * nested command. If an error occurs then interp->result + * contains a standard error message. *TermPtr is filled + * in with the address of the character just after the + * last one processed; this is usually the character just + * after the matching close-bracket, or the null character + * at the end of the string if the close-bracket was missing + * (a missing close bracket is an error). The result returned + * by the command is stored in standard fashion in *pvPtr, + * null-terminated, with pvPtr->next pointing to the null + * character. + * + * Side effects: + * The storage space at *pvPtr may be expanded. + * + *-------------------------------------------------------------- + */ + +int +TclParseNestedCmd(interp, string, flags, termPtr, pvPtr) + Tcl_Interp *interp; /* Interpreter to use for nested command + * evaluations and error messages. */ + char *string; /* Character just after opening bracket. */ + int flags; /* Flags to pass to nested Tcl_Eval. */ + char **termPtr; /* Store address of terminating character + * here. */ + register ParseValue *pvPtr; /* Information about where to place + * result of command. */ +{ + int result, length, shortfall; + Interp *iPtr = (Interp *) interp; + + iPtr->evalFlags = flags | TCL_BRACKET_TERM; + result = Tcl_Eval(interp, string); + *termPtr = iPtr->termPtr; + if (result != TCL_OK) { + /* + * The increment below results in slightly cleaner message in + * the errorInfo variable (the close-bracket will appear). + */ + + if (**termPtr == ']') { + *termPtr += 1; + } + return result; + } + (*termPtr) += 1; + length = strlen(iPtr->result); + shortfall = length + 1 - (pvPtr->end - pvPtr->next); + if (shortfall > 0) { + (*pvPtr->expandProc)(pvPtr, shortfall); + } + strcpy(pvPtr->next, iPtr->result); + pvPtr->next += length; + Tcl_FreeResult(iPtr); + iPtr->result = iPtr->resultSpace; + iPtr->resultSpace[0] = '\0'; + return TCL_OK; +} + +/* + *-------------------------------------------------------------- + * + * TclParseBraces -- + * + * This procedure scans the information between matching + * curly braces. + * + * Results: + * The return value is a standard Tcl result, which is + * TCL_OK unless there was an error while parsing string. + * If an error occurs then interp->result contains a + * standard error message. *TermPtr is filled + * in with the address of the character just after the + * last one successfully processed; this is usually the + * character just after the matching close-brace. The + * information between curly braces is stored in standard + * fashion in *pvPtr, null-terminated with pvPtr->next + * pointing to the terminating null character. + * + * Side effects: + * The storage space at *pvPtr may be expanded. + * + *-------------------------------------------------------------- + */ + +int +TclParseBraces(interp, string, termPtr, pvPtr) + Tcl_Interp *interp; /* Interpreter to use for nested command + * evaluations and error messages. */ + char *string; /* Character just after opening bracket. */ + char **termPtr; /* Store address of terminating character + * here. */ + register ParseValue *pvPtr; /* Information about where to place + * result of command. */ +{ + int level; + register char *src, *dst, *end; + register char c; + + src = string; + dst = pvPtr->next; + end = pvPtr->end; + level = 1; + + /* + * Copy the characters one at a time to the result area, stopping + * when the matching close-brace is found. + */ + + while (1) { + c = *src; + src++; + if (dst == end) { + pvPtr->next = dst; + (*pvPtr->expandProc)(pvPtr, 20); + dst = pvPtr->next; + end = pvPtr->end; + } + *dst = c; + dst++; + if (CHAR_TYPE(c) == TCL_NORMAL) { + continue; + } else if (c == '{') { + level++; + } else if (c == '}') { + level--; + if (level == 0) { + dst--; /* Don't copy the last close brace. */ + break; + } + } else if (c == '\\') { + int count; + + /* + * Must always squish out backslash-newlines, even when in + * braces. This is needed so that this sequence can appear + * anywhere in a command, such as the middle of an expression. + */ + + if (*src == '\n') { + dst[-1] = Tcl_Backslash(src-1, &count); + src += count - 1; + } else { + (void) Tcl_Backslash(src-1, &count); + while (count > 1) { + if (dst == end) { + pvPtr->next = dst; + (*pvPtr->expandProc)(pvPtr, 20); + dst = pvPtr->next; + end = pvPtr->end; + } + *dst = *src; + dst++; + src++; + count--; + } + } + } else if (c == '\0') { + Tcl_SetResult(interp, "missing close-brace", TCL_STATIC); + *termPtr = string-1; + return TCL_ERROR; + } + } + + *dst = '\0'; + pvPtr->next = dst; + *termPtr = src; + return TCL_OK; +} + +/* + *-------------------------------------------------------------- + * + * TclParseWords -- + * + * This procedure parses one or more words from a command + * string and creates argv-style pointers to fully-substituted + * copies of those words. + * + * Results: + * The return value is a standard Tcl result. + * + * *argcPtr is modified to hold a count of the number of words + * successfully parsed, which may be 0. At most maxWords words + * will be parsed. If 0 <= *argcPtr < maxWords then it + * means that a command separator was seen. If *argcPtr + * is maxWords then it means that a command separator was + * not seen yet. + * + * *TermPtr is filled in with the address of the character + * just after the last one successfully processed in the + * last word. This is either the command terminator (if + * *argcPtr < maxWords), the character just after the last + * one in a word (if *argcPtr is maxWords), or the vicinity + * of an error (if the result is not TCL_OK). + * + * The pointers at *argv are filled in with pointers to the + * fully-substituted words, and the actual contents of the + * words are copied to the buffer at pvPtr. + * + * If an error occurrs then an error message is left in + * interp->result and the information at *argv, *argcPtr, + * and *pvPtr may be incomplete. + * + * Side effects: + * The buffer space in pvPtr may be enlarged by calling its + * expandProc. + * + *-------------------------------------------------------------- + */ + +int +TclParseWords(interp, string, flags, maxWords, termPtr, argcPtr, argv, pvPtr) + Tcl_Interp *interp; /* Interpreter to use for nested command + * evaluations and error messages. */ + char *string; /* First character of word. */ + int flags; /* Flags to control parsing (same values as + * passed to Tcl_Eval). */ + int maxWords; /* Maximum number of words to parse. */ + char **termPtr; /* Store address of terminating character + * here. */ + int *argcPtr; /* Filled in with actual number of words + * parsed. */ + char **argv; /* Store addresses of individual words here. */ + register ParseValue *pvPtr; /* Information about where to place + * fully-substituted word. */ +{ + register char *src, *dst; + register char c; + int type, result, argc; + char *oldBuffer; /* Used to detect when pvPtr's buffer gets + * reallocated, so we can adjust all of the + * argv pointers. */ + + src = string; + oldBuffer = pvPtr->buffer; + dst = pvPtr->next; + for (argc = 0; argc < maxWords; argc++) { + argv[argc] = dst; + + /* + * Skip leading space. + */ + + skipSpace: + c = *src; + type = CHAR_TYPE(c); + while (type == TCL_SPACE) { + src++; + c = *src; + type = CHAR_TYPE(c); + } + + /* + * Handle the normal case (i.e. no leading double-quote or brace). + */ + + if (type == TCL_NORMAL) { + normalArg: + while (1) { + if (dst == pvPtr->end) { + /* + * Target buffer space is about to run out. Make + * more space. + */ + + pvPtr->next = dst; + (*pvPtr->expandProc)(pvPtr, 1); + dst = pvPtr->next; + } + + if (type == TCL_NORMAL) { + copy: + *dst = c; + dst++; + src++; + } else if (type == TCL_SPACE) { + goto wordEnd; + } else if (type == TCL_DOLLAR) { + int length; + char *value; + + value = Tcl_ParseVar(interp, src, termPtr); + if (value == NULL) { + return TCL_ERROR; + } + src = *termPtr; + length = strlen(value); + if ((pvPtr->end - dst) <= length) { + pvPtr->next = dst; + (*pvPtr->expandProc)(pvPtr, length); + dst = pvPtr->next; + } + strcpy(dst, value); + dst += length; + } else if (type == TCL_COMMAND_END) { + if ((c == ']') && !(flags & TCL_BRACKET_TERM)) { + goto copy; + } + + /* + * End of command; simulate a word-end first, so + * that the end-of-command can be processed as the + * first thing in a new word. + */ + + goto wordEnd; + } else if (type == TCL_OPEN_BRACKET) { + pvPtr->next = dst; + result = TclParseNestedCmd(interp, src+1, flags, termPtr, + pvPtr); + if (result != TCL_OK) { + return result; + } + src = *termPtr; + dst = pvPtr->next; + } else if (type == TCL_BACKSLASH) { + int numRead; + + *dst = Tcl_Backslash(src, &numRead); + + /* + * The following special check allows a backslash-newline + * to be treated as a word-separator, as if the backslash + * and newline had been collapsed before command parsing + * began. + */ + + if (src[1] == '\n') { + src += numRead; + goto wordEnd; + } + src += numRead; + dst++; + } else { + goto copy; + } + c = *src; + type = CHAR_TYPE(c); + } + } else { + + /* + * Check for the end of the command. + */ + + if (type == TCL_COMMAND_END) { + if (flags & TCL_BRACKET_TERM) { + if (c == '\0') { + Tcl_SetResult(interp, "missing close-bracket", + TCL_STATIC); + return TCL_ERROR; + } + } else { + if (c == ']') { + goto normalArg; + } + } + goto done; + } + + /* + * Now handle the special cases: open braces, double-quotes, + * and backslash-newline. + */ + + pvPtr->next = dst; + if (type == TCL_QUOTE) { + result = TclParseQuotes(interp, src+1, '"', flags, + termPtr, pvPtr); + } else if (type == TCL_OPEN_BRACE) { + result = TclParseBraces(interp, src+1, termPtr, pvPtr); + } else if ((type == TCL_BACKSLASH) && (src[1] == '\n')) { + /* + * This code is needed so that a backslash-newline at the + * very beginning of a word is treated as part of the white + * space between words and not as a space within the word. + */ + + src += 2; + goto skipSpace; + } else { + goto normalArg; + } + if (result != TCL_OK) { + return result; + } + + /* + * Back from quotes or braces; make sure that the terminating + * character was the end of the word. + */ + + c = **termPtr; + if ((c == '\\') && ((*termPtr)[1] == '\n')) { + /* + * Line is continued on next line; the backslash-newline + * sequence turns into space, which is OK. No need to do + * anything here. + */ + } else { + type = CHAR_TYPE(c); + if ((type != TCL_SPACE) && (type != TCL_COMMAND_END)) { + if (*src == '"') { + Tcl_SetResult(interp, + "extra characters after close-quote", + TCL_STATIC); + } else { + Tcl_SetResult(interp, + "extra characters after close-brace", + TCL_STATIC); + } + return TCL_ERROR; + } + } + src = *termPtr; + dst = pvPtr->next; + } + + /* + * We're at the end of a word, so add a null terminator. Then + * see if the buffer was re-allocated during this word. If so, + * update all of the argv pointers. + */ + + wordEnd: + *dst = '\0'; + dst++; + if (oldBuffer != pvPtr->buffer) { + int i; + + for (i = 0; i <= argc; i++) { + argv[i] = pvPtr->buffer + (argv[i] - oldBuffer); + } + oldBuffer = pvPtr->buffer; + } + } + + done: + pvPtr->next = dst; + *termPtr = src; + *argcPtr = argc; + return TCL_OK; +} + +/* + *-------------------------------------------------------------- + * + * TclExpandParseValue -- + * + * This procedure is commonly used as the value of the + * expandProc in a ParseValue. It uses malloc to allocate + * more space for the result of a parse. + * + * Results: + * The buffer space in *pvPtr is reallocated to something + * larger, and if pvPtr->clientData is non-zero the old + * buffer is freed. Information is copied from the old + * buffer to the new one. + * + * Side effects: + * None. + * + *-------------------------------------------------------------- + */ + +void +TclExpandParseValue(pvPtr, needed) + register ParseValue *pvPtr; /* Information about buffer that + * must be expanded. If the clientData + * in the structure is non-zero, it + * means that the current buffer is + * dynamically allocated. */ + int needed; /* Minimum amount of additional space + * to allocate. */ +{ + int newSpace; + char *new; + + /* + * Either double the size of the buffer or add enough new space + * to meet the demand, whichever produces a larger new buffer. + */ + + newSpace = (pvPtr->end - pvPtr->buffer) + 1; + if (newSpace < needed) { + newSpace += needed; + } else { + newSpace += newSpace; + } + new = (char *) ckalloc((unsigned) newSpace); + + /* + * Copy from old buffer to new, free old buffer if needed, and + * mark new buffer as malloc-ed. + */ + + memcpy((VOID *) new, (VOID *) pvPtr->buffer, + (size_t) (pvPtr->next - pvPtr->buffer)); + pvPtr->next = new + (pvPtr->next - pvPtr->buffer); + if (pvPtr->clientData != 0) { + ckfree(pvPtr->buffer); + } + pvPtr->buffer = new; + pvPtr->end = new + newSpace - 1; + pvPtr->clientData = (ClientData) 1; +} + +/* + *---------------------------------------------------------------------- + * + * TclWordEnd -- + * + * Given a pointer into a Tcl command, find the end of the next + * word of the command. + * + * Results: + * The return value is a pointer to the last character that's part + * of the word pointed to by "start". If the word doesn't end + * properly within the string then the return value is the address + * of the null character at the end of the string. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +char * +TclWordEnd(start, nested, semiPtr) + char *start; /* Beginning of a word of a Tcl command. */ + int nested; /* Zero means this is a top-level command. + * One means this is a nested command (close + * bracket is a word terminator). */ + int *semiPtr; /* Set to 1 if word ends with a command- + * terminating semi-colon, zero otherwise. + * If NULL then ignored. */ +{ + register char *p; + int count; + + if (semiPtr != NULL) { + *semiPtr = 0; + } + + /* + * Skip leading white space (backslash-newline must be treated like + * white-space, except that it better not be the last thing in the + * command). + */ + + for (p = start; ; p++) { + if (isspace(UCHAR(*p))) { + continue; + } + if ((p[0] == '\\') && (p[1] == '\n')) { + if (p[2] == 0) { + return p+2; + } + continue; + } + break; + } + + /* + * Handle words beginning with a double-quote or a brace. + */ + + if (*p == '"') { + p = QuoteEnd(p+1, '"'); + if (*p == 0) { + return p; + } + p++; + } else if (*p == '{') { + int braces = 1; + while (braces != 0) { + p++; + while (*p == '\\') { + (void) Tcl_Backslash(p, &count); + p += count; + } + if (*p == '}') { + braces--; + } else if (*p == '{') { + braces++; + } else if (*p == 0) { + return p; + } + } + p++; + } + + /* + * Handle words that don't start with a brace or double-quote. + * This code is also invoked if the word starts with a brace or + * double-quote and there is garbage after the closing brace or + * quote. This is an error as far as Tcl_Eval is concerned, but + * for here the garbage is treated as part of the word. + */ + + while (1) { + if (*p == '[') { + p = ScriptEnd(p+1, 1); + if (*p == 0) { + return p; + } + p++; + } else if (*p == '\\') { + if (p[1] == '\n') { + /* + * Backslash-newline: it maps to a space character + * that is a word separator, so the word ends just before + * the backslash. + */ + + return p-1; + } + (void) Tcl_Backslash(p, &count); + p += count; + } else if (*p == '$') { + p = VarNameEnd(p); + if (*p == 0) { + return p; + } + p++; + } else if (*p == ';') { + /* + * Include the semi-colon in the word that is returned. + */ + + if (semiPtr != NULL) { + *semiPtr = 1; + } + return p; + } else if (isspace(UCHAR(*p))) { + return p-1; + } else if ((*p == ']') && nested) { + return p-1; + } else if (*p == 0) { + if (nested) { + /* + * Nested commands can't end because of the end of the + * string. + */ + return p; + } + return p-1; + } else { + p++; + } + } +} + +/* + *---------------------------------------------------------------------- + * + * QuoteEnd -- + * + * Given a pointer to a string that obeys the parsing conventions + * for quoted things in Tcl, find the end of that quoted thing. + * The actual thing may be a quoted argument or a parenthesized + * index name. + * + * Results: + * The return value is a pointer to the last character that is + * part of the quoted string (i.e the character that's equal to + * term). If the quoted string doesn't terminate properly then + * the return value is a pointer to the null character at the + * end of the string. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static char * +QuoteEnd(string, term) + char *string; /* Pointer to character just after opening + * "quote". */ + int term; /* This character will terminate the + * quoted string (e.g. '"' or ')'). */ +{ + register char *p = string; + int count; + + while (*p != term) { + if (*p == '\\') { + (void) Tcl_Backslash(p, &count); + p += count; + } else if (*p == '[') { + for (p++; *p != ']'; p++) { + p = TclWordEnd(p, 1, (int *) NULL); + if (*p == 0) { + return p; + } + } + p++; + } else if (*p == '$') { + p = VarNameEnd(p); + if (*p == 0) { + return p; + } + p++; + } else if (*p == 0) { + return p; + } else { + p++; + } + } + return p-1; +} + +/* + *---------------------------------------------------------------------- + * + * VarNameEnd -- + * + * Given a pointer to a variable reference using $-notation, find + * the end of the variable name spec. + * + * Results: + * The return value is a pointer to the last character that + * is part of the variable name. If the variable name doesn't + * terminate properly then the return value is a pointer to the + * null character at the end of the string. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static char * +VarNameEnd(string) + char *string; /* Pointer to dollar-sign character. */ +{ + register char *p = string+1; + + if (*p == '{') { + for (p++; (*p != '}') && (*p != 0); p++) { + /* Empty loop body. */ + } + return p; + } + while (isalnum(UCHAR(*p)) || (*p == '_')) { + p++; + } + if ((*p == '(') && (p != string+1)) { + return QuoteEnd(p+1, ')'); + } + return p-1; +} + + +/* + *---------------------------------------------------------------------- + * + * ScriptEnd -- + * + * Given a pointer to the beginning of a Tcl script, find the end of + * the script. + * + * Results: + * The return value is a pointer to the last character that's part + * of the script pointed to by "p". If the command doesn't end + * properly within the string then the return value is the address + * of the null character at the end of the string. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static char * +ScriptEnd(p, nested) + char *p; /* Script to check. */ + int nested; /* Zero means this is a top-level command. + * One means this is a nested command (the + * last character of the script must be + * an unquoted ]). */ +{ + int commentOK = 1; + int length; + + while (1) { + while (isspace(UCHAR(*p))) { + if (*p == '\n') { + commentOK = 1; + } + p++; + } + if ((*p == '#') && commentOK) { + do { + if (*p == '\\') { + /* + * If the script ends with backslash-newline, then + * this command isn't complete. + */ + + if ((p[1] == '\n') && (p[2] == 0)) { + return p+2; + } + Tcl_Backslash(p, &length); + p += length; + } else { + p++; + } + } while ((*p != 0) && (*p != '\n')); + continue; + } + p = TclWordEnd(p, nested, &commentOK); + if (*p == 0) { + return p; + } + p++; + if (nested) { + if (*p == ']') { + return p; + } + } else { + if (*p == 0) { + return p-1; + } + } + } +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_ParseVar -- + * + * Given a string starting with a $ sign, parse off a variable + * name and return its value. + * + * Results: + * The return value is the contents of the variable given by + * the leading characters of string. If termPtr isn't NULL, + * *termPtr gets filled in with the address of the character + * just after the last one in the variable specifier. If the + * variable doesn't exist, then the return value is NULL and + * an error message will be left in interp->result. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +char * +Tcl_ParseVar(interp, string, termPtr) + Tcl_Interp *interp; /* Context for looking up variable. */ + register char *string; /* String containing variable name. + * First character must be "$". */ + char **termPtr; /* If non-NULL, points to word to fill + * in with character just after last + * one in the variable specifier. */ + +{ + char *name1, *name1End, c, *result; + register char *name2; +#define NUM_CHARS 200 + char copyStorage[NUM_CHARS]; + ParseValue pv; + + /* + * There are three cases: + * 1. The $ sign is followed by an open curly brace. Then the variable + * name is everything up to the next close curly brace, and the + * variable is a scalar variable. + * 2. The $ sign is not followed by an open curly brace. Then the + * variable name is everything up to the next character that isn't + * a letter, digit, or underscore. If the following character is an + * open parenthesis, then the information between parentheses is + * the array element name, which can include any of the substitutions + * permissible between quotes. + * 3. The $ sign is followed by something that isn't a letter, digit, + * or underscore: in this case, there is no variable name, and "$" + * is returned. + */ + + name2 = NULL; + string++; + if (*string == '{') { + string++; + name1 = string; + while (*string != '}') { + if (*string == 0) { + Tcl_SetResult(interp, "missing close-brace for variable name", + TCL_STATIC); + if (termPtr != 0) { + *termPtr = string; + } + return NULL; + } + string++; + } + name1End = string; + string++; + } else { + name1 = string; + while (isalnum(UCHAR(*string)) || (*string == '_')) { + string++; + } + if (string == name1) { + if (termPtr != 0) { + *termPtr = string; + } + return "$"; + } + name1End = string; + if (*string == '(') { + char *end; + + /* + * Perform substitutions on the array element name, just as + * is done for quotes. + */ + + pv.buffer = pv.next = copyStorage; + pv.end = copyStorage + NUM_CHARS - 1; + pv.expandProc = TclExpandParseValue; + pv.clientData = (ClientData) NULL; + if (TclParseQuotes(interp, string+1, ')', 0, &end, &pv) + != TCL_OK) { + char msg[200]; + int length; + + length = string-name1; + if (length > 100) { + length = 100; + } + sprintf(msg, "\n (parsing index for array \"%.*s\")", + length, name1); + Tcl_AddErrorInfo(interp, msg); + result = NULL; + name2 = pv.buffer; + if (termPtr != 0) { + *termPtr = end; + } + goto done; + } + Tcl_ResetResult(interp); + string = end; + name2 = pv.buffer; + } + } + if (termPtr != 0) { + *termPtr = string; + } + + if (((Interp *) interp)->noEval) { + return ""; + } + c = *name1End; + *name1End = 0; + result = Tcl_GetVar2(interp, name1, name2, TCL_LEAVE_ERR_MSG); + *name1End = c; + + done: + if ((name2 != NULL) && (pv.buffer != copyStorage)) { + ckfree(pv.buffer); + } + return result; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_CommandComplete -- + * + * Given a partial or complete Tcl command, this procedure + * determines whether the command is complete in the sense + * of having matched braces and quotes and brackets. + * + * Results: + * 1 is returned if the command is complete, 0 otherwise. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_CommandComplete(cmd) + char *cmd; /* Command to check. */ +{ + char *p; + + if (*cmd == 0) { + return 1; + } + p = ScriptEnd(cmd, 0); + return (*p != 0); +} diff --git a/contrib/tcl/generic/tclPkg.c b/contrib/tcl/generic/tclPkg.c new file mode 100644 index 0000000..9dc0b94 --- /dev/null +++ b/contrib/tcl/generic/tclPkg.c @@ -0,0 +1,732 @@ +/* + * tclPkg.c -- + * + * This file implements package and version control for Tcl via + * the "package" command and a few C APIs. + * + * Copyright (c) 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: @(#) tclPkg.c 1.6 96/02/15 11:43:16 + */ + +#include "tclInt.h" + +/* + * Each invocation of the "package ifneeded" command creates a structure + * of the following type, which is used to load the package into the + * interpreter if it is requested with a "package require" command. + */ + +typedef struct PkgAvail { + char *version; /* Version string; malloc'ed. */ + char *script; /* Script to invoke to provide this version + * of the package. Malloc'ed and protected + * by Tcl_Preserve and Tcl_Release. */ + struct PkgAvail *nextPtr; /* Next in list of available versions of + * the same package. */ +} PkgAvail; + +/* + * For each package that is known in any way to an interpreter, there + * is one record of the following type. These records are stored in + * the "packageTable" hash table in the interpreter, keyed by + * package name such as "Tk" (no version number). + */ + +typedef struct Package { + char *version; /* Version that has been supplied in this + * interpreter via "package provide" + * (malloc'ed). NULL means the package doesn't + * exist in this interpreter yet. */ + PkgAvail *availPtr; /* First in list of all available versions + * of this package. */ +} Package; + +/* + * Prototypes for procedures defined in this file: + */ + +static int CheckVersion _ANSI_ARGS_((Tcl_Interp *interp, + char *string)); +static int ComparePkgVersions _ANSI_ARGS_((char *v1, char *v2, + int *satPtr)); +static Package * FindPackage _ANSI_ARGS_((Tcl_Interp *interp, + char *name)); + +/* + *---------------------------------------------------------------------- + * + * Tcl_PkgProvide -- + * + * This procedure is invoked to declare that a particular version + * of a particular package is now present in an interpreter. There + * must not be any other version of this package already + * provided in the interpreter. + * + * Results: + * Normally returns TCL_OK; if there is already another version + * of the package loaded then TCL_ERROR is returned and an error + * message is left in interp->result. + * + * Side effects: + * The interpreter remembers that this package is available, + * so that no other version of the package may be provided for + * the interpreter. + * + *---------------------------------------------------------------------- + */ + +int +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. */ +{ + Package *pkgPtr; + + pkgPtr = FindPackage(interp, name); + if (pkgPtr->version == NULL) { + pkgPtr->version = ckalloc((unsigned) (strlen(version) + 1)); + strcpy(pkgPtr->version, version); + return TCL_OK; + } + if (ComparePkgVersions(pkgPtr->version, version, (int *) NULL) == 0) { + return TCL_OK; + } + Tcl_AppendResult(interp, "conflicting versions provided for package \"", + name, "\": ", pkgPtr->version, ", then ", version, (char *) NULL); + return TCL_ERROR; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_PkgRequire -- + * + * This procedure is called by code that depends on a particular + * version of a particular package. If the package is not already + * provided in the interpreter, this procedure invokes a Tcl script + * to provide it. If the package is already provided, this + * procedure makes sure that the caller's needs don't conflict with + * the version that is present. + * + * Results: + * If successful, returns the version string for the currently + * provided version of the package, which may be different from + * the "version" argument. If the caller's requirements + * cannot be met (e.g. the version requested conflicts with + * a currently provided version, or the required version cannot + * be found, or the script to provide the required version + * generates an error), NULL is returned and an error + * message is left in interp->result. + * + * Side effects: + * The script from some previous "package ifneeded" command may + * be invoked to provide the package. + * + *---------------------------------------------------------------------- + */ + +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; + * NULL means use the latest version + * available. */ + int exact; /* Non-zero means that only the particular + * version given is acceptable. Zero means + * use the latest compatible version. */ +{ + Package *pkgPtr; + PkgAvail *availPtr, *bestPtr; + char *script; + int code, satisfies, result, pass; + Tcl_DString command; + + /* + * It can take up to three passes to find the package: one pass to + * run the "package unknown" script, one to run the "package ifneeded" + * script for a specific version, and a final pass to lookup the + * package loaded by the "package ifneeded" script. + */ + + for (pass = 1; ; pass++) { + pkgPtr = FindPackage(interp, name); + if (pkgPtr->version != NULL) { + break; + } + + /* + * The package isn't yet present. Search the list of available + * versions and invoke the script for the best available version. + */ + + bestPtr = NULL; + for (availPtr = pkgPtr->availPtr; availPtr != NULL; + availPtr = availPtr->nextPtr) { + if ((bestPtr != NULL) && (ComparePkgVersions(availPtr->version, + bestPtr->version, (int *) NULL) <= 0)) { + continue; + } + if (version != NULL) { + result = ComparePkgVersions(availPtr->version, version, + &satisfies); + if ((result != 0) && exact) { + continue; + } + if (!satisfies) { + continue; + } + } + bestPtr = availPtr; + } + if (bestPtr != NULL) { + /* + * We found an ifneeded script for the package. Be careful while + * executing it: this could cause reentrancy, so (a) protect the + * script itself from deletion and (b) don't assume that bestPtr + * will still exist when the script completes. + */ + + script = bestPtr->script; + Tcl_Preserve((ClientData) script); + code = Tcl_GlobalEval(interp, script); + Tcl_Release((ClientData) script); + if (code != TCL_OK) { + if (code == TCL_ERROR) { + Tcl_AddErrorInfo(interp, + "\n (\"package ifneeded\" script)"); + } + return NULL; + } + Tcl_ResetResult(interp); + pkgPtr = FindPackage(interp, name); + break; + } + + /* + * Package not in the database. If there is a "package unknown" + * command, invoke it (but only on the first pass; after that, + * we should not get here in the first place). + */ + + if (pass > 1) { + break; + } + script = ((Interp *) interp)->packageUnknown; + if (script != NULL) { + Tcl_DStringInit(&command); + Tcl_DStringAppend(&command, script, -1); + Tcl_DStringAppendElement(&command, name); + Tcl_DStringAppend(&command, " ", 1); + Tcl_DStringAppend(&command, (version != NULL) ? version : "{}", + -1); + if (exact) { + Tcl_DStringAppend(&command, " -exact", 7); + } + code = Tcl_GlobalEval(interp, Tcl_DStringValue(&command)); + Tcl_DStringFree(&command); + if (code != TCL_OK) { + if (code == TCL_ERROR) { + Tcl_AddErrorInfo(interp, + "\n (\"package unknown\" script)"); + } + return NULL; + } + Tcl_ResetResult(interp); + } + } + + if (pkgPtr->version == NULL) { + Tcl_AppendResult(interp, "can't find package ", name, + (char *) NULL); + if (version != NULL) { + Tcl_AppendResult(interp, " ", version, (char *) NULL); + } + return NULL; + } + + /* + * At this point we now that the package is present. Make sure that the + * provided version meets the current requirement. + */ + + if (version == NULL) { + return pkgPtr->version; + } + result = ComparePkgVersions(pkgPtr->version, version, &satisfies); + if ((satisfies && !exact) || (result == 0)) { + return pkgPtr->version; + } + Tcl_AppendResult(interp, "version conflict for package \"", + name, "\": have ", pkgPtr->version, ", need ", version, + (char *) NULL); + return NULL; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_PackageCmd -- + * + * This procedure is invoked to process the "package" Tcl command. + * See the user documentation for details on what it does. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * See the user documentation. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +int +Tcl_PackageCmd(dummy, interp, argc, argv) + ClientData dummy; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ + Interp *iPtr = (Interp *) interp; + size_t length; + int c, exact, i, satisfies; + PkgAvail *availPtr, *prevPtr; + Package *pkgPtr; + Tcl_HashEntry *hPtr; + Tcl_HashSearch search; + Tcl_HashTable *tablePtr; + char *version; + + if (argc < 2) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " option ?arg arg ...?\"", (char *) NULL); + return TCL_ERROR; + } + c = argv[1][0]; + length = strlen(argv[1]); + if ((c == 'f') && (strncmp(argv[1], "forget", length) == 0)) { + for (i = 2; i < argc; i++) { + hPtr = Tcl_FindHashEntry(&iPtr->packageTable, argv[i]); + if (hPtr == NULL) { + return TCL_OK; + } + pkgPtr = (Package *) Tcl_GetHashValue(hPtr); + Tcl_DeleteHashEntry(hPtr); + if (pkgPtr->version != NULL) { + ckfree(pkgPtr->version); + } + while (pkgPtr->availPtr != NULL) { + availPtr = pkgPtr->availPtr; + pkgPtr->availPtr = availPtr->nextPtr; + ckfree(availPtr->version); + Tcl_EventuallyFree((ClientData)availPtr->script, TCL_DYNAMIC); + ckfree((char *) availPtr); + } + ckfree((char *) pkgPtr); + } + } else if ((c == 'i') && (strncmp(argv[1], "ifneeded", length) == 0)) { + if ((argc != 4) && (argc != 5)) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " ifneeded package version ?script?\"", (char *) NULL); + return TCL_ERROR; + } + if (CheckVersion(interp, argv[3]) != TCL_OK) { + return TCL_ERROR; + } + if (argc == 4) { + hPtr = Tcl_FindHashEntry(&iPtr->packageTable, argv[2]); + if (hPtr == NULL) { + return TCL_OK; + } + pkgPtr = (Package *) Tcl_GetHashValue(hPtr); + } else { + pkgPtr = FindPackage(interp, argv[2]); + } + for (availPtr = pkgPtr->availPtr, prevPtr = NULL; availPtr != NULL; + prevPtr = availPtr, availPtr = availPtr->nextPtr) { + if (ComparePkgVersions(availPtr->version, argv[3], (int *) NULL) + == 0) { + if (argc == 4) { + interp->result = availPtr->script; + return TCL_OK; + } + Tcl_EventuallyFree((ClientData)availPtr->script, TCL_DYNAMIC); + break; + } + } + if (argc == 4) { + return TCL_OK; + } + if (availPtr == NULL) { + availPtr = (PkgAvail *) ckalloc(sizeof(PkgAvail)); + availPtr->version = ckalloc((unsigned) (strlen(argv[3]) + 1)); + strcpy(availPtr->version, argv[3]); + if (prevPtr == NULL) { + availPtr->nextPtr = pkgPtr->availPtr; + pkgPtr->availPtr = availPtr; + } else { + availPtr->nextPtr = prevPtr->nextPtr; + prevPtr->nextPtr = availPtr; + } + } + availPtr->script = ckalloc((unsigned) (strlen(argv[4]) + 1)); + strcpy(availPtr->script, argv[4]); + } else if ((c == 'n') && (strncmp(argv[1], "names", length) == 0)) { + if (argc != 2) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " names\"", (char *) NULL); + return TCL_ERROR; + } + tablePtr = &iPtr->packageTable; + for (hPtr = Tcl_FirstHashEntry(tablePtr, &search); hPtr != NULL; + hPtr = Tcl_NextHashEntry(&search)) { + pkgPtr = (Package *) Tcl_GetHashValue(hPtr); + if ((pkgPtr->version != NULL) || (pkgPtr->availPtr != NULL)) { + Tcl_AppendElement(interp, Tcl_GetHashKey(tablePtr, hPtr)); + } + } + } else if ((c == 'p') && (strncmp(argv[1], "provide", length) == 0)) { + if ((argc != 3) && (argc != 4)) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " provide package ?version?\"", (char *) NULL); + return TCL_ERROR; + } + if (argc == 3) { + hPtr = Tcl_FindHashEntry(&iPtr->packageTable, argv[2]); + if (hPtr != NULL) { + pkgPtr = (Package *) Tcl_GetHashValue(hPtr); + if (pkgPtr->version != NULL) { + interp->result = pkgPtr->version; + } + } + return TCL_OK; + } + if (CheckVersion(interp, argv[3]) != TCL_OK) { + return TCL_ERROR; + } + return Tcl_PkgProvide(interp, argv[2], argv[3]); + } else if ((c == 'r') && (strncmp(argv[1], "require", length) == 0)) { + if (argc < 3) { + requireSyntax: + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " require ?-exact? package ?version?\"", (char *) NULL); + return TCL_ERROR; + } + if ((argv[2][0] == '-') && (strcmp(argv[2], "-exact") == 0)) { + exact = 1; + } else { + exact = 0; + } + version = NULL; + if (argc == (4+exact)) { + version = argv[3+exact]; + if (CheckVersion(interp, version) != TCL_OK) { + return TCL_ERROR; + } + } else if ((argc != 3) || exact) { + goto requireSyntax; + } + version = Tcl_PkgRequire(interp, argv[2+exact], version, exact); + if (version == NULL) { + return TCL_ERROR; + } + interp->result = version; + } else if ((c == 'u') && (strncmp(argv[1], "unknown", length) == 0)) { + if (argc == 2) { + if (iPtr->packageUnknown != NULL) { + iPtr->result = iPtr->packageUnknown; + } + } else if (argc == 3) { + if (iPtr->packageUnknown != NULL) { + ckfree(iPtr->packageUnknown); + } + if (argv[2][0] == 0) { + iPtr->packageUnknown = NULL; + } else { + iPtr->packageUnknown = (char *) ckalloc((unsigned) + (strlen(argv[2]) + 1)); + strcpy(iPtr->packageUnknown, argv[2]); + } + } else { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " unknown ?command?\"", (char *) NULL); + return TCL_ERROR; + } + } else if ((c == 'v') && (strncmp(argv[1], "vcompare", length) == 0) + && (length >= 2)) { + if (argc != 4) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " vcompare version1 version2\"", (char *) NULL); + return TCL_ERROR; + } + if ((CheckVersion(interp, argv[2]) != TCL_OK) + || (CheckVersion(interp, argv[3]) != TCL_OK)) { + return TCL_ERROR; + } + sprintf(interp->result, "%d", ComparePkgVersions(argv[2], argv[3], + (int *) NULL)); + } else if ((c == 'v') && (strncmp(argv[1], "versions", length) == 0) + && (length >= 2)) { + if (argc != 3) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " versions package\"", (char *) NULL); + return TCL_ERROR; + } + hPtr = Tcl_FindHashEntry(&iPtr->packageTable, argv[2]); + if (hPtr != NULL) { + pkgPtr = (Package *) Tcl_GetHashValue(hPtr); + for (availPtr = pkgPtr->availPtr; availPtr != NULL; + availPtr = availPtr->nextPtr) { + Tcl_AppendElement(interp, availPtr->version); + } + } + } else if ((c == 'v') && (strncmp(argv[1], "vsatisfies", length) == 0) + && (length >= 2)) { + if (argc != 4) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " vsatisfies version1 version2\"", (char *) NULL); + return TCL_ERROR; + } + if ((CheckVersion(interp, argv[2]) != TCL_OK) + || (CheckVersion(interp, argv[3]) != TCL_OK)) { + return TCL_ERROR; + } + ComparePkgVersions(argv[2], argv[3], &satisfies); + sprintf(interp->result, "%d", satisfies); + } else { + Tcl_AppendResult(interp, "bad option \"", argv[1], + "\": should be forget, ifneeded, names, ", + "provide, require, unknown, vcompare, ", + "versions, or vsatisfies", (char *) NULL); + return TCL_ERROR; + } + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * FindPackage -- + * + * This procedure finds the Package record for a particular package + * in a particular interpreter, creating a record if one doesn't + * already exist. + * + * Results: + * The return value is a pointer to the Package record for the + * package. + * + * Side effects: + * A new Package record may be created. + * + *---------------------------------------------------------------------- + */ + +static Package * +FindPackage(interp, name) + Tcl_Interp *interp; /* Interpreter to use for package lookup. */ + char *name; /* Name of package to fine. */ +{ + Interp *iPtr = (Interp *) interp; + Tcl_HashEntry *hPtr; + int new; + Package *pkgPtr; + + hPtr = Tcl_CreateHashEntry(&iPtr->packageTable, name, &new); + if (new) { + pkgPtr = (Package *) ckalloc(sizeof(Package)); + pkgPtr->version = NULL; + pkgPtr->availPtr = NULL; + Tcl_SetHashValue(hPtr, pkgPtr); + } else { + pkgPtr = (Package *) Tcl_GetHashValue(hPtr); + } + return pkgPtr; +} + +/* + *---------------------------------------------------------------------- + * + * TclFreePackageInfo -- + * + * This procedure is called during interpreter deletion to + * free all of the package-related information for the + * interpreter. + * + * Results: + * None. + * + * Side effects: + * Memory is freed. + * + *---------------------------------------------------------------------- + */ + +void +TclFreePackageInfo(iPtr) + Interp *iPtr; /* Interpereter that is being deleted. */ +{ + Package *pkgPtr; + Tcl_HashSearch search; + Tcl_HashEntry *hPtr; + PkgAvail *availPtr; + + for (hPtr = Tcl_FirstHashEntry(&iPtr->packageTable, &search); + hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) { + pkgPtr = (Package *) Tcl_GetHashValue(hPtr); + if (pkgPtr->version != NULL) { + ckfree(pkgPtr->version); + } + while (pkgPtr->availPtr != NULL) { + availPtr = pkgPtr->availPtr; + pkgPtr->availPtr = availPtr->nextPtr; + ckfree(availPtr->version); + Tcl_EventuallyFree((ClientData)availPtr->script, TCL_DYNAMIC); + ckfree((char *) availPtr); + } + ckfree((char *) pkgPtr); + } + Tcl_DeleteHashTable(&iPtr->packageTable); + if (iPtr->packageUnknown != NULL) { + ckfree(iPtr->packageUnknown); + } +} + +/* + *---------------------------------------------------------------------- + * + * CheckVersion -- + * + * This procedure checks to see whether a version number has + * valid syntax. + * + * Results: + * If string is a properly formed version number the TCL_OK + * is returned. Otherwise TCL_ERROR is returned and an error + * message is left in interp->result. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static int +CheckVersion(interp, string) + Tcl_Interp *interp; /* Used for error reporting. */ + char *string; /* Supposedly a version number, which is + * groups of decimal digits separated + * by dots. */ +{ + char *p = string; + + if (!isdigit(*p)) { + goto error; + } + for (p++; *p != 0; p++) { + if (!isdigit(*p) && (*p != '.')) { + goto error; + } + } + if (p[-1] != '.') { + return TCL_OK; + } + + error: + Tcl_AppendResult(interp, "expected version number but got \"", + string, "\"", (char *) NULL); + return TCL_ERROR; +} + +/* + *---------------------------------------------------------------------- + * + * ComparePkgVersions -- + * + * This procedure compares two version numbers. + * + * Results: + * The return value is -1 if v1 is less than v2, 0 if the two + * version numbers are the same, and 1 if v1 is greater than v2. + * If *satPtr is non-NULL, the word it points to is filled in + * with 1 if v2 >= v1 and both numbers have the same major number + * or 0 otherwise. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static int +ComparePkgVersions(v1, v2, satPtr) + char *v1, *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 + * v1 "satisfies" v2: v1 is greater than + * or equal to v2 and both version numbers + * have the same major number. */ +{ + int thisIsMajor, n1, n2; + + /* + * Each iteration of the following loop processes one number from + * each string, terminated by a ".". If those numbers don't match + * then the comparison is over; otherwise, we loop back for the + * next number. + */ + + thisIsMajor = 1; + while (1) { + /* + * Parse one decimal number from the front of each string. + */ + + n1 = n2 = 0; + while ((*v1 != 0) && (*v1 != '.')) { + n1 = 10*n1 + (*v1 - '0'); + v1++; + } + while ((*v2 != 0) && (*v2 != '.')) { + n2 = 10*n2 + (*v2 - '0'); + v2++; + } + + /* + * Compare and go on to the next version number if the + * current numbers match. + */ + + if (n1 != n2) { + break; + } + if (*v1 != 0) { + v1++; + } else if (*v2 == 0) { + break; + } + if (*v2 != 0) { + v2++; + } + thisIsMajor = 0; + } + if (satPtr != NULL) { + *satPtr = (n1 == n2) || ((n1 > n2) && !thisIsMajor); + } + if (n1 > n2) { + return 1; + } else if (n1 == n2) { + return 0; + } else { + return -1; + } +} diff --git a/contrib/tcl/generic/tclPort.h b/contrib/tcl/generic/tclPort.h new file mode 100644 index 0000000..2aa27f5 --- /dev/null +++ b/contrib/tcl/generic/tclPort.h @@ -0,0 +1,29 @@ +/* + * tclPort.h -- + * + * This header file handles porting issues that occur because + * of differences between systems. It reads in platform specific + * portability files. + * + * Copyright (c) 1994-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: @(#) tclPort.h 1.15 96/02/07 17:24:21 + */ + +#ifndef _TCLPORT +#define _TCLPORT + +#if defined(__WIN32__) || defined(_WIN32) +# include "../win/tclWinPort.h" +#else +# if defined(MAC_TCL) +# include "tclMacPort.h" +# else +# include "../unix/tclUnixPort.h" +# endif +#endif + +#endif /* _TCLPORT */ diff --git a/contrib/tcl/generic/tclPosixStr.c b/contrib/tcl/generic/tclPosixStr.c new file mode 100644 index 0000000..9f46ff8 --- /dev/null +++ b/contrib/tcl/generic/tclPosixStr.c @@ -0,0 +1,1174 @@ +/* + * tclPosixStr.c -- + * + * This file contains procedures that generate strings + * corresponding to various POSIX-related codes, such + * as errno and signals. + * + * Copyright (c) 1991-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: @(#) tclPosixStr.c 1.30 96/02/08 16:33:34 + */ + +#include "tclInt.h" +#include "tclPort.h" + +/* + *---------------------------------------------------------------------- + * + * Tcl_ErrnoId -- + * + * Return a textual identifier for the current errno value. + * + * Results: + * This procedure returns a machine-readable textual identifier + * that corresponds to the current errno value (e.g. "EPERM"). + * The identifier is the same as the #define name in errno.h. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +char * +Tcl_ErrnoId() +{ + switch (errno) { +#ifdef E2BIG + case E2BIG: return "E2BIG"; +#endif +#ifdef EACCES + case EACCES: return "EACCES"; +#endif +#ifdef EADDRINUSE + case EADDRINUSE: return "EADDRINUSE"; +#endif +#ifdef EADDRNOTAVAIL + case EADDRNOTAVAIL: return "EADDRNOTAVAIL"; +#endif +#ifdef EADV + case EADV: return "EADV"; +#endif +#ifdef EAFNOSUPPORT + case EAFNOSUPPORT: return "EAFNOSUPPORT"; +#endif +#ifdef EAGAIN + case EAGAIN: return "EAGAIN"; +#endif +#ifdef EALIGN + case EALIGN: return "EALIGN"; +#endif +#if defined(EALREADY) && (!defined(EBUSY) || (EALREADY != EBUSY )) + case EALREADY: return "EALREADY"; +#endif +#ifdef EBADE + case EBADE: return "EBADE"; +#endif +#ifdef EBADF + case EBADF: return "EBADF"; +#endif +#ifdef EBADFD + case EBADFD: return "EBADFD"; +#endif +#ifdef EBADMSG + case EBADMSG: return "EBADMSG"; +#endif +#ifdef EBADR + case EBADR: return "EBADR"; +#endif +#ifdef EBADRPC + case EBADRPC: return "EBADRPC"; +#endif +#ifdef EBADRQC + case EBADRQC: return "EBADRQC"; +#endif +#ifdef EBADSLT + case EBADSLT: return "EBADSLT"; +#endif +#ifdef EBFONT + case EBFONT: return "EBFONT"; +#endif +#ifdef EBUSY + case EBUSY: return "EBUSY"; +#endif +#ifdef ECHILD + case ECHILD: return "ECHILD"; +#endif +#ifdef ECHRNG + case ECHRNG: return "ECHRNG"; +#endif +#ifdef ECOMM + case ECOMM: return "ECOMM"; +#endif +#ifdef ECONNABORTED + case ECONNABORTED: return "ECONNABORTED"; +#endif +#ifdef ECONNREFUSED + case ECONNREFUSED: return "ECONNREFUSED"; +#endif +#ifdef ECONNRESET + case ECONNRESET: return "ECONNRESET"; +#endif +#if defined(EDEADLK) && (!defined(EWOULDBLOCK) || (EDEADLK != EWOULDBLOCK)) + case EDEADLK: return "EDEADLK"; +#endif +#ifdef EDEADLOCK + case EDEADLOCK: return "EDEADLOCK"; +#endif +#ifdef EDESTADDRREQ + case EDESTADDRREQ: return "EDESTADDRREQ"; +#endif +#ifdef EDIRTY + case EDIRTY: return "EDIRTY"; +#endif +#ifdef EDOM + case EDOM: return "EDOM"; +#endif +#ifdef EDOTDOT + case EDOTDOT: return "EDOTDOT"; +#endif +#ifdef EDQUOT + case EDQUOT: return "EDQUOT"; +#endif +#ifdef EDUPPKG + case EDUPPKG: return "EDUPPKG"; +#endif +#ifdef EEXIST + case EEXIST: return "EEXIST"; +#endif +#ifdef EFAULT + case EFAULT: return "EFAULT"; +#endif +#ifdef EFBIG + case EFBIG: return "EFBIG"; +#endif +#ifdef EHOSTDOWN + case EHOSTDOWN: return "EHOSTDOWN"; +#endif +#ifdef EHOSTUNREACH + case EHOSTUNREACH: return "EHOSTUNREACH"; +#endif +#if defined(EIDRM) && (!defined(EINPROGRESS) || (EIDRM != EINPROGRESS)) + case EIDRM: return "EIDRM"; +#endif +#ifdef EINIT + case EINIT: return "EINIT"; +#endif +#ifdef EINPROGRESS + case EINPROGRESS: return "EINPROGRESS"; +#endif +#ifdef EINTR + case EINTR: return "EINTR"; +#endif +#ifdef EINVAL + case EINVAL: return "EINVAL"; +#endif +#ifdef EIO + case EIO: return "EIO"; +#endif +#ifdef EISCONN + case EISCONN: return "EISCONN"; +#endif +#ifdef EISDIR + case EISDIR: return "EISDIR"; +#endif +#ifdef EISNAME + case EISNAM: return "EISNAM"; +#endif +#ifdef ELBIN + case ELBIN: return "ELBIN"; +#endif +#ifdef EL2HLT + case EL2HLT: return "EL2HLT"; +#endif +#ifdef EL2NSYNC + case EL2NSYNC: return "EL2NSYNC"; +#endif +#ifdef EL3HLT + case EL3HLT: return "EL3HLT"; +#endif +#ifdef EL3RST + case EL3RST: return "EL3RST"; +#endif +#ifdef ELIBACC + case ELIBACC: return "ELIBACC"; +#endif +#ifdef ELIBBAD + case ELIBBAD: return "ELIBBAD"; +#endif +#ifdef ELIBEXEC + case ELIBEXEC: return "ELIBEXEC"; +#endif +#ifdef ELIBMAX + case ELIBMAX: return "ELIBMAX"; +#endif +#ifdef ELIBSCN + case ELIBSCN: return "ELIBSCN"; +#endif +#ifdef ELNRNG + case ELNRNG: return "ELNRNG"; +#endif +#if defined(ELOOP) && (!defined(ENOENT) || (ELOOP != ENOENT)) + case ELOOP: return "ELOOP"; +#endif +#ifdef EMFILE + case EMFILE: return "EMFILE"; +#endif +#ifdef EMLINK + case EMLINK: return "EMLINK"; +#endif +#ifdef EMSGSIZE + case EMSGSIZE: return "EMSGSIZE"; +#endif +#ifdef EMULTIHOP + case EMULTIHOP: return "EMULTIHOP"; +#endif +#ifdef ENAMETOOLONG + case ENAMETOOLONG: return "ENAMETOOLONG"; +#endif +#ifdef ENAVAIL + case ENAVAIL: return "ENAVAIL"; +#endif +#ifdef ENET + case ENET: return "ENET"; +#endif +#ifdef ENETDOWN + case ENETDOWN: return "ENETDOWN"; +#endif +#ifdef ENETRESET + case ENETRESET: return "ENETRESET"; +#endif +#ifdef ENETUNREACH + case ENETUNREACH: return "ENETUNREACH"; +#endif +#ifdef ENFILE + case ENFILE: return "ENFILE"; +#endif +#ifdef ENOANO + case ENOANO: return "ENOANO"; +#endif +#if defined(ENOBUFS) && (!defined(ENOSR) || (ENOBUFS != ENOSR)) + case ENOBUFS: return "ENOBUFS"; +#endif +#ifdef ENOCSI + case ENOCSI: return "ENOCSI"; +#endif +#if defined(ENODATA) && (!defined(ECONNREFUSED) || (ENODATA != ECONNREFUSED)) + case ENODATA: return "ENODATA"; +#endif +#ifdef ENODEV + case ENODEV: return "ENODEV"; +#endif +#ifdef ENOENT + case ENOENT: return "ENOENT"; +#endif +#ifdef ENOEXEC + case ENOEXEC: return "ENOEXEC"; +#endif +#ifdef ENOLCK + case ENOLCK: return "ENOLCK"; +#endif +#ifdef ENOLINK + case ENOLINK: return "ENOLINK"; +#endif +#ifdef ENOMEM + case ENOMEM: return "ENOMEM"; +#endif +#ifdef ENOMSG + case ENOMSG: return "ENOMSG"; +#endif +#ifdef ENONET + case ENONET: return "ENONET"; +#endif +#ifdef ENOPKG + case ENOPKG: return "ENOPKG"; +#endif +#ifdef ENOPROTOOPT + case ENOPROTOOPT: return "ENOPROTOOPT"; +#endif +#ifdef ENOSPC + case ENOSPC: return "ENOSPC"; +#endif +#if defined(ENOSR) && (!defined(ENAMETOOLONG) || (ENAMETOOLONG != ENOSR)) + case ENOSR: return "ENOSR"; +#endif +#if defined(ENOSTR) && (!defined(ENOTTY) || (ENOTTY != ENOSTR)) + case ENOSTR: return "ENOSTR"; +#endif +#ifdef ENOSYM + case ENOSYM: return "ENOSYM"; +#endif +#ifdef ENOSYS + case ENOSYS: return "ENOSYS"; +#endif +#ifdef ENOTBLK + case ENOTBLK: return "ENOTBLK"; +#endif +#ifdef ENOTCONN + case ENOTCONN: return "ENOTCONN"; +#endif +#ifdef ENOTDIR + case ENOTDIR: return "ENOTDIR"; +#endif +#if defined(ENOTEMPTY) && (!defined(EEXIST) || (ENOTEMPTY != EEXIST)) + case ENOTEMPTY: return "ENOTEMPTY"; +#endif +#ifdef ENOTNAM + case ENOTNAM: return "ENOTNAM"; +#endif +#ifdef ENOTSOCK + case ENOTSOCK: return "ENOTSOCK"; +#endif +#ifdef ENOTSUP + case ENOTSUP: return "ENOTSUP"; +#endif +#ifdef ENOTTY + case ENOTTY: return "ENOTTY"; +#endif +#ifdef ENOTUNIQ + case ENOTUNIQ: return "ENOTUNIQ"; +#endif +#ifdef ENXIO + case ENXIO: return "ENXIO"; +#endif +#ifdef EOPNOTSUPP + case EOPNOTSUPP: return "EOPNOTSUPP"; +#endif +#ifdef EPERM + case EPERM: return "EPERM"; +#endif +#if defined(EPFNOSUPPORT) && (!defined(ENOLCK) || (ENOLCK != EPFNOSUPPORT)) + case EPFNOSUPPORT: return "EPFNOSUPPORT"; +#endif +#ifdef EPIPE + case EPIPE: return "EPIPE"; +#endif +#ifdef EPROCLIM + case EPROCLIM: return "EPROCLIM"; +#endif +#ifdef EPROCUNAVAIL + case EPROCUNAVAIL: return "EPROCUNAVAIL"; +#endif +#ifdef EPROGMISMATCH + case EPROGMISMATCH: return "EPROGMISMATCH"; +#endif +#ifdef EPROGUNAVAIL + case EPROGUNAVAIL: return "EPROGUNAVAIL"; +#endif +#ifdef EPROTO + case EPROTO: return "EPROTO"; +#endif +#ifdef EPROTONOSUPPORT + case EPROTONOSUPPORT: return "EPROTONOSUPPORT"; +#endif +#ifdef EPROTOTYPE + case EPROTOTYPE: return "EPROTOTYPE"; +#endif +#ifdef ERANGE + case ERANGE: return "ERANGE"; +#endif +#if defined(EREFUSED) && (!defined(ECONNREFUSED) || (EREFUSED != ECONNREFUSED)) + case EREFUSED: return "EREFUSED"; +#endif +#ifdef EREMCHG + case EREMCHG: return "EREMCHG"; +#endif +#ifdef EREMDEV + case EREMDEV: return "EREMDEV"; +#endif +#ifdef EREMOTE + case EREMOTE: return "EREMOTE"; +#endif +#ifdef EREMOTEIO + case EREMOTEIO: return "EREMOTEIO"; +#endif +#ifdef EREMOTERELEASE + case EREMOTERELEASE: return "EREMOTERELEASE"; +#endif +#ifdef EROFS + case EROFS: return "EROFS"; +#endif +#ifdef ERPCMISMATCH + case ERPCMISMATCH: return "ERPCMISMATCH"; +#endif +#ifdef ERREMOTE + case ERREMOTE: return "ERREMOTE"; +#endif +#ifdef ESHUTDOWN + case ESHUTDOWN: return "ESHUTDOWN"; +#endif +#ifdef ESOCKTNOSUPPORT + case ESOCKTNOSUPPORT: return "ESOCKTNOSUPPORT"; +#endif +#ifdef ESPIPE + case ESPIPE: return "ESPIPE"; +#endif +#ifdef ESRCH + case ESRCH: return "ESRCH"; +#endif +#ifdef ESRMNT + case ESRMNT: return "ESRMNT"; +#endif +#ifdef ESTALE + case ESTALE: return "ESTALE"; +#endif +#ifdef ESUCCESS + case ESUCCESS: return "ESUCCESS"; +#endif +#if defined(ETIME) && (!defined(ELOOP) || (ETIME != ELOOP)) + case ETIME: return "ETIME"; +#endif +#if defined(ETIMEDOUT) && (!defined(ENOSTR) || (ETIMEDOUT != ENOSTR)) + case ETIMEDOUT: return "ETIMEDOUT"; +#endif +#ifdef ETOOMANYREFS + case ETOOMANYREFS: return "ETOOMANYREFS"; +#endif +#ifdef ETXTBSY + case ETXTBSY: return "ETXTBSY"; +#endif +#ifdef EUCLEAN + case EUCLEAN: return "EUCLEAN"; +#endif +#ifdef EUNATCH + case EUNATCH: return "EUNATCH"; +#endif +#ifdef EUSERS + case EUSERS: return "EUSERS"; +#endif +#ifdef EVERSION + case EVERSION: return "EVERSION"; +#endif +#if defined(EWOULDBLOCK) && (!defined(EAGAIN) || (EWOULDBLOCK != EAGAIN)) + case EWOULDBLOCK: return "EWOULDBLOCK"; +#endif +#ifdef EXDEV + case EXDEV: return "EXDEV"; +#endif +#ifdef EXFULL + case EXFULL: return "EXFULL"; +#endif + } + return "unknown error"; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_ErrnoMsg -- + * + * Return a human-readable message corresponding to a given + * errno value. + * + * Results: + * The return value is the standard POSIX error message for + * errno. This procedure is used instead of strerror because + * strerror returns slightly different values on different + * machines (e.g. different capitalizations), which cause + * problems for things such as regression tests. This procedure + * provides messages for most standard errors, then it calls + * strerror for things it doesn't understand. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +char * +Tcl_ErrnoMsg(err) + int err; /* Error number (such as in errno variable). */ +{ + switch (err) { +#ifdef E2BIG + case E2BIG: return "argument list too long"; +#endif +#ifdef EACCES + case EACCES: return "permission denied"; +#endif +#ifdef EADDRINUSE + case EADDRINUSE: return "address already in use"; +#endif +#ifdef EADDRNOTAVAIL + case EADDRNOTAVAIL: return "can't assign requested address"; +#endif +#ifdef EADV + case EADV: return "advertise error"; +#endif +#ifdef EAFNOSUPPORT + case EAFNOSUPPORT: return "address family not supported by protocol family"; +#endif +#ifdef EAGAIN + case EAGAIN: return "resource temporarily unavailable"; +#endif +#ifdef EALIGN + case EALIGN: return "EALIGN"; +#endif +#if defined(EALREADY) && (!defined(EBUSY) || (EALREADY != EBUSY )) + case EALREADY: return "operation already in progress"; +#endif +#ifdef EBADE + case EBADE: return "bad exchange descriptor"; +#endif +#ifdef EBADF + case EBADF: return "bad file number"; +#endif +#ifdef EBADFD + case EBADFD: return "file descriptor in bad state"; +#endif +#ifdef EBADMSG + case EBADMSG: return "not a data message"; +#endif +#ifdef EBADR + case EBADR: return "bad request descriptor"; +#endif +#ifdef EBADRPC + case EBADRPC: return "RPC structure is bad"; +#endif +#ifdef EBADRQC + case EBADRQC: return "bad request code"; +#endif +#ifdef EBADSLT + case EBADSLT: return "invalid slot"; +#endif +#ifdef EBFONT + case EBFONT: return "bad font file format"; +#endif +#ifdef EBUSY + case EBUSY: return "mount device busy"; +#endif +#ifdef ECHILD + case ECHILD: return "no children"; +#endif +#ifdef ECHRNG + case ECHRNG: return "channel number out of range"; +#endif +#ifdef ECOMM + case ECOMM: return "communication error on send"; +#endif +#ifdef ECONNABORTED + case ECONNABORTED: return "software caused connection abort"; +#endif +#ifdef ECONNREFUSED + case ECONNREFUSED: return "connection refused"; +#endif +#ifdef ECONNRESET + case ECONNRESET: return "connection reset by peer"; +#endif +#if defined(EDEADLK) && (!defined(EWOULDBLOCK) || (EDEADLK != EWOULDBLOCK)) + case EDEADLK: return "resource deadlock avoided"; +#endif +#ifdef EDEADLOCK + case EDEADLOCK: return "resource deadlock avoided"; +#endif +#ifdef EDESTADDRREQ + case EDESTADDRREQ: return "destination address required"; +#endif +#ifdef EDIRTY + case EDIRTY: return "mounting a dirty fs w/o force"; +#endif +#ifdef EDOM + case EDOM: return "math argument out of range"; +#endif +#ifdef EDOTDOT + case EDOTDOT: return "cross mount point"; +#endif +#ifdef EDQUOT + case EDQUOT: return "disk quota exceeded"; +#endif +#ifdef EDUPPKG + case EDUPPKG: return "duplicate package name"; +#endif +#ifdef EEXIST + case EEXIST: return "file already exists"; +#endif +#ifdef EFAULT + case EFAULT: return "bad address in system call argument"; +#endif +#ifdef EFBIG + case EFBIG: return "file too large"; +#endif +#ifdef EHOSTDOWN + case EHOSTDOWN: return "host is down"; +#endif +#ifdef EHOSTUNREACH + case EHOSTUNREACH: return "host is unreachable"; +#endif +#if defined(EIDRM) && (!defined(EINPROGRESS) || (EIDRM != EINPROGRESS)) + case EIDRM: return "identifier removed"; +#endif +#ifdef EINIT + case EINIT: return "initialization error"; +#endif +#ifdef EINPROGRESS + case EINPROGRESS: return "operation now in progress"; +#endif +#ifdef EINTR + case EINTR: return "interrupted system call"; +#endif +#ifdef EINVAL + case EINVAL: return "invalid argument"; +#endif +#ifdef EIO + case EIO: return "I/O error"; +#endif +#ifdef EISCONN + case EISCONN: return "socket is already connected"; +#endif +#ifdef EISDIR + case EISDIR: return "illegal operation on a directory"; +#endif +#ifdef EISNAME + case EISNAM: return "is a name file"; +#endif +#ifdef ELBIN + case ELBIN: return "ELBIN"; +#endif +#ifdef EL2HLT + case EL2HLT: return "level 2 halted"; +#endif +#ifdef EL2NSYNC + case EL2NSYNC: return "level 2 not synchronized"; +#endif +#ifdef EL3HLT + case EL3HLT: return "level 3 halted"; +#endif +#ifdef EL3RST + case EL3RST: return "level 3 reset"; +#endif +#ifdef ELIBACC + case ELIBACC: return "can not access a needed shared library"; +#endif +#ifdef ELIBBAD + case ELIBBAD: return "accessing a corrupted shared library"; +#endif +#ifdef ELIBEXEC + case ELIBEXEC: return "can not exec a shared library directly"; +#endif +#ifdef ELIBMAX + case ELIBMAX: return + "attempting to link in more shared libraries than system limit"; +#endif +#ifdef ELIBSCN + case ELIBSCN: return ".lib section in a.out corrupted"; +#endif +#ifdef ELNRNG + case ELNRNG: return "link number out of range"; +#endif +#if defined(ELOOP) && (!defined(ENOENT) || (ELOOP != ENOENT)) + case ELOOP: return "too many levels of symbolic links"; +#endif +#ifdef EMFILE + case EMFILE: return "too many open files"; +#endif +#ifdef EMLINK + case EMLINK: return "too many links"; +#endif +#ifdef EMSGSIZE + case EMSGSIZE: return "message too long"; +#endif +#ifdef EMULTIHOP + case EMULTIHOP: return "multihop attempted"; +#endif +#ifdef ENAMETOOLONG + case ENAMETOOLONG: return "file name too long"; +#endif +#ifdef ENAVAIL + case ENAVAIL: return "not available"; +#endif +#ifdef ENET + case ENET: return "ENET"; +#endif +#ifdef ENETDOWN + case ENETDOWN: return "network is down"; +#endif +#ifdef ENETRESET + case ENETRESET: return "network dropped connection on reset"; +#endif +#ifdef ENETUNREACH + case ENETUNREACH: return "network is unreachable"; +#endif +#ifdef ENFILE + case ENFILE: return "file table overflow"; +#endif +#ifdef ENOANO + case ENOANO: return "anode table overflow"; +#endif +#if defined(ENOBUFS) && (!defined(ENOSR) || (ENOBUFS != ENOSR)) + case ENOBUFS: return "no buffer space available"; +#endif +#ifdef ENOCSI + case ENOCSI: return "no CSI structure available"; +#endif +#if defined(ENODATA) && (!defined(ECONNREFUSED) || (ENODATA != ECONNREFUSED)) + case ENODATA: return "no data available"; +#endif +#ifdef ENODEV + case ENODEV: return "no such device"; +#endif +#ifdef ENOENT + case ENOENT: return "no such file or directory"; +#endif +#ifdef ENOEXEC + case ENOEXEC: return "exec format error"; +#endif +#ifdef ENOLCK + case ENOLCK: return "no locks available"; +#endif +#ifdef ENOLINK + case ENOLINK: return "link has be severed"; +#endif +#ifdef ENOMEM + case ENOMEM: return "not enough memory"; +#endif +#ifdef ENOMSG + case ENOMSG: return "no message of desired type"; +#endif +#ifdef ENONET + case ENONET: return "machine is not on the network"; +#endif +#ifdef ENOPKG + case ENOPKG: return "package not installed"; +#endif +#ifdef ENOPROTOOPT + case ENOPROTOOPT: return "bad proocol option"; +#endif +#ifdef ENOSPC + case ENOSPC: return "no space left on device"; +#endif +#if defined(ENOSR) && (!defined(ENAMETOOLONG) || (ENAMETOOLONG != ENOSR)) + case ENOSR: return "out of stream resources"; +#endif +#if defined(ENOSTR) && (!defined(ENOTTY) || (ENOTTY != ENOSTR)) + case ENOSTR: return "not a stream device"; +#endif +#ifdef ENOSYM + case ENOSYM: return "unresolved symbol name"; +#endif +#ifdef ENOSYS + case ENOSYS: return "function not implemented"; +#endif +#ifdef ENOTBLK + case ENOTBLK: return "block device required"; +#endif +#ifdef ENOTCONN + case ENOTCONN: return "socket is not connected"; +#endif +#ifdef ENOTDIR + case ENOTDIR: return "not a directory"; +#endif +#if defined(ENOTEMPTY) && (!defined(EEXIST) || (ENOTEMPTY != EEXIST)) + case ENOTEMPTY: return "directory not empty"; +#endif +#ifdef ENOTNAM + case ENOTNAM: return "not a name file"; +#endif +#ifdef ENOTSOCK + case ENOTSOCK: return "socket operation on non-socket"; +#endif +#ifdef ENOTSUP + case ENOTSUP: return "operation not supported"; +#endif +#ifdef ENOTTY + case ENOTTY: return "inappropriate device for ioctl"; +#endif +#ifdef ENOTUNIQ + case ENOTUNIQ: return "name not unique on network"; +#endif +#ifdef ENXIO + case ENXIO: return "no such device or address"; +#endif +#ifdef EOPNOTSUPP + case EOPNOTSUPP: return "operation not supported on socket"; +#endif +#ifdef EPERM + case EPERM: return "not owner"; +#endif +#if defined(EPFNOSUPPORT) && (!defined(ENOLCK) || (ENOLCK != EPFNOSUPPORT)) + case EPFNOSUPPORT: return "protocol family not supported"; +#endif +#ifdef EPIPE + case EPIPE: return "broken pipe"; +#endif +#ifdef EPROCLIM + case EPROCLIM: return "too many processes"; +#endif +#ifdef EPROCUNAVAIL + case EPROCUNAVAIL: return "bad procedure for program"; +#endif +#ifdef EPROGMISMATCH + case EPROGMISMATCH: return "program version wrong"; +#endif +#ifdef EPROGUNAVAIL + case EPROGUNAVAIL: return "RPC program not available"; +#endif +#ifdef EPROTO + case EPROTO: return "protocol error"; +#endif +#ifdef EPROTONOSUPPORT + case EPROTONOSUPPORT: return "protocol not suppored"; +#endif +#ifdef EPROTOTYPE + case EPROTOTYPE: return "protocol wrong type for socket"; +#endif +#ifdef ERANGE + case ERANGE: return "math result unrepresentable"; +#endif +#if defined(EREFUSED) && (!defined(ECONNREFUSED) || (EREFUSED != ECONNREFUSED)) + case EREFUSED: return "EREFUSED"; +#endif +#ifdef EREMCHG + case EREMCHG: return "remote address changed"; +#endif +#ifdef EREMDEV + case EREMDEV: return "remote device"; +#endif +#ifdef EREMOTE + case EREMOTE: return "pathname hit remote file system"; +#endif +#ifdef EREMOTEIO + case EREMOTEIO: return "remote i/o error"; +#endif +#ifdef EREMOTERELEASE + case EREMOTERELEASE: return "EREMOTERELEASE"; +#endif +#ifdef EROFS + case EROFS: return "read-only file system"; +#endif +#ifdef ERPCMISMATCH + case ERPCMISMATCH: return "RPC version is wrong"; +#endif +#ifdef ERREMOTE + case ERREMOTE: return "object is remote"; +#endif +#ifdef ESHUTDOWN + case ESHUTDOWN: return "can't send afer socket shutdown"; +#endif +#ifdef ESOCKTNOSUPPORT + case ESOCKTNOSUPPORT: return "socket type not supported"; +#endif +#ifdef ESPIPE + case ESPIPE: return "invalid seek"; +#endif +#ifdef ESRCH + case ESRCH: return "no such process"; +#endif +#ifdef ESRMNT + case ESRMNT: return "srmount error"; +#endif +#ifdef ESTALE + case ESTALE: return "stale remote file handle"; +#endif +#ifdef ESUCCESS + case ESUCCESS: return "Error 0"; +#endif +#if defined(ETIME) && (!defined(ELOOP) || (ETIME != ELOOP)) + case ETIME: return "timer expired"; +#endif +#if defined(ETIMEDOUT) && (!defined(ENOSTR) || (ETIMEDOUT != ENOSTR)) + case ETIMEDOUT: return "connection timed out"; +#endif +#ifdef ETOOMANYREFS + case ETOOMANYREFS: return "too many references: can't splice"; +#endif +#ifdef ETXTBSY + case ETXTBSY: return "text file or pseudo-device busy"; +#endif +#ifdef EUCLEAN + case EUCLEAN: return "structure needs cleaning"; +#endif +#ifdef EUNATCH + case EUNATCH: return "protocol driver not attached"; +#endif +#ifdef EUSERS + case EUSERS: return "too many users"; +#endif +#ifdef EVERSION + case EVERSION: return "version mismatch"; +#endif +#if defined(EWOULDBLOCK) && (!defined(EAGAIN) || (EWOULDBLOCK != EAGAIN)) + case EWOULDBLOCK: return "operation would block"; +#endif +#ifdef EXDEV + case EXDEV: return "cross-domain link"; +#endif +#ifdef EXFULL + case EXFULL: return "message tables full"; +#endif + default: +#ifdef NO_STRERROR + return "unknown POSIX error"; +#else + return strerror(errno); +#endif + } +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_SignalId -- + * + * Return a textual identifier for a signal number. + * + * Results: + * This procedure returns a machine-readable textual identifier + * that corresponds to sig. The identifier is the same as the + * #define name in signal.h. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +char * +Tcl_SignalId(sig) + int sig; /* Number of signal. */ +{ + switch (sig) { +#ifdef SIGABRT + case SIGABRT: return "SIGABRT"; +#endif +#ifdef SIGALRM + case SIGALRM: return "SIGALRM"; +#endif +#ifdef SIGBUS + case SIGBUS: return "SIGBUS"; +#endif +#ifdef SIGCHLD + case SIGCHLD: return "SIGCHLD"; +#endif +#if defined(SIGCLD) && (!defined(SIGCHLD) || (SIGCLD != SIGCHLD)) + case SIGCLD: return "SIGCLD"; +#endif +#ifdef SIGCONT + case SIGCONT: return "SIGCONT"; +#endif +#if defined(SIGEMT) && (!defined(SIGXCPU) || (SIGEMT != SIGXCPU)) + case SIGEMT: return "SIGEMT"; +#endif +#ifdef SIGFPE + case SIGFPE: return "SIGFPE"; +#endif +#ifdef SIGHUP + case SIGHUP: return "SIGHUP"; +#endif +#ifdef SIGILL + case SIGILL: return "SIGILL"; +#endif +#ifdef SIGINT + case SIGINT: return "SIGINT"; +#endif +#ifdef SIGIO + case SIGIO: return "SIGIO"; +#endif +#if defined(SIGIOT) && (!defined(SIGABRT) || (SIGIOT != SIGABRT)) + case SIGIOT: return "SIGIOT"; +#endif +#ifdef SIGKILL + case SIGKILL: return "SIGKILL"; +#endif +#if defined(SIGLOST) && (!defined(SIGIOT) || (SIGLOST != SIGIOT)) && (!defined(SIGURG) || (SIGLOST != SIGURG)) && (!defined(SIGPROF) || (SIGLOST != SIGPROF)) + case SIGLOST: return "SIGLOST"; +#endif +#ifdef SIGPIPE + case SIGPIPE: return "SIGPIPE"; +#endif +#if defined(SIGPOLL) && (!defined(SIGIO) || (SIGPOLL != SIGIO)) + case SIGPOLL: return "SIGPOLL"; +#endif +#ifdef SIGPROF + case SIGPROF: return "SIGPROF"; +#endif +#if defined(SIGPWR) && (!defined(SIGXFSZ) || (SIGPWR != SIGXFSZ)) + case SIGPWR: return "SIGPWR"; +#endif +#ifdef SIGQUIT + case SIGQUIT: return "SIGQUIT"; +#endif +#ifdef SIGSEGV + case SIGSEGV: return "SIGSEGV"; +#endif +#ifdef SIGSTOP + case SIGSTOP: return "SIGSTOP"; +#endif +#ifdef SIGSYS + case SIGSYS: return "SIGSYS"; +#endif +#ifdef SIGTERM + case SIGTERM: return "SIGTERM"; +#endif +#ifdef SIGTRAP + case SIGTRAP: return "SIGTRAP"; +#endif +#ifdef SIGTSTP + case SIGTSTP: return "SIGTSTP"; +#endif +#ifdef SIGTTIN + case SIGTTIN: return "SIGTTIN"; +#endif +#ifdef SIGTTOU + case SIGTTOU: return "SIGTTOU"; +#endif +#if defined(SIGURG) && (!defined(SIGIO) || (SIGURG != SIGIO)) + case SIGURG: return "SIGURG"; +#endif +#if defined(SIGUSR1) && (!defined(SIGIO) || (SIGUSR1 != SIGIO)) + case SIGUSR1: return "SIGUSR1"; +#endif +#if defined(SIGUSR2) && (!defined(SIGURG) || (SIGUSR2 != SIGURG)) + case SIGUSR2: return "SIGUSR2"; +#endif +#ifdef SIGVTALRM + case SIGVTALRM: return "SIGVTALRM"; +#endif +#ifdef SIGWINCH + case SIGWINCH: return "SIGWINCH"; +#endif +#ifdef SIGXCPU + case SIGXCPU: return "SIGXCPU"; +#endif +#ifdef SIGXFSZ + case SIGXFSZ: return "SIGXFSZ"; +#endif + } + return "unknown signal"; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_SignalMsg -- + * + * Return a human-readable message describing a signal. + * + * Results: + * This procedure returns a string describing sig that should + * make sense to a human. It may not be easy for a machine + * to parse. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +char * +Tcl_SignalMsg(sig) + int sig; /* Number of signal. */ +{ + switch (sig) { +#ifdef SIGABRT + case SIGABRT: return "SIGABRT"; +#endif +#ifdef SIGALRM + case SIGALRM: return "alarm clock"; +#endif +#ifdef SIGBUS + case SIGBUS: return "bus error"; +#endif +#ifdef SIGCHLD + case SIGCHLD: return "child status changed"; +#endif +#if defined(SIGCLD) && (!defined(SIGCHLD) || (SIGCLD != SIGCHLD)) + case SIGCLD: return "child status changed"; +#endif +#ifdef SIGCONT + case SIGCONT: return "continue after stop"; +#endif +#if defined(SIGEMT) && (!defined(SIGXCPU) || (SIGEMT != SIGXCPU)) + case SIGEMT: return "EMT instruction"; +#endif +#ifdef SIGFPE + case SIGFPE: return "floating-point exception"; +#endif +#ifdef SIGHUP + case SIGHUP: return "hangup"; +#endif +#ifdef SIGILL + case SIGILL: return "illegal instruction"; +#endif +#ifdef SIGINT + case SIGINT: return "interrupt"; +#endif +#ifdef SIGIO + case SIGIO: return "input/output possible on file"; +#endif +#if defined(SIGIOT) && (!defined(SIGABRT) || (SIGABRT != SIGIOT)) + case SIGIOT: return "IOT instruction"; +#endif +#ifdef SIGKILL + case SIGKILL: return "kill signal"; +#endif +#if defined(SIGLOST) && (!defined(SIGIOT) || (SIGLOST != SIGIOT)) && (!defined(SIGURG) || (SIGLOST != SIGURG)) + case SIGLOST: return "resource lost"; +#endif +#ifdef SIGPIPE + case SIGPIPE: return "write on pipe with no readers"; +#endif +#if defined(SIGPOLL) && (!defined(SIGIO) || (SIGPOLL != SIGIO)) + case SIGPOLL: return "input/output possible on file"; +#endif +#ifdef SIGPROF + case SIGPROF: return "profiling alarm"; +#endif +#if defined(SIGPWR) && (!defined(SIGXFSZ) || (SIGPWR != SIGXFSZ)) + case SIGPWR: return "power-fail restart"; +#endif +#ifdef SIGQUIT + case SIGQUIT: return "quit signal"; +#endif +#ifdef SIGSEGV + case SIGSEGV: return "segmentation violation"; +#endif +#ifdef SIGSTOP + case SIGSTOP: return "stop"; +#endif +#ifdef SIGSYS + case SIGSYS: return "bad argument to system call"; +#endif +#ifdef SIGTERM + case SIGTERM: return "software termination signal"; +#endif +#ifdef SIGTRAP + case SIGTRAP: return "trace trap"; +#endif +#ifdef SIGTSTP + case SIGTSTP: return "stop signal from tty"; +#endif +#ifdef SIGTTIN + case SIGTTIN: return "background tty read"; +#endif +#ifdef SIGTTOU + case SIGTTOU: return "background tty write"; +#endif +#if defined(SIGURG) && (!defined(SIGIO) || (SIGURG != SIGIO)) + case SIGURG: return "urgent I/O condition"; +#endif +#if defined(SIGUSR1) && (!defined(SIGIO) || (SIGUSR1 != SIGIO)) + case SIGUSR1: return "user-defined signal 1"; +#endif +#if defined(SIGUSR2) && (!defined(SIGURG) || (SIGUSR2 != SIGURG)) + case SIGUSR2: return "user-defined signal 2"; +#endif +#ifdef SIGVTALRM + case SIGVTALRM: return "virtual time alarm"; +#endif +#ifdef SIGWINCH + case SIGWINCH: return "window changed"; +#endif +#ifdef SIGXCPU + case SIGXCPU: return "exceeded CPU time limit"; +#endif +#ifdef SIGXFSZ + case SIGXFSZ: return "exceeded file size limit"; +#endif + } + return "unknown signal"; +} diff --git a/contrib/tcl/generic/tclPreserve.c b/contrib/tcl/generic/tclPreserve.c new file mode 100644 index 0000000..714fb54 --- /dev/null +++ b/contrib/tcl/generic/tclPreserve.c @@ -0,0 +1,275 @@ +/* + * tclPreserve.c -- + * + * This file contains a collection of procedures that are used + * to make sure that widget records and other data structures + * aren't reallocated when there are nested procedures that + * depend on their existence. + * + * Copyright (c) 1991-1994 The Regents of the University of California. + * Copyright (c) 1994-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: @(#) tclPreserve.c 1.14 96/03/20 08:24:37 + */ + +#include "tclInt.h" + +/* + * The following data structure is used to keep track of all the + * Tcl_Preserve calls that are still in effect. It grows as needed + * to accommodate any number of calls in effect. + */ + +typedef struct { + ClientData clientData; /* Address of preserved block. */ + int refCount; /* Number of Tcl_Preserve calls in effect + * for block. */ + int mustFree; /* Non-zero means Tcl_EventuallyFree was + * called while a Tcl_Preserve call was in + * effect, so the structure must be freed + * when refCount becomes zero. */ + Tcl_FreeProc *freeProc; /* Procedure to call to free. */ +} Reference; + +static Reference *refArray; /* First in array of references. */ +static int spaceAvl = 0; /* Total number of structures available + * at *firstRefPtr. */ +static int inUse = 0; /* Count of structures currently in use + * in refArray. */ +#define INITIAL_SIZE 2 + +/* + * Static routines in this file: + */ + +static void PreserveExitProc _ANSI_ARGS_((ClientData clientData)); + + +/* + *---------------------------------------------------------------------- + * + * PreserveExitProc -- + * + * Called during exit processing to clean up the reference array. + * + * Results: + * None. + * + * Side effects: + * Frees the storage of the reference array. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +static void +PreserveExitProc(clientData) + ClientData clientData; /* NULL -Unused. */ +{ + if (spaceAvl != 0) { + ckfree((char *) refArray); + refArray = (Reference *) NULL; + inUse = 0; + spaceAvl = 0; + } +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_Preserve -- + * + * This procedure is used by a procedure to declare its interest + * in a particular block of memory, so that the block will not be + * reallocated until a matching call to Tcl_Release has been made. + * + * Results: + * None. + * + * Side effects: + * Information is retained so that the block of memory will + * not be freed until at least the matching call to Tcl_Release. + * + *---------------------------------------------------------------------- + */ + +void +Tcl_Preserve(clientData) + ClientData clientData; /* Pointer to malloc'ed block of memory. */ +{ + Reference *refPtr; + int i; + + /* + * See if there is already a reference for this pointer. If so, + * just increment its reference count. + */ + + for (i = 0, refPtr = refArray; i < inUse; i++, refPtr++) { + if (refPtr->clientData == clientData) { + refPtr->refCount++; + return; + } + } + + /* + * Make a reference array if it doesn't already exist, or make it + * bigger if it is full. + */ + + if (inUse == spaceAvl) { + if (spaceAvl == 0) { + Tcl_CreateExitHandler((Tcl_ExitProc *) PreserveExitProc, + (ClientData) NULL); + refArray = (Reference *) ckalloc((unsigned) + (INITIAL_SIZE*sizeof(Reference))); + spaceAvl = INITIAL_SIZE; + } else { + Reference *new; + + new = (Reference *) ckalloc((unsigned) + (2*spaceAvl*sizeof(Reference))); + memcpy((VOID *) new, (VOID *) refArray, + spaceAvl*sizeof(Reference)); + ckfree((char *) refArray); + refArray = new; + spaceAvl *= 2; + } + } + + /* + * Make a new entry for the new reference. + */ + + refPtr = &refArray[inUse]; + refPtr->clientData = clientData; + refPtr->refCount = 1; + refPtr->mustFree = 0; + inUse += 1; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_Release -- + * + * This procedure is called to cancel a previous call to + * Tcl_Preserve, thereby allowing a block of memory to be + * freed (if no one else cares about it). + * + * Results: + * None. + * + * Side effects: + * If Tcl_EventuallyFree has been called for clientData, and if + * no other call to Tcl_Preserve is still in effect, the block of + * memory is freed. + * + *---------------------------------------------------------------------- + */ + +void +Tcl_Release(clientData) + ClientData clientData; /* Pointer to malloc'ed block of memory. */ +{ + Reference *refPtr; + int mustFree; + Tcl_FreeProc *freeProc; + int i; + + for (i = 0, refPtr = refArray; i < inUse; i++, refPtr++) { + if (refPtr->clientData != clientData) { + continue; + } + refPtr->refCount--; + if (refPtr->refCount == 0) { + + /* + * Must remove information from the slot before calling freeProc + * to avoid reentrancy problems if the freeProc calls Tcl_Preserve + * on the same clientData. Copy down the last reference in the + * array to overwrite the current slot. + */ + + freeProc = refPtr->freeProc; + mustFree = refPtr->mustFree; + inUse--; + if (i < inUse) { + refArray[i] = refArray[inUse]; + } + if (mustFree) { + if ((freeProc == TCL_DYNAMIC) || + (freeProc == (Tcl_FreeProc *) free)) { + ckfree((char *) clientData); + } else { + (*freeProc)((char *) clientData); + } + } + } + return; + } + + /* + * Reference not found. This is a bug in the caller. + */ + + panic("Tcl_Release couldn't find reference for 0x%x", clientData); +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_EventuallyFree -- + * + * Free up a block of memory, unless a call to Tcl_Preserve is in + * effect for that block. In this case, defer the free until all + * calls to Tcl_Preserve have been undone by matching calls to + * Tcl_Release. + * + * Results: + * None. + * + * Side effects: + * Ptr may be released by calling free(). + * + *---------------------------------------------------------------------- + */ + +void +Tcl_EventuallyFree(clientData, freeProc) + ClientData clientData; /* Pointer to malloc'ed block of memory. */ + Tcl_FreeProc *freeProc; /* Procedure to actually do free. */ +{ + Reference *refPtr; + int i; + + /* + * See if there is a reference for this pointer. If so, set its + * "mustFree" flag (the flag had better not be set already!). + */ + + for (i = 0, refPtr = refArray; i < inUse; i++, refPtr++) { + if (refPtr->clientData != clientData) { + continue; + } + if (refPtr->mustFree) { + panic("Tcl_EventuallyFree called twice for 0x%x\n", clientData); + } + refPtr->mustFree = 1; + refPtr->freeProc = freeProc; + return; + } + + /* + * No reference for this block. Free it now. + */ + + if ((freeProc == TCL_DYNAMIC) || (freeProc == (Tcl_FreeProc *) free)) { + ckfree((char *) clientData); + } else { + (*freeProc)((char *)clientData); + } +} diff --git a/contrib/tcl/generic/tclProc.c b/contrib/tcl/generic/tclProc.c new file mode 100644 index 0000000..0b34e23 --- /dev/null +++ b/contrib/tcl/generic/tclProc.c @@ -0,0 +1,658 @@ +/* + * tclProc.c -- + * + * This file contains routines that implement Tcl procedures, + * including the "proc" and "uplevel" commands. + * + * Copyright (c) 1987-1993 The Regents of the University of California. + * Copyright (c) 1994-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: @(#) tclProc.c 1.72 96/02/15 11:42:48 + */ + +#include "tclInt.h" + +/* + * Forward references to procedures defined later in this file: + */ + +static void CleanupProc _ANSI_ARGS_((Proc *procPtr)); +static int InterpProc _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int argc, char **argv)); +static void ProcDeleteProc _ANSI_ARGS_((ClientData clientData)); + +/* + *---------------------------------------------------------------------- + * + * Tcl_ProcCmd -- + * + * This procedure is invoked to process the "proc" Tcl command. + * See the user documentation for details on what it does. + * + * Results: + * A standard Tcl result value. + * + * Side effects: + * A new procedure gets created. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +int +Tcl_ProcCmd(dummy, interp, argc, argv) + ClientData dummy; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ + register Interp *iPtr = (Interp *) interp; + register Proc *procPtr; + int result, argCount, i; + char **argArray = NULL; + Arg *lastArgPtr; + register Arg *argPtr = NULL; /* Initialization not needed, but + * prevents compiler warning. */ + + if (argc != 4) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " name args body\"", (char *) NULL); + return TCL_ERROR; + } + + procPtr = (Proc *) ckalloc(sizeof(Proc)); + procPtr->iPtr = iPtr; + procPtr->refCount = 1; + procPtr->command = (char *) ckalloc((unsigned) strlen(argv[3]) + 1); + strcpy(procPtr->command, argv[3]); + procPtr->argPtr = NULL; + + /* + * Break up the argument list into argument specifiers, then process + * each argument specifier. + */ + + result = Tcl_SplitList(interp, argv[2], &argCount, &argArray); + if (result != TCL_OK) { + goto procError; + } + lastArgPtr = NULL; + for (i = 0; i < argCount; i++) { + int fieldCount, nameLength, valueLength; + char **fieldValues; + + /* + * Now divide the specifier up into name and default. + */ + + result = Tcl_SplitList(interp, argArray[i], &fieldCount, + &fieldValues); + if (result != TCL_OK) { + goto procError; + } + if (fieldCount > 2) { + ckfree((char *) fieldValues); + Tcl_AppendResult(interp, + "too many fields in argument specifier \"", + argArray[i], "\"", (char *) NULL); + result = TCL_ERROR; + goto procError; + } + if ((fieldCount == 0) || (*fieldValues[0] == 0)) { + ckfree((char *) fieldValues); + Tcl_AppendResult(interp, "procedure \"", argv[1], + "\" has argument with no name", (char *) NULL); + result = TCL_ERROR; + goto procError; + } + nameLength = strlen(fieldValues[0]) + 1; + if (fieldCount == 2) { + valueLength = strlen(fieldValues[1]) + 1; + } else { + valueLength = 0; + } + argPtr = (Arg *) ckalloc((unsigned) + (sizeof(Arg) - sizeof(argPtr->name) + nameLength + + valueLength)); + if (lastArgPtr == NULL) { + procPtr->argPtr = argPtr; + } else { + lastArgPtr->nextPtr = argPtr; + } + lastArgPtr = argPtr; + argPtr->nextPtr = NULL; + strcpy(argPtr->name, fieldValues[0]); + if (fieldCount == 2) { + argPtr->defValue = argPtr->name + nameLength; + strcpy(argPtr->defValue, fieldValues[1]); + } else { + argPtr->defValue = NULL; + } + ckfree((char *) fieldValues); + } + + Tcl_CreateCommand(interp, argv[1], InterpProc, (ClientData) procPtr, + ProcDeleteProc); + ckfree((char *) argArray); + return TCL_OK; + + procError: + ckfree(procPtr->command); + while (procPtr->argPtr != NULL) { + argPtr = procPtr->argPtr; + procPtr->argPtr = argPtr->nextPtr; + ckfree((char *) argPtr); + } + ckfree((char *) procPtr); + if (argArray != NULL) { + ckfree((char *) argArray); + } + return result; +} + +/* + *---------------------------------------------------------------------- + * + * TclGetFrame -- + * + * Given a description of a procedure frame, such as the first + * argument to an "uplevel" or "upvar" command, locate the + * call frame for the appropriate level of procedure. + * + * Results: + * The return value is -1 if an error occurred in finding the + * frame (in this case an error message is left in interp->result). + * 1 is returned if string was either a number or a number preceded + * by "#" and it specified a valid frame. 0 is returned if string + * isn't one of the two things above (in this case, the lookup + * acts as if string were "1"). The variable pointed to by + * framePtrPtr is filled in with the address of the desired frame + * (unless an error occurs, in which case it isn't modified). + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +int +TclGetFrame(interp, string, framePtrPtr) + Tcl_Interp *interp; /* Interpreter in which to find frame. */ + char *string; /* String describing frame. */ + CallFrame **framePtrPtr; /* Store pointer to frame here (or NULL + * if global frame indicated). */ +{ + register Interp *iPtr = (Interp *) interp; + int curLevel, level, result; + CallFrame *framePtr; + + /* + * Parse string to figure out which level number to go to. + */ + + result = 1; + curLevel = (iPtr->varFramePtr == NULL) ? 0 : iPtr->varFramePtr->level; + if (*string == '#') { + if (Tcl_GetInt(interp, string+1, &level) != TCL_OK) { + return -1; + } + if (level < 0) { + levelError: + Tcl_AppendResult(interp, "bad level \"", string, "\"", + (char *) NULL); + return -1; + } + } else if (isdigit(UCHAR(*string))) { + if (Tcl_GetInt(interp, string, &level) != TCL_OK) { + return -1; + } + level = curLevel - level; + } else { + level = curLevel - 1; + result = 0; + } + + /* + * Figure out which frame to use, and modify the interpreter so + * its variables come from that frame. + */ + + if (level == 0) { + framePtr = NULL; + } else { + for (framePtr = iPtr->varFramePtr; framePtr != NULL; + framePtr = framePtr->callerVarPtr) { + if (framePtr->level == level) { + break; + } + } + if (framePtr == NULL) { + goto levelError; + } + } + *framePtrPtr = framePtr; + return result; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_UplevelCmd -- + * + * This procedure is invoked to process the "uplevel" Tcl command. + * See the user documentation for details on what it does. + * + * Results: + * A standard Tcl result value. + * + * Side effects: + * See the user documentation. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +int +Tcl_UplevelCmd(dummy, interp, argc, argv) + ClientData dummy; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ + register Interp *iPtr = (Interp *) interp; + int result; + CallFrame *savedVarFramePtr, *framePtr; + + if (argc < 2) { + uplevelSyntax: + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " ?level? command ?arg ...?\"", (char *) NULL); + return TCL_ERROR; + } + + /* + * Find the level to use for executing the command. + */ + + result = TclGetFrame(interp, argv[1], &framePtr); + if (result == -1) { + return TCL_ERROR; + } + argc -= (result+1); + if (argc == 0) { + goto uplevelSyntax; + } + argv += (result+1); + + /* + * Modify the interpreter state to execute in the given frame. + */ + + savedVarFramePtr = iPtr->varFramePtr; + iPtr->varFramePtr = framePtr; + + /* + * Execute the residual arguments as a command. + */ + + if (argc == 1) { + result = Tcl_Eval(interp, argv[0]); + } else { + char *cmd; + + cmd = Tcl_Concat(argc, argv); + result = Tcl_Eval(interp, cmd); + ckfree(cmd); + } + if (result == TCL_ERROR) { + char msg[60]; + sprintf(msg, "\n (\"uplevel\" body line %d)", interp->errorLine); + Tcl_AddErrorInfo(interp, msg); + } + + /* + * Restore the variable frame, and return. + */ + + iPtr->varFramePtr = savedVarFramePtr; + return result; +} + +/* + *---------------------------------------------------------------------- + * + * TclFindProc -- + * + * Given the name of a procedure, return a pointer to the + * record describing the procedure. + * + * Results: + * NULL is returned if the name doesn't correspond to any + * procedure. Otherwise the return value is a pointer to + * the procedure's record. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +Proc * +TclFindProc(iPtr, procName) + Interp *iPtr; /* Interpreter in which to look. */ + char *procName; /* Name of desired procedure. */ +{ + Tcl_HashEntry *hPtr; + Command *cmdPtr; + + hPtr = Tcl_FindHashEntry(&iPtr->commandTable, procName); + if (hPtr == NULL) { + return NULL; + } + cmdPtr = (Command *) Tcl_GetHashValue(hPtr); + if (cmdPtr->proc != InterpProc) { + return NULL; + } + return (Proc *) cmdPtr->clientData; +} + +/* + *---------------------------------------------------------------------- + * + * TclIsProc -- + * + * Tells whether a command is a Tcl procedure or not. + * + * Results: + * If the given command is actuall a Tcl procedure, the + * return value is the address of the record describing + * the procedure. Otherwise the return value is 0. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +Proc * +TclIsProc(cmdPtr) + Command *cmdPtr; /* Command to test. */ +{ + if (cmdPtr->proc == InterpProc) { + return (Proc *) cmdPtr->clientData; + } + return (Proc *) 0; +} + +/* + *---------------------------------------------------------------------- + * + * InterpProc -- + * + * When a Tcl procedure gets invoked, this routine gets invoked + * to interpret the procedure. + * + * Results: + * A standard Tcl result value, usually TCL_OK. + * + * Side effects: + * Depends on the commands in the procedure. + * + *---------------------------------------------------------------------- + */ + +static int +InterpProc(clientData, interp, argc, argv) + ClientData clientData; /* Record describing procedure to be + * interpreted. */ + Tcl_Interp *interp; /* Interpreter in which procedure was + * invoked. */ + int argc; /* Count of number of arguments to this + * procedure. */ + char **argv; /* Argument values. */ +{ + register Proc *procPtr = (Proc *) clientData; + register Arg *argPtr; + register Interp *iPtr; + char **args; + CallFrame frame; + char *value; + int result; + + /* + * Set up a call frame for the new procedure invocation. + */ + + iPtr = procPtr->iPtr; + Tcl_InitHashTable(&frame.varTable, TCL_STRING_KEYS); + if (iPtr->varFramePtr != NULL) { + frame.level = iPtr->varFramePtr->level + 1; + } else { + frame.level = 1; + } + frame.argc = argc; + frame.argv = argv; + frame.callerPtr = iPtr->framePtr; + frame.callerVarPtr = iPtr->varFramePtr; + iPtr->framePtr = &frame; + iPtr->varFramePtr = &frame; + iPtr->returnCode = TCL_OK; + + /* + * Match the actual arguments against the procedure's formal + * parameters to compute local variables. + */ + + for (argPtr = procPtr->argPtr, args = argv+1, argc -= 1; + argPtr != NULL; + argPtr = argPtr->nextPtr, args++, argc--) { + + /* + * Handle the special case of the last formal being "args". When + * it occurs, assign it a list consisting of all the remaining + * actual arguments. + */ + + if ((argPtr->nextPtr == NULL) + && (strcmp(argPtr->name, "args") == 0)) { + if (argc < 0) { + argc = 0; + } + value = Tcl_Merge(argc, args); + Tcl_SetVar(interp, argPtr->name, value, 0); + ckfree(value); + argc = 0; + break; + } else if (argc > 0) { + value = *args; + } else if (argPtr->defValue != NULL) { + value = argPtr->defValue; + } else { + Tcl_AppendResult(interp, "no value given for parameter \"", + argPtr->name, "\" to \"", argv[0], "\"", + (char *) NULL); + result = TCL_ERROR; + goto procDone; + } + Tcl_SetVar(interp, argPtr->name, value, 0); + } + if (argc > 0) { + Tcl_AppendResult(interp, "called \"", argv[0], + "\" with too many arguments", (char *) NULL); + result = TCL_ERROR; + goto procDone; + } + + /* + * Invoke the commands in the procedure's body. + */ + + procPtr->refCount++; + result = Tcl_Eval(interp, procPtr->command); + procPtr->refCount--; + if (procPtr->refCount <= 0) { + CleanupProc(procPtr); + } + if (result == TCL_RETURN) { + result = TclUpdateReturnInfo(iPtr); + } else if (result == TCL_ERROR) { + char msg[100]; + + /* + * Record information telling where the error occurred. + */ + + sprintf(msg, "\n (procedure \"%.50s\" line %d)", argv[0], + iPtr->errorLine); + Tcl_AddErrorInfo(interp, msg); + } else if (result == TCL_BREAK) { + iPtr->result = "invoked \"break\" outside of a loop"; + result = TCL_ERROR; + } else if (result == TCL_CONTINUE) { + iPtr->result = "invoked \"continue\" outside of a loop"; + result = TCL_ERROR; + } + + /* + * Delete the call frame for this procedure invocation (it's + * important to remove the call frame from the interpreter + * before deleting it, so that traces invoked during the + * deletion don't see the partially-deleted frame). + */ + + procDone: + iPtr->framePtr = frame.callerPtr; + iPtr->varFramePtr = frame.callerVarPtr; + + /* + * The check below is a hack. The problem is that there could be + * unset traces on the variables, which cause scripts to be evaluated. + * This will clear the ERR_IN_PROGRESS flag, losing stack trace + * information if the procedure was exiting with an error. The + * code below preserves the flag. Unfortunately, that isn't + * really enough: we really should preserve the errorInfo variable + * too (otherwise a nested error in the trace script will trash + * errorInfo). What's really needed is a general-purpose + * mechanism for saving and restoring interpreter state. + */ + + if (iPtr->flags & ERR_IN_PROGRESS) { + TclDeleteVars(iPtr, &frame.varTable); + iPtr->flags |= ERR_IN_PROGRESS; + } else { + TclDeleteVars(iPtr, &frame.varTable); + } + return result; +} + +/* + *---------------------------------------------------------------------- + * + * ProcDeleteProc -- + * + * This procedure is invoked just before a command procedure is + * removed from an interpreter. Its job is to release all the + * resources allocated to the procedure. + * + * Results: + * None. + * + * Side effects: + * Memory gets freed, unless the procedure is actively being + * executed. In this case the cleanup is delayed until the + * last call to the current procedure completes. + * + *---------------------------------------------------------------------- + */ + +static void +ProcDeleteProc(clientData) + ClientData clientData; /* Procedure to be deleted. */ +{ + Proc *procPtr = (Proc *) clientData; + + procPtr->refCount--; + if (procPtr->refCount <= 0) { + CleanupProc(procPtr); + } +} + +/* + *---------------------------------------------------------------------- + * + * CleanupProc -- + * + * This procedure does all the real work of freeing up a Proc + * structure. It's called only when the structure's reference + * count becomes zero. + * + * Results: + * None. + * + * Side effects: + * Memory gets freed. + * + *---------------------------------------------------------------------- + */ + +static void +CleanupProc(procPtr) + register Proc *procPtr; /* Procedure to be deleted. */ +{ + register Arg *argPtr; + + ckfree((char *) procPtr->command); + for (argPtr = procPtr->argPtr; argPtr != NULL; ) { + Arg *nextPtr = argPtr->nextPtr; + + ckfree((char *) argPtr); + argPtr = nextPtr; + } + ckfree((char *) procPtr); +} + +/* + *---------------------------------------------------------------------- + * + * TclUpdateReturnInfo -- + * + * This procedure is called when procedures return, and at other + * points where the TCL_RETURN code is used. It examines fields + * such as iPtr->returnCode and iPtr->errorCode and modifies + * the real return status accordingly. + * + * Results: + * The return value is the true completion code to use for + * the procedure, instead of TCL_RETURN. + * + * Side effects: + * The errorInfo and errorCode variables may get modified. + * + *---------------------------------------------------------------------- + */ + +int +TclUpdateReturnInfo(iPtr) + Interp *iPtr; /* Interpreter for which TCL_RETURN + * exception is being processed. */ +{ + int code; + + 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", + 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); + iPtr->flags |= ERR_IN_PROGRESS; + } + } + return code; +} diff --git a/contrib/tcl/generic/tclRegexp.h b/contrib/tcl/generic/tclRegexp.h new file mode 100644 index 0000000..986316b --- /dev/null +++ b/contrib/tcl/generic/tclRegexp.h @@ -0,0 +1,40 @@ +/* + * Definitions etc. for regexp(3) routines. + * + * Caveat: this is V8 regexp(3) [actually, a reimplementation thereof], + * not the System V one. + * + * SCCS: @(#) tclRegexp.h 1.6 96/04/02 18:43:57 + */ + +#ifndef _REGEXP +#define _REGEXP 1 + +#ifndef _TCL +#include "tcl.h" +#endif + +/* + * NSUBEXP must be at least 10, and no greater than 117 or the parser + * will not work properly. + */ + +#define NSUBEXP 20 + +typedef struct regexp { + char *startp[NSUBEXP]; + char *endp[NSUBEXP]; + char regstart; /* Internal use only. */ + char reganch; /* Internal use only. */ + char *regmust; /* Internal use only. */ + int regmlen; /* Internal use only. */ + char program[1]; /* Unwarranted chumminess with compiler. */ +} regexp; + +EXTERN regexp *TclRegComp _ANSI_ARGS_((char *exp)); +EXTERN int TclRegExec _ANSI_ARGS_((regexp *prog, char *string, char *start)); +EXTERN void TclRegSub _ANSI_ARGS_((regexp *prog, char *source, char *dest)); +EXTERN void TclRegError _ANSI_ARGS_((char *msg)); +EXTERN char *TclGetRegError _ANSI_ARGS_((void)); + +#endif /* REGEXP */ diff --git a/contrib/tcl/generic/tclTest.c b/contrib/tcl/generic/tclTest.c new file mode 100644 index 0000000..74ff0e2 --- /dev/null +++ b/contrib/tcl/generic/tclTest.c @@ -0,0 +1,1932 @@ +/* + * tclTest.c -- + * + * This file contains C command procedures for a bunch of additional + * Tcl commands that are used for testing out Tcl's C interfaces. + * These commands are not normally included in Tcl applications; + * they're only used for testing. + * + * 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: @(#) tclTest.c 1.78 96/04/11 14:50:51 + */ + +#include "tclInt.h" +#include "tclPort.h" + +/* + * Declare external functions used in Windows tests. + */ + +#if defined(__WIN32__) +extern TclPlatformType * TclWinGetPlatform _ANSI_ARGS_((void)); +#endif + +/* + * Dynamic string shared by TestdcallCmd and DelCallbackProc; used + * to collect the results of the various deletion callbacks. + */ + +static Tcl_DString delString; +static Tcl_Interp *delInterp; + +/* + * One of the following structures exists for each asynchronous + * handler created by the "testasync" command". + */ + +typedef struct TestAsyncHandler { + int id; /* Identifier for this handler. */ + Tcl_AsyncHandler handler; /* Tcl's token for the handler. */ + char *command; /* Command to invoke when the + * handler is invoked. */ + struct TestAsyncHandler *nextPtr; /* Next is list of handlers. */ +} TestAsyncHandler; + +static TestAsyncHandler *firstHandler = NULL; + +/* + * The dynamic string below is used by the "testdstring" command + * to test the dynamic string facilities. + */ + +static Tcl_DString dstring; + +/* + * One of the following structures exists for each command created + * by TestdelCmd: + */ + +typedef struct DelCmd { + Tcl_Interp *interp; /* Interpreter in which command exists. */ + char *deleteCmd; /* Script to execute when command is + * deleted. Malloc'ed. */ +} DelCmd; + +/* + * The following structure is used to keep track of modal timeout + * handlers created by the "testmodal" command. + */ + +typedef struct Modal { + Tcl_Interp *interp; /* Interpreter in which to set variable + * "x" when timer fires. */ + char *key; /* Null-terminated string to store in + * global variable "x" in interp when + * timer fires. Malloc-ed. */ +} Modal; + +/* + * Forward declarations for procedures defined later in this file: + */ + +int Tcltest_Init _ANSI_ARGS_((Tcl_Interp *interp)); +static int AsyncHandlerProc _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int code)); +static void CleanupTestSetassocdataTests _ANSI_ARGS_(( + ClientData clientData, Tcl_Interp *interp)); +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)); +static int CmdProc2 _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int argc, 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)); +static void DelDeleteProc _ANSI_ARGS_((ClientData clientData)); +static void ExitProcEven _ANSI_ARGS_((ClientData clientData)); +static void ExitProcOdd _ANSI_ARGS_((ClientData clientData)); +static void ModalTimeoutProc _ANSI_ARGS_((ClientData clientData)); +static void SpecialFree _ANSI_ARGS_((char *blockPtr)); +static int StaticInitProc _ANSI_ARGS_((Tcl_Interp *interp)); +static int TestasyncCmd _ANSI_ARGS_((ClientData dummy, + Tcl_Interp *interp, int argc, char **argv)); +static int TestcmdinfoCmd _ANSI_ARGS_((ClientData dummy, + Tcl_Interp *interp, int argc, char **argv)); +static int TestcmdtokenCmd _ANSI_ARGS_((ClientData dummy, + Tcl_Interp *interp, int argc, char **argv)); +static int TestdcallCmd _ANSI_ARGS_((ClientData dummy, + Tcl_Interp *interp, int argc, char **argv)); +static int TestdelCmd _ANSI_ARGS_((ClientData dummy, + Tcl_Interp *interp, int argc, char **argv)); +static int TestdelassocdataCmd _ANSI_ARGS_((ClientData dummy, + Tcl_Interp *interp, int argc, char **argv)); +static int TestdstringCmd _ANSI_ARGS_((ClientData dummy, + Tcl_Interp *interp, int argc, char **argv)); +static int TestexithandlerCmd _ANSI_ARGS_((ClientData dummy, + Tcl_Interp *interp, int argc, char **argv)); +static int TestfilewaitCmd _ANSI_ARGS_((ClientData dummy, + Tcl_Interp *interp, int argc, char **argv)); +static int TestgetassocdataCmd _ANSI_ARGS_((ClientData dummy, + Tcl_Interp *interp, int argc, char **argv)); +static int TestgetplatformCmd _ANSI_ARGS_((ClientData dummy, + Tcl_Interp *interp, int argc, char **argv)); +static int TestfhandleCmd _ANSI_ARGS_((ClientData dummy, + Tcl_Interp *interp, int argc, char **argv)); +static int TestinterpdeleteCmd _ANSI_ARGS_((ClientData dummy, + Tcl_Interp *interp, int argc, char **argv)); +static int TestlinkCmd _ANSI_ARGS_((ClientData dummy, + Tcl_Interp *interp, int argc, char **argv)); +static int TestMathFunc _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, Tcl_Value *args, + Tcl_Value *resultPtr)); +static int TestmodalCmd _ANSI_ARGS_((ClientData dummy, + Tcl_Interp *interp, int argc, char **argv)); +static int TestsetassocdataCmd _ANSI_ARGS_((ClientData dummy, + Tcl_Interp *interp, int argc, char **argv)); +static int TestsetplatformCmd _ANSI_ARGS_((ClientData dummy, + Tcl_Interp *interp, int argc, char **argv)); +static int TeststaticpkgCmd _ANSI_ARGS_((ClientData dummy, + Tcl_Interp *interp, int argc, char **argv)); +static int TesttranslatefilenameCmd _ANSI_ARGS_((ClientData dummy, + Tcl_Interp *interp, int argc, char **argv)); +static int TestupvarCmd _ANSI_ARGS_((ClientData dummy, + Tcl_Interp *interp, int argc, char **argv)); +static int TestwordendCmd _ANSI_ARGS_((ClientData dummy, + Tcl_Interp *interp, int argc, char **argv)); +static int TestfeventCmd _ANSI_ARGS_((ClientData dummy, + Tcl_Interp *interp, int argc, char **argv)); +static int TestPanicCmd _ANSI_ARGS_((ClientData dummy, + Tcl_Interp *interp, int argc, char **argv)); + +/* + * External (platform specific) initialization routine: + */ + +EXTERN int TclplatformtestInit _ANSI_ARGS_(( + Tcl_Interp *interp)); + +/* + *---------------------------------------------------------------------- + * + * Tcltest_Init -- + * + * This procedure performs application-specific initialization. + * Most applications, especially those that incorporate additional + * packages, will have their own version of this procedure. + * + * Results: + * Returns a standard Tcl completion code, and leaves an error + * message in interp->result if an error occurs. + * + * Side effects: + * Depends on the startup script. + * + *---------------------------------------------------------------------- + */ + +int +Tcltest_Init(interp) + Tcl_Interp *interp; /* Interpreter for application. */ +{ + if (Tcl_PkgProvide(interp, "Tcltest", "7.5") == TCL_ERROR) { + return TCL_ERROR; + } + + /* + * Create additional commands and math functions for testing Tcl. + */ + + Tcl_CreateCommand(interp, "testasync", TestasyncCmd, (ClientData) 0, + (Tcl_CmdDeleteProc *) NULL); + Tcl_CreateCommand(interp, "testchannel", TclTestChannelCmd, + (ClientData) 0, (Tcl_CmdDeleteProc *) NULL); + Tcl_CreateCommand(interp, "testchannelevent", TclTestChannelEventCmd, + (ClientData) 0, (Tcl_CmdDeleteProc *) NULL); + Tcl_CreateCommand(interp, "testcmdtoken", TestcmdtokenCmd, (ClientData) 0, + (Tcl_CmdDeleteProc *) NULL); + Tcl_CreateCommand(interp, "testcmdinfo", TestcmdinfoCmd, (ClientData) 0, + (Tcl_CmdDeleteProc *) NULL); + Tcl_CreateCommand(interp, "testdcall", TestdcallCmd, (ClientData) 0, + (Tcl_CmdDeleteProc *) NULL); + Tcl_CreateCommand(interp, "testdel", TestdelCmd, (ClientData) 0, + (Tcl_CmdDeleteProc *) NULL); + Tcl_CreateCommand(interp, "testdelassocdata", TestdelassocdataCmd, + (ClientData) 0, (Tcl_CmdDeleteProc *) NULL); + Tcl_DStringInit(&dstring); + Tcl_CreateCommand(interp, "testdstring", TestdstringCmd, (ClientData) 0, + (Tcl_CmdDeleteProc *) NULL); + Tcl_CreateCommand(interp, "testexithandler", TestexithandlerCmd, + (ClientData) 0, (Tcl_CmdDeleteProc *) NULL); + Tcl_CreateCommand(interp, "testfhandle", TestfhandleCmd, + (ClientData) 0, (Tcl_CmdDeleteProc *) NULL); + Tcl_CreateCommand(interp, "testfilewait", TestfilewaitCmd, + (ClientData) 0, (Tcl_CmdDeleteProc *) NULL); + Tcl_CreateCommand(interp, "testgetassocdata", TestgetassocdataCmd, + (ClientData) 0, (Tcl_CmdDeleteProc *) NULL); + Tcl_CreateCommand(interp, "testgetplatform", TestgetplatformCmd, + (ClientData) 0, (Tcl_CmdDeleteProc *) NULL); + Tcl_CreateCommand(interp, "testinterpdelete", TestinterpdeleteCmd, + (ClientData) 0, (Tcl_CmdDeleteProc *) NULL); + Tcl_CreateCommand(interp, "testlink", TestlinkCmd, (ClientData) 0, + (Tcl_CmdDeleteProc *) NULL); + Tcl_CreateCommand(interp, "testmodal", TestmodalCmd, + (ClientData) 0, (Tcl_CmdDeleteProc *) NULL); + Tcl_CreateCommand(interp, "testsetassocdata", TestsetassocdataCmd, + (ClientData) 0, (Tcl_CmdDeleteProc *) NULL); + Tcl_CreateCommand(interp, "testsetplatform", TestsetplatformCmd, + (ClientData) 0, (Tcl_CmdDeleteProc *) NULL); + Tcl_CreateCommand(interp, "teststaticpkg", TeststaticpkgCmd, + (ClientData) 0, (Tcl_CmdDeleteProc *) NULL); + Tcl_CreateCommand(interp, "testtranslatefilename", + TesttranslatefilenameCmd, (ClientData) 0, + (Tcl_CmdDeleteProc *) NULL); + Tcl_CreateCommand(interp, "testupvar", TestupvarCmd, (ClientData) 0, + (Tcl_CmdDeleteProc *) NULL); + Tcl_CreateCommand(interp, "testwordend", TestwordendCmd, (ClientData) 0, + (Tcl_CmdDeleteProc *) NULL); + Tcl_CreateCommand(interp, "testfevent", TestfeventCmd, (ClientData) 0, + (Tcl_CmdDeleteProc *) NULL); + Tcl_CreateCommand(interp, "testpanic", TestPanicCmd, (ClientData) 0, + (Tcl_CmdDeleteProc *) NULL); + Tcl_CreateMathFunc(interp, "T1", 0, (Tcl_ValueType *) NULL, TestMathFunc, + (ClientData) 123); + Tcl_CreateMathFunc(interp, "T2", 0, (Tcl_ValueType *) NULL, TestMathFunc, + (ClientData) 345); + + /* + * And finally add any platform specific test commands. + */ + + return TclplatformtestInit(interp); +} + +/* + *---------------------------------------------------------------------- + * + * TestasyncCmd -- + * + * This procedure implements the "testasync" command. It is used + * to test the asynchronous handler facilities of Tcl. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * Creates, deletes, and invokes handlers. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +static int +TestasyncCmd(dummy, interp, argc, argv) + ClientData dummy; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ + TestAsyncHandler *asyncPtr, *prevPtr; + int id, code; + static int nextId = 1; + + if (argc < 2) { + wrongNumArgs: + interp->result = "wrong # args"; + return TCL_ERROR; + } + if (strcmp(argv[1], "create") == 0) { + if (argc != 3) { + goto wrongNumArgs; + } + asyncPtr = (TestAsyncHandler *) ckalloc(sizeof(TestAsyncHandler)); + asyncPtr->id = nextId; + nextId++; + asyncPtr->handler = Tcl_AsyncCreate(AsyncHandlerProc, + (ClientData) asyncPtr); + asyncPtr->command = (char *) ckalloc((unsigned) (strlen(argv[2]) + 1)); + strcpy(asyncPtr->command, argv[2]); + asyncPtr->nextPtr = firstHandler; + firstHandler = asyncPtr; + sprintf(interp->result, "%d", asyncPtr->id); + } else if (strcmp(argv[1], "delete") == 0) { + if (argc == 2) { + while (firstHandler != NULL) { + asyncPtr = firstHandler; + firstHandler = asyncPtr->nextPtr; + Tcl_AsyncDelete(asyncPtr->handler); + ckfree(asyncPtr->command); + ckfree((char *) asyncPtr); + } + return TCL_OK; + } + if (argc != 3) { + goto wrongNumArgs; + } + if (Tcl_GetInt(interp, argv[2], &id) != TCL_OK) { + return TCL_ERROR; + } + for (prevPtr = NULL, asyncPtr = firstHandler; asyncPtr != NULL; + prevPtr = asyncPtr, asyncPtr = asyncPtr->nextPtr) { + if (asyncPtr->id != id) { + continue; + } + if (prevPtr == NULL) { + firstHandler = asyncPtr->nextPtr; + } else { + prevPtr->nextPtr = asyncPtr->nextPtr; + } + Tcl_AsyncDelete(asyncPtr->handler); + ckfree(asyncPtr->command); + ckfree((char *) asyncPtr); + break; + } + } else if (strcmp(argv[1], "mark") == 0) { + if (argc != 5) { + goto wrongNumArgs; + } + if ((Tcl_GetInt(interp, argv[2], &id) != TCL_OK) + || (Tcl_GetInt(interp, argv[4], &code) != TCL_OK)) { + return TCL_ERROR; + } + for (asyncPtr = firstHandler; asyncPtr != NULL; + asyncPtr = asyncPtr->nextPtr) { + if (asyncPtr->id == id) { + Tcl_AsyncMark(asyncPtr->handler); + break; + } + } + Tcl_SetResult(interp, argv[3], TCL_VOLATILE); + return code; + } else { + Tcl_AppendResult(interp, "bad option \"", argv[1], + "\": must be create, delete, int, or mark", + (char *) NULL); + return TCL_ERROR; + } + return TCL_OK; +} + +static int +AsyncHandlerProc(clientData, interp, code) + ClientData clientData; /* Pointer to TestAsyncHandler structure. */ + Tcl_Interp *interp; /* Interpreter in which command was + * executed, or NULL. */ + int code; /* Current return code from command. */ +{ + TestAsyncHandler *asyncPtr = (TestAsyncHandler *) clientData; + char *listArgv[4]; + char string[20], *cmd; + + sprintf(string, "%d", code); + listArgv[0] = asyncPtr->command; + listArgv[1] = interp->result; + listArgv[2] = string; + listArgv[3] = NULL; + cmd = Tcl_Merge(3, listArgv); + code = Tcl_Eval(interp, cmd); + ckfree(cmd); + return code; +} + +/* + *---------------------------------------------------------------------- + * + * TestcmdinfoCmd -- + * + * This procedure implements the "testcmdinfo" command. It is used + * to test Tcl_GetCommandInfo, Tcl_SetCommandInfo, and command creation + * and deletion. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * Creates and deletes various commands and modifies their data. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +static int +TestcmdinfoCmd(dummy, interp, argc, argv) + ClientData dummy; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ + Tcl_CmdInfo info; + + if (argc != 3) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " option cmdName\"", (char *) NULL); + return TCL_ERROR; + } + if (strcmp(argv[1], "create") == 0) { + Tcl_CreateCommand(interp, argv[2], CmdProc1, (ClientData) "original", + CmdDelProc1); + } else if (strcmp(argv[1], "delete") == 0) { + Tcl_DStringInit(&delString); + Tcl_DeleteCommand(interp, argv[2]); + Tcl_DStringResult(interp, &delString); + } else if (strcmp(argv[1], "get") == 0) { + if (Tcl_GetCommandInfo(interp, argv[2], &info) ==0) { + interp->result = "??"; + return TCL_OK; + } + if (info.proc == CmdProc1) { + Tcl_AppendResult(interp, "CmdProc1", " ", + (char *) info.clientData, (char *) NULL); + } else if (info.proc == CmdProc2) { + Tcl_AppendResult(interp, "CmdProc2", " ", + (char *) info.clientData, (char *) NULL); + } else { + Tcl_AppendResult(interp, "unknown", (char *) NULL); + } + if (info.deleteProc == CmdDelProc1) { + Tcl_AppendResult(interp, " CmdDelProc1", " ", + (char *) info.deleteData, (char *) NULL); + } else if (info.deleteProc == CmdDelProc2) { + Tcl_AppendResult(interp, " CmdDelProc2", " ", + (char *) info.deleteData, (char *) NULL); + } else { + Tcl_AppendResult(interp, " unknown", (char *) NULL); + } + } else if (strcmp(argv[1], "modify") == 0) { + info.proc = CmdProc2; + info.clientData = (ClientData) "new_command_data"; + info.deleteProc = CmdDelProc2; + info.deleteData = (ClientData) "new_delete_data"; + if (Tcl_SetCommandInfo(interp, argv[2], &info) == 0) { + interp->result = "0"; + } else { + interp->result = "1"; + } + } else { + Tcl_AppendResult(interp, "bad option \"", argv[1], + "\": must be create, delete, get, or modify", + (char *) NULL); + return TCL_ERROR; + } + return TCL_OK; +} + + /*ARGSUSED*/ +static int +CmdProc1(clientData, interp, argc, argv) + ClientData clientData; /* String to return. */ + Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ + Tcl_AppendResult(interp, "CmdProc1 ", (char *) clientData, + (char *) NULL); + return TCL_OK; +} + + /*ARGSUSED*/ +static int +CmdProc2(clientData, interp, argc, argv) + ClientData clientData; /* String to return. */ + Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ + Tcl_AppendResult(interp, "CmdProc2 ", (char *) clientData, + (char *) NULL); + return TCL_OK; +} + +static void +CmdDelProc1(clientData) + ClientData clientData; /* String to save. */ +{ + Tcl_DStringInit(&delString); + Tcl_DStringAppend(&delString, "CmdDelProc1 ", -1); + Tcl_DStringAppend(&delString, (char *) clientData, -1); +} + +static void +CmdDelProc2(clientData) + ClientData clientData; /* String to save. */ +{ + Tcl_DStringInit(&delString); + Tcl_DStringAppend(&delString, "CmdDelProc2 ", -1); + Tcl_DStringAppend(&delString, (char *) clientData, -1); +} + +/* + *---------------------------------------------------------------------- + * + * TestcmdtokenCmd -- + * + * This procedure implements the "testcmdtoken" command. It is used + * to test Tcl_Command tokens and Tcl_GetCommandName. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * Creates and deletes various commands and modifies their data. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +static int +TestcmdtokenCmd(dummy, interp, argc, argv) + ClientData dummy; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ + Tcl_Command token; + long int l; + + if (argc != 3) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " option arg\"", (char *) NULL); + return TCL_ERROR; + } + if (strcmp(argv[1], "create") == 0) { + token = Tcl_CreateCommand(interp, argv[2], CmdProc1, + (ClientData) "original", (Tcl_CmdDeleteProc *) NULL); + sprintf(interp->result, "%lx", (long int) token); + } else if (strcmp(argv[1], "name") == 0) { + if (sscanf(argv[2], "%lx", &l) != 1) { + Tcl_AppendResult(interp, "bad command token \"", argv[2], + "\"", (char *) NULL); + return TCL_ERROR; + } + interp->result = Tcl_GetCommandName(interp, (Tcl_Command) l); + } else { + Tcl_AppendResult(interp, "bad option \"", argv[1], + "\": must be create or name", (char *) NULL); + return TCL_ERROR; + } + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * TestdcallCmd -- + * + * This procedure implements the "testdcall" command. It is used + * to test Tcl_CallWhenDeleted. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * Creates and deletes interpreters. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +static int +TestdcallCmd(dummy, interp, argc, argv) + ClientData dummy; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ + int i, id; + + delInterp = Tcl_CreateInterp(); + Tcl_DStringInit(&delString); + for (i = 1; i < argc; i++) { + if (Tcl_GetInt(interp, argv[i], &id) != TCL_OK) { + return TCL_ERROR; + } + if (id < 0) { + Tcl_DontCallWhenDeleted(delInterp, DelCallbackProc, + (ClientData) (-id)); + } else { + Tcl_CallWhenDeleted(delInterp, DelCallbackProc, + (ClientData) id); + } + } + Tcl_DeleteInterp(delInterp); + Tcl_DStringResult(interp, &delString); + return TCL_OK; +} + +/* + * The deletion callback used by TestdcallCmd: + */ + +static void +DelCallbackProc(clientData, interp) + ClientData clientData; /* Numerical value to append to + * delString. */ + Tcl_Interp *interp; /* Interpreter being deleted. */ +{ + int id = (int) clientData; + char buffer[10]; + + sprintf(buffer, "%d", id); + Tcl_DStringAppendElement(&delString, buffer); + if (interp != delInterp) { + Tcl_DStringAppendElement(&delString, "bogus interpreter argument!"); + } +} + +/* + *---------------------------------------------------------------------- + * + * TestdelCmd -- + * + * This procedure implements the "testdcall" command. It is used + * to test Tcl_CallWhenDeleted. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * Creates and deletes interpreters. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +static int +TestdelCmd(dummy, interp, argc, argv) + ClientData dummy; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ + DelCmd *dPtr; + Tcl_Interp *slave; + + if (argc != 4) { + interp->result = "wrong # args"; + return TCL_ERROR; + } + + slave = Tcl_GetSlave(interp, argv[1]); + if (slave == NULL) { + return TCL_ERROR; + } + + dPtr = (DelCmd *) ckalloc(sizeof(DelCmd)); + dPtr->interp = interp; + dPtr->deleteCmd = (char *) ckalloc((unsigned) (strlen(argv[3]) + 1)); + strcpy(dPtr->deleteCmd, argv[3]); + + Tcl_CreateCommand(slave, argv[2], DelCmdProc, (ClientData) dPtr, + DelDeleteProc); + return TCL_OK; +} + +static int +DelCmdProc(clientData, interp, argc, argv) + ClientData clientData; /* String result to return. */ + Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ + DelCmd *dPtr = (DelCmd *) clientData; + + Tcl_AppendResult(interp, dPtr->deleteCmd, (char *) NULL); + ckfree(dPtr->deleteCmd); + ckfree((char *) dPtr); + return TCL_OK; +} + +static void +DelDeleteProc(clientData) + ClientData clientData; /* String command to evaluate. */ +{ + DelCmd *dPtr = (DelCmd *) clientData; + + Tcl_Eval(dPtr->interp, dPtr->deleteCmd); + Tcl_ResetResult(dPtr->interp); + ckfree(dPtr->deleteCmd); + ckfree((char *) dPtr); +} + +/* + *---------------------------------------------------------------------- + * + * TestdelassocdataCmd -- + * + * This procedure implements the "testdelassocdata" command. It is used + * to test Tcl_DeleteAssocData. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * Deletes an association between a key and associated data from an + * interpreter. + * + *---------------------------------------------------------------------- + */ + +static int +TestdelassocdataCmd(clientData, interp, argc, argv) + ClientData clientData; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ + if (argc != 2) { + Tcl_AppendResult(interp, "wrong # arguments: should be \"", argv[0], + " data_key\"", (char *) NULL); + return TCL_ERROR; + } + Tcl_DeleteAssocData(interp, argv[1]); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * TestdstringCmd -- + * + * This procedure implements the "testdstring" command. It is used + * to test the dynamic string facilities of Tcl. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * Creates, deletes, and invokes handlers. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +static int +TestdstringCmd(dummy, interp, argc, argv) + ClientData dummy; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ + int count; + + if (argc < 2) { + wrongNumArgs: + interp->result = "wrong # args"; + return TCL_ERROR; + } + if (strcmp(argv[1], "append") == 0) { + if (argc != 4) { + goto wrongNumArgs; + } + if (Tcl_GetInt(interp, argv[3], &count) != TCL_OK) { + return TCL_ERROR; + } + Tcl_DStringAppend(&dstring, argv[2], count); + } else if (strcmp(argv[1], "element") == 0) { + if (argc != 3) { + goto wrongNumArgs; + } + Tcl_DStringAppendElement(&dstring, argv[2]); + } else if (strcmp(argv[1], "end") == 0) { + if (argc != 2) { + goto wrongNumArgs; + } + Tcl_DStringEndSublist(&dstring); + } else if (strcmp(argv[1], "free") == 0) { + if (argc != 2) { + goto wrongNumArgs; + } + Tcl_DStringFree(&dstring); + } else if (strcmp(argv[1], "get") == 0) { + if (argc != 2) { + goto wrongNumArgs; + } + interp->result = Tcl_DStringValue(&dstring); + } else if (strcmp(argv[1], "gresult") == 0) { + if (argc != 3) { + goto wrongNumArgs; + } + if (strcmp(argv[2], "staticsmall") == 0) { + interp->result = "short"; + } else if (strcmp(argv[2], "staticlarge") == 0) { + interp->result = "first0 first1 first2 first3 first4 first5 first6 first7 first8 first9\nsecond0 second1 second2 second3 second4 second5 second6 second7 second8 second9\nthird0 third1 third2 third3 third4 third5 third6 third7 third8 third9\nfourth0 fourth1 fourth2 fourth3 fourth4 fourth5 fourth6 fourth7 fourth8 fourth9\nfifth0 fifth1 fifth2 fifth3 fifth4 fifth5 fifth6 fifth7 fifth8 fifth9\nsixth0 sixth1 sixth2 sixth3 sixth4 sixth5 sixth6 sixth7 sixth8 sixth9\nseventh0 seventh1 seventh2 seventh3 seventh4 seventh5 seventh6 seventh7 seventh8 seventh9\n"; + } else if (strcmp(argv[2], "free") == 0) { + interp->result = (char *) ckalloc(100); + interp->freeProc = TCL_DYNAMIC; + strcpy(interp->result, "This is a malloc-ed string"); + } else if (strcmp(argv[2], "special") == 0) { + interp->result = (char *) ckalloc(100); + interp->result += 4; + interp->freeProc = SpecialFree; + strcpy(interp->result, "This is a specially-allocated string"); + } else { + Tcl_AppendResult(interp, "bad gresult option \"", argv[2], + "\": must be staticsmall, staticlarge, free, or special", + (char *) NULL); + return TCL_ERROR; + } + Tcl_DStringGetResult(interp, &dstring); + } else if (strcmp(argv[1], "length") == 0) { + if (argc != 2) { + goto wrongNumArgs; + } + sprintf(interp->result, "%d", Tcl_DStringLength(&dstring)); + } else if (strcmp(argv[1], "result") == 0) { + if (argc != 2) { + goto wrongNumArgs; + } + Tcl_DStringResult(interp, &dstring); + } else if (strcmp(argv[1], "trunc") == 0) { + if (argc != 3) { + goto wrongNumArgs; + } + if (Tcl_GetInt(interp, argv[2], &count) != TCL_OK) { + return TCL_ERROR; + } + Tcl_DStringTrunc(&dstring, count); + } else if (strcmp(argv[1], "start") == 0) { + if (argc != 2) { + goto wrongNumArgs; + } + Tcl_DStringStartSublist(&dstring); + } else { + Tcl_AppendResult(interp, "bad option \"", argv[1], + "\": must be append, element, end, free, get, length, ", + "result, trunc, or start", (char *) NULL); + return TCL_ERROR; + } + return TCL_OK; +} + +/* + * The procedure below is used as a special freeProc to test how well + * Tcl_DStringGetResult handles freeProc's other than free. + */ + +static void SpecialFree(blockPtr) + char *blockPtr; /* Block to free. */ +{ + ckfree(blockPtr - 4); +} + +/* + *---------------------------------------------------------------------- + * + * TestexithandlerCmd -- + * + * This procedure implements the "testexithandler" command. It is + * used to test Tcl_CreateExitHandler and Tcl_DeleteExitHandler. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static int +TestexithandlerCmd(clientData, interp, argc, argv) + ClientData clientData; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ + int value; + + if (argc != 3) { + Tcl_AppendResult(interp, "wrong # arguments: should be \"", argv[0], + " create|delete value\"", (char *) NULL); + return TCL_ERROR; + } + if (Tcl_GetInt(interp, argv[2], &value) != TCL_OK) { + return TCL_ERROR; + } + if (strcmp(argv[1], "create") == 0) { + Tcl_CreateExitHandler((value & 1) ? ExitProcOdd : ExitProcEven, + (ClientData) value); + } else if (strcmp(argv[1], "delete") == 0) { + Tcl_DeleteExitHandler((value & 1) ? ExitProcOdd : ExitProcEven, + (ClientData) value); + } else { + Tcl_AppendResult(interp, "bad option \"", argv[1], + "\": must be create or delete", (char *) NULL); + return TCL_ERROR; + } + return TCL_OK; +} + +static void +ExitProcOdd(clientData) + ClientData clientData; /* Integer value to print. */ +{ + char buf[100]; + + sprintf(buf, "odd %d\n", (int) clientData); + write(1, buf, strlen(buf)); +} + +static void +ExitProcEven(clientData) + ClientData clientData; /* Integer value to print. */ +{ + char buf[100]; + + sprintf(buf, "even %d\n", (int) clientData); + write(1, buf, strlen(buf)); +} + +/* + *---------------------------------------------------------------------- + * + * TestfhandleCmd -- + * + * This procedure implements the "testfhandle" command. It is + * used to test Tcl_GetFile, Tcl_FreeFile, and + * Tcl_GetFileInfo. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static int +TestfhandleCmd(clientData, interp, argc, argv) + ClientData clientData; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ +#define MAX_FHANDLES 10 + static Tcl_File testHandles[MAX_FHANDLES]; + static initialized = 0; + + int i, index, type; + ClientData data; + + if (!initialized) { + for (i = 0; i < MAX_FHANDLES; i++) { + testHandles[i] = NULL; + } + initialized = 1; + } + if (argc < 2) { + Tcl_AppendResult(interp, "wrong # arguments: should be \"", argv[0], + " option ... \"", (char *) NULL); + return TCL_ERROR; + } + index = -1; + if (argc >= 3) { + if (Tcl_GetInt(interp, argv[2], &index) != TCL_OK) { + return TCL_ERROR; + } + if (index >= MAX_FHANDLES) { + Tcl_AppendResult(interp, "bad index ", argv[2], (char *) NULL); + return TCL_ERROR; + } + } + if (strcmp(argv[1], "compare") == 0) { + int index2; + if (argc != 4) { + Tcl_AppendResult(interp, "wrong # arguments: should be \"", + argv[0], " index index\"", (char *) NULL); + return TCL_ERROR; + } + if (Tcl_GetInt(interp, argv[3], (int *) &index2) != TCL_OK) { + return TCL_ERROR; + } + if (testHandles[index] == testHandles[index2]) { + sprintf(interp->result, "equal"); + } else { + sprintf(interp->result, "notequal"); + } + } else if (strcmp(argv[1], "get") == 0) { + if (argc != 5) { + Tcl_AppendResult(interp, "wrong # arguments: should be \"", + argv[0], " index data type\"", (char *) NULL); + return TCL_ERROR; + } + if (Tcl_GetInt(interp, argv[3], (int *) &data) != TCL_OK) { + return TCL_ERROR; + } + if (Tcl_GetInt(interp, argv[4], &type) != TCL_OK) { + return TCL_ERROR; + } + testHandles[index] = Tcl_GetFile(data, type); + } else if (strcmp(argv[1], "free") == 0) { + if (argc != 3) { + Tcl_AppendResult(interp, "wrong # arguments: should be \"", + argv[0], " index\"", (char *) NULL); + return TCL_ERROR; + } + Tcl_FreeFile(testHandles[index]); + } else if (strcmp(argv[1], "info1") == 0) { + if (argc != 3) { + Tcl_AppendResult(interp, "wrong # arguments: should be \"", + argv[0], " index\"", (char *) NULL); + return TCL_ERROR; + } + data = Tcl_GetFileInfo(testHandles[index], NULL); + sprintf(interp->result, "%d", (int)data); + } else if (strcmp(argv[1], "info2") == 0) { + if (argc != 3) { + Tcl_AppendResult(interp, "wrong # arguments: should be \"", + argv[0], " index\"", (char *) NULL); + return TCL_ERROR; + } + data = Tcl_GetFileInfo(testHandles[index], &type); + sprintf(interp->result, "%d %d", (int)data, type); + } else { + Tcl_AppendResult(interp, "bad option \"", argv[1], + "\": must be compare, get, free, info1, or info2", + (char *) NULL); + return TCL_ERROR; + } + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * TestfilewaitCmd -- + * + * This procedure implements the "testfilewait" command. It is + * used to test TclWaitForFile. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static int +TestfilewaitCmd(clientData, interp, argc, argv) + ClientData clientData; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ + int mask, result, timeout; + Tcl_Channel channel; + Tcl_File file; + + if (argc != 4) { + Tcl_AppendResult(interp, "wrong # arguments: should be \"", argv[0], + " file readable|writable|both timeout\"", (char *) NULL); + return TCL_ERROR; + } + channel = Tcl_GetChannel(interp, argv[1], NULL); + if (channel == NULL) { + return TCL_ERROR; + } + if (strcmp(argv[2], "readable") == 0) { + mask = TCL_READABLE; + } else if (strcmp(argv[2], "writable") == 0){ + mask = TCL_WRITABLE; + } else if (strcmp(argv[2], "both") == 0){ + mask = TCL_WRITABLE|TCL_READABLE; + } else { + Tcl_AppendResult(interp, "bad argument \"", argv[2], + "\": must be readable, writable, or both", (char *) NULL); + return TCL_ERROR; + } + file = Tcl_GetChannelFile(channel, + (mask & TCL_READABLE) ? TCL_READABLE : TCL_WRITABLE); + if (file == NULL) { + interp->result = "couldn't get channel file"; + return TCL_ERROR; + } + if (Tcl_GetInt(interp, argv[3], &timeout) != TCL_OK) { + return TCL_ERROR; + } + result = TclWaitForFile(file, mask, timeout); + if (result & TCL_READABLE) { + Tcl_AppendElement(interp, "readable"); + } + if (result & TCL_WRITABLE) { + Tcl_AppendElement(interp, "writable"); + } + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * TestgetassocdataCmd -- + * + * This procedure implements the "testgetassocdata" command. It is + * used to test Tcl_GetAssocData. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static int +TestgetassocdataCmd(clientData, interp, argc, argv) + ClientData clientData; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ + char *res; + + if (argc != 2) { + Tcl_AppendResult(interp, "wrong # arguments: should be \"", argv[0], + " data_key\"", (char *) NULL); + return TCL_ERROR; + } + res = (char *) Tcl_GetAssocData(interp, argv[1], NULL); + if (res != NULL) { + Tcl_AppendResult(interp, res, NULL); + } + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * TestgetplatformCmd -- + * + * This procedure implements the "testgetplatform" command. It is + * used to retrievel the value of the tclPlatform global variable. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static int +TestgetplatformCmd(clientData, interp, argc, argv) + ClientData clientData; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ + static char *platformStrings[] = { "unix", "mac", "windows" }; + TclPlatformType *platform; + +#ifdef __WIN32__ + platform = TclWinGetPlatform(); +#else + platform = &tclPlatform; +#endif + + if (argc != 1) { + Tcl_AppendResult(interp, "wrong # arguments: should be \"", argv[0], + (char *) NULL); + return TCL_ERROR; + } + + Tcl_AppendResult(interp, platformStrings[*platform], NULL); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * TestinterpdeleteCmd -- + * + * This procedure tests the code in tclInterp.c that deals with + * interpreter deletion. It deletes a user-specified interpreter + * from the hierarchy, and subsequent code checks integrity. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * Deletes one or more interpreters. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +static int +TestinterpdeleteCmd(dummy, interp, argc, argv) + ClientData dummy; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ + Tcl_Interp *slaveToDelete; + + if (argc != 2) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " 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) { + Tcl_AppendResult(interp, "could not find interpreter \"", + argv[1], "\"", (char *) NULL); + return TCL_ERROR; + } + Tcl_DeleteInterp(slaveToDelete); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * TestlinkCmd -- + * + * This procedure implements the "testlink" command. It is used + * to test Tcl_LinkVar and related library procedures. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * Creates and deletes various variable links, plus returns + * values of the linked variables. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +static int +TestlinkCmd(dummy, interp, argc, argv) + ClientData dummy; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ + static int intVar = 43; + static int boolVar = 4; + static double realVar = 1.23; + static char *stringVar = NULL; + static int created = 0; + char buffer[TCL_DOUBLE_SPACE]; + int writable, flag; + + if (argc < 2) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " option ?arg arg arg?\"", (char *) NULL); + return TCL_ERROR; + } + if (strcmp(argv[1], "create") == 0) { + if (created) { + Tcl_UnlinkVar(interp, "int"); + Tcl_UnlinkVar(interp, "real"); + Tcl_UnlinkVar(interp, "bool"); + Tcl_UnlinkVar(interp, "string"); + } + created = 1; + if (Tcl_GetBoolean(interp, argv[2], &writable) != TCL_OK) { + return TCL_ERROR; + } + flag = (writable != 0) ? 0 : TCL_LINK_READ_ONLY; + if (Tcl_LinkVar(interp, "int", (char *) &intVar, + TCL_LINK_INT | flag) != TCL_OK) { + return TCL_ERROR; + } + if (Tcl_GetBoolean(interp, argv[3], &writable) != TCL_OK) { + return TCL_ERROR; + } + flag = (writable != 0) ? 0 : TCL_LINK_READ_ONLY; + if (Tcl_LinkVar(interp, "real", (char *) &realVar, + TCL_LINK_DOUBLE | flag) != TCL_OK) { + return TCL_ERROR; + } + if (Tcl_GetBoolean(interp, argv[4], &writable) != TCL_OK) { + return TCL_ERROR; + } + flag = (writable != 0) ? 0 : TCL_LINK_READ_ONLY; + if (Tcl_LinkVar(interp, "bool", (char *) &boolVar, + TCL_LINK_BOOLEAN | flag) != TCL_OK) { + return TCL_ERROR; + } + if (Tcl_GetBoolean(interp, argv[5], &writable) != TCL_OK) { + return TCL_ERROR; + } + flag = (writable != 0) ? 0 : TCL_LINK_READ_ONLY; + if (Tcl_LinkVar(interp, "string", (char *) &stringVar, + TCL_LINK_STRING | 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"); + created = 0; + } else if (strcmp(argv[1], "get") == 0) { + sprintf(buffer, "%d", intVar); + Tcl_AppendElement(interp, buffer); + Tcl_PrintDouble(interp, realVar, buffer); + Tcl_AppendElement(interp, buffer); + sprintf(buffer, "%d", boolVar); + Tcl_AppendElement(interp, buffer); + Tcl_AppendElement(interp, (stringVar == NULL) ? "-" : stringVar); + } else if (strcmp(argv[1], "set") == 0) { + if (argc != 6) { + Tcl_AppendResult(interp, "wrong # args: should be \"", + argv[0], " ", argv[1], + "intValue realValue boolValue stringValue\"", (char *) NULL); + return TCL_ERROR; + } + if (argv[2][0] != 0) { + if (Tcl_GetInt(interp, argv[2], &intVar) != TCL_OK) { + return TCL_ERROR; + } + } + if (argv[3][0] != 0) { + if (Tcl_GetDouble(interp, argv[3], &realVar) != TCL_OK) { + return TCL_ERROR; + } + } + if (argv[4][0] != 0) { + if (Tcl_GetInt(interp, argv[4], &boolVar) != TCL_OK) { + return TCL_ERROR; + } + } + if (argv[5][0] != 0) { + if (stringVar != NULL) { + ckfree(stringVar); + } + if (strcmp(argv[5], "-") == 0) { + stringVar = NULL; + } else { + stringVar = (char *) ckalloc((unsigned) (strlen(argv[5]) + 1)); + strcpy(stringVar, argv[5]); + } + } + } else if (strcmp(argv[1], "update") == 0) { + if (argc != 6) { + Tcl_AppendResult(interp, "wrong # args: should be \"", + argv[0], " ", argv[1], + "intValue realValue boolValue stringValue\"", (char *) NULL); + return TCL_ERROR; + } + if (argv[2][0] != 0) { + if (Tcl_GetInt(interp, argv[2], &intVar) != TCL_OK) { + return TCL_ERROR; + } + Tcl_UpdateLinkedVar(interp, "int"); + } + if (argv[3][0] != 0) { + if (Tcl_GetDouble(interp, argv[3], &realVar) != TCL_OK) { + return TCL_ERROR; + } + Tcl_UpdateLinkedVar(interp, "real"); + } + if (argv[4][0] != 0) { + if (Tcl_GetInt(interp, argv[4], &boolVar) != TCL_OK) { + return TCL_ERROR; + } + Tcl_UpdateLinkedVar(interp, "bool"); + } + if (argv[5][0] != 0) { + if (stringVar != NULL) { + ckfree(stringVar); + } + if (strcmp(argv[5], "-") == 0) { + stringVar = NULL; + } else { + stringVar = (char *) ckalloc((unsigned) (strlen(argv[5]) + 1)); + strcpy(stringVar, argv[5]); + } + Tcl_UpdateLinkedVar(interp, "string"); + } + } else { + Tcl_AppendResult(interp, "bad option \"", argv[1], + "\": should be create, delete, get, set, or update", + (char *) NULL); + return TCL_ERROR; + } + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * TestMathFunc -- + * + * This is a user-defined math procedure to test out math procedures + * with no arguments. + * + * Results: + * A normal Tcl completion code. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +static int +TestMathFunc(clientData, interp, args, resultPtr) + ClientData clientData; /* Integer value to return. */ + Tcl_Interp *interp; /* Not used. */ + Tcl_Value *args; /* Not used. */ + Tcl_Value *resultPtr; /* Where to store result. */ +{ + resultPtr->type = TCL_INT; + resultPtr->intValue = (int) clientData; + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * CleanupTestSetassocdataTests -- + * + * This function is called when an interpreter is deleted to clean + * up any data left over from running the testsetassocdata command. + * + * Results: + * None. + * + * Side effects: + * Releases storage. + * + *---------------------------------------------------------------------- + */ + /* ARGSUSED */ +static void +CleanupTestSetassocdataTests(clientData, interp) + ClientData clientData; /* Data to be released. */ + Tcl_Interp *interp; /* Interpreter being deleted. */ +{ + ckfree((char *) clientData); +} + +/* + *---------------------------------------------------------------------- + * + * TestmodalCmd -- + * + * This procedure implements the "testmodal" command. It is used + * to test modal timeouts created by Tcl_CreateModalTimeout. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * Modifies or creates an association between a key and associated + * data for this interpreter. + * + *---------------------------------------------------------------------- + */ + +static int +TestmodalCmd(clientData, interp, argc, argv) + ClientData clientData; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ +#define NUM_MODALS 10 + static Modal modals[NUM_MODALS]; + static int numModals = 0; + int ms; + + if (argc < 2) { + Tcl_AppendResult(interp, "wrong # arguments: should be \"", argv[0], + " option ?arg arg ...?\"", (char *) NULL); + return TCL_ERROR; + } + + if (strcmp(argv[1], "create") == 0) { + if (argc != 4) { + Tcl_AppendResult(interp, "wrong # arguments: should be \"", argv[0], + " create ms key\"", (char *) NULL); + return TCL_ERROR; + } + if (numModals >= NUM_MODALS) { + interp->result = "too many modal timeouts"; + return TCL_ERROR; + } + if (Tcl_GetInt(interp, argv[2], &ms) != TCL_OK) { + return TCL_ERROR; + } + modals[numModals].interp = interp; + modals[numModals].key = (char *) ckalloc((unsigned) + (strlen(argv[3]) + 1)); + strcpy(modals[numModals].key, argv[3]); + Tcl_CreateModalTimeout(ms, ModalTimeoutProc, + (ClientData) &modals[numModals]); + numModals += 1; + } else if (strcmp(argv[1], "delete") == 0) { + if (numModals == 0) { + interp->result = "no more modal timeouts"; + return TCL_ERROR; + } + numModals -= 1; + ckfree(modals[numModals].key); + Tcl_DeleteModalTimeout(ModalTimeoutProc, + (ClientData) &modals[numModals]); + } else if (strcmp(argv[1], "event") == 0) { + Tcl_DoOneEvent(TCL_TIMER_EVENTS|TCL_DONT_WAIT); + } else if (strcmp(argv[1], "eventnotimers") == 0) { + Tcl_DoOneEvent(0x100000|TCL_DONT_WAIT); + } else { + Tcl_AppendResult(interp, "bad option \"", argv[1], + "\": must be create, delete, event, or eventnotimers", + (char *) NULL); + return TCL_ERROR; + } + return TCL_OK; +} + +static void +ModalTimeoutProc(clientData) + ClientData clientData; /* Pointer to Modal structure. */ +{ + Modal *modalPtr = (Modal *) clientData; + Tcl_SetVar(modalPtr->interp, "x", modalPtr->key, + TCL_GLOBAL_ONLY|TCL_APPEND_VALUE|TCL_LIST_ELEMENT); +} + +/* + *---------------------------------------------------------------------- + * + * TestsetassocdataCmd -- + * + * This procedure implements the "testsetassocdata" command. It is used + * to test Tcl_SetAssocData. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * Modifies or creates an association between a key and associated + * data for this interpreter. + * + *---------------------------------------------------------------------- + */ + +static int +TestsetassocdataCmd(clientData, interp, argc, argv) + ClientData clientData; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ + char *buf; + + if (argc != 3) { + Tcl_AppendResult(interp, "wrong # arguments: should be \"", argv[0], + " data_key data_item\"", (char *) NULL); + return TCL_ERROR; + } + + buf = ckalloc((unsigned) strlen(argv[2]) + 1); + strcpy(buf, argv[2]); + + Tcl_SetAssocData(interp, argv[1], CleanupTestSetassocdataTests, + (ClientData) buf); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * TestsetplatformCmd -- + * + * This procedure implements the "testsetplatform" command. It is + * used to change the tclPlatform global variable so all file + * name conversions can be tested on a single platform. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * Sets the tclPlatform global variable. + * + *---------------------------------------------------------------------- + */ + +static int +TestsetplatformCmd(clientData, interp, argc, argv) + ClientData clientData; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ + size_t length; + TclPlatformType *platform; + +#ifdef __WIN32__ + platform = TclWinGetPlatform(); +#else + platform = &tclPlatform; +#endif + + if (argc != 2) { + Tcl_AppendResult(interp, "wrong # arguments: should be \"", argv[0], + " platform\"", (char *) NULL); + return TCL_ERROR; + } + + length = strlen(argv[1]); + if (strncmp(argv[1], "unix", length) == 0) { + *platform = TCL_PLATFORM_UNIX; + } else if (strncmp(argv[1], "mac", length) == 0) { + *platform = TCL_PLATFORM_MAC; + } else if (strncmp(argv[1], "windows", length) == 0) { + *platform = TCL_PLATFORM_WINDOWS; + } else { + Tcl_AppendResult(interp, "unsupported platform: should be one of ", + "unix, mac, or windows", (char *) NULL); + return TCL_ERROR; + } + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * TeststaticpkgCmd -- + * + * This procedure implements the "teststaticpkg" command. + * It is used to test the procedure Tcl_StaticPackage. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * When the packge given by argv[1] is loaded into an interpeter, + * variable "x" in that interpreter is set to "loaded". + * + *---------------------------------------------------------------------- + */ + +static int +TeststaticpkgCmd(dummy, interp, argc, argv) + ClientData dummy; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ + int safe, loaded; + + if (argc != 4) { + Tcl_AppendResult(interp, "wrong # arguments: should be \"", + argv[0], " pkgName safe loaded\"", (char *) NULL); + return TCL_ERROR; + } + if (Tcl_GetInt(interp, argv[2], &safe) != TCL_OK) { + return TCL_ERROR; + } + if (Tcl_GetInt(interp, argv[3], &loaded) != TCL_OK) { + return TCL_ERROR; + } + Tcl_StaticPackage((loaded) ? interp : NULL, argv[1], StaticInitProc, + (safe) ? StaticInitProc : NULL); + return TCL_OK; +} + +static int +StaticInitProc(interp) + Tcl_Interp *interp; /* Interpreter in which package + * is supposedly being loaded. */ +{ + Tcl_SetVar(interp, "x", "loaded", TCL_GLOBAL_ONLY); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * TesttranslatefilenameCmd -- + * + * This procedure implements the "testtranslatefilename" command. + * It is used to test the Tcl_TranslateFileName command. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static int +TesttranslatefilenameCmd(dummy, interp, argc, argv) + ClientData dummy; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ + Tcl_DString buffer; + char *result; + + if (argc != 2) { + Tcl_AppendResult(interp, "wrong # arguments: should be \"", + argv[0], " path\"", (char *) NULL); + return TCL_ERROR; + } + result = Tcl_TranslateFileName(interp, argv[1], &buffer); + if (result == NULL) { + return TCL_ERROR; + } + Tcl_AppendResult(interp, result, NULL); + Tcl_DStringFree(&buffer); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * TestupvarCmd -- + * + * This procedure implements the "testupvar2" command. It is used + * to test Tcl_UpVar and Tcl_UpVar2. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * Creates or modifies an "upvar" reference. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +static int +TestupvarCmd(dummy, interp, argc, argv) + ClientData dummy; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ + if ((argc != 5) && (argc != 6)) { + Tcl_AppendResult(interp, "wrong # arguments: should be \"", + argv[0], " level name ?name2? dest global\"", (char *) NULL); + return TCL_ERROR; + } + + if (argc == 5) { + return Tcl_UpVar(interp, argv[1], argv[2], argv[3], + (strcmp(argv[4], "global") == 0) ? TCL_GLOBAL_ONLY : 0); + } else { + return Tcl_UpVar2(interp, argv[1], argv[2], + (argv[3][0] == 0) ? (char *) NULL : argv[3], argv[4], + (strcmp(argv[5], "global") == 0) ? TCL_GLOBAL_ONLY : 0); + } +} + +/* + *---------------------------------------------------------------------- + * + * TestwordendCmd -- + * + * This procedure implements the "testwordend" command. It is used + * to test TclWordEnd. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +static int +TestwordendCmd(dummy, interp, argc, argv) + ClientData dummy; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ + if (argc != 2) { + Tcl_AppendResult(interp, "wrong # arguments: should be \"", + argv[0], " string\"", (char *) NULL); + return TCL_ERROR; + } + Tcl_SetResult(interp, TclWordEnd(argv[1], 0, (int *) NULL), TCL_VOLATILE); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * TestfeventCmd -- + * + * This procedure implements the "testfevent" command. It is + * used for testing the "fileevent" command. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * Creates and deletes interpreters. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +static int +TestfeventCmd(clientData, interp, argc, argv) + ClientData clientData; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ + static Tcl_Interp *interp2 = NULL; + int code; + Tcl_Channel chan; + + if (argc < 2) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " option ?arg arg ...?", (char *) NULL); + return TCL_ERROR; + } + if (strcmp(argv[1], "cmd") == 0) { + if (argc != 3) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " cmd script", (char *) NULL); + return TCL_ERROR; + } + if (interp2 != (Tcl_Interp *) NULL) { + code = Tcl_GlobalEval(interp2, argv[2]); + interp->result = interp2->result; + return code; + } else { + Tcl_AppendResult(interp, + "called \"testfevent code\" before \"testfevent create\"", + (char *) NULL); + return TCL_ERROR; + } + } else if (strcmp(argv[1], "create") == 0) { + if (interp2 != NULL) { + Tcl_DeleteInterp(interp2); + } + interp2 = Tcl_CreateInterp(); + return TCL_OK; + } else if (strcmp(argv[1], "delete") == 0) { + if (interp2 != NULL) { + Tcl_DeleteInterp(interp2); + } + interp2 = NULL; + } else if (strcmp(argv[1], "share") == 0) { + if (interp2 != NULL) { + chan = Tcl_GetChannel(interp, argv[2], NULL); + if (chan == (Tcl_Channel) NULL) { + return TCL_ERROR; + } + Tcl_RegisterChannel(interp2, chan); + } + } + + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * TestPanicCmd -- + * + * Calls the panic routine. + * + * Results: + * Always returns TCL_OK. + * + * Side effects: + * May exit application. + * + *---------------------------------------------------------------------- + */ + +static int +TestPanicCmd(dummy, interp, argc, argv) + ClientData dummy; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ + char *argString; + + /* + * Put the arguments into a var args structure + * Append all of the arguments together separated by spaces + */ + + argString = Tcl_Merge(argc-1, argv+1); + panic(argString); + ckfree(argString); + + return TCL_OK; +} diff --git a/contrib/tcl/generic/tclUtil.c b/contrib/tcl/generic/tclUtil.c new file mode 100644 index 0000000..5f83c58 --- /dev/null +++ b/contrib/tcl/generic/tclUtil.c @@ -0,0 +1,2133 @@ +/* + * tclUtil.c -- + * + * This file contains utility procedures that are used by many Tcl + * commands. + * + * Copyright (c) 1987-1993 The Regents of the University of California. + * Copyright (c) 1994-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: @(#) tclUtil.c 1.112 96/02/15 11:42:52 + */ + +#include "tclInt.h" +#include "tclPort.h" + +/* + * The following values are used in the flags returned by Tcl_ScanElement + * and used by Tcl_ConvertElement. The value TCL_DONT_USE_BRACES is also + * defined in tcl.h; make sure its value doesn't overlap with any of the + * values below. + * + * TCL_DONT_USE_BRACES - 1 means the string mustn't be enclosed in + * braces (e.g. it contains unmatched braces, + * or ends in a backslash character, or user + * just doesn't want braces); handle all + * special characters by adding backslashes. + * USE_BRACES - 1 means the string contains a special + * character that can be handled simply by + * enclosing the entire argument in braces. + * BRACES_UNMATCHED - 1 means that braces aren't properly matched + * in the argument. + */ + +#define USE_BRACES 2 +#define BRACES_UNMATCHED 4 + +/* + * Function prototypes for local procedures in this file: + */ + +static void SetupAppendBuffer _ANSI_ARGS_((Interp *iPtr, + int newSpace)); + +/* + *---------------------------------------------------------------------- + * + * TclFindElement -- + * + * Given a pointer into a Tcl list, locate the first (or next) + * element in the list. + * + * Results: + * The return value is normally TCL_OK, which means that the + * element was successfully located. If TCL_ERROR is returned + * it means that list didn't have proper list structure; + * interp->result contains a more detailed error message. + * + * If TCL_OK is returned, then *elementPtr will be set to point + * to the first element of list, and *nextPtr will be set to point + * to the character just after any white space following the last + * character that's part of the element. If this is the last argument + * in the list, then *nextPtr will point to the NULL character at the + * end of list. If sizePtr is non-NULL, *sizePtr is filled in with + * the number of characters in the element. If the element is in + * braces, then *elementPtr will point to the character after the + * opening brace and *sizePtr will not include either of the braces. + * If there isn't an element in the list, *sizePtr will be zero, and + * both *elementPtr and *termPtr will refer to the null character at + * the end of list. Note: this procedure does NOT collapse backslash + * sequences. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +int +TclFindElement(interp, list, elementPtr, nextPtr, sizePtr, bracePtr) + Tcl_Interp *interp; /* Interpreter to use for error reporting. + * If NULL, then no error message is left + * after errors. */ + register char *list; /* String containing Tcl list with zero + * or more elements (possibly in braces). */ + char **elementPtr; /* Fill in with location of first significant + * character in first element of list. */ + char **nextPtr; /* Fill in with location of character just + * after all white space following end of + * argument (i.e. next argument or end of + * list). */ + int *sizePtr; /* If non-zero, fill in with size of + * element. */ + int *bracePtr; /* If non-zero fill in with non-zero/zero + * to indicate that arg was/wasn't + * in braces. */ +{ + register char *p; + int openBraces = 0; + int inQuotes = 0; + int size; + + /* + * Skim off leading white space and check for an opening brace or + * quote. Note: use of "isascii" below and elsewhere in this + * procedure is a temporary hack (7/27/90) because Mx uses characters + * with the high-order bit set for some things. This should probably + * be changed back eventually, or all of Tcl should call isascii. + */ + + while (isspace(UCHAR(*list))) { + list++; + } + if (*list == '{') { + openBraces = 1; + list++; + } else if (*list == '"') { + inQuotes = 1; + list++; + } + if (bracePtr != 0) { + *bracePtr = openBraces; + } + p = list; + + /* + * Find the end of the element (either a space or a close brace or + * the end of the string). + */ + + while (1) { + switch (*p) { + + /* + * Open brace: don't treat specially unless the element is + * in braces. In this case, keep a nesting count. + */ + + case '{': + if (openBraces != 0) { + openBraces++; + } + break; + + /* + * Close brace: if element is in braces, keep nesting + * count and quit when the last close brace is seen. + */ + + case '}': + if (openBraces == 1) { + char *p2; + + size = p - list; + p++; + if (isspace(UCHAR(*p)) || (*p == 0)) { + goto done; + } + for (p2 = p; (*p2 != 0) && (!isspace(UCHAR(*p2))) + && (p2 < p+20); p2++) { + /* null body */ + } + if (interp != NULL) { + Tcl_ResetResult(interp); + sprintf(interp->result, + "list element in braces followed by \"%.*s\" instead of space", + (int) (p2-p), p); + } + return TCL_ERROR; + } else if (openBraces != 0) { + openBraces--; + } + break; + + /* + * Backslash: skip over everything up to the end of the + * backslash sequence. + */ + + case '\\': { + int size; + + (void) Tcl_Backslash(p, &size); + p += size - 1; + break; + } + + /* + * Space: ignore if element is in braces or quotes; otherwise + * terminate element. + */ + + case ' ': + case '\f': + case '\n': + case '\r': + case '\t': + case '\v': + if ((openBraces == 0) && !inQuotes) { + size = p - list; + goto done; + } + break; + + /* + * Double-quote: if element is in quotes then terminate it. + */ + + case '"': + if (inQuotes) { + char *p2; + + size = p-list; + p++; + if (isspace(UCHAR(*p)) || (*p == 0)) { + goto done; + } + for (p2 = p; (*p2 != 0) && (!isspace(UCHAR(*p2))) + && (p2 < p+20); p2++) { + /* null body */ + } + if (interp != NULL) { + Tcl_ResetResult(interp); + sprintf(interp->result, + "list element in quotes followed by \"%.*s\" %s", (int) (p2-p), p, + "instead of space"); + } + return TCL_ERROR; + } + break; + + /* + * End of list: terminate element. + */ + + case 0: + if (openBraces != 0) { + if (interp != NULL) { + Tcl_SetResult(interp, "unmatched open brace in list", + TCL_STATIC); + } + return TCL_ERROR; + } else if (inQuotes) { + if (interp != NULL) { + Tcl_SetResult(interp, "unmatched open quote in list", + TCL_STATIC); + } + return TCL_ERROR; + } + size = p - list; + goto done; + + } + p++; + } + + done: + while (isspace(UCHAR(*p))) { + p++; + } + *elementPtr = list; + *nextPtr = p; + if (sizePtr != 0) { + *sizePtr = size; + } + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * TclCopyAndCollapse -- + * + * Copy a string and eliminate any backslashes that aren't in braces. + * + * Results: + * There is no return value. Count chars. 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. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +void +TclCopyAndCollapse(count, src, dst) + int count; /* Total number of characters to copy + * from src. */ + register char *src; /* Copy from here... */ + register char *dst; /* ... to here. */ +{ + register char c; + int numRead; + + for (c = *src; count > 0; src++, c = *src, count--) { + if (c == '\\') { + *dst = Tcl_Backslash(src, &numRead); + dst++; + src += numRead-1; + count -= numRead-1; + } else { + *dst = c; + dst++; + } + } + *dst = 0; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_SplitList -- + * + * Splits a list up into its constituent fields. + * + * Results + * The return value is normally TCL_OK, which means that + * the list was successfully split up. If TCL_ERROR is + * returned, it means that "list" didn't have proper list + * structure; interp->result will contain a more detailed + * error message. + * + * *argvPtr will be filled in with the address of an array + * whose elements point to the elements of list, in order. + * *argcPtr will get filled in with the number of valid elements + * in the array. A single block of memory is dynamically allocated + * to hold both the argv array and a copy of the list (with + * backslashes and braces removed in the standard way). + * The caller must eventually free this memory by calling free() + * on *argvPtr. Note: *argvPtr and *argcPtr are only modified + * if the procedure returns normally. + * + * Side effects: + * Memory is allocated. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_SplitList(interp, list, argcPtr, argvPtr) + Tcl_Interp *interp; /* Interpreter to use for error reporting. + * If NULL, then no error message is left. */ + 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 array + * of pointers to list elements. */ +{ + char **argv; + register char *p; + int size, i, result, elSize, brace; + char *element; + + /* + * Figure out how much space to allocate. There must be enough + * space for both the array of pointers and also for a copy of + * the list. To estimate the number of pointers needed, count + * the number of space characters in the list. + */ + + for (size = 1, p = list; *p != 0; p++) { + if (isspace(UCHAR(*p))) { + size++; + } + } + size++; /* Leave space for final NULL pointer. */ + argv = (char **) ckalloc((unsigned) + ((size * sizeof(char *)) + (p - list) + 1)); + for (i = 0, p = ((char *) argv) + size*sizeof(char *); + *list != 0; i++) { + result = TclFindElement(interp, list, &element, &list, &elSize, &brace); + if (result != TCL_OK) { + ckfree((char *) argv); + return result; + } + if (*element == 0) { + break; + } + if (i >= size) { + ckfree((char *) argv); + if (interp != NULL) { + Tcl_SetResult(interp, "internal error in Tcl_SplitList", + TCL_STATIC); + } + return TCL_ERROR; + } + argv[i] = p; + if (brace) { + strncpy(p, element, (size_t) elSize); + p += elSize; + *p = 0; + p++; + } else { + TclCopyAndCollapse(elSize, element, p); + p += elSize+1; + } + } + + argv[i] = NULL; + *argvPtr = argv; + *argcPtr = i; + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_ScanElement -- + * + * This procedure is a companion procedure to Tcl_ConvertElement. + * It scans a string to see what needs to be done to it (e.g. + * add backslashes or enclosing braces) to make the string into + * a valid Tcl list element. + * + * Results: + * The return value is an overestimate of the number of characters + * that will be needed by Tcl_ConvertElement to produce a valid + * list element from string. The word at *flagPtr is filled in + * with a value needed by Tcl_ConvertElement when doing the actual + * conversion. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_ScanElement(string, flagPtr) + char *string; /* String to convert to Tcl list element. */ + int *flagPtr; /* Where to store information to guide + * Tcl_ConvertElement. */ +{ + int flags, nestingLevel; + register char *p; + + /* + * This procedure and Tcl_ConvertElement together do two things: + * + * 1. They produce a proper list, one that will yield back the + * argument strings when evaluated or when disassembled with + * Tcl_SplitList. This is the most important thing. + * + * 2. They try to produce legible output, which means minimizing the + * use of backslashes (using braces instead). However, there are + * some situations where backslashes must be used (e.g. an element + * like "{abc": the leading brace will have to be backslashed. For + * each element, one of three things must be done: + * + * (a) Use the element as-is (it doesn't contain anything special + * characters). This is the most desirable option. + * + * (b) Enclose the element in braces, but leave the contents alone. + * This happens if the element contains embedded space, or if it + * contains characters with special interpretation ($, [, ;, or \), + * or if it starts with a brace or double-quote, or if there are + * no characters in the element. + * + * (c) Don't enclose the element in braces, but add backslashes to + * prevent special interpretation of special characters. This is a + * last resort used when the argument would normally fall under case + * (b) but contains unmatched braces. It also occurs if the last + * character of the argument is a backslash or if the element contains + * a backslash followed by newline. + * + * The procedure figures out how many bytes will be needed to store + * the result (actually, it overestimates). It also collects information + * about the element in the form of a flags word. + */ + + nestingLevel = 0; + flags = 0; + if (string == NULL) { + string = ""; + } + p = string; + if ((*p == '{') || (*p == '"') || (*p == 0)) { + flags |= USE_BRACES; + } + for ( ; *p != 0; p++) { + switch (*p) { + case '{': + nestingLevel++; + break; + case '}': + nestingLevel--; + if (nestingLevel < 0) { + flags |= TCL_DONT_USE_BRACES|BRACES_UNMATCHED; + } + break; + case '[': + case '$': + case ';': + case ' ': + case '\f': + case '\n': + case '\r': + case '\t': + case '\v': + flags |= USE_BRACES; + break; + case '\\': + if ((p[1] == 0) || (p[1] == '\n')) { + flags = TCL_DONT_USE_BRACES; + } else { + int size; + + (void) Tcl_Backslash(p, &size); + p += size-1; + flags |= USE_BRACES; + } + break; + } + } + if (nestingLevel != 0) { + flags = TCL_DONT_USE_BRACES | BRACES_UNMATCHED; + } + *flagPtr = flags; + + /* + * Allow enough space to backslash every character plus leave + * two spaces for braces. + */ + + return 2*(p-string) + 2; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_ConvertElement -- + * + * This is a companion procedure to Tcl_ScanElement. Given the + * information produced by Tcl_ScanElement, this procedure converts + * a string to a list element equal to that string. + * + * Results: + * Information is copied to *dst in the form of a list element + * identical to src (i.e. if Tcl_SplitList is applied to dst it + * will produce a string identical to src). The return value is + * a count of the number of characters copied (not including the + * terminating NULL character). + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_ConvertElement(src, dst, flags) + register char *src; /* Source information for list element. */ + char *dst; /* Place to put list-ified element. */ + int flags; /* Flags produced by Tcl_ScanElement. */ +{ + register char *p = dst; + + /* + * See the comment block at the beginning of the Tcl_ScanElement + * code for details of how this works. + */ + + if ((src == NULL) || (*src == 0)) { + p[0] = '{'; + p[1] = '}'; + p[2] = 0; + return 2; + } + if ((flags & USE_BRACES) && !(flags & TCL_DONT_USE_BRACES)) { + *p = '{'; + p++; + for ( ; *src != 0; src++, p++) { + *p = *src; + } + *p = '}'; + p++; + } else { + if (*src == '{') { + /* + * Can't have a leading brace unless the whole element is + * enclosed in braces. Add a backslash before the brace. + * Furthermore, this may destroy the balance between open + * and close braces, so set BRACES_UNMATCHED. + */ + + p[0] = '\\'; + p[1] = '{'; + p += 2; + src++; + flags |= BRACES_UNMATCHED; + } + for (; *src != 0 ; src++) { + switch (*src) { + case ']': + case '[': + case '$': + case ';': + case ' ': + case '\\': + case '"': + *p = '\\'; + p++; + break; + case '{': + case '}': + /* + * It may not seem necessary to backslash braces, but + * it is. The reason for this is that the resulting + * list element may actually be an element of a sub-list + * enclosed in braces (e.g. if Tcl_DStringStartSublist + * has been invoked), so there may be a brace mismatch + * if the braces aren't backslashed. + */ + + if (flags & BRACES_UNMATCHED) { + *p = '\\'; + p++; + } + break; + case '\f': + *p = '\\'; + p++; + *p = 'f'; + p++; + continue; + case '\n': + *p = '\\'; + p++; + *p = 'n'; + p++; + continue; + case '\r': + *p = '\\'; + p++; + *p = 'r'; + p++; + continue; + case '\t': + *p = '\\'; + p++; + *p = 't'; + p++; + continue; + case '\v': + *p = '\\'; + p++; + *p = 'v'; + p++; + continue; + } + *p = *src; + p++; + } + } + *p = '\0'; + return p-dst; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_Merge -- + * + * Given a collection of strings, merge them together into a + * single string that has proper Tcl list structured (i.e. + * Tcl_SplitList may be used to retrieve strings equal to the + * original elements, and Tcl_Eval will parse the string back + * into its original elements). + * + * Results: + * The return value is the address of a dynamically-allocated + * string containing the merged list. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +char * +Tcl_Merge(argc, argv) + int argc; /* How many strings to merge. */ + char **argv; /* Array of string values. */ +{ +# define LOCAL_SIZE 20 + int localFlags[LOCAL_SIZE], *flagPtr; + int numChars; + char *result; + register char *dst; + int i; + + /* + * Pass 1: estimate space, gather flags. + */ + + if (argc <= LOCAL_SIZE) { + flagPtr = localFlags; + } else { + flagPtr = (int *) ckalloc((unsigned) argc*sizeof(int)); + } + numChars = 1; + for (i = 0; i < argc; i++) { + numChars += Tcl_ScanElement(argv[i], &flagPtr[i]) + 1; + } + + /* + * Pass two: copy into the result area. + */ + + result = (char *) ckalloc((unsigned) numChars); + dst = result; + for (i = 0; i < argc; i++) { + numChars = Tcl_ConvertElement(argv[i], dst, flagPtr[i]); + dst += numChars; + *dst = ' '; + dst++; + } + if (dst == result) { + *dst = 0; + } else { + dst[-1] = 0; + } + + if (flagPtr != localFlags) { + ckfree((char *) flagPtr); + } + return result; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_Concat -- + * + * Concatenate a set of strings into a single large string. + * + * Results: + * The return value is dynamically-allocated string containing + * a concatenation of all the strings in argv, with spaces between + * the original argv elements. + * + * Side effects: + * Memory is allocated for the result; the caller is responsible + * for freeing the memory. + * + *---------------------------------------------------------------------- + */ + +char * +Tcl_Concat(argc, argv) + int argc; /* Number of strings to concatenate. */ + char **argv; /* Array of strings to concatenate. */ +{ + int totalSize, i; + register char *p; + char *result; + + for (totalSize = 1, i = 0; i < argc; i++) { + totalSize += strlen(argv[i]) + 1; + } + result = (char *) ckalloc((unsigned) totalSize); + if (argc == 0) { + *result = '\0'; + return result; + } + for (p = result, i = 0; i < argc; i++) { + char *element; + int length; + + /* + * Clip white space off the front and back of the string + * to generate a neater result, and ignore any empty + * elements. + */ + + element = argv[i]; + while (isspace(UCHAR(*element))) { + element++; + } + for (length = strlen(element); + (length > 0) && (isspace(UCHAR(element[length-1]))); + length--) { + /* Null loop body. */ + } + if (length == 0) { + continue; + } + (void) strncpy(p, element, (size_t) length); + p += length; + *p = ' '; + p++; + } + if (p != result) { + p[-1] = 0; + } else { + *p = 0; + } + return result; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_StringMatch -- + * + * See if a particular string matches a particular pattern. + * + * 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_StringMatch(string, pattern) + register char *string; /* String. */ + register char *pattern; /* Pattern, which may contain + * special characters. */ +{ + char c2; + + while (1) { + /* 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 (*pattern == 0) { + if (*string == 0) { + return 1; + } else { + return 0; + } + } + if ((*string == 0) && (*pattern != '*')) { + 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 (*pattern == '*') { + pattern += 1; + if (*pattern == 0) { + return 1; + } + while (1) { + if (Tcl_StringMatch(string, pattern)) { + return 1; + } + if (*string == 0) { + return 0; + } + string += 1; + } + } + + /* Check for a "?" as the next pattern character. It matches + * any single character. + */ + + if (*pattern == '?') { + goto thisCharOK; + } + + /* 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 (*pattern == '[') { + pattern += 1; + while (1) { + if ((*pattern == ']') || (*pattern == 0)) { + return 0; + } + if (*pattern == *string) { + break; + } + if (pattern[1] == '-') { + c2 = pattern[2]; + if (c2 == 0) { + return 0; + } + if ((*pattern <= *string) && (c2 >= *string)) { + break; + } + if ((*pattern >= *string) && (c2 <= *string)) { + break; + } + pattern += 2; + } + pattern += 1; + } + while (*pattern != ']') { + if (*pattern == 0) { + pattern--; + break; + } + pattern += 1; + } + goto thisCharOK; + } + + /* If the next pattern character is '/', just strip off the '/' + * so we do exact matching on the character that follows. + */ + + if (*pattern == '\\') { + pattern += 1; + if (*pattern == 0) { + return 0; + } + } + + /* There's no special character. Just make sure that the next + * characters of each string match. + */ + + if (*pattern != *string) { + return 0; + } + + thisCharOK: pattern += 1; + string += 1; + } +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_SetResult -- + * + * Arrange for "string" to be the Tcl return value. + * + * Results: + * None. + * + * Side effects: + * interp->result is left pointing either to "string" (if "copy" is 0) + * or to a copy of string. + * + *---------------------------------------------------------------------- + */ + +void +Tcl_SetResult(interp, string, freeProc) + Tcl_Interp *interp; /* Interpreter with which to associate the + * return value. */ + char *string; /* Value to be returned. If NULL, + * the result is set to an empty string. */ + Tcl_FreeProc *freeProc; /* Gives information about the string: + * TCL_STATIC, TCL_VOLATILE, or the address + * of a Tcl_FreeProc such as free. */ +{ + register Interp *iPtr = (Interp *) interp; + int length; + Tcl_FreeProc *oldFreeProc = iPtr->freeProc; + char *oldResult = iPtr->result; + + if (string == NULL) { + iPtr->resultSpace[0] = 0; + iPtr->result = iPtr->resultSpace; + iPtr->freeProc = 0; + } else if (freeProc == TCL_DYNAMIC) { + iPtr->result = string; + iPtr->freeProc = TCL_DYNAMIC; + } else if (freeProc == TCL_VOLATILE) { + length = strlen(string); + if (length > TCL_RESULT_SIZE) { + iPtr->result = (char *) ckalloc((unsigned) length+1); + iPtr->freeProc = TCL_DYNAMIC; + } else { + iPtr->result = iPtr->resultSpace; + iPtr->freeProc = 0; + } + strcpy(iPtr->result, string); + } else { + iPtr->result = string; + iPtr->freeProc = freeProc; + } + + /* + * If the old result was dynamically-allocated, free it up. Do it + * here, rather than at the beginning, in case the new result value + * was part of the old result value. + */ + + if (oldFreeProc != 0) { + if ((oldFreeProc == TCL_DYNAMIC) + || (oldFreeProc == (Tcl_FreeProc *) free)) { + ckfree(oldResult); + } else { + (*oldFreeProc)(oldResult); + } + } +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_AppendResult -- + * + * Append a variable number of strings onto the result already + * present for an interpreter. + * + * Results: + * None. + * + * Side effects: + * The result in the interpreter given by the first argument + * is extended by the strings given by the second and following + * arguments (up to a terminating NULL argument). + * + *---------------------------------------------------------------------- + */ + + /* VARARGS2 */ +void +Tcl_AppendResult TCL_VARARGS_DEF(Tcl_Interp *,arg1) +{ + va_list argList; + register Interp *iPtr; + char *string; + int newSpace; + + /* + * First, scan through all the arguments to see how much space is + * needed. + */ + + iPtr = (Interp *) TCL_VARARGS_START(Tcl_Interp *,arg1,argList); + newSpace = 0; + while (1) { + string = va_arg(argList, char *); + if (string == NULL) { + break; + } + newSpace += strlen(string); + } + va_end(argList); + + /* + * If the append buffer isn't already setup and large enough + * to hold the new data, set it up. + */ + + if ((iPtr->result != iPtr->appendResult) + || (iPtr->appendResult[iPtr->appendUsed] != 0) + || ((newSpace + iPtr->appendUsed) >= iPtr->appendAvl)) { + SetupAppendBuffer(iPtr, newSpace); + } + + /* + * Final step: go through all the argument strings again, copying + * them into the buffer. + */ + + TCL_VARARGS_START(Tcl_Interp *,arg1,argList); + while (1) { + string = va_arg(argList, char *); + if (string == NULL) { + break; + } + strcpy(iPtr->appendResult + iPtr->appendUsed, string); + iPtr->appendUsed += strlen(string); + } + va_end(argList); +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_AppendElement -- + * + * Convert a string to a valid Tcl list element and append it + * to the current result (which is ostensibly a list). + * + * Results: + * None. + * + * Side effects: + * The result in the interpreter given by the first argument + * is extended with a list element converted from string. A + * separator space is added before the converted list element + * unless the current result is empty, contains the single + * character "{", or ends in " {". + * + *---------------------------------------------------------------------- + */ + +void +Tcl_AppendElement(interp, string) + Tcl_Interp *interp; /* Interpreter whose result is to be + * extended. */ + char *string; /* String to convert to list element and + * add to result. */ +{ + register Interp *iPtr = (Interp *) interp; + int size, flags; + char *dst; + + /* + * See how much space is needed, and grow the append buffer if + * needed to accommodate the list element. + */ + + size = Tcl_ScanElement(string, &flags) + 1; + if ((iPtr->result != iPtr->appendResult) + || (iPtr->appendResult[iPtr->appendUsed] != 0) + || ((size + iPtr->appendUsed) >= iPtr->appendAvl)) { + SetupAppendBuffer(iPtr, size+iPtr->appendUsed); + } + + /* + * Convert the string into a list element and copy it to the + * buffer that's forming, with a space separator if needed. + */ + + dst = iPtr->appendResult + iPtr->appendUsed; + if (TclNeedSpace(iPtr->appendResult, dst)) { + iPtr->appendUsed++; + *dst = ' '; + dst++; + } + iPtr->appendUsed += Tcl_ConvertElement(string, dst, flags); +} + +/* + *---------------------------------------------------------------------- + * + * SetupAppendBuffer -- + * + * This procedure makes sure that there is an append buffer + * properly initialized for interp, and that it has at least + * enough room to accommodate newSpace new bytes of information. + * + * Results: + * None. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static void +SetupAppendBuffer(iPtr, newSpace) + register Interp *iPtr; /* Interpreter whose result is being set up. */ + int newSpace; /* Make sure that at least this many bytes + * of new information may be added. */ +{ + int totalSpace; + + /* + * Make the append buffer larger, if that's necessary, then + * copy the current result into the append buffer and make the + * append buffer the official Tcl result. + */ + + if (iPtr->result != iPtr->appendResult) { + /* + * If an oversized buffer was used recently, then free it up + * so we go back to a smaller buffer. This avoids tying up + * memory forever after a large operation. + */ + + if (iPtr->appendAvl > 500) { + ckfree(iPtr->appendResult); + iPtr->appendResult = NULL; + iPtr->appendAvl = 0; + } + iPtr->appendUsed = strlen(iPtr->result); + } else if (iPtr->result[iPtr->appendUsed] != 0) { + /* + * Most likely someone has modified a result created by + * Tcl_AppendResult et al. so that it has a different size. + * Just recompute the size. + */ + + iPtr->appendUsed = strlen(iPtr->result); + } + totalSpace = newSpace + iPtr->appendUsed; + if (totalSpace >= iPtr->appendAvl) { + char *new; + + if (totalSpace < 100) { + totalSpace = 200; + } else { + totalSpace *= 2; + } + new = (char *) ckalloc((unsigned) totalSpace); + strcpy(new, iPtr->result); + if (iPtr->appendResult != NULL) { + ckfree(iPtr->appendResult); + } + iPtr->appendResult = new; + iPtr->appendAvl = totalSpace; + } else if (iPtr->result != iPtr->appendResult) { + strcpy(iPtr->appendResult, iPtr->result); + } + Tcl_FreeResult(iPtr); + iPtr->result = iPtr->appendResult; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_ResetResult -- + * + * This procedure restores the result area for an interpreter + * to its default initialized state, freeing up any memory that + * may have been allocated for the result and clearing any + * error information for the interpreter. + * + * Results: + * None. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +void +Tcl_ResetResult(interp) + Tcl_Interp *interp; /* Interpreter for which to clear result. */ +{ + register Interp *iPtr = (Interp *) interp; + + Tcl_FreeResult(iPtr); + iPtr->result = iPtr->resultSpace; + iPtr->resultSpace[0] = 0; + iPtr->flags &= + ~(ERR_ALREADY_LOGGED | ERR_IN_PROGRESS | ERROR_CODE_SET); +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_SetErrorCode -- + * + * This procedure is called to record machine-readable information + * about an error that is about to be returned. + * + * Results: + * None. + * + * Side effects: + * The errorCode global variable is modified to hold all of the + * arguments to this procedure, in a list form with each argument + * becoming one element of the list. A flag is set internally + * to remember that errorCode has been set, so the variable doesn't + * get set automatically when the error is returned. + * + *---------------------------------------------------------------------- + */ + /* VARARGS2 */ +void +Tcl_SetErrorCode TCL_VARARGS_DEF(Tcl_Interp *,arg1) +{ + va_list argList; + char *string; + int flags; + Interp *iPtr; + + /* + * Scan through the arguments one at a time, appending them to + * $errorCode as list elements. + */ + + iPtr = (Interp *) TCL_VARARGS_START(Tcl_Interp *,arg1,argList); + flags = TCL_GLOBAL_ONLY | TCL_LIST_ELEMENT; + while (1) { + string = va_arg(argList, char *); + if (string == NULL) { + break; + } + (void) Tcl_SetVar2((Tcl_Interp *) iPtr, "errorCode", + (char *) NULL, string, flags); + flags |= TCL_APPEND_VALUE; + } + va_end(argList); + iPtr->flags |= ERROR_CODE_SET; +} + +/* + *---------------------------------------------------------------------- + * + * TclGetListIndex -- + * + * Parse a list index, which may be either an integer or the + * value "end". + * + * Results: + * The return value is either TCL_OK or TCL_ERROR. If it is + * TCL_OK, then the index corresponding to string is left in + * *indexPtr. If the return value is TCL_ERROR, then string + * was bogus; an error message is returned in interp->result. + * If a negative index is specified, it is rounded up to 0. + * The index value may be larger than the size of the list + * (this happens when "end" is specified). + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +int +TclGetListIndex(interp, string, indexPtr) + Tcl_Interp *interp; /* Interpreter for error reporting. */ + char *string; /* String containing list index. */ + int *indexPtr; /* Where to store index. */ +{ + if (isdigit(UCHAR(*string)) || (*string == '-')) { + if (Tcl_GetInt(interp, string, indexPtr) != TCL_OK) { + return TCL_ERROR; + } + if (*indexPtr < 0) { + *indexPtr = 0; + } + } else if (strncmp(string, "end", strlen(string)) == 0) { + *indexPtr = INT_MAX; + } else { + Tcl_AppendResult(interp, "bad index \"", string, + "\": must be integer or \"end\"", (char *) NULL); + return TCL_ERROR; + } + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_RegExpCompile -- + * + * Compile a regular expression into a form suitable for fast + * matching. This procedure retains a small cache of pre-compiled + * regular expressions in the interpreter, in order to avoid + * compilation costs as much as possible. + * + * Results: + * The return value is a pointer to the compiled form of string, + * suitable for passing to Tcl_RegExpExec. This compiled form + * is only valid up until the next call to this procedure, so + * don't keep these around for a long time! If an error occurred + * while compiling the pattern, then NULL is returned and an error + * message is left in interp->result. + * + * Side effects: + * The cache of compiled regexp's in interp will be modified to + * hold information for string, if such information isn't already + * present in the cache. + * + *---------------------------------------------------------------------- + */ + +Tcl_RegExp +Tcl_RegExpCompile(interp, string) + Tcl_Interp *interp; /* For use in error reporting. */ + char *string; /* String for which to produce + * compiled regular expression. */ +{ + register Interp *iPtr = (Interp *) interp; + int i, length; + regexp *result; + + length = strlen(string); + for (i = 0; i < NUM_REGEXPS; i++) { + if ((length == iPtr->patLengths[i]) + && (strcmp(string, iPtr->patterns[i]) == 0)) { + /* + * Move the matched pattern to the first slot in the + * cache and shift the other patterns down one position. + */ + + if (i != 0) { + int j; + char *cachedString; + + cachedString = iPtr->patterns[i]; + result = iPtr->regexps[i]; + for (j = i-1; j >= 0; j--) { + iPtr->patterns[j+1] = iPtr->patterns[j]; + iPtr->patLengths[j+1] = iPtr->patLengths[j]; + iPtr->regexps[j+1] = iPtr->regexps[j]; + } + iPtr->patterns[0] = cachedString; + iPtr->patLengths[0] = length; + iPtr->regexps[0] = result; + } + return (Tcl_RegExp) iPtr->regexps[0]; + } + } + + /* + * No match in the cache. Compile the string and add it to the + * cache. + */ + + TclRegError((char *) NULL); + result = TclRegComp(string); + if (TclGetRegError() != NULL) { + Tcl_AppendResult(interp, + "couldn't compile regular expression pattern: ", + TclGetRegError(), (char *) NULL); + return NULL; + } + if (iPtr->patterns[NUM_REGEXPS-1] != NULL) { + ckfree(iPtr->patterns[NUM_REGEXPS-1]); + ckfree((char *) iPtr->regexps[NUM_REGEXPS-1]); + } + for (i = NUM_REGEXPS - 2; i >= 0; i--) { + iPtr->patterns[i+1] = iPtr->patterns[i]; + iPtr->patLengths[i+1] = iPtr->patLengths[i]; + iPtr->regexps[i+1] = iPtr->regexps[i]; + } + iPtr->patterns[0] = (char *) ckalloc((unsigned) (length+1)); + strcpy(iPtr->patterns[0], string); + iPtr->patLengths[0] = length; + iPtr->regexps[0] = result; + return (Tcl_RegExp) result; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_RegExpExec -- + * + * Execute the regular expression matcher using a compiled form + * of a regular expression and save information about any match + * that is found. + * + * Results: + * If an error occurs during the matching operation then -1 + * is returned and interp->result contains an error message. + * Otherwise the return value is 1 if a matching range is + * found and 0 if there is no matching range. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_RegExpExec(interp, re, string, start) + Tcl_Interp *interp; /* Interpreter to use for error reporting. */ + Tcl_RegExp re; /* Compiled regular expression; must have + * been returned by previous call to + * Tcl_RegExpCompile. */ + char *string; /* String against which to match re. */ + char *start; /* If string is part of a larger string, + * this identifies beginning of larger + * string, so that "^" won't match. */ +{ + int match; + + regexp *regexpPtr = (regexp *) re; + TclRegError((char *) NULL); + match = TclRegExec(regexpPtr, string, start); + if (TclGetRegError() != NULL) { + Tcl_ResetResult(interp); + Tcl_AppendResult(interp, "error while matching regular expression: ", + TclGetRegError(), (char *) NULL); + return -1; + } + return match; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_RegExpRange -- + * + * Returns pointers describing the range of a regular expression match, + * or one of the subranges within the match. + * + * Results: + * The variables at *startPtr and *endPtr are modified to hold the + * addresses of the endpoints of the range given by index. If the + * specified range doesn't exist then NULLs are returned. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +void +Tcl_RegExpRange(re, index, startPtr, endPtr) + Tcl_RegExp re; /* Compiled regular expression that has + * been passed to Tcl_RegExpExec. */ + int index; /* 0 means give the range of the entire + * match, > 0 means give the range of + * a matching subrange. Must be no greater + * than NSUBEXP. */ + char **startPtr; /* Store address of first character in + * (sub-) range here. */ + char **endPtr; /* Store address of character just after last + * in (sub-) range here. */ +{ + regexp *regexpPtr = (regexp *) re; + + if (index >= NSUBEXP) { + *startPtr = *endPtr = NULL; + } else { + *startPtr = regexpPtr->startp[index]; + *endPtr = regexpPtr->endp[index]; + } +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_RegExpMatch -- + * + * See if a string matches a regular expression. + * + * Results: + * If an error occurs during the matching operation then -1 + * is returned and interp->result contains an error message. + * Otherwise the return value is 1 if "string" matches "pattern" + * and 0 otherwise. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_RegExpMatch(interp, string, pattern) + Tcl_Interp *interp; /* Used for error reporting. */ + char *string; /* String. */ + char *pattern; /* Regular expression to match against + * string. */ +{ + Tcl_RegExp re; + + re = Tcl_RegExpCompile(interp, pattern); + if (re == NULL) { + return -1; + } + return Tcl_RegExpExec(interp, re, string, string); +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_DStringInit -- + * + * Initializes a dynamic string, discarding any previous contents + * of the string (Tcl_DStringFree should have been called already + * if the dynamic string was previously in use). + * + * Results: + * None. + * + * Side effects: + * The dynamic string is initialized to be empty. + * + *---------------------------------------------------------------------- + */ + +void +Tcl_DStringInit(dsPtr) + register Tcl_DString *dsPtr; /* Pointer to structure for + * dynamic string. */ +{ + dsPtr->string = dsPtr->staticSpace; + dsPtr->length = 0; + dsPtr->spaceAvl = TCL_DSTRING_STATIC_SIZE; + dsPtr->staticSpace[0] = 0; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_DStringAppend -- + * + * Append more characters to the current value of a dynamic string. + * + * Results: + * The return value is a pointer to the dynamic string's new value. + * + * Side effects: + * Length bytes from string (or all of string if length is less + * than zero) are added to the current value of the string. Memory + * gets reallocated if needed to accomodate the string's new size. + * + *---------------------------------------------------------------------- + */ + +char * +Tcl_DStringAppend(dsPtr, string, length) + register Tcl_DString *dsPtr; /* Structure describing dynamic + * string. */ + char *string; /* String to append. If length is + * -1 then this must be + * null-terminated. */ + int length; /* Number of characters from string + * to append. If < 0, then append all + * of string, up to null at end. */ +{ + int newSize; + char *newString, *dst, *end; + + if (length < 0) { + length = strlen(string); + } + newSize = length + dsPtr->length; + + /* + * Allocate a larger buffer for the string if the current one isn't + * large enough. Allocate extra space in the new buffer so that there + * will be room to grow before we have to allocate again. + */ + + if (newSize >= dsPtr->spaceAvl) { + dsPtr->spaceAvl = newSize*2; + newString = (char *) ckalloc((unsigned) dsPtr->spaceAvl); + memcpy((VOID *)newString, (VOID *) dsPtr->string, + (size_t) dsPtr->length); + if (dsPtr->string != dsPtr->staticSpace) { + ckfree(dsPtr->string); + } + dsPtr->string = newString; + } + + /* + * Copy the new string into the buffer at the end of the old + * one. + */ + + for (dst = dsPtr->string + dsPtr->length, end = string+length; + string < end; string++, dst++) { + *dst = *string; + } + *dst = 0; + dsPtr->length += length; + return dsPtr->string; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_DStringAppendElement -- + * + * Append a list element to the current value of a dynamic string. + * + * Results: + * The return value is a pointer to the dynamic string's new value. + * + * Side effects: + * String is reformatted as a list element and added to the current + * value of the string. Memory gets reallocated if needed to + * accomodate the string's new size. + * + *---------------------------------------------------------------------- + */ + +char * +Tcl_DStringAppendElement(dsPtr, string) + register Tcl_DString *dsPtr; /* Structure describing dynamic + * string. */ + char *string; /* String to append. Must be + * null-terminated. */ +{ + int newSize, flags; + char *dst, *newString; + + newSize = Tcl_ScanElement(string, &flags) + dsPtr->length + 1; + + /* + * Allocate a larger buffer for the string if the current one isn't + * large enough. Allocate extra space in the new buffer so that there + * will be room to grow before we have to allocate again. + * SPECIAL NOTE: must use memcpy, not strcpy, to copy the string + * to a larger buffer, since there may be embedded NULLs in the + * string in some cases. + */ + + if (newSize >= dsPtr->spaceAvl) { + dsPtr->spaceAvl = newSize*2; + newString = (char *) ckalloc((unsigned) dsPtr->spaceAvl); + memcpy((VOID *) newString, (VOID *) dsPtr->string, + (size_t) dsPtr->length); + if (dsPtr->string != dsPtr->staticSpace) { + ckfree(dsPtr->string); + } + dsPtr->string = newString; + } + + /* + * Convert the new string to a list element and copy it into the + * buffer at the end, with a space, if needed. + */ + + dst = dsPtr->string + dsPtr->length; + if (TclNeedSpace(dsPtr->string, dst)) { + *dst = ' '; + dst++; + dsPtr->length++; + } + dsPtr->length += Tcl_ConvertElement(string, dst, flags); + return dsPtr->string; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_DStringSetLength -- + * + * Change the length of a dynamic string. This can cause the + * string to either grow or shrink, depending on the value of + * length. + * + * Results: + * None. + * + * Side effects: + * The length of dsPtr is changed to length and a null byte is + * stored at that position in the string. If length is larger + * than the space allocated for dsPtr, then a panic occurs. + * + *---------------------------------------------------------------------- + */ + +void +Tcl_DStringSetLength(dsPtr, length) + register Tcl_DString *dsPtr; /* Structure describing dynamic + * string. */ + int length; /* New length for dynamic string. */ +{ + if (length < 0) { + length = 0; + } + if (length >= dsPtr->spaceAvl) { + char *newString; + + dsPtr->spaceAvl = length+1; + newString = (char *) ckalloc((unsigned) dsPtr->spaceAvl); + + /* + * SPECIAL NOTE: must use memcpy, not strcpy, to copy the string + * to a larger buffer, since there may be embedded NULLs in the + * string in some cases. + */ + + memcpy((VOID *) newString, (VOID *) dsPtr->string, + (size_t) dsPtr->length); + if (dsPtr->string != dsPtr->staticSpace) { + ckfree(dsPtr->string); + } + dsPtr->string = newString; + } + dsPtr->length = length; + dsPtr->string[length] = 0; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_DStringFree -- + * + * Frees up any memory allocated for the dynamic string and + * reinitializes the string to an empty state. + * + * Results: + * None. + * + * Side effects: + * The previous contents of the dynamic string are lost, and + * the new value is an empty string. + * + *---------------------------------------------------------------------- + */ + +void +Tcl_DStringFree(dsPtr) + register Tcl_DString *dsPtr; /* Structure describing dynamic + * string. */ +{ + if (dsPtr->string != dsPtr->staticSpace) { + ckfree(dsPtr->string); + } + dsPtr->string = dsPtr->staticSpace; + dsPtr->length = 0; + dsPtr->spaceAvl = TCL_DSTRING_STATIC_SIZE; + dsPtr->staticSpace[0] = 0; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_DStringResult -- + * + * This procedure moves the value of a dynamic string into an + * interpreter as its result. The string itself is reinitialized + * to an empty string. + * + * Results: + * None. + * + * Side effects: + * The string is "moved" to interp's result, and any existing + * result for interp is freed up. DsPtr is reinitialized to + * an empty string. + * + *---------------------------------------------------------------------- + */ + +void +Tcl_DStringResult(interp, dsPtr) + Tcl_Interp *interp; /* Interpreter whose result is to be + * reset. */ + Tcl_DString *dsPtr; /* Dynamic string that is to become + * the result of interp. */ +{ + Tcl_ResetResult(interp); + if (dsPtr->string != dsPtr->staticSpace) { + interp->result = dsPtr->string; + interp->freeProc = TCL_DYNAMIC; + } else if (dsPtr->length < TCL_RESULT_SIZE) { + interp->result = ((Interp *) interp)->resultSpace; + strcpy(interp->result, dsPtr->string); + } else { + Tcl_SetResult(interp, dsPtr->string, TCL_VOLATILE); + } + dsPtr->string = dsPtr->staticSpace; + dsPtr->length = 0; + dsPtr->spaceAvl = TCL_DSTRING_STATIC_SIZE; + dsPtr->staticSpace[0] = 0; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_DStringGetResult -- + * + * This procedure moves the result of an interpreter into a + * dynamic string. + * + * Results: + * None. + * + * Side effects: + * The interpreter's result is cleared, and the previous contents + * of dsPtr are freed. + * + *---------------------------------------------------------------------- + */ + +void +Tcl_DStringGetResult(interp, dsPtr) + Tcl_Interp *interp; /* Interpreter whose result is to be + * reset. */ + Tcl_DString *dsPtr; /* Dynamic string that is to become + * the result of interp. */ +{ + Interp *iPtr = (Interp *) interp; + if (dsPtr->string != dsPtr->staticSpace) { + ckfree(dsPtr->string); + } + dsPtr->length = strlen(iPtr->result); + if (iPtr->freeProc != NULL) { + if ((iPtr->freeProc == TCL_DYNAMIC) + || (iPtr->freeProc == (Tcl_FreeProc *) free)) { + dsPtr->string = iPtr->result; + dsPtr->spaceAvl = dsPtr->length+1; + } else { + dsPtr->string = (char *) ckalloc((unsigned) (dsPtr->length+1)); + strcpy(dsPtr->string, iPtr->result); + (*iPtr->freeProc)(iPtr->result); + } + dsPtr->spaceAvl = dsPtr->length+1; + iPtr->freeProc = NULL; + } else { + if (dsPtr->length < TCL_DSTRING_STATIC_SIZE) { + dsPtr->string = dsPtr->staticSpace; + dsPtr->spaceAvl = TCL_DSTRING_STATIC_SIZE; + } else { + dsPtr->string = (char *) ckalloc((unsigned) (dsPtr->length + 1)); + dsPtr->spaceAvl = dsPtr->length + 1; + } + strcpy(dsPtr->string, iPtr->result); + } + iPtr->result = iPtr->resultSpace; + iPtr->resultSpace[0] = 0; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_DStringStartSublist -- + * + * This procedure adds the necessary information to a dynamic + * string (e.g. " {" to start a sublist. Future element + * appends will be in the sublist rather than the main list. + * + * Results: + * None. + * + * Side effects: + * Characters get added to the dynamic string. + * + *---------------------------------------------------------------------- + */ + +void +Tcl_DStringStartSublist(dsPtr) + Tcl_DString *dsPtr; /* Dynamic string. */ +{ + if (TclNeedSpace(dsPtr->string, dsPtr->string + dsPtr->length)) { + Tcl_DStringAppend(dsPtr, " {", -1); + } else { + Tcl_DStringAppend(dsPtr, "{", -1); + } +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_DStringEndSublist -- + * + * This procedure adds the necessary characters to a dynamic + * string to end a sublist (e.g. "}"). Future element appends + * will be in the enclosing (sub)list rather than the current + * sublist. + * + * Results: + * None. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +void +Tcl_DStringEndSublist(dsPtr) + Tcl_DString *dsPtr; /* Dynamic string. */ +{ + Tcl_DStringAppend(dsPtr, "}", -1); +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_PrintDouble -- + * + * Given a floating-point value, this procedure converts it to + * an ASCII string using. + * + * Results: + * The ASCII equivalent of "value" is written at "dst". It is + * written using the current precision, and it is guaranteed to + * contain a decimal point or exponent, so that it looks like + * a floating-point value and not an integer. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +void +Tcl_PrintDouble(interp, value, dst) + Tcl_Interp *interp; /* Interpreter whose tcl_precision + * variable controls printing. */ + double value; /* Value to print as string. */ + char *dst; /* Where to store converted value; + * must have at least TCL_DOUBLE_SPACE + * characters. */ +{ + register char *p; + sprintf(dst, ((Interp *) interp)->pdFormat, value); + + /* + * If the ASCII result looks like an integer, add ".0" so that it + * doesn't look like an integer anymore. This prevents floating-point + * values from being converted to integers unintentionally. + */ + + for (p = dst; *p != 0; p++) { + if ((*p == '.') || (isalpha(UCHAR(*p)))) { + return; + } + } + p[0] = '.'; + p[1] = '0'; + p[2] = 0; +} + +/* + *---------------------------------------------------------------------- + * + * TclPrecTraceProc -- + * + * This procedure is invoked whenever the variable "tcl_precision" + * is written. + * + * Results: + * Returns NULL if all went well, or an error message if the + * new value for the variable doesn't make sense. + * + * Side effects: + * If the new value doesn't make sense then this procedure + * undoes the effect of the variable modification. Otherwise + * it modifies the format string that's used by Tcl_PrintDouble. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +char * +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. */ + int flags; /* Information about what happened. */ +{ + register Interp *iPtr = (Interp *) interp; + char *value, *end; + int prec; + + /* + * If the variable is unset, then recreate the trace and restore + * the default value of the format string. + */ + + if (flags & TCL_TRACE_UNSETS) { + if ((flags & TCL_TRACE_DESTROYED) && !(flags & TCL_INTERP_DESTROYED)) { + Tcl_TraceVar2(interp, name1, name2, + TCL_GLOBAL_ONLY|TCL_TRACE_WRITES|TCL_TRACE_UNSETS, + TclPrecTraceProc, clientData); + } + strcpy(iPtr->pdFormat, DEFAULT_PD_FORMAT); + iPtr->pdPrec = DEFAULT_PD_PREC; + return (char *) NULL; + } + + value = Tcl_GetVar2(interp, name1, name2, flags & TCL_GLOBAL_ONLY); + if (value == NULL) { + value = ""; + } + prec = strtoul(value, &end, 10); + if ((prec <= 0) || (prec > TCL_MAX_PREC) || (prec > 100) || + (end == value) || (*end != 0)) { + char oldValue[10]; + + sprintf(oldValue, "%d", iPtr->pdPrec); + Tcl_SetVar2(interp, name1, name2, oldValue, flags & TCL_GLOBAL_ONLY); + return "improper value for precision"; + } + sprintf(iPtr->pdFormat, "%%.%dg", prec); + iPtr->pdPrec = prec; + return (char *) NULL; +} + +/* + *---------------------------------------------------------------------- + * + * TclNeedSpace -- + * + * This procedure checks to see whether it is appropriate to + * add a space before appending a new list element to an + * existing string. + * + * Results: + * The return value is 1 if a space is appropriate, 0 otherwise. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +int +TclNeedSpace(start, end) + char *start; /* First character in string. */ + char *end; /* End of string (place where space will + * be added, if appropriate). */ +{ + /* + * A space is needed unless either + * (a) we're at the start of the string, or + * (b) the trailing characters of the string consist of one or more + * open curly braces preceded by a space or extending back to + * the beginning of the string. + * (c) the trailing characters of the string consist of a space + * preceded by a character other than backslash. + */ + + if (end == start) { + return 0; + } + end--; + if (*end != '{') { + if (isspace(UCHAR(*end)) && ((end == start) || (end[-1] != '\\'))) { + return 0; + } + return 1; + } + do { + if (end == start) { + return 0; + } + end--; + } while (*end == '{'); + if (isspace(UCHAR(*end))) { + return 0; + } + return 1; +} diff --git a/contrib/tcl/generic/tclVar.c b/contrib/tcl/generic/tclVar.c new file mode 100644 index 0000000..c5c2147 --- /dev/null +++ b/contrib/tcl/generic/tclVar.c @@ -0,0 +1,2575 @@ +/* + * tclVar.c -- + * + * This file contains routines that implement Tcl variables + * (both scalars and arrays). + * + * The implementation of arrays is modelled after an initial + * implementation by Mark Diekhans and Karl Lehenbauer. + * + * Copyright (c) 1987-1994 The Regents of the University of California. + * Copyright (c) 1994-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: @(#) tclVar.c 1.69 96/02/28 21:45:10 + */ + +#include "tclInt.h" +#include "tclPort.h" + +/* + * The strings below are used to indicate what went wrong when a + * 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 *danglingUpvar = "upvar refers to element in deleted array"; + +/* + * Creation flag values passed in to LookupVar: + * + * CRT_PART1 - 1 means create hash table entry for part 1 of + * name, if it doesn't already exist. 0 means + * return an error if it doesn't exist. + * CRT_PART2 - 1 means create hash table entry for part 2 of + * name, if it doesn't already exist. 0 means + * return an error if it doesn't exist. + */ + +#define CRT_PART1 1 +#define CRT_PART2 2 + +/* + * The following additional flag is used internally and passed through + * to LookupVar to indicate that a procedure like Tcl_GetVar was called + * instead of Tcl_GetVar2 and the single name value hasn't yet been + * parsed into an array name and index (if any). + */ + +#define PART1_NOT_PARSED 0x10000 + +/* + * 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 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 Var * LookupVar _ANSI_ARGS_((Tcl_Interp *interp, char *part1, + char *part2, int flags, char *msg, int create, + Var **arrayPtrPtr)); +static int MakeUpvar _ANSI_ARGS_((Interp *iPtr, + CallFrame *framePtr, char *otherP1, + char *otherP2, char *myName, int flags)); +static Var * NewVar _ANSI_ARGS_((void)); +static ArraySearch * ParseSearchId _ANSI_ARGS_((Tcl_Interp *interp, + Var *varPtr, char *varName, char *string)); +static void VarErrMsg _ANSI_ARGS_((Tcl_Interp *interp, + char *part1, char *part2, char *operation, + char *reason)); + +/* + *---------------------------------------------------------------------- + * + * LookupVar -- + * + * This procedure is used by virtually all of the variable + * code to locate a variable given its name(s). + * + * Results: + * The return value is a pointer to the variable indicated by + * part1 and part2, or NULL if the variable couldn't be found. + * If the variable is found, *arrayPtrPtr is filled in with + * the address of the array that contains the variable (or NULL + * if the variable is a scalar). Note: it's possible that the + * variable returned may be VAR_UNDEFINED, even if CRT_PART1 and + * CRT_PART2 are specified (these only cause the hash table entry + * and/or array to be created). + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static Var * +LookupVar(interp, part1, part2, flags, msg, create, arrayPtrPtr) + Tcl_Interp *interp; /* Interpreter to use for lookup. */ + char *part1; /* If part2 isn't NULL, this is the name + * of an array. Otherwise, if the + * PART1_NOT_PARSED flag bit is set this + * is a full variable name that could + * include a parenthesized array elemnt. + * If PART1_NOT_PARSED isn't present, then + * this is the name of a scalar variable. */ + char *part2; /* Name of an element within array, or NULL. */ + int flags; /* Only the TCL_GLOBAL_ONLY, TCL_LEAVE_ERR_MSG, + * and PART1_NOT_PARSED bits matter. */ + 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 create; /* OR'ed combination of CRT_PART1 and + * CRT_PART2. Tells which entries to create + * if they don't already 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; + Tcl_HashTable *tablePtr; + Tcl_HashEntry *hPtr; + Var *varPtr; + int new; + char *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. */ + char *elName; /* Name of array element or NULL; + * may be same as part2, or may be + * openParen+1. */ + char *p; + + /* + * If the name hasn't been parsed into array name and index yet, + * do it now. + */ + + openParen = closeParen = NULL; + elName = part2; + if (flags & PART1_NOT_PARSED) { + for (p = part1; ; p++) { + if (*p == 0) { + elName = NULL; + break; + } + if (*p == '(') { + openParen = p; + do { + p++; + } while (*p != '\0'); + p--; + if (*p == ')') { + closeParen = p; + *openParen = 0; + elName = openParen+1; + } else { + openParen = NULL; + elName = NULL; + } + break; + } + } + } + + /* + * Lookup part1. + */ + + *arrayPtrPtr = NULL; + if ((flags & TCL_GLOBAL_ONLY) || (iPtr->varFramePtr == NULL)) { + tablePtr = &iPtr->globalTable; + } else { + tablePtr = &iPtr->varFramePtr->varTable; + } + if (create & CRT_PART1) { + hPtr = Tcl_CreateHashEntry(tablePtr, part1, &new); + if (openParen != NULL) { + *openParen = '('; + } + if (new) { + varPtr = NewVar(); + Tcl_SetHashValue(hPtr, varPtr); + varPtr->hPtr = hPtr; + } + } else { + hPtr = Tcl_FindHashEntry(tablePtr, part1); + if (openParen != NULL) { + *openParen = '('; + } + if (hPtr == NULL) { + if (flags & TCL_LEAVE_ERR_MSG) { + VarErrMsg(interp, part1, part2, msg, noSuchVar); + } + return NULL; + } + } + varPtr = (Var *) Tcl_GetHashValue(hPtr); + if (varPtr->flags & VAR_UPVAR) { + varPtr = varPtr->value.upvarPtr; + } + + if (elName == NULL) { + return varPtr; + } + + /* + * We're dealing with an array element, so make sure the variable + * is an array and lookup the element (create it if desired). + */ + + if (varPtr->flags & VAR_UNDEFINED) { + if (!(create & CRT_PART1)) { + if (flags & TCL_LEAVE_ERR_MSG) { + VarErrMsg(interp, part1, part2, msg, noSuchVar); + } + return NULL; + } + varPtr->flags = VAR_ARRAY; + varPtr->value.tablePtr = (Tcl_HashTable *) + ckalloc(sizeof(Tcl_HashTable)); + Tcl_InitHashTable(varPtr->value.tablePtr, TCL_STRING_KEYS); + } else if (!(varPtr->flags & VAR_ARRAY)) { + if (flags & TCL_LEAVE_ERR_MSG) { + VarErrMsg(interp, part1, part2, msg, needArray); + } + return NULL; + } + *arrayPtrPtr = varPtr; + if (closeParen != NULL) { + *closeParen = 0; + } + if (create & CRT_PART2) { + hPtr = Tcl_CreateHashEntry(varPtr->value.tablePtr, elName, &new); + if (closeParen != NULL) { + *closeParen = ')'; + } + if (new) { + if (varPtr->searchPtr != NULL) { + DeleteSearches(varPtr); + } + varPtr = NewVar(); + Tcl_SetHashValue(hPtr, varPtr); + varPtr->hPtr = hPtr; + } + } else { + hPtr = Tcl_FindHashEntry(varPtr->value.tablePtr, elName); + if (closeParen != NULL) { + *closeParen = ')'; + } + if (hPtr == NULL) { + if (flags & TCL_LEAVE_ERR_MSG) { + VarErrMsg(interp, part1, part2, msg, noSuchElement); + } + return NULL; + } + } + return (Var *) Tcl_GetHashValue(hPtr); +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_GetVar -- + * + * Return the value of a Tcl variable. + * + * Results: + * The return value points to the current value of varName. If + * the variable is not defined or can't be read because of a clash + * in array usage then a NULL pointer is returned and an error + * message is left in interp->result if the TCL_LEAVE_ERR_MSG + * flag is set. Note: the return value is only valid up until + * the next call to Tcl_SetVar or Tcl_SetVar2; if you depend on + * the value lasting longer than that, then make yourself a private + * copy. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +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. */ + int flags; /* OR-ed combination of TCL_GLOBAL_ONLY + * or TCL_LEAVE_ERR_MSG bits. */ +{ + return Tcl_GetVar2(interp, varName, (char *) NULL, + flags | PART1_NOT_PARSED); +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_GetVar2 -- + * + * Return the value of a Tcl variable, given a two-part name + * consisting of array name and element within array. + * + * Results: + * The return value points to the current value of the variable + * given by part1 and part2. 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 interp->result if the + * TCL_LEAVE_ERR_MSG flag is set. Note: the return value is + * only valid up until the next call to Tcl_SetVar or Tcl_SetVar2; + * if you depend on the value lasting longer than that, then make + * yourself a private copy. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +char * +Tcl_GetVar2(interp, part1, part2, flags) + Tcl_Interp *interp; /* Command interpreter in which variable is + * to be looked up. */ + char *part1; /* Name of array (if part2 is NULL) or + * name of variable. */ + char *part2; /* If non-null, gives name of element in + * array. */ + int flags; /* OR-ed combination of TCL_GLOBAL_ONLY, + * TCL_LEAVE_ERR_MSG, and PART1_NOT_PARSED + * bits. */ +{ + Var *varPtr, *arrayPtr; + Interp *iPtr = (Interp *) interp; + + varPtr = LookupVar(interp, part1, part2, flags, "read", CRT_PART2, + &arrayPtr); + if (varPtr == NULL) { + return NULL; + } + + /* + * Invoke any traces that have been set for the variable. + */ + + if ((varPtr->tracePtr != NULL) + || ((arrayPtr != NULL) && (arrayPtr->tracePtr != NULL))) { + char *msg; + + msg = CallTraces(iPtr, arrayPtr, varPtr, part1, part2, + (flags & (TCL_GLOBAL_ONLY|PART1_NOT_PARSED)) | TCL_TRACE_READS); + if (msg != NULL) { + VarErrMsg(interp, part1, part2, "read", msg); + goto cleanup; + } + } + if (!(varPtr->flags & (VAR_UNDEFINED|VAR_UPVAR|VAR_ARRAY))) { + return varPtr->value.string; + } + if (flags & TCL_LEAVE_ERR_MSG) { + char *msg; + + if ((varPtr->flags & VAR_UNDEFINED) && (arrayPtr != NULL) + && !(arrayPtr->flags & VAR_UNDEFINED)) { + msg = noSuchElement; + } else if (varPtr->flags & VAR_ARRAY) { + msg = isArray; + } else { + msg = noSuchVar; + } + VarErrMsg(interp, part1, part2, "read", msg); + } + + /* + * 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 (varPtr->flags & VAR_UNDEFINED) { + CleanupVar(varPtr, arrayPtr); + } + return NULL; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_SetVar -- + * + * Change the value of a variable. + * + * Results: + * Returns a pointer to the malloc'ed string holding the new + * value of the variable. The caller should 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 interp->result. + * + * 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_APPEND_VALUE, + * TCL_LIST_ELEMENT, or TCL_LEAVE_ERR_MSG. */ +{ + return Tcl_SetVar2(interp, varName, (char *) NULL, newValue, + flags | PART1_NOT_PARSED); +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_SetVar2 -- + * + * 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. If the named scalar or array or element + * doesn't exist then create one. + * + * Results: + * Returns a pointer to the malloc'ed string holding the new + * value of the variable. The caller should not modify this + * string. 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 interp->result. + * + * Side effects: + * The value of the given variable is set. If either the array + * or the entry didn't exist then a new one is created. + * + *---------------------------------------------------------------------- + */ + +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 + * variable. Otherwise it is name of array. */ + char *part2; /* Name of an element within array, or NULL. */ + char *newValue; /* New value for variable. */ + int flags; /* Various flags that tell how to set value: + * any of TCL_GLOBAL_ONLY, TCL_APPEND_VALUE, + * TCL_LIST_ELEMENT, TCL_LEAVE_ERR_MSG, or + * PART1_NOT_PARSED. */ +{ + register Var *varPtr; + register Interp *iPtr = (Interp *) interp; + int length, listFlags; + Var *arrayPtr; + char *result; + + varPtr = LookupVar(interp, part1, part2, flags, "set", CRT_PART1|CRT_PART2, + &arrayPtr); + if (varPtr == NULL) { + return NULL; + } + + /* + * If the variable's hPtr field is NULL, it means that this is an + * upvar to an array element where the array was deleted, leaving + * the element dangling at the end of the upvar. Generate an error + * (allowing the variable to be reset would screw up our storage + * allocation and is meaningless anyway). + */ + + if (varPtr->hPtr == NULL) { + if (flags & TCL_LEAVE_ERR_MSG) { + VarErrMsg(interp, part1, part2, "set", danglingUpvar); + } + return NULL; + } + + /* + * Clear the variable's current value unless this is an + * append operation. + */ + + if (varPtr->flags & VAR_ARRAY) { + if (flags & TCL_LEAVE_ERR_MSG) { + VarErrMsg(interp, part1, part2, "set", isArray); + } + return NULL; + } + if (!(flags & TCL_APPEND_VALUE) || (varPtr->flags & VAR_UNDEFINED)) { + varPtr->valueLength = 0; + } + + /* + * Call read trace if variable is being appended to. + */ + + if ((flags & TCL_APPEND_VALUE) && ((varPtr->tracePtr != NULL) + || ((arrayPtr != NULL) && (arrayPtr->tracePtr != NULL)))) { + char *msg; + msg = CallTraces(iPtr, arrayPtr, varPtr, part1, part2, + (flags & (TCL_GLOBAL_ONLY|PART1_NOT_PARSED)) | TCL_TRACE_READS); + if (msg != NULL) { + VarErrMsg(interp, part1, part2, "read", msg); + result = NULL; + goto cleanup; + } + } + + /* + * Compute how many total bytes will be needed for the variable's + * new value (leave space for a separating space between list + * elements). Allocate new space for the value if needed. + */ + + if (flags & TCL_LIST_ELEMENT) { + length = Tcl_ScanElement(newValue, &listFlags) + 1; + } else { + length = strlen(newValue); + } + length += varPtr->valueLength; + if (length >= varPtr->valueSpace) { + char *newValue; + int newSize; + + newSize = 2*varPtr->valueSpace; + if (newSize <= length) { + newSize = length + 1; + } + if (newSize < 24) { + /* + * Don't waste time with teensy-tiny variables; we'll + * just end up expanding them later. + */ + + newSize = 24; + } + newValue = (char *) ckalloc((unsigned) newSize); + if (varPtr->valueSpace > 0) { + strcpy(newValue, varPtr->value.string); + ckfree(varPtr->value.string); + } + varPtr->valueSpace = newSize; + varPtr->value.string = newValue; + } + + /* + * Append the new value to the variable, either as a list + * element or as a string. + */ + + if (flags & TCL_LIST_ELEMENT) { + char *dst = varPtr->value.string + varPtr->valueLength; + + if (TclNeedSpace(varPtr->value.string, dst)) { + *dst = ' '; + dst++; + varPtr->valueLength++; + } + varPtr->valueLength += Tcl_ConvertElement(newValue, dst, listFlags); + } else { + strcpy(varPtr->value.string + varPtr->valueLength, newValue); + varPtr->valueLength = length; + } + varPtr->flags &= ~VAR_UNDEFINED; + + /* + * Invoke any write traces for the variable. + */ + + if ((varPtr->tracePtr != NULL) + || ((arrayPtr != NULL) && (arrayPtr->tracePtr != NULL))) { + char *msg; + + msg = CallTraces(iPtr, arrayPtr, varPtr, part1, part2, + (flags & (TCL_GLOBAL_ONLY|PART1_NOT_PARSED)) + | TCL_TRACE_WRITES); + if (msg != NULL) { + VarErrMsg(interp, part1, part2, "set", msg); + result = NULL; + goto cleanup; + } + } + + /* + * If the variable was changed in some gross way by a trace (e.g. + * it was unset and then recreated as an array) then just return + * an empty string; otherwise return the variable's current + * value. + */ + + if (!(varPtr->flags & (VAR_UNDEFINED|VAR_UPVAR|VAR_ARRAY))) { + return varPtr->value.string; + } + result = ""; + + /* + * 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 (varPtr->flags & VAR_UNDEFINED) { + CleanupVar(varPtr, arrayPtr); + } + return result; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_UnsetVar -- + * + * Delete a variable, so that it may not be accessed anymore. + * + * 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 interp->result. + * + * Side effects: + * If varName is defined as a local or global variable in interp, + * it is deleted. + * + *---------------------------------------------------------------------- + */ + +int +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 + * either a scalar name or an array name + * or an element in an array. */ + int flags; /* OR-ed combination of any of + * TCL_GLOBAL_ONLY or TCL_LEAVE_ERR_MSG. */ +{ + return Tcl_UnsetVar2(interp, varName, (char *) NULL, + flags | PART1_NOT_PARSED); +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_UnsetVar2 -- + * + * Delete a variable, given a 2-part 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 interp->result. + * + * Side effects: + * If part1 and part2 indicate a local or global variable in interp, + * it is deleted. If part1 is an array name and part2 is NULL, then + * the whole array is deleted. + * + *---------------------------------------------------------------------- + */ + +int +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. */ + int flags; /* OR-ed combination of any of + * TCL_GLOBAL_ONLY, TCL_LEAVE_ERR_MSG, + * or PART1_NOT_PARSED. */ +{ + Var *varPtr, dummyVar; + Interp *iPtr = (Interp *) interp; + Var *arrayPtr; + ActiveVarTrace *activePtr; + int result; + + varPtr = LookupVar(interp, part1, part2, flags, "unset", 0, &arrayPtr); + if (varPtr == NULL) { + return TCL_ERROR; + } + result = (varPtr->flags & VAR_UNDEFINED) ? TCL_ERROR : TCL_OK; + + if ((arrayPtr != NULL) && (arrayPtr->searchPtr != NULL)) { + DeleteSearches(arrayPtr); + } + + /* + * The code below is tricky, because of the possibility that + * a trace procedure might try to access a variable being + * deleted. To handle this situation gracefully, do things + * in three steps: + * 1. Copy the contents of the variable to a dummy variable + * structure, and mark the original structure as undefined. + * 2. Invoke traces and clean up the variable, using the copy. + * 3. If at the end of this the original variable is still + * undefined and has no outstanding references, then delete + * it (but it could have gotten recreated by a trace). + */ + + dummyVar = *varPtr; + varPtr->valueSpace = 0; + varPtr->flags = VAR_UNDEFINED; + varPtr->tracePtr = NULL; + varPtr->searchPtr = NULL; + + /* + * Call trace procedures for the variable being deleted and delete + * its traces. Be sure to abort any other traces for the variable + * that are still pending. Special tricks: + * 1. Increment varPtr's refCount around this: CallTraces will + * use dummyVar so it won't increment varPtr's refCount. + * 2. Turn off the VAR_TRACE_ACTIVE flag in dummyVar: we want to + * call unset traces even if other traces are pending. + */ + + if ((dummyVar.tracePtr != NULL) + || ((arrayPtr != NULL) && (arrayPtr->tracePtr != NULL))) { + varPtr->refCount++; + dummyVar.flags &= ~VAR_TRACE_ACTIVE; + (void) CallTraces(iPtr, arrayPtr, &dummyVar, part1, part2, + (flags & (TCL_GLOBAL_ONLY|PART1_NOT_PARSED)) + | TCL_TRACE_UNSETS); + while (dummyVar.tracePtr != NULL) { + VarTrace *tracePtr = dummyVar.tracePtr; + dummyVar.tracePtr = tracePtr->nextPtr; + ckfree((char *) tracePtr); + } + for (activePtr = iPtr->activeTracePtr; activePtr != NULL; + activePtr = activePtr->nextPtr) { + if (activePtr->varPtr == varPtr) { + activePtr->nextTracePtr = NULL; + } + } + varPtr->refCount--; + } + + /* + * If the variable is an array, delete all of its elements. This + * must be done after calling the traces on the array, above (that's + * the way traces are defined). + */ + + if (dummyVar.flags & VAR_ARRAY) { + DeleteArray(iPtr, part1, &dummyVar, + (flags & TCL_GLOBAL_ONLY) | TCL_TRACE_UNSETS); + } + if (dummyVar.valueSpace > 0) { + ckfree(dummyVar.value.string); + } + if (result == TCL_ERROR) { + if (flags & TCL_LEAVE_ERR_MSG) { + VarErrMsg(interp, part1, part2, "unset", + (arrayPtr == NULL) ? noSuchVar : noSuchElement); + } + } + + /* + * Finally, if the variable is truly not in use then free up its + * record and remove it from the hash table. + */ + + CleanupVar(varPtr, arrayPtr); + return result; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_TraceVar -- + * + * Arrange for reads and/or writes to a variable to cause a + * procedure to be invoked, which can monitor the operations + * and/or change their actions. + * + * Results: + * A standard Tcl return value. + * + * Side effects: + * A trace is set up on the variable given by varName, such that + * future references to the variable will be intermediated by + * proc. See the manual entry for complete details on the calling + * sequence for proc. + * + *---------------------------------------------------------------------- + */ + +int +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)" + * to signify an array reference. */ + int flags; /* OR-ed collection of bits, including any + * of TCL_TRACE_READS, TCL_TRACE_WRITES, + * TCL_TRACE_UNSETS, and TCL_GLOBAL_ONLY. */ + Tcl_VarTraceProc *proc; /* Procedure to call when specified ops are + * invoked upon varName. */ + ClientData clientData; /* Arbitrary argument to pass to proc. */ +{ + return Tcl_TraceVar2(interp, varName, (char *) NULL, + flags | PART1_NOT_PARSED, proc, clientData); +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_TraceVar2 -- + * + * Arrange for reads and/or writes to a variable to cause a + * procedure to be invoked, which can monitor the operations + * and/or change their actions. + * + * Results: + * A standard Tcl return value. + * + * Side effects: + * A trace is set up on the variable given by part1 and part2, such + * that future references to the variable will be intermediated by + * proc. See the manual entry for complete details on the calling + * sequence for proc. + * + *---------------------------------------------------------------------- + */ + +int +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 + * trace applies to scalar variable or array + * as-a-whole. */ + int flags; /* OR-ed collection of bits, including any + * of TCL_TRACE_READS, TCL_TRACE_WRITES, + * TCL_TRACE_UNSETS, TCL_GLOBAL_ONLY, and + * PART1_NOT_PARSED. */ + Tcl_VarTraceProc *proc; /* Procedure to call when specified ops are + * invoked upon varName. */ + ClientData clientData; /* Arbitrary argument to pass to proc. */ +{ + Var *varPtr, *arrayPtr; + register VarTrace *tracePtr; + + varPtr = LookupVar(interp, part1, part2, (flags | TCL_LEAVE_ERR_MSG), + "trace", CRT_PART1|CRT_PART2, &arrayPtr); + if (varPtr == NULL) { + return TCL_ERROR; + } + + /* + * Set up trace information. + */ + + tracePtr = (VarTrace *) ckalloc(sizeof(VarTrace)); + tracePtr->traceProc = proc; + tracePtr->clientData = clientData; + tracePtr->flags = flags & + (TCL_TRACE_READS|TCL_TRACE_WRITES|TCL_TRACE_UNSETS); + tracePtr->nextPtr = varPtr->tracePtr; + varPtr->tracePtr = tracePtr; + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_UntraceVar -- + * + * Remove a previously-created trace for a variable. + * + * Results: + * None. + * + * Side effects: + * If there exists a trace for the variable given by varName + * with the given flags, proc, and clientData, then that trace + * is removed. + * + *---------------------------------------------------------------------- + */ + +void +Tcl_UntraceVar(interp, varName, flags, proc, clientData) + Tcl_Interp *interp; /* Interpreter containing traced variable. */ + 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 + * TCL_TRACE_READS, TCL_TRACE_WRITES, + * TCL_TRACE_UNSETS, and TCL_GLOBAL_ONLY. */ + Tcl_VarTraceProc *proc; /* Procedure assocated with trace. */ + ClientData clientData; /* Arbitrary argument to pass to proc. */ +{ + Tcl_UntraceVar2(interp, varName, (char *) NULL, flags | PART1_NOT_PARSED, + proc, clientData); +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_UntraceVar2 -- + * + * Remove a previously-created trace for a variable. + * + * Results: + * None. + * + * Side effects: + * If there exists a trace for the variable given by part1 + * and part2 with the given flags, proc, and clientData, then + * that trace is removed. + * + *---------------------------------------------------------------------- + */ + +void +Tcl_UntraceVar2(interp, part1, part2, flags, proc, clientData) + Tcl_Interp *interp; /* Interpreter containing traced variable. */ + char *part1; /* Name of variable or array. */ + 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 + * current trace, including any of + * TCL_TRACE_READS, TCL_TRACE_WRITES, + * TCL_TRACE_UNSETS, TCL_GLOBAL_ONLY, and + * PART1_NOT_PARSED. */ + Tcl_VarTraceProc *proc; /* Procedure assocated with trace. */ + ClientData clientData; /* Arbitrary argument to pass to proc. */ +{ + register VarTrace *tracePtr; + VarTrace *prevPtr; + Var *varPtr, *arrayPtr; + Interp *iPtr = (Interp *) interp; + ActiveVarTrace *activePtr; + + varPtr = LookupVar(interp, part1, part2, + flags & (TCL_GLOBAL_ONLY|PART1_NOT_PARSED), (char *) NULL, 0, + &arrayPtr); + if (varPtr == NULL) { + return; + } + + flags &= (TCL_TRACE_READS | TCL_TRACE_WRITES | TCL_TRACE_UNSETS); + for (tracePtr = varPtr->tracePtr, prevPtr = NULL; ; + prevPtr = tracePtr, tracePtr = tracePtr->nextPtr) { + if (tracePtr == NULL) { + return; + } + if ((tracePtr->traceProc == proc) && (tracePtr->flags == flags) + && (tracePtr->clientData == clientData)) { + 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 CallTraces. + */ + + for (activePtr = iPtr->activeTracePtr; activePtr != NULL; + activePtr = activePtr->nextPtr) { + if (activePtr->nextTracePtr == tracePtr) { + activePtr->nextTracePtr = tracePtr->nextPtr; + } + } + if (prevPtr == NULL) { + varPtr->tracePtr = tracePtr->nextPtr; + } else { + prevPtr->nextPtr = tracePtr->nextPtr; + } + ckfree((char *) tracePtr); + + /* + * If this is the last trace on the variable, and the variable is + * unset and unused, then free up the variable. + */ + + if (varPtr->flags & VAR_UNDEFINED) { + CleanupVar(varPtr, (Var *) NULL); + } +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_VarTraceInfo -- + * + * Return the clientData value associated with a trace on a + * variable. This procedure can also be used to step through + * all of the traces on a particular variable that have the + * same trace procedure. + * + * Results: + * The return value is the clientData value associated with + * a trace on the given variable. 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 variable + * doesn't exist, or if there are no (more) traces for it, + * then NULL is returned. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +ClientData +Tcl_VarTraceInfo(interp, varName, flags, proc, prevClientData) + Tcl_Interp *interp; /* Interpreter containing variable. */ + char *varName; /* Name of variable; may end with "(index)" + * to signify an array reference. */ + int flags; /* 0 or TCL_GLOBAL_ONLY. */ + Tcl_VarTraceProc *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. */ +{ + return Tcl_VarTraceInfo2(interp, varName, (char *) NULL, + flags | PART1_NOT_PARSED, proc, prevClientData); +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_VarTraceInfo2 -- + * + * Same as Tcl_VarTraceInfo, except takes name in two pieces + * instead of one. + * + * Results: + * Same as Tcl_VarTraceInfo. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +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 + * trace applies to scalar variable or array + * as-a-whole. */ + int flags; /* OR-ed combination of TCL_GLOBAL_ONLY and + * PART1_NOT_PARSED. */ + Tcl_VarTraceProc *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. */ +{ + register VarTrace *tracePtr; + Var *varPtr, *arrayPtr; + + varPtr = LookupVar(interp, part1, part2, + flags & (TCL_GLOBAL_ONLY|PART1_NOT_PARSED), (char *) NULL, 0, + &arrayPtr); + if (varPtr == NULL) { + return NULL; + } + + /* + * Find the relevant trace, if any, and return its clientData. + */ + + tracePtr = varPtr->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; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_SetCmd -- + * + * 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_SetCmd(dummy, interp, argc, argv) + ClientData dummy; /* Not used. */ + register Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ + if (argc == 2) { + char *value; + + value = Tcl_GetVar2(interp, argv[1], (char *) NULL, + TCL_LEAVE_ERR_MSG|PART1_NOT_PARSED); + if (value == NULL) { + return TCL_ERROR; + } + interp->result = value; + return TCL_OK; + } else if (argc == 3) { + char *result; + + result = Tcl_SetVar2(interp, argv[1], (char *) NULL, argv[2], + TCL_LEAVE_ERR_MSG|PART1_NOT_PARSED); + if (result == NULL) { + return TCL_ERROR; + } + interp->result = result; + return TCL_OK; + } else { + Tcl_AppendResult(interp, "wrong # args: should be \"", + argv[0], " varName ?newValue?\"", (char *) NULL); + return TCL_ERROR; + } +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_UnsetCmd -- + * + * This procedure is invoked to process the "unset" Tcl command. + * See the user documentation for details on what it does. + * + * Results: + * A standard Tcl result value. + * + * Side effects: + * See the user documentation. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +int +Tcl_UnsetCmd(dummy, interp, argc, argv) + ClientData dummy; /* Not used. */ + register Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ + int i; + + if (argc < 2) { + Tcl_AppendResult(interp, "wrong # args: should be \"", + argv[0], " varName ?varName ...?\"", (char *) NULL); + return TCL_ERROR; + } + for (i = 1; i < argc; i++) { + if (Tcl_UnsetVar2(interp, argv[i], (char *) NULL, + TCL_LEAVE_ERR_MSG|PART1_NOT_PARSED) != TCL_OK) { + return TCL_ERROR; + } + } + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_AppendCmd -- + * + * This procedure is invoked to process the "append" 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_AppendCmd(dummy, interp, argc, argv) + ClientData dummy; /* Not used. */ + register Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ + int i; + char *result = NULL; /* (Initialization only needed to keep + * the compiler from complaining) */ + + if (argc < 2) { + Tcl_AppendResult(interp, "wrong # args: should be \"", + argv[0], " varName ?value value ...?\"", (char *) NULL); + return TCL_ERROR; + } + if (argc == 2) { + result = Tcl_GetVar2(interp, argv[1], (char *) NULL, + TCL_LEAVE_ERR_MSG|PART1_NOT_PARSED); + if (result == NULL) { + return TCL_ERROR; + } + interp->result = result; + return TCL_OK; + } + + for (i = 2; i < argc; i++) { + result = Tcl_SetVar2(interp, argv[1], (char *) NULL, argv[i], + TCL_APPEND_VALUE|TCL_LEAVE_ERR_MSG|PART1_NOT_PARSED); + if (result == NULL) { + return TCL_ERROR; + } + } + interp->result = result; + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_LappendCmd -- + * + * This procedure is invoked to process the "lappend" 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_LappendCmd(dummy, interp, argc, argv) + ClientData dummy; /* Not used. */ + register Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ + int i; + char *result = NULL; /* (Initialization only needed to keep + * the compiler from complaining) */ + + if (argc < 2) { + Tcl_AppendResult(interp, "wrong # args: should be \"", + argv[0], " varName ?value value ...?\"", (char *) NULL); + return TCL_ERROR; + } + if (argc == 2) { + result = Tcl_GetVar2(interp, argv[1], (char *) NULL, + TCL_LEAVE_ERR_MSG|PART1_NOT_PARSED); + if (result == NULL) { + return TCL_ERROR; + } + interp->result = result; + return TCL_OK; + } + + for (i = 2; i < argc; i++) { + result = Tcl_SetVar2(interp, argv[1], (char *) NULL, argv[i], + TCL_APPEND_VALUE|TCL_LIST_ELEMENT|TCL_LEAVE_ERR_MSG + |PART1_NOT_PARSED); + if (result == NULL) { + return TCL_ERROR; + } + } + interp->result = result; + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_ArrayCmd -- + * + * This procedure is invoked to process the "array" Tcl command. + * See the user documentation for details on what it does. + * + * Results: + * A standard Tcl result value. + * + * Side effects: + * See the user documentation. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +int +Tcl_ArrayCmd(dummy, interp, argc, argv) + ClientData dummy; /* Not used. */ + register Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ + int c, notArray; + size_t length; + Var *varPtr = NULL; /* Initialization needed only to prevent + * compiler warning. */ + Tcl_HashEntry *hPtr; + Interp *iPtr = (Interp *) interp; + + if (argc < 3) { + Tcl_AppendResult(interp, "wrong # args: should be \"", + argv[0], " option arrayName ?arg ...?\"", (char *) NULL); + return TCL_ERROR; + } + + /* + * Locate the array variable (and it better be an array). + */ + + if (iPtr->varFramePtr == NULL) { + hPtr = Tcl_FindHashEntry(&iPtr->globalTable, argv[2]); + } else { + hPtr = Tcl_FindHashEntry(&iPtr->varFramePtr->varTable, argv[2]); + } + notArray = 0; + if (hPtr == NULL) { + notArray = 1; + } else { + varPtr = (Var *) Tcl_GetHashValue(hPtr); + if (varPtr->flags & VAR_UPVAR) { + varPtr = varPtr->value.upvarPtr; + } + if (!(varPtr->flags & VAR_ARRAY)) { + notArray = 1; + } + } + + /* + * Dispatch based on the option. + */ + + c = argv[1][0]; + length = strlen(argv[1]); + if ((c == 'a') && (strncmp(argv[1], "anymore", length) == 0)) { + ArraySearch *searchPtr; + + if (argc != 4) { + Tcl_AppendResult(interp, "wrong # args: should be \"", + argv[0], " anymore arrayName searchId\"", (char *) NULL); + return TCL_ERROR; + } + if (notArray) { + goto error; + } + searchPtr = ParseSearchId(interp, varPtr, argv[2], argv[3]); + if (searchPtr == NULL) { + return TCL_ERROR; + } + while (1) { + Var *varPtr2; + + if (searchPtr->nextEntry != NULL) { + varPtr2 = (Var *) Tcl_GetHashValue(searchPtr->nextEntry); + if (!(varPtr2->flags & VAR_UNDEFINED)) { + break; + } + } + searchPtr->nextEntry = Tcl_NextHashEntry(&searchPtr->search); + if (searchPtr->nextEntry == NULL) { + interp->result = "0"; + return TCL_OK; + } + } + interp->result = "1"; + return TCL_OK; + } else if ((c == 'd') && (strncmp(argv[1], "donesearch", length) == 0)) { + ArraySearch *searchPtr, *prevPtr; + + if (argc != 4) { + Tcl_AppendResult(interp, "wrong # args: should be \"", + argv[0], " donesearch arrayName searchId\"", (char *) NULL); + return TCL_ERROR; + } + if (notArray) { + goto error; + } + searchPtr = ParseSearchId(interp, varPtr, argv[2], argv[3]); + if (searchPtr == NULL) { + return TCL_ERROR; + } + if (varPtr->searchPtr == searchPtr) { + varPtr->searchPtr = searchPtr->nextPtr; + } else { + for (prevPtr = varPtr->searchPtr; ; prevPtr = prevPtr->nextPtr) { + if (prevPtr->nextPtr == searchPtr) { + prevPtr->nextPtr = searchPtr->nextPtr; + break; + } + } + } + ckfree((char *) searchPtr); + } else if ((c == 'e') && (strncmp(argv[1], "exists", length) == 0)) { + if (argc != 3) { + Tcl_AppendResult(interp, "wrong # args: should be \"", + argv[0], " exists arrayName\"", (char *) NULL); + return TCL_ERROR; + } + interp->result = (notArray) ? "0" : "1"; + } else if ((c == 'g') && (strncmp(argv[1], "get", length) == 0)) { + Tcl_HashSearch search; + Var *varPtr2; + char *name; + + if ((argc != 3) && (argc != 4)) { + Tcl_AppendResult(interp, "wrong # args: should be \"", + argv[0], " get arrayName ?pattern?\"", (char *) NULL); + return TCL_ERROR; + } + if (notArray) { + return TCL_OK; + } + for (hPtr = Tcl_FirstHashEntry(varPtr->value.tablePtr, &search); + hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) { + varPtr2 = (Var *) Tcl_GetHashValue(hPtr); + if (varPtr2->flags & VAR_UNDEFINED) { + continue; + } + name = Tcl_GetHashKey(varPtr->value.tablePtr, hPtr); + if ((argc == 4) && !Tcl_StringMatch(name, argv[3])) { + continue; + } + Tcl_AppendElement(interp, name); + Tcl_AppendElement(interp, varPtr2->value.string); + } + } else if ((c == 'n') && (strncmp(argv[1], "names", length) == 0) + && (length >= 2)) { + Tcl_HashSearch search; + Var *varPtr2; + char *name; + + if ((argc != 3) && (argc != 4)) { + Tcl_AppendResult(interp, "wrong # args: should be \"", + argv[0], " names arrayName ?pattern?\"", (char *) NULL); + return TCL_ERROR; + } + if (notArray) { + return TCL_OK; + } + for (hPtr = Tcl_FirstHashEntry(varPtr->value.tablePtr, &search); + hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) { + varPtr2 = (Var *) Tcl_GetHashValue(hPtr); + if (varPtr2->flags & VAR_UNDEFINED) { + continue; + } + name = Tcl_GetHashKey(varPtr->value.tablePtr, hPtr); + if ((argc == 4) && !Tcl_StringMatch(name, argv[3])) { + continue; + } + Tcl_AppendElement(interp, name); + } + } else if ((c == 'n') && (strncmp(argv[1], "nextelement", length) == 0) + && (length >= 2)) { + ArraySearch *searchPtr; + Tcl_HashEntry *hPtr; + + if (argc != 4) { + Tcl_AppendResult(interp, "wrong # args: should be \"", + argv[0], " nextelement arrayName searchId\"", + (char *) NULL); + return TCL_ERROR; + } + if (notArray) { + goto error; + } + searchPtr = ParseSearchId(interp, varPtr, argv[2], argv[3]); + if (searchPtr == NULL) { + return TCL_ERROR; + } + while (1) { + Var *varPtr2; + + hPtr = searchPtr->nextEntry; + if (hPtr == NULL) { + hPtr = Tcl_NextHashEntry(&searchPtr->search); + if (hPtr == NULL) { + return TCL_OK; + } + } else { + searchPtr->nextEntry = NULL; + } + varPtr2 = (Var *) Tcl_GetHashValue(hPtr); + if (!(varPtr2->flags & VAR_UNDEFINED)) { + break; + } + } + interp->result = Tcl_GetHashKey(varPtr->value.tablePtr, hPtr); + } else if ((c == 's') && (strncmp(argv[1], "set", length) == 0) + && (length >= 2)) { + char **valueArgv; + int valueArgc, i, result; + + if (argc != 4) { + Tcl_AppendResult(interp, "wrong # args: should be \"", + argv[0], " set arrayName list\"", (char *) NULL); + return TCL_ERROR; + } + if (Tcl_SplitList(interp, argv[3], &valueArgc, &valueArgv) != TCL_OK) { + return TCL_ERROR; + } + result = TCL_OK; + if (valueArgc & 1) { + interp->result = "list must have an even number of elements"; + result = TCL_ERROR; + goto setDone; + } + for (i = 0; i < valueArgc; i += 2) { + if (Tcl_SetVar2(interp, argv[2], valueArgv[i], valueArgv[i+1], + TCL_LEAVE_ERR_MSG) == NULL) { + result = TCL_ERROR; + break; + } + } + setDone: + ckfree((char *) valueArgv); + return result; + } else if ((c == 's') && (strncmp(argv[1], "size", length) == 0) + && (length >= 2)) { + Tcl_HashSearch search; + Var *varPtr2; + int size; + + if (argc != 3) { + Tcl_AppendResult(interp, "wrong # args: should be \"", + argv[0], " size arrayName\"", (char *) NULL); + return TCL_ERROR; + } + size = 0; + if (!notArray) { + for (hPtr = Tcl_FirstHashEntry(varPtr->value.tablePtr, &search); + hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) { + varPtr2 = (Var *) Tcl_GetHashValue(hPtr); + if (varPtr2->flags & VAR_UNDEFINED) { + continue; + } + size++; + } + } + sprintf(interp->result, "%d", size); + } else if ((c == 's') && (strncmp(argv[1], "startsearch", length) == 0) + && (length >= 2)) { + ArraySearch *searchPtr; + + if (argc != 3) { + Tcl_AppendResult(interp, "wrong # args: should be \"", + argv[0], " startsearch arrayName\"", (char *) NULL); + return TCL_ERROR; + } + if (notArray) { + goto error; + } + searchPtr = (ArraySearch *) ckalloc(sizeof(ArraySearch)); + if (varPtr->searchPtr == NULL) { + searchPtr->id = 1; + Tcl_AppendResult(interp, "s-1-", argv[2], (char *) NULL); + } else { + char string[20]; + + searchPtr->id = varPtr->searchPtr->id + 1; + sprintf(string, "%d", searchPtr->id); + Tcl_AppendResult(interp, "s-", string, "-", argv[2], + (char *) NULL); + } + searchPtr->varPtr = varPtr; + searchPtr->nextEntry = Tcl_FirstHashEntry(varPtr->value.tablePtr, + &searchPtr->search); + searchPtr->nextPtr = varPtr->searchPtr; + varPtr->searchPtr = searchPtr; + } else { + Tcl_AppendResult(interp, "bad option \"", argv[1], + "\": should be anymore, donesearch, exists, ", + "get, names, nextelement, ", + "set, size, or startsearch", (char *) NULL); + return TCL_ERROR; + } + return TCL_OK; + + error: + Tcl_AppendResult(interp, "\"", argv[2], "\" isn't an array", + (char *) NULL); + return TCL_ERROR; +} + +/* + *---------------------------------------------------------------------- + * + * MakeUpvar -- + * + * This procedure does all of the work of the "global" and "upvar" + * commands. + * + * Results: + * A standard Tcl completion code. If an error occurs then an + * error message is left in iPtr->result. + * + * Side effects: + * The variable given by myName is linked to the variable in + * framePtr given by otherP1 and otherP2, so that references to + * myName are redirected to the other variable like a symbolic +* link. + * + *---------------------------------------------------------------------- + */ + +static int +MakeUpvar(iPtr, framePtr, otherP1, otherP2, myName, flags) + Interp *iPtr; /* 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. */ + char *myName; /* Name of variable in local table, which + * will refer to otherP1/P2. Must be a + * scalar. */ + int flags; /* 0 or TCL_GLOBAL_ONLY: indicates scope of + * myName. */ +{ + Tcl_HashEntry *hPtr; + Var *otherPtr, *varPtr, *arrayPtr; + CallFrame *savedFramePtr; + int new; + + /* + * In order to use LookupVar to find "other", temporarily replace + * the current frame pointer in the interpreter. + */ + + savedFramePtr = iPtr->varFramePtr; + iPtr->varFramePtr = framePtr; + otherPtr = LookupVar((Tcl_Interp *) iPtr, otherP1, otherP2, + TCL_LEAVE_ERR_MSG, "access", CRT_PART1|CRT_PART2, &arrayPtr); + iPtr->varFramePtr = savedFramePtr; + if (otherPtr == NULL) { + return TCL_ERROR; + } + if ((flags & TCL_GLOBAL_ONLY) || (iPtr->varFramePtr == NULL)) { + hPtr = Tcl_CreateHashEntry(&iPtr->globalTable, myName, &new); + } else { + hPtr = Tcl_CreateHashEntry(&iPtr->varFramePtr->varTable, myName, &new); + } + if (new) { + varPtr = NewVar(); + Tcl_SetHashValue(hPtr, varPtr); + varPtr->hPtr = hPtr; + } else { + /* + * The variable already exists. Make sure that this variable + * isn't also "otherVar" (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. + */ + + varPtr = (Var *) Tcl_GetHashValue(hPtr); + if (varPtr == otherPtr) { + iPtr->result = "can't upvar from variable to itself"; + return TCL_ERROR; + } + if (varPtr->flags & VAR_UPVAR) { + Var *upvarPtr; + + upvarPtr = varPtr->value.upvarPtr; + if (upvarPtr == otherPtr) { + return TCL_OK; + } + upvarPtr->refCount--; + if (upvarPtr->flags & VAR_UNDEFINED) { + CleanupVar(upvarPtr, (Var *) NULL); + } + } else if (!(varPtr->flags & VAR_UNDEFINED)) { + 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; + } + } + varPtr->flags = (varPtr->flags & ~VAR_UNDEFINED) | VAR_UPVAR; + varPtr->value.upvarPtr = otherPtr; + otherPtr->refCount++; + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_UpVar -- + * + * Delete a variable, so that it may not be accessed anymore. + * + * 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 interp->result. + * + * Side effects: + * If varName is defined as a local or global variable in interp, + * it is deleted. + * + *---------------------------------------------------------------------- + */ + +int +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 + * variable, such as "1" or "#0". */ + char *varName; /* Name of a variable in interp. May be + * either a scalar name or an element + * in an array. */ + char *localName; /* Destination variable name. */ + int flags; /* Either 0 or TCL_GLOBAL_ONLY; indicates + * whether localName is local or global. */ +{ + int result; + CallFrame *framePtr; + register char *p; + + result = TclGetFrame(interp, frameName, &framePtr); + if (result == -1) { + return TCL_ERROR; + } + + /* + * Figure out whether this is an array reference, then call + * Tcl_UpVar2 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, localName, flags); + *openParen = '('; + *p = ')'; + return result; + } + } + + scalar: + return MakeUpvar((Interp *) interp, framePtr, varName, (char *) NULL, + localName, flags); +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_UpVar2 -- + * + * This procedure links one variable to another, just like + * the "upvar" command. + * + * Results: + * A standard Tcl completion code. If an error occurs then + * an error message is left in interp->result. + * + * Side effects: + * The variable in frameName whose name is given by part1 and + * part2 becomes accessible under the name newName, so that + * references to newName are redirected to the other variable + * like a symbolic link. + * + *---------------------------------------------------------------------- + */ + +int +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 + * variable, such as "1" or "#0". */ + char *part1, *part2; /* Two parts of source variable name. */ + char *localName; /* Destination variable name. */ + int flags; /* TCL_GLOBAL_ONLY or 0. */ +{ + int result; + CallFrame *framePtr; + + result = TclGetFrame(interp, frameName, &framePtr); + if (result == -1) { + return TCL_ERROR; + } + return MakeUpvar((Interp *) interp, framePtr, part1, part2, + localName, flags); +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_GlobalCmd -- + * + * This procedure is invoked to process the "global" Tcl command. + * See the user documentation for details on what it does. + * + * Results: + * A standard Tcl result value. + * + * Side effects: + * See the user documentation. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +int +Tcl_GlobalCmd(dummy, interp, argc, argv) + ClientData dummy; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ + register Interp *iPtr = (Interp *) interp; + + if (argc < 2) { + Tcl_AppendResult((Tcl_Interp *) iPtr, "wrong # args: should be \"", + argv[0], " varName ?varName ...?\"", (char *) NULL); + return TCL_ERROR; + } + if (iPtr->varFramePtr == NULL) { + return TCL_OK; + } + + for (argc--, argv++; argc > 0; argc--, argv++) { + if (MakeUpvar(iPtr, (CallFrame *) NULL, *argv, (char *) NULL, *argv, 0) + != TCL_OK) { + return TCL_ERROR; + } + } + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_UpvarCmd -- + * + * This procedure is invoked to process the "upvar" Tcl command. + * See the user documentation for details on what it does. + * + * Results: + * A standard Tcl result value. + * + * Side effects: + * See the user documentation. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +int +Tcl_UpvarCmd(dummy, interp, argc, argv) + ClientData dummy; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ + register Interp *iPtr = (Interp *) interp; + int result; + CallFrame *framePtr; + register char *p; + + if (argc < 3) { + upvarSyntax: + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " ?level? otherVar localVar ?otherVar localVar ...?\"", + (char *) NULL); + return TCL_ERROR; + } + + /* + * Find the hash table containing the variable being referenced. + */ + + result = TclGetFrame(interp, argv[1], &framePtr); + if (result == -1) { + return TCL_ERROR; + } + argc -= result+1; + if ((argc & 1) != 0) { + goto upvarSyntax; + } + argv += result+1; + + /* + * Iterate over all the pairs of (other variable, local variable) + * names. For each pair, divide the other variable name into two + * parts, then call MakeUpvar to do all the work of creating linking + * it to the local variable. + */ + + for ( ; argc > 0; argc -= 2, argv += 2) { + for (p = argv[0]; *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, argv[0], openParen+1, + argv[1], 0); + *openParen = '('; + *p = ')'; + goto checkResult; + } + } + scalar: + result = MakeUpvar(iPtr, framePtr, argv[0], (char *) NULL, argv[1], 0); + + checkResult: + if (result != TCL_OK) { + return TCL_ERROR; + } + } + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * CallTraces -- + * + * This procedure is invoked to find and invoke relevant + * trace procedures associated with a particular operation on + * a variable. This procedure invokes traces both on the + * 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-zero 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. + * + * Side effects: + * Almost anything can happen, depending on trace; this procedure + * itself doesn't have any side effects. + * + *---------------------------------------------------------------------- + */ + +static char * +CallTraces(iPtr, arrayPtr, varPtr, part1, part2, flags) + 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. */ + int flags; /* Flags to pass to trace procedures: + * indicates what's happening to + * variable, plus other stuff like + * TCL_GLOBAL_ONLY and + * TCL_INTERP_DESTROYED. May also + * contain PART1_NOT_PARSEd, which + * should not be passed through + * to callbacks. */ +{ + register VarTrace *tracePtr; + ActiveVarTrace active; + char *result, *openParen, *p; + Tcl_DString nameCopy; + int copiedName; + + /* + * If there are already similar trace procedures active for the + * variable, don't call them again. + */ + + if (varPtr->flags & VAR_TRACE_ACTIVE) { + return NULL; + } + varPtr->flags |= VAR_TRACE_ACTIVE; + varPtr->refCount++; + + /* + * If the variable name hasn't been parsed into array name and + * element, do it here. If there really is an array element, + * make a copy of the original name so that NULLs can be + * inserted into it to separate the names (can't modify the name + * string in place, because the string might get used by the + * callbacks we invoke). + */ + + copiedName = 0; + if (flags & PART1_NOT_PARSED) { + for (p = part1; ; p++) { + if (*p == 0) { + break; + } + if (*p == '(') { + openParen = p; + do { + p++; + } while (*p != '\0'); + p--; + if (*p == ')') { + Tcl_DStringInit(&nameCopy); + Tcl_DStringAppend(&nameCopy, part1, (p-part1)); + part2 = Tcl_DStringValue(&nameCopy) + + (openParen + 1 - part1); + part2[-1] = 0; + part1 = Tcl_DStringValue(&nameCopy); + copiedName = 1; + } + break; + } + } + } + flags &= ~PART1_NOT_PARSED; + + /* + * Invoke traces on the array containing the variable, if relevant. + */ + + result = NULL; + active.nextPtr = iPtr->activeTracePtr; + iPtr->activeTracePtr = &active; + if (arrayPtr != NULL) { + arrayPtr->refCount++; + active.varPtr = arrayPtr; + for (tracePtr = arrayPtr->tracePtr; tracePtr != NULL; + tracePtr = active.nextTracePtr) { + active.nextTracePtr = tracePtr->nextPtr; + if (!(tracePtr->flags & flags)) { + continue; + } + result = (*tracePtr->traceProc)(tracePtr->clientData, + (Tcl_Interp *) iPtr, part1, part2, flags); + if (result != NULL) { + if (flags & TCL_TRACE_UNSETS) { + result = NULL; + } else { + goto done; + } + } + } + } + + /* + * Invoke traces on the variable itself. + */ + + if (flags & TCL_TRACE_UNSETS) { + flags |= TCL_TRACE_DESTROYED; + } + active.varPtr = varPtr; + for (tracePtr = varPtr->tracePtr; tracePtr != NULL; + tracePtr = active.nextTracePtr) { + active.nextTracePtr = tracePtr->nextPtr; + if (!(tracePtr->flags & flags)) { + continue; + } + result = (*tracePtr->traceProc)(tracePtr->clientData, + (Tcl_Interp *) iPtr, part1, part2, flags); + if (result != NULL) { + if (flags & TCL_TRACE_UNSETS) { + result = NULL; + } else { + goto done; + } + } + } + + /* + * Restore the variable's flags, remove the record of our active + * traces, and then return. + */ + + done: + if (arrayPtr != NULL) { + arrayPtr->refCount--; + } + if (copiedName) { + Tcl_DStringFree(&nameCopy); + } + varPtr->flags &= ~VAR_TRACE_ACTIVE; + varPtr->refCount--; + iPtr->activeTracePtr = active.nextPtr; + return result; +} + +/* + *---------------------------------------------------------------------- + * + * NewVar -- + * + * Create a new variable with a given amount of storage + * space. + * + * Results: + * The return value is a pointer to the new variable structure. + * The variable will not be part of any hash table yet. Its + * initial value is empty. + * + * Side effects: + * Storage gets allocated. + * + *---------------------------------------------------------------------- + */ + +static Var * +NewVar() +{ + register Var *varPtr; + + varPtr = (Var *) ckalloc(sizeof(Var)); + varPtr->valueLength = 0; + varPtr->valueSpace = 0; + varPtr->value.string = NULL; + varPtr->hPtr = NULL; + varPtr->refCount = 0; + varPtr->tracePtr = NULL; + varPtr->searchPtr = NULL; + varPtr->flags = VAR_UNDEFINED; + return varPtr; +} + +/* + *---------------------------------------------------------------------- + * + * ParseSearchId -- + * + * This procedure translates from a string to a pointer to an + * active array search (if there is one that matches the string). + * + * Results: + * The return value is a pointer to the array search indicated + * by string, or NULL if there isn't one. If NULL is returned, + * interp->result contains an error message. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static ArraySearch * +ParseSearchId(interp, varPtr, varName, string) + Tcl_Interp *interp; /* Interpreter containing variable. */ + Var *varPtr; /* Array variable search is for. */ + char *varName; /* Name of array variable that search is + * supposed to be for. */ + char *string; /* String containing id of search. Must have + * form "search-num-var" where "num" is a + * decimal number and "var" is a variable + * name. */ +{ + char *end; + int id; + ArraySearch *searchPtr; + + /* + * 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 NULL; + } + id = strtoul(string+2, &end, 10); + if ((end == (string+2)) || (*end != '-')) { + goto syntax; + } + if (strcmp(end+1, 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. + */ + + for (searchPtr = varPtr->searchPtr; searchPtr != NULL; + searchPtr = searchPtr->nextPtr) { + if (searchPtr->id == id) { + return searchPtr; + } + } + Tcl_AppendResult(interp, "couldn't find search \"", string, "\"", + (char *) NULL); + return NULL; +} + +/* + *---------------------------------------------------------------------- + * + * DeleteSearches -- + * + * This procedure is called to free up all of the searches + * associated with an array variable. + * + * Results: + * None. + * + * Side effects: + * Memory is released to the storage allocator. + * + *---------------------------------------------------------------------- + */ + +static void +DeleteSearches(arrayVarPtr) + register Var *arrayVarPtr; /* Variable whose searches are + * to be deleted. */ +{ + ArraySearch *searchPtr; + + while (arrayVarPtr->searchPtr != NULL) { + searchPtr = arrayVarPtr->searchPtr; + arrayVarPtr->searchPtr = searchPtr->nextPtr; + ckfree((char *) searchPtr); + } +} + +/* + *---------------------------------------------------------------------- + * + * TclDeleteVars -- + * + * This procedure is called to recycle all the storage space + * associated with a table of variables. For this procedure + * to work correctly, it must not be possible for any of the + * variable in the table to be accessed from Tcl commands + * (e.g. from trace procedures). + * + * Results: + * None. + * + * Side effects: + * Variables are deleted and trace procedures are invoked, if + * any are declared. + * + *---------------------------------------------------------------------- + */ + +void +TclDeleteVars(iPtr, tablePtr) + Interp *iPtr; /* Interpreter to which variables belong. */ + Tcl_HashTable *tablePtr; /* Hash table containing variables to + * delete. */ +{ + Tcl_HashSearch search; + Tcl_HashEntry *hPtr; + register Var *varPtr; + Var *upvarPtr; + int flags; + ActiveVarTrace *activePtr; + + flags = TCL_TRACE_UNSETS; + if (tablePtr == &iPtr->globalTable) { + flags |= TCL_INTERP_DESTROYED | TCL_GLOBAL_ONLY; + } + for (hPtr = Tcl_FirstHashEntry(tablePtr, &search); hPtr != NULL; + hPtr = Tcl_NextHashEntry(&search)) { + varPtr = (Var *) Tcl_GetHashValue(hPtr); + + /* + * For global/upvar variables referenced in procedures, decrement + * the reference count on the variable referred to, and free + * the referenced variable if it's no longer needed. Don't delete + * the hash entry for the other variable if it's in the same table + * as us: this will happen automatically later on. + */ + + if (varPtr->flags & VAR_UPVAR) { + upvarPtr = varPtr->value.upvarPtr; + upvarPtr->refCount--; + if ((upvarPtr->refCount == 0) && (upvarPtr->flags & VAR_UNDEFINED) + && (upvarPtr->tracePtr == NULL)) { + if (upvarPtr->hPtr == NULL) { + ckfree((char *) upvarPtr); + } else if (upvarPtr->hPtr->tablePtr != tablePtr) { + Tcl_DeleteHashEntry(upvarPtr->hPtr); + ckfree((char *) upvarPtr); + } + } + } + + /* + * Invoke traces on the variable that is being deleted, then + * 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). + */ + + if (varPtr->tracePtr != NULL) { + (void) CallTraces(iPtr, (Var *) NULL, varPtr, + Tcl_GetHashKey(tablePtr, hPtr), (char *) NULL, flags); + while (varPtr->tracePtr != NULL) { + VarTrace *tracePtr = varPtr->tracePtr; + varPtr->tracePtr = tracePtr->nextPtr; + ckfree((char *) tracePtr); + } + for (activePtr = iPtr->activeTracePtr; activePtr != NULL; + activePtr = activePtr->nextPtr) { + if (activePtr->varPtr == varPtr) { + activePtr->nextTracePtr = NULL; + } + } + } + if (varPtr->flags & VAR_ARRAY) { + DeleteArray(iPtr, Tcl_GetHashKey(tablePtr, hPtr), varPtr, flags); + } + if (varPtr->valueSpace > 0) { + /* + * SPECIAL TRICK: it's possible that the interpreter's result + * currently points to this variable (for example, a "set" or + * "lappend" command was the last command in a procedure that's + * being returned from). If this is the case, then just pass + * ownership of the value string to the Tcl interpreter. + */ + + if (iPtr->result == varPtr->value.string) { + iPtr->freeProc = TCL_DYNAMIC; + } else { + ckfree(varPtr->value.string); + } + varPtr->valueSpace = 0; + } + varPtr->hPtr = NULL; + varPtr->tracePtr = NULL; + varPtr->flags = VAR_UNDEFINED; + + /* + * Recycle the variable's memory space if there aren't any upvar's + * pointing to it. If there are upvars, then the variable will + * get freed when the last upvar goes away. + */ + + if (varPtr->refCount == 0) { + ckfree((char *) varPtr); + } + } + Tcl_DeleteHashTable(tablePtr); +} + +/* + *---------------------------------------------------------------------- + * + * DeleteArray -- + * + * This procedure is called to free up everything in an array + * variable. It's the caller's responsibility to make sure + * that the array is no longer accessible before this procedure + * is called. + * + * Results: + * None. + * + * Side effects: + * All storage associated with varPtr's array elements is deleted + * (including the hash table). Delete trace procedures for + * array elements are invoked. + * + *---------------------------------------------------------------------- + */ + +static void +DeleteArray(iPtr, arrayName, varPtr, flags) + Interp *iPtr; /* Interpreter containing array. */ + char *arrayName; /* Name of array (used for trace + * callbacks). */ + Var *varPtr; /* Pointer to variable structure. */ + int flags; /* Flags to pass to CallTraces: + * TCL_TRACE_UNSETS and sometimes + * TCL_INTERP_DESTROYED and/or + * TCL_GLOBAL_ONLY. */ +{ + Tcl_HashSearch search; + register Tcl_HashEntry *hPtr; + register Var *elPtr; + ActiveVarTrace *activePtr; + + DeleteSearches(varPtr); + for (hPtr = Tcl_FirstHashEntry(varPtr->value.tablePtr, &search); + hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) { + elPtr = (Var *) Tcl_GetHashValue(hPtr); + if (elPtr->valueSpace != 0) { + /* + * SPECIAL TRICK: it's possible that the interpreter's result + * currently points to this element (for example, a "set" or + * "lappend" command was the last command in a procedure that's + * being returned from). If this is the case, then just pass + * ownership of the value string to the Tcl interpreter. + */ + + if (iPtr->result == elPtr->value.string) { + iPtr->freeProc = TCL_DYNAMIC; + } else { + ckfree(elPtr->value.string); + } + elPtr->valueSpace = 0; + } + 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); + while (elPtr->tracePtr != NULL) { + VarTrace *tracePtr = elPtr->tracePtr; + elPtr->tracePtr = tracePtr->nextPtr; + ckfree((char *) tracePtr); + } + for (activePtr = iPtr->activeTracePtr; activePtr != NULL; + activePtr = activePtr->nextPtr) { + if (activePtr->varPtr == elPtr) { + activePtr->nextTracePtr = NULL; + } + } + } + elPtr->flags = VAR_UNDEFINED; + if (elPtr->refCount == 0) { + ckfree((char *) elPtr); + } + } + Tcl_DeleteHashTable(varPtr->value.tablePtr); + ckfree((char *) varPtr->value.tablePtr); +} + +/* + *---------------------------------------------------------------------- + * + * CleanupVar -- + * + * This procedure is called when it looks like it may be OK + * to free up the variable's record and hash table entry, and + * those of its containing parent. It's called, for example, + * when a trace on a variable deletes the variable. + * + * Results: + * None. + * + * Side effects: + * If the variable (or its containing array) really is dead then + * its record, and possibly its hash table entry, gets freed up. + * + *---------------------------------------------------------------------- + */ + +static void +CleanupVar(varPtr, arrayPtr) + Var *varPtr; /* Pointer to variable that may be a + * candidate for being expunged. */ + Var *arrayPtr; /* Array that contains the variable, or + * NULL if this variable isn't an array + * element. */ +{ + if ((varPtr->flags & VAR_UNDEFINED) && (varPtr->refCount == 0) + && (varPtr->tracePtr == NULL)) { + if (varPtr->hPtr != NULL) { + Tcl_DeleteHashEntry(varPtr->hPtr); + } + ckfree((char *) varPtr); + } + if (arrayPtr != NULL) { + if ((arrayPtr->flags & VAR_UNDEFINED) && (arrayPtr->refCount == 0) + && (arrayPtr->tracePtr == NULL)) { + if (arrayPtr->hPtr != NULL) { + Tcl_DeleteHashEntry(arrayPtr->hPtr); + } + ckfree((char *) arrayPtr); + } + } + return; +} + +/* + *---------------------------------------------------------------------- + * + * VarErrMsg -- + * + * Generate a reasonable error message describing why a variable + * operation failed. + * + * Results: + * None. + * + * Side effects: + * Interp->result is reset to hold a message identifying the + * variable given by part1 and part2 and describing why the + * variable operation failed. + * + *---------------------------------------------------------------------- + */ + +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, + * e.g. "read", "set", or "unset". */ + char *reason; /* String describing why operation failed. */ +{ + Tcl_ResetResult(interp); + Tcl_AppendResult(interp, "can't ", operation, " \"", part1, (char *) NULL); + if (part2 != NULL) { + Tcl_AppendResult(interp, "(", part2, ")", (char *) NULL); + } + Tcl_AppendResult(interp, "\": ", reason, (char *) NULL); +} diff --git a/contrib/tcl/library/init.tcl b/contrib/tcl/library/init.tcl new file mode 100644 index 0000000..7ffc647 --- /dev/null +++ b/contrib/tcl/library/init.tcl @@ -0,0 +1,531 @@ +# init.tcl -- +# +# Default system startup file for Tcl-based applications. Defines +# "unknown" procedure and auto-load facilities. +# +# SCCS: @(#) init.tcl 1.54 96/04/21 13:55:08 +# +# Copyright (c) 1991-1993 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. +# + +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 7.5 +if [catch {set auto_path $env(TCLLIBPATH)}] { + set auto_path "" +} +if {[lsearch -exact $auto_path [info library]] < 0} { + lappend auto_path [info library] +} +package unknown tclPkgUnknown +if {[info commands exec] == ""} { + # Some machines, such as the Macintosh, do not have exec + set auto_noexec 1 +} +set errorCode "" +set errorInfo "" + +# unknown -- +# This procedure is called when a Tcl command is invoked that doesn't +# exist in the interpreter. It takes the following steps to make the +# command available: +# +# 1. See if the autoload facility can locate the command in a +# Tcl script file. If so, load it and execute it. +# 2. If the command was invoked interactively at top-level: +# (a) see if the command exists as an executable UNIX program. +# If so, "exec" the command. +# (b) see if the command requests csh-like history substitution +# in one of the common forms !!, !<number>, or ^old^new. If +# so, emulate csh's history substitution. +# (c) see if the command is a unique abbreviation for another +# command. If so, invoke the command. +# +# Arguments: +# args - A list whose elements are the words of the original +# command, including the command name. + +proc unknown args { + global auto_noexec auto_noload env unknown_pending tcl_interactive + global errorCode errorInfo + + # Save the values of errorCode and errorInfo variables, since they + # may get modified if caught errors occur below. The variables will + # be restored just before re-executing the missing command. + + set savedErrorCode $errorCode + set savedErrorInfo $errorInfo + set name [lindex $args 0] + if ![info exists auto_noload] { + # + # Make sure we're not trying to load the same proc twice. + # + if [info exists unknown_pending($name)] { + unset unknown_pending($name) + if {[array size unknown_pending] == 0} { + unset unknown_pending + } + return -code error "self-referential recursion in \"unknown\" for command \"$name\""; + } + set unknown_pending($name) pending; + set ret [catch {auto_load $name} msg] + unset unknown_pending($name); + if {$ret != 0} { + return -code $ret -errorcode $errorCode \ + "error while autoloading \"$name\": $msg" + } + if ![array size unknown_pending] { + unset unknown_pending + } + if $msg { + set errorCode $savedErrorCode + set errorInfo $savedErrorInfo + set code [catch {uplevel $args} msg] + if {$code == 1} { + # + # Strip the last five lines off the error stack (they're + # from the "uplevel" command). + # + + set new [split $errorInfo \n] + set new [join [lrange $new 0 [expr [llength $new] - 6]] \n] + return -code error -errorcode $errorCode \ + -errorinfo $new $msg + } else { + return -code $code $msg + } + } + } + if {([info level] == 1) && ([info script] == "") \ + && [info exists tcl_interactive] && $tcl_interactive} { + if ![info exists auto_noexec] { + if [auto_execok $name] { + set errorCode $savedErrorCode + set errorInfo $savedErrorInfo + return [uplevel exec >&@stdout <@stdin $args] + } + } + set errorCode $savedErrorCode + set errorInfo $savedErrorInfo + if {$name == "!!"} { + return [uplevel {history redo}] + } + if [regexp {^!(.+)$} $name dummy event] { + return [uplevel [list history redo $event]] + } + if [regexp {^\^([^^]*)\^([^^]*)\^?$} $name dummy old new] { + return [uplevel [list history substitute $old $new]] + } + set cmds [info commands $name*] + if {[llength $cmds] == 1} { + return [uplevel [lreplace $args 0 0 $cmds]] + } + if {[llength $cmds] != 0} { + if {$name == ""} { + return -code error "empty command name \"\"" + } else { + return -code error \ + "ambiguous command name \"$name\": [lsort $cmds]" + } + } + } + return -code error "invalid command name \"$name\"" +} + +# auto_load -- +# Checks a collection of library directories to see if a procedure +# is defined in one of them. If so, it sources the appropriate +# library file to create the procedure. Returns 1 if it successfully +# loaded the procedure, 0 otherwise. +# +# Arguments: +# cmd - Name of the command to find and load. + +proc auto_load cmd { + global auto_index auto_oldpath auto_path env errorInfo errorCode + + if [info exists auto_index($cmd)] { + uplevel #0 $auto_index($cmd) + return [expr {[info commands $cmd] != ""}] + } + if ![info exists auto_path] { + return 0 + } + if [info exists auto_oldpath] { + if {$auto_oldpath == $auto_path} { + return 0 + } + } + set auto_oldpath $auto_path + for {set i [expr [llength $auto_path] - 1]} {$i >= 0} {incr i -1} { + set dir [lindex $auto_path $i] + set f "" + if [catch {set f [open [file join $dir tclIndex]]}] { + continue + } + set error [catch { + set id [gets $f] + if {$id == "# Tcl autoload index file, version 2.0"} { + eval [read $f] + } elseif {$id == "# Tcl autoload index file: each line identifies a Tcl"} { + while {[gets $f line] >= 0} { + if {([string index $line 0] == "#") + || ([llength $line] != 2)} { + continue + } + set name [lindex $line 0] + set auto_index($name) \ + "source [file join $dir [lindex $line 1]]" + } + } else { + error "[file join $dir tclIndex] isn't a proper Tcl index file" + } + } msg] + if {$f != ""} { + close $f + } + if $error { + error $msg $errorInfo $errorCode + } + } + if [info exists auto_index($cmd)] { + uplevel #0 $auto_index($cmd) + if {[info commands $cmd] != ""} { + return 1 + } + } + return 0 +} + +if {[string compare $tcl_platform(platform) windows] == 0} { + +# auto_execok -- +# +# Returns 1 if there's an executable in the current path for the +# given name, 0 otherwise. Builds an associative array auto_execs +# that caches information about previous checks, for speed. +# +# Arguments: +# name - Name of a command. + +# Windows version. +# +# Note that info executable doesn't work under Windows, so we have to +# look for files with .exe, .com, or .bat extensions. Also, the path +# may be in the Path or PATH environment variables, and path +# components are separated with semicolons, not colons as under Unix. +# +proc auto_execok name { + global auto_execs env + + if [info exists auto_execs($name)] { + return $auto_execs($name) + } + set auto_execs($name) 0 + if {[file pathtype $name] != "relative"} { + foreach ext {.exe .bat .cmd} { + if {[file exists ${name}${ext}] + && ![file isdirectory ${name}${ext}]} { + set auto_execs($name) 1 + } + } + return $auto_execs($name) + } + if {! [info exists env(PATH)]} { + if [info exists env(Path)] { + set path $env(Path) + } else { + return 0 + } + } else { + set path $env(PATH) + } + foreach dir [split $path {;}] { + if {$dir == ""} { + set dir . + } + foreach ext {.exe .bat .cmd} { + set file [file join $dir ${name}${ext}] + if {[file exists $file] && ![file isdirectory $file]} { + set auto_execs($name) 1 + return 1 + } + } + } + return 0 +} + +} else { + +# Unix version. +# +proc auto_execok name { + global auto_execs env + + if [info exists auto_execs($name)] { + return $auto_execs($name) + } + set auto_execs($name) 0 + if {[file pathtype $name] != "relative"} { + if {[file executable $name] && ![file isdirectory $name]} { + set auto_execs($name) 1 + } + return $auto_execs($name) + } + foreach dir [split $env(PATH) :] { + if {$dir == ""} { + set dir . + } + set file [file join $dir $name] + if {[file executable $file] && ![file isdirectory $file]} { + set auto_execs($name) 1 + return 1 + } + } + return 0 +} + +} +# auto_reset -- +# Destroy all cached information for auto-loading and auto-execution, +# so that the information gets recomputed the next time it's needed. +# Also delete any procedures that are listed in the auto-load index +# except those related to auto-loading. +# +# Arguments: +# None. + +proc auto_reset {} { + global auto_execs auto_index auto_oldpath + foreach p [info procs] { + if {[info exists auto_index($p)] && ($p != "unknown") + && ![string match auto_* $p]} { + rename $p {} + } + } + catch {unset auto_execs} + catch {unset auto_index} + catch {unset auto_oldpath} +} + +# auto_mkindex -- +# Regenerate a tclIndex file from Tcl source files. Takes as argument +# the name of the directory in which the tclIndex file is to be placed, +# followed by any number of glob patterns to use in that directory to +# locate all of the relevant files. +# +# Arguments: +# dir - Name of the directory in which to create an index. +# args - Any number of additional arguments giving the +# names of files within dir. If no additional +# are given auto_mkindex will look for *.tcl. + +proc auto_mkindex {dir args} { + global errorCode errorInfo + set oldDir [pwd] + cd $dir + set dir [pwd] + append index "# Tcl autoload index file, version 2.0\n" + append index "# This file is generated by the \"auto_mkindex\" command\n" + append index "# and sourced to set up indexing information for one or\n" + append index "# more commands. Typically each line is a command that\n" + append index "# sets an element in the auto_index array, where the\n" + append index "# element name is the name of a command and the value is\n" + append index "# a script that loads the command.\n\n" + if {$args == ""} { + set args *.tcl + } + foreach file [eval glob $args] { + set f "" + set error [catch { + set f [open $file] + while {[gets $f line] >= 0} { + if [regexp {^proc[ ]+([^ ]*)} $line match procName] { + append index "set [list auto_index($procName)]" + append index " \[list source \[file join \$dir [list $file]\]\]\n" + } + } + close $f + } msg] + if $error { + set code $errorCode + set info $errorInfo + catch {close $f} + cd $oldDir + error $msg $info $code + } + } + set f "" + set error [catch { + set f [open tclIndex w] + puts $f $index nonewline + close $f + cd $oldDir + } msg] + if $error { + set code $errorCode + set info $errorInfo + catch {close $f} + cd $oldDir + error $msg $info $code + } +} + +# pkg_mkIndex -- +# This procedure creates a package index in a given directory. The +# package index consists of a "pkgIndex.tcl" file whose contents are +# a Tcl script that sets up package information with "package require" +# commands. The commands describe all of the packages defined by the +# files given as arguments. +# +# Arguments: +# dir - Name of the directory in which to create the index. +# args - Any number of additional arguments, each giving +# a glob pattern that matches the names of one or +# more shared libraries or Tcl script files in +# dir. + +proc pkg_mkIndex {dir args} { + global errorCode errorInfo + append index "# Tcl package index file, version 1.0\n" + append index "# This file is generated by the \"pkg_mkIndex\" command\n" + append index "# and sourced either when an application starts up or\n" + append index "# by a \"package unknown\" script. It invokes the\n" + append index "# \"package ifneeded\" command to set up package-related\n" + append index "# information so that packages will be loaded automatically\n" + append index "# in response to \"package require\" commands. When this\n" + append index "# script is sourced, the variable \$dir must contain the\n" + append index "# full path name of this file's directory.\n" + set oldDir [pwd] + cd $dir + foreach file [eval glob $args] { + # For each file, figure out what commands and packages it provides. + # To do this, create a child interpreter, load the file into the + # interpreter, and get a list of the new commands and packages + # that are defined. Define an empty "package unknown" script so + # that there are no recursive package inclusions. + + set c [interp create] + $c eval [list set file $file] + if [catch { + $c eval { + proc dummy args {} + package unknown dummy + set origCmds [info commands] + set dir "" ;# in case file is pkgIndex.tcl + set pkgs "" + + # The "file join ." command below is necessary. Without it, + # if the file name has no \'s and we're on UNIX, the + # LD_LIBRARY_PATH search mechanism will be invoked, which + # could cause the wrong file to be used. + + if [catch {load [file join . $file]}] { + if [catch {source $file}] { + puts $errorInfo + error "can't either load or source $file" + } else { + set type source + } + } else { + set type load + } + foreach i [info commands] { + set cmds($i) 1 + } + foreach i $origCmds { + catch {unset cmds($i)} + } + foreach i [package names] { + if {([string compare [package provide $i] ""] != 0) + && ([string compare $i Tcl] != 0)} { + lappend pkgs [list $i [package provide $i]] + } + } + } + } msg] { + interp delete $c + error $msg $errorInfo $errorCode + } + foreach pkg [$c eval set pkgs] { + lappend files($pkg) [list $file [$c eval set type] \ + [lsort [$c eval array names cmds]]] + } + interp delete $c + } + foreach pkg [lsort [array names files]] { + append index "\npackage ifneeded $pkg\ + \"tclPkgSetup \$dir [lrange $pkg 0 0] [lrange $pkg 1 1]\ + [list $files($pkg)]\"" + } + set f [open pkgIndex.tcl w] + puts $f $index + close $f + cd $oldDir +} + +# tclPkgSetup -- +# This is a utility procedure use by pkgIndex.tcl files. It is invoked +# as part of a "package ifneeded" script. It calls "package provide" +# to indicate that a package is available, then sets entries in the +# auto_index array so that the package's files will be auto-loaded when +# the commands are used. +# +# Arguments: +# dir - Directory containing all the files for this package. +# pkg - Name of the package (no version number). +# version - Version number for the package, such as 2.1.3. +# files - List of files that constitute the package. Each +# element is a sub-list with three elements. The first +# is the name of a file relative to $dir, the second is +# "load" or "source", indicating whether the file is a +# loadable binary or a script to source, and the third +# is a list of commands defined by this file. + +proc tclPkgSetup {dir pkg version files} { + global auto_index + + package provide $pkg $version + foreach fileInfo $files { + set f [lindex $fileInfo 0] + set type [lindex $fileInfo 1] + foreach cmd [lindex $fileInfo 2] { + if {$type == "load"} { + set auto_index($cmd) [list load [file join $dir $f] $pkg] + } else { + set auto_index($cmd) [list source [file join $dir $f]] + } + } + } +} + +# tclPkgUnknown -- +# This procedure provides the default for the "package unknown" function. +# It is invoked when a package that's needed can't be found. It scans +# the auto_path directories looking for pkgIndex.tcl files and sources any +# such files that are found to setup the package database. +# +# Arguments: +# name - Name of desired package. Not used. +# version - Version of desired package. Not used. +# exact - Either "-exact" or omitted. Not used. + +proc tclPkgUnknown {name version {exact {}}} { + global auto_path + + if ![info exists auto_path] { + return + } + for {set i [expr [llength $auto_path] - 1]} {$i >= 0} {incr i -1} { + set dir [lindex $auto_path $i] + set file [file join $dir pkgIndex.tcl] + if [file readable $file] { + source $file + } + } +} diff --git a/contrib/tcl/library/ldAout.tcl b/contrib/tcl/library/ldAout.tcl new file mode 100644 index 0000000..2e532d3 --- /dev/null +++ b/contrib/tcl/library/ldAout.tcl @@ -0,0 +1,224 @@ +# ldAout.tcl -- +# +# This "tclldAout" procedure in this script acts as a replacement +# for the "ld" command when linking an object file that will be +# loaded dynamically into Tcl or Tk using pseudo-static linking. +# +# Parameters: +# The arguments to the script are the command line options for +# an "ld" command. +# +# Results: +# The "ld" command is parsed, and the "-o" option determines the +# module name. ".a" and ".o" options are accumulated. +# The input archives and object files are examined with the "nm" +# command to determine whether the modules initialization +# entry and safe initialization entry are present. A trivial +# C function that locates the entries is composed, compiled, and +# its .o file placed before all others in the command; then +# "ld" is executed to bind the objects together. +# +# SCCS: @(#) ldAout.tcl 1.9 96/04/11 10:03:24 +# +# Copyright (c) 1995, by General Electric Company. 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 work was supported in part by the ARPA Manufacturing Automation +# and Design Engineering (MADE) Initiative through ARPA contract +# F33615-94-C-4400. + +proc tclLdAout {{cc {}} {shlib_suffix {}} {shlib_cflags none}} { + global env + global argv + + if {$cc==""} { + set cc $env(CC) + } + + # if only two parameters are supplied there is assumed that the + # only shlib_suffix is missing. This parameter is anyway available + # as "info sharedlibextension" too, so there is no need to transfer + # 3 parameters to the function tclLdAout. For compatibility, this + # function now accepts both 2 and 3 parameters. + + if {$shlib_suffix==""} { + set shlib_suffix $env(SHLIB_SUFFIX) + set shlib_cflags $env(SHLIB_CFLAGS) + } else { + if {$shlib_cflags=="none"} { + set shlib_cflags $shlib_suffix + set shlib_suffix [info sharedlibextension] + } + } + + # seenDotO is nonzero if a .o or .a file has been seen + + set seenDotO 0 + + # minusO is nonzero if the last command line argument was "-o". + + set minusO 0 + + # head has command line arguments up to but not including the first + # .o or .a file. tail has the rest of the arguments. + + set head {} + set tail {} + + # nmCommand is the "nm" command that lists global symbols from the + # object files. + + set nmCommand {|nm -g} + + # entryProtos is the table of _Init and _SafeInit prototypes found in the + # module. + + set entryProtos {} + + # entryPoints is the table of _Init and _SafeInit entries found in the + # module. + + set entryPoints {} + + # libraries is the list of -L and -l flags to the linker. + + set libraries {} + set libdirs {} + + # Process command line arguments + + foreach a $argv { + if {!$minusO && [regexp {\.[ao]$} $a]} { + set seenDotO 1 + lappend nmCommand $a + } + if {$minusO} { + set outputFile $a + set minusO 0 + } elseif {![string compare $a -o]} { + set minusO 1 + } + if [regexp {^-[lL]} $a] { + lappend libraries $a + if [regexp {^-L} $a] { + lappend libdirs [string range $a 2 end] + } + } elseif {$seenDotO} { + lappend tail $a + } else { + lappend head $a + } + } + lappend libdirs /lib /usr/lib + lappend libraries -lm -lc + + # MIPS -- If there are corresponding G0 libraries, replace the + # ordinary ones with the G0 ones. + + set libs {} + foreach lib $libraries { + if [regexp {^-l} $lib] { + set lname [string range $lib 2 end] + foreach dir $libdirs { + if [file exists [file join $dir lib${lname}_G0.a]] { + set lname ${lname}_G0 + break + } + } + lappend libs -l$lname + } else { + lappend libs $lib + } + } + set libraries $libs + + # Extract the module name from the "-o" option + + if {![info exists outputFile]} { + error "-o option must be supplied to link a Tcl load module" + } + set m [file tail $outputFile] + set l [expr [string length $m] - [string length $shlib_suffix]] + if [string compare [string range $m $l end] $shlib_suffix] { + error "Output file does not appear to have a $shlib_suffix suffix" + } + set modName [string toupper [string index $m 0]] + append modName [string tolower [string range $m 1 [expr $l-1]]] + regsub -all \\. $modName _ modName + + # Catalog initialization entry points found in the module + + set f [open $nmCommand r] + while {[gets $f l] >= 0} { + if [regexp {T[ ]*_?([A-Z][a-z0-9_]*_(Safe)?Init(__FP10Tcl_Interp)?)$} $l trash symbol] { + if {![regexp {_?([A-Z][a-z0-9_]*_(Safe)?Init)} $symbol trash s]} { + set s $symbol + } + append entryProtos {extern int } $symbol { (); } \n + append entryPoints { } \{ { "} $s {", } $symbol { } \} , \n + } + } + close $f + + if {$entryPoints==""} { + error "No entry point found in objects" + } + + # Compose a C function that resolves the initialization entry points and + # embeds the required libraries in the object code. + + set C {#include <string.h>} + append C \n + append C {char TclLoadLibraries_} $modName { [] =} \n + append C { "@LIBS: } $libraries {";} \n + append C $entryProtos + append C {static struct } \{ \n + append C { char * name;} \n + append C { int (*value)();} \n + append C \} {dictionary [] = } \{ \n + append C $entryPoints + append C { 0, 0 } \n \} \; \n + append C {typedef struct Tcl_Interp Tcl_Interp;} \n + append C {typedef int Tcl_PackageInitProc (Tcl_Interp *);} \n + append C {Tcl_PackageInitProc *} \n + append C TclLoadDictionary_ $modName { (symbol)} \n + append C { char * symbol;} \n + append C {{ + int i; + for (i = 0; dictionary [i] . name != 0; ++i) { + if (!strcmp (symbol, dictionary [i] . name)) { + return dictionary [i].value; + } + } + return 0; +}} \n + + # Write the C module and compile it + + set cFile tcl$modName.c + set f [open $cFile w] + puts -nonewline $f $C + close $f + set ccCommand "$cc -c $shlib_cflags $cFile" + puts stderr $ccCommand + eval exec $ccCommand + + # Now compose and execute the ld command that packages the module + + set ldCommand ld + foreach item $head { + lappend ldCommand $item + } + lappend ldCommand tcl$modName.o + foreach item $tail { + lappend ldCommand $item + } + puts stderr $ldCommand + eval exec $ldCommand + + # Clean up working files + + exec /bin/rm $cFile [file rootname $cFile].o +} diff --git a/contrib/tcl/library/license.terms b/contrib/tcl/library/license.terms new file mode 100644 index 0000000..3dcd816 --- /dev/null +++ b/contrib/tcl/library/license.terms @@ -0,0 +1,32 @@ +This software is copyrighted by the Regents of the University of +California, Sun Microsystems, Inc., 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. + +RESTRICTED RIGHTS: Use, duplication or disclosure by the government +is subject to the restrictions as set forth in subparagraph (c) (1) (ii) +of the Rights in Technical Data and Computer Software Clause as DFARS +252.227-7013 and FAR 52.227-19. diff --git a/contrib/tcl/library/parray.tcl b/contrib/tcl/library/parray.tcl new file mode 100644 index 0000000..430e7ff --- /dev/null +++ b/contrib/tcl/library/parray.tcl @@ -0,0 +1,29 @@ +# parray: +# Print the contents of a global array on stdout. +# +# SCCS: @(#) parray.tcl 1.9 96/02/16 08:56:44 +# +# Copyright (c) 1991-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. +# + +proc parray {a {pattern *}} { + upvar 1 $a array + if ![array exists array] { + error "\"$a\" isn't an array" + } + set maxl 0 + foreach name [lsort [array names array $pattern]] { + if {[string length $name] > $maxl} { + set maxl [string length $name] + } + } + set maxl [expr {$maxl + [string length $a] + 2}] + foreach name [lsort [array names array $pattern]] { + set nameString [format %s(%s) $a $name] + puts stdout [format "%-*s = %s" $maxl $nameString $array($name)] + } +} diff --git a/contrib/tcl/library/tclIndex b/contrib/tcl/library/tclIndex new file mode 100644 index 0000000..98ceff1 --- /dev/null +++ b/contrib/tcl/library/tclIndex @@ -0,0 +1,19 @@ +# Tcl autoload index file, version 2.0 +# This file is generated by the "auto_mkindex" command +# and sourced to set up indexing information for one or +# more commands. Typically each line is a command that +# sets an element in the auto_index array, where the +# element name is the name of a command and the value is +# a script that loads the command. + +set auto_index(unknown) [list source [file join $dir init.tcl]] +set auto_index(auto_load) [list source [file join $dir init.tcl]] +set auto_index(auto_execok) [list source [file join $dir init.tcl]] +set auto_index(auto_execok) [list source [file join $dir init.tcl]] +set auto_index(auto_reset) [list source [file join $dir init.tcl]] +set auto_index(auto_mkindex) [list source [file join $dir init.tcl]] +set auto_index(pkg_mkIndex) [list source [file join $dir init.tcl]] +set auto_index(tclPkgSetup) [list source [file join $dir init.tcl]] +set auto_index(tclPkgUnknown) [list source [file join $dir init.tcl]] +set auto_index(parray) [list source [file join $dir parray.tcl]] +set auto_index(tclLdAout) [list source [file join $dir ldAout.tcl]] diff --git a/contrib/tcl/license.terms b/contrib/tcl/license.terms new file mode 100644 index 0000000..3dcd816 --- /dev/null +++ b/contrib/tcl/license.terms @@ -0,0 +1,32 @@ +This software is copyrighted by the Regents of the University of +California, Sun Microsystems, Inc., 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. + +RESTRICTED RIGHTS: Use, duplication or disclosure by the government +is subject to the restrictions as set forth in subparagraph (c) (1) (ii) +of the Rights in Technical Data and Computer Software Clause as DFARS +252.227-7013 and FAR 52.227-19. diff --git a/contrib/tcl/tests/README b/contrib/tcl/tests/README new file mode 100644 index 0000000..7dce2a2 --- /dev/null +++ b/contrib/tcl/tests/README @@ -0,0 +1,96 @@ +Tcl Test Suite +-------------- + +SCCS: @(#) README 1.6 96/04/17 10:51:11 + +This directory contains a set of validation tests for the Tcl +commands. Each of the files whose name ends in ".test" is +intended to fully exercise one or a few Tcl commands. The +commands tested by a given file are listed in the first line +of the file. + +You can run the tests in two ways: + (a) type "make test" in ../unix; this will run all of the tests. + (b) 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". +In either case no output will be generated if all goes well, except +for a listing of the tests.. If there are errors then additional +messages will appear in the format described below. Note: don't +run the tests as superuser, since this will cause several of the tests +to fail. + +The rest of this file provides additional information on the +features of the testing environment. + +This approach to testing was designed and initially implemented +by Mary Ann May-Pumphrey of Sun Microsystems. Many thanks to +her for donating her work back to the public Tcl release. + +Definitions file: +----------------- + +The file "defs" defines a collection of procedures and variables +used to run the tests. It is read in automatically by each of the +.test files if needed, but once it has been read once it will not +be read again by the .test files. If you change defs while running +tests you'll have to "source" it by hand to load its new contents. + +Test output: +------------ + +Normally, output only appears when there are errors. However, if +the variable VERBOSE is set to 1 then tests will be run in "verbose" +mode and output will be generated for each test regardless of +whether it succeeded or failed. Test output consists of the +following information: + + - the test identifier (which can be used to locate the test code + in the .test file) + - a brief description of the test + - the contents of the test code + - the actual results produced by the tests + - a "PASSED" or "FAILED" message + - the expected results (if the test failed) + +You can set VERBOSE either interactively (after the defs file has been +read in), or you can change the default value in "defs". + +Selecting tests for execution: +------------------------------ + +Normally, all the tests in a file are run whenever the file is +"source"d. However, you can select a specific set of tests using +the global variable TESTS. This variable contains a pattern; any +test whose identifier matches TESTS will be run. For example, +the following interactive command causes all of the "for" tests in +groups 2 and 4 to be executed: + + set TESTS {for-[24]*} + +TESTS defaults to *, but you can change the default in "defs" if +you wish. + +Saving keystrokes: +------------------ + +A convenience procedure named "dotests" is included in file +"defs". It 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 TESTS to the second argument, calls "source" on +the file specified in the first argument, and restores TESTS to +its pre-call value at the end. + +Batch vs. interactive execution: +-------------------------------- + +The tests can be run in either batch or interactive mode. Batch +mode refers to using I/O redirection from a UNIX shell. For example, +the following command causes the tests in the file named "parse.test" +to be executed: + + tclTest < parse.test > parse.test.results + +Users who want to execute the tests in this fashion need to first +ensure that the file "defs" has proper values for the global +variables that control the testing environment (VERBOSE and TESTS). diff --git a/contrib/tcl/tests/all b/contrib/tcl/tests/all new file mode 100644 index 0000000..b50794c --- /dev/null +++ b/contrib/tcl/tests/all @@ -0,0 +1,16 @@ +# 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. +# +# SCCS: @(#) all 1.7 96/02/16 08:55:38 + +foreach i [lsort [glob *.test]] { + if [string match l.*.test $i] { + # This is an SCCS lock file; ignore it. + continue + } + puts stdout $i + if [catch {source $i} msg] { + puts $msg + } +} diff --git a/contrib/tcl/tests/append.test b/contrib/tcl/tests/append.test new file mode 100644 index 0000000..2be7194 --- /dev/null +++ b/contrib/tcl/tests/append.test @@ -0,0 +1,158 @@ +# Commands covered: append lappend +# +# 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) 1991-1993 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: @(#) append.test 1.14 96/04/05 15:28:42 + +if {[string compare test [info procs test]] == 1} then {source defs} + +catch {unset x} +test append-1.1 {append command} { + catch {unset x} + list [append x 1 2 abc "long string"] $x +} {{12abclong string} {12abclong string}} +test append-1.2 {append command} { + set x "" + list [append x first] [append x second] [append x third] $x +} {first firstsecond firstsecondthird firstsecondthird} +test append-1.3 {append command} { + set x "abcd" + append x +} abcd + +test append-2.1 {long appends} { + set x "" + for {set i 0} {$i < 1000} {set i [expr $i+1]} { + append x "foobar " + } + set y "foobar" + set y "$y $y $y $y $y $y $y $y $y $y" + set y "$y $y $y $y $y $y $y $y $y $y" + set y "$y $y $y $y $y $y $y $y $y $y " + expr {$x == $y} +} 1 + +test append-3.1 {append errors} { + list [catch {append} msg] $msg +} {1 {wrong # args: should be "append varName ?value value ...?"}} +test append-3.2 {append errors} { + set x "" + list [catch {append x(0) 44} msg] $msg +} {1 {can't set "x(0)": variable isn't array}} +test append-3.3 {append errors} { + catch {unset x} + list [catch {append x} msg] $msg +} {1 {can't read "x": no such variable}} + +test append-4.1 {lappend command} { + catch {unset x} + list [lappend x 1 2 abc "long string"] $x +} {{1 2 abc {long string}} {1 2 abc {long string}}} +test append-4.2 {lappend command} { + set x "" + list [lappend x first] [lappend x second] [lappend x third] $x +} {first {first second} {first second third} {first second third}} +test append-4.3 {lappend command} { + proc foo {} { + global x + set x old + unset x + lappend x new + } + set result [foo] + rename foo {} + set result +} {new} +test append-4.4 {lappend command} { + set x {} + lappend x \{\ abc +} {\{\ abc} +test append-4.5 {lappend command} { + set x {} + lappend x \{ abc +} {\{ abc} +test append-4.6 {lappend command} { + set x {1 2 3} + lappend x +} {1 2 3} +test append-4.7 {lappend command} { + set x "a\{" + lappend x abc +} "a{ abc" +test append-4.8 {lappend command} { + set x "\\\{" + lappend x abc +} "\\{ abc" +test append-4.9 {lappend command} { + set x " \{" + lappend x abc +} " {abc" +test append-4.10 {lappend command} { + set x " \{" + lappend x abc +} " {abc" +test append-4.11 {lappend command} { + set x "\{\{\{" + lappend x abc +} "{{{abc" +test append-4.12 {lappend command} { + set x "x \{\{\{" + lappend x abc +} "x {{{abc" +test append-4.13 {lappend command} { + set x "x\{\{\{" + lappend x abc +} "x{{{ abc" +test append-4.14 {lappend command} { + set x " " + lappend x abc +} " abc" +test append-4.15 {lappend command} { + set x "\\ " + lappend x abc +} "\\ abc" +test append-4.16 {lappend command} { + set x "x " + lappend x abc +} "x abc" + +proc check {var size} { + set l [llength $var] + if {$l != $size} { + return "length mismatch: should have been $size, was $l" + } + for {set i 0} {$i < $size} {set i [expr $i+1]} { + set j [lindex $var $i] + if {$j != "item $i"} { + return "element $i should have been \"item $i\", was \"$j\"" + } + } + return ok +} +test append-5.1 {long lappends} { + set x "" + for {set i 0} {$i < 300} {set i [expr $i+1]} { + lappend x "item $i" + } + check $x 300 +} ok + +test append-6.1 {lappend errors} { + list [catch {lappend} msg] $msg +} {1 {wrong # args: should be "lappend varName ?value value ...?"}} +test append-6.2 {lappend errors} { + set x "" + list [catch {lappend x(0) 44} msg] $msg +} {1 {can't set "x(0)": variable isn't array}} +test append-6.3 {lappend errors} { + catch {unset x} + list [catch {lappend x} msg] $msg +} {1 {can't read "x": no such variable}} diff --git a/contrib/tcl/tests/assocd.test b/contrib/tcl/tests/assocd.test new file mode 100644 index 0000000..20e8223 --- /dev/null +++ b/contrib/tcl/tests/assocd.test @@ -0,0 +1,57 @@ +# This file tests the AssocData facility of Tcl +# +# 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) 1991-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. +# +# "@(#) assocd.test 1.5 95/08/02 17:11:37" + +if {[string compare test [info procs test]] == 1} then {source defs} + +if {[string compare testsetassocdata [info commands testsetassocdata]] != 0} { + puts "This application hasn't been compiled with the tests for assocData," + puts "therefore I am skipping all of these tests." + return +} + +test assocd-1.1 {testing setting assoc data} { + testsetassocdata a 1 +} "" +test assocd-1.2 {testing setting assoc data} { + testsetassocdata a 2 +} "" +test assocd-1.3 {testing setting assoc data} { + testsetassocdata 123 456 +} "" +test assocd-1.4 {testing setting assoc data} { + testsetassocdata abc "abc d e f" +} "" + +test assocd-2.1 {testing getting assoc data} { + testgetassocdata a +} 2 +test assocd-2.2 {testing getting assoc data} { + testgetassocdata 123 +} 456 +test assocd-2.3 {testing getting assoc data} { + testgetassocdata abc +} {abc d e f} +test assocd-2.4 {testing getting assoc data} { + testgetassocdata xxx +} "" + +test assocd-3.1 {testing deleting assoc data} { + testdelassocdata a +} "" +test assocd-3.2 {testing deleting assoc data} { + testdelassocdata 123 +} "" +test assocd-3.3 {testing deleting assoc data} { + list [catch {testdelassocdata nonexistent} msg] $msg +} {0 {}} diff --git a/contrib/tcl/tests/async.test b/contrib/tcl/tests/async.test new file mode 100644 index 0000000..cfc572c --- /dev/null +++ b/contrib/tcl/tests/async.test @@ -0,0 +1,131 @@ +# Commands covered: none +# +# This file contains a collection of tests for Tcl_AsyncCreate and related +# library procedures. Sourcing this file into Tcl runs the tests and +# generates output for errors. No output means no errors were found. +# +# Copyright (c) 1993 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: @(#) async.test 1.5 96/04/05 15:29:38 + +if {[info commands testasync] == {}} { + puts "This application hasn't been compiled with the \"testasync\"" + puts "command, so I can't test Tcl_AsyncCreate et al." + return +} + +if {[string compare test [info procs test]] == 1} then {source defs} + +proc async1 {result code} { + global aresult acode + set aresult $result + set acode $code + return "new result" +} +proc async2 {result code} { + global aresult acode + set aresult $result + set acode $code + return -code error "xyzzy" +} +proc async3 {result code} { + global aresult + set aresult "test pattern" + return -code $code $result +} + +set handler1 [testasync create async1] +set handler2 [testasync create async2] +set handler3 [testasync create async3] +test async-1.1 {basic async handlers} { + set aresult xxx + set acode yyy + list [catch {testasync mark $handler1 "original" 0} msg] $msg \ + $acode $aresult +} {0 {new result} 0 original} +test async-1.2 {basic async handlers} { + set aresult xxx + set acode yyy + list [catch {testasync mark $handler1 "original" 1} msg] $msg \ + $acode $aresult +} {0 {new result} 1 original} +test async-1.3 {basic async handlers} { + set aresult xxx + set acode yyy + list [catch {testasync mark $handler2 "old" 0} msg] $msg \ + $acode $aresult +} {1 xyzzy 0 old} +test async-1.4 {basic async handlers} { + set aresult xxx + set acode yyy + list [catch {testasync mark $handler2 "old" 3} msg] $msg \ + $acode $aresult +} {1 xyzzy 3 old} +test async-1.5 {basic async handlers} { + set aresult xxx + list [catch {testasync mark $handler3 "foobar" 0} msg] $msg $aresult +} {0 foobar {test pattern}} +test async-1.6 {basic async handlers} { + set aresult xxx + list [catch {testasync mark $handler3 "foobar" 1} msg] $msg $aresult +} {1 foobar {test pattern}} + +proc mult1 {result code} { + global x + lappend x mult1 + return -code 7 mult1 +} +set hm1 [testasync create mult1] +proc mult2 {result code} { + global x + lappend x mult2 + return -code 9 mult2 +} +set hm2 [testasync create mult2] +proc mult3 {result code} { + global x hm1 hm2 + lappend x [catch {testasync mark $hm2 serial2 0}] + lappend x [catch {testasync mark $hm1 serial1 0}] + lappend x mult3 + return -code 11 mult3 +} +set hm3 [testasync create mult3] + +test async-2.1 {multiple handlers} { + set x {} + list [catch {testasync mark $hm3 "foobar" 5} msg] $msg $x +} {9 mult2 {0 0 mult3 mult1 mult2}} + +proc del1 {result code} { + global x hm1 hm2 hm3 hm4 + lappend x [catch {testasync mark $hm3 serial2 0}] + lappend x [catch {testasync mark $hm1 serial1 0}] + lappend x [catch {testasync mark $hm4 serial1 0}] + testasync delete $hm1 + testasync delete $hm2 + testasync delete $hm3 + lappend x del1 + return -code 13 del1 +} +proc del2 {result code} { + global x + lappend x del2 + return -code 3 del2 +} +testasync delete $handler1 +testasync delete $hm2 +testasync delete $hm3 +set hm2 [testasync create del1] +set hm3 [testasync create mult2] +set hm4 [testasync create del2] + +test async-3.1 {deleting handlers} { + set x {} + list [catch {testasync mark $hm2 "foobar" 5} msg] $msg $x +} {3 del2 {0 0 0 del1 del2}} + +testasync delete diff --git a/contrib/tcl/tests/case.test b/contrib/tcl/tests/case.test new file mode 100644 index 0000000..9224372 --- /dev/null +++ b/contrib/tcl/tests/case.test @@ -0,0 +1,83 @@ +# Commands covered: case +# +# 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) 1991-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: @(#) case.test 1.13 96/02/16 08:55:41 + +if {[string compare test [info procs test]] == 1} then {source defs} + +test case-1.1 {simple pattern} { + case a in a {format 1} b {format 2} c {format 3} default {format 4} +} 1 +test case-1.2 {simple pattern} { + case b a {format 1} b {format 2} c {format 3} default {format 4} +} 2 +test case-1.3 {simple pattern} { + case x in a {format 1} b {format 2} c {format 3} default {format 4} +} 4 +test case-1.4 {simple pattern} { + case x a {format 1} b {format 2} c {format 3} +} {} +test case-1.5 {simple pattern matches many times} { + case b a {format 1} b {format 2} b {format 3} b {format 4} +} 2 +test case-1.6 {fancier pattern} { + case cx a {format 1} *c {format 2} *x {format 3} default {format 4} +} 3 +test case-1.7 {list of patterns} { + case abc in {a b c} {format 1} {def abc ghi} {format 2} +} 2 + +test case-2.1 {error in executed command} { + list [catch {case a in a {error "Just a test"} default {format 1}} msg] \ + $msg $errorInfo +} {1 {Just a test} {Just a test + while executing +"error "Just a test"" + ("a" arm line 1) + invoked from within +"case a in a {error "Just a test"} default {format 1}"}} +test case-2.2 {error: not enough args} { + list [catch {case} msg] $msg +} {1 {wrong # args: should be "case string ?in? patList body ... ?default body?"}} +test case-2.3 {error: pattern with no body} { + list [catch {case a b} msg] $msg +} {1 {extra case pattern with no body}} +test case-2.4 {error: pattern with no body} { + list [catch {case a in b {format 1} c} msg] $msg +} {1 {extra case pattern with no body}} +test case-2.5 {error in default command} { + list [catch {case foo in a {error case1} default {error case2} \ + b {error case 3}} msg] $msg $errorInfo +} {1 case2 {case2 + while executing +"error case2" + ("default" arm line 1) + invoked from within +"case foo in a {error case1} default {error case2} b {error case 3}"}} + +test case-3.1 {single-argument form for pattern/command pairs} { + case b in { + a {format 1} + b {format 2} + default {format 6} + } +} {2} +test case-3.2 {single-argument form for pattern/command pairs} { + case b { + a {format 1} + b {format 2} + default {format 6} + } +} {2} +test case-3.3 {single-argument form for pattern/command pairs} { + list [catch {case z in {a 2 b}} msg] $msg +} {1 {extra case pattern with no body}} diff --git a/contrib/tcl/tests/clock.test b/contrib/tcl/tests/clock.test new file mode 100644 index 0000000..a14f13a --- /dev/null +++ b/contrib/tcl/tests/clock.test @@ -0,0 +1,101 @@ +# Commands covered: clock +# +# 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) 1995-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: @(#) clock.test 1.5 96/04/05 15:30:36 + +if {[string compare test [info procs test]] == 1} then {source defs} + +test clock-1.1 {clock tests} { + list [catch {clock} msg] $msg +} {1 {wrong # args: should be "clock option ?arg ...?"}} +test clock-1.2 {clock tests} { + list [catch {clock foo} msg] $msg +} {1 {unknown option "foo": must be clicks, format, scan, or seconds}} + +# clock clicks +test clock-2.1 {clock clicks tests} { + expr [clock clicks]+1 + concat {} +} {} +test clock-2.2 {clock clicks tests} { + list [catch {clock clicks foo} msg] $msg +} {1 {wrong # arguments: must be "clock clicks"}} +test clock-2.3 {clock clicks tests} { + set start [clock clicks] + after 10 + set end [clock clicks] + expr "$end > $start" +} {1} + +# clock format +test clock-3.1 {clock format tests} {unixOnly} { + set clockval 657687766 + clock format $clockval -format {%a %b %d %I:%M:%S %p %Y} -gmt true +} {Sun Nov 04 03:02:46 AM 1990} +test clock-3.2 {clock format tests} { + list [catch {clock format} msg] $msg +} {1 {wrong # args: clock format clockval ?-format string? ?-gmt boolean?}} +test clock-3.3 {clock format tests} { + list [catch {clock format foo} msg] $msg +} {1 {expected unsigned time but got "foo"}} +test clock-3.4 {clock format tests} {unixOnly} { + set clockval 657687766 + clock format $clockval -format "%a %b %d %I:%M:%S %p %Y" -gmt true +} "Sun Nov 04 03:02:46 AM 1990" + +# clock scan +test clock-4.1 {clock scan tests} { + list [catch {clock scan} msg] $msg +} {1 {wrong # args: clock scan dateString ?-base clockValue? ?-gmt boolean?}} +test clock-4.2 {clock scan tests} { + list [catch {clock scan "bad-string"} msg] $msg +} {1 {unable to convert date-time string "bad-string"}} +test clock-4.3 {clock scan tests} { + clock format [clock scan "14 Feb 92" -gmt true] \ + -format {%m/%d/%y %I:%M:%S %p} -gmt true +} {02/14/92 12:00:00 AM} +test clock-4.4 {clock scan tests} { + clock format [clock scan "Feb 14, 1992 12:20 PM" -gmt true] \ + -format {%m/%d/%y %I:%M:%S %p} -gmt true +} {02/14/92 12:20:00 PM} +test clock-4.5 {clock scan tests} { + clock format \ + [clock scan "Feb 14, 1992 12:20 PM" -base 319363200 -gmt true] \ + -format {%m/%d/%y %I:%M:%S %p} -gmt true +} {02/14/92 12:20:00 PM} +test clock-4.6 {clock scan tests} { + set time [clock scan "Oct 23,1992 15:00"] + clock format $time -format {%b %d,%Y %H:%M} +} {Oct 23,1992 15:00} +test clock-4.7 {clock scan tests} { + set time [clock scan "Oct 23,1992 15:00 GMT"] + clock format $time -format {%b %d,%Y %H:%M GMT} -gmt true +} {Oct 23,1992 15:00 GMT} +test clock-4.8 {clock scan tests} { + set time [clock scan "Oct 23,1992 15:00" -gmt true] + clock format $time -format {%b %d,%Y %H:%M GMT} -gmt true +} {Oct 23,1992 15:00 GMT} + +# clock seconds +test clock-5.1 {clock seconds tests} { + expr [clock seconds]+1 + concat {} +} {} +test clock-5.2 {clock seconds tests} { + list [catch {clock seconds foo} msg] $msg +} {1 {wrong # arguments: must be "clock seconds"}} +test clock-5.3 {clock seconds tests} { + set start [clock seconds] + after 2000 + set end [clock seconds] + expr "$end > $start" +} {1} + diff --git a/contrib/tcl/tests/cmdAH.test b/contrib/tcl/tests/cmdAH.test new file mode 100644 index 0000000..058ee73 --- /dev/null +++ b/contrib/tcl/tests/cmdAH.test @@ -0,0 +1,1132 @@ +# The file tests the tclCmdAH.c file. +# +# 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) 1996 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. +# +# SCCS: @(#) cmdah.test 1.7 96/04/12 10:49:01 + +if {[string compare test [info procs test]] == 1} then {source defs} + +global env +set platform [testgetplatform] + +test cmdah-1.1 {Tcl_FileCmd} { + list [catch file msg] $msg +} {1 {wrong # args: should be "file option name ?arg ...?"}} +test cmdah-1.2 {Tcl_FileCmd} { + list [catch {file x} msg] $msg +} {1 {wrong # args: should be "file option name ?arg ...?"}} + +# dirname + +test cmdah-2.1 {Tcl_FileCmd: dirname} { + testsetplatform unix + list [catch {file dirname a b} msg] $msg +} {1 {wrong # args: should be "file dirname name"}} +test cmdah-2.2 {Tcl_FileCmd: dirname} { + testsetplatform unix + file dirname /a/b +} /a +test cmdah-2.3 {Tcl_FileCmd: dirname} { + testsetplatform unix + file dirname {} +} . +test cmdah-2.4 {Tcl_FileCmd: dirname} { + testsetplatform mac + file dirname {} +} : +test cmdah-2.5 {Tcl_FileCmd: dirname} { + testsetplatform win + file dirname {} +} . +test cmdah-2.6 {Tcl_FileCmd: dirname} { + testsetplatform unix + file dirname .def +} . +test cmdah-2.7 {Tcl_FileCmd: dirname} { + testsetplatform mac + file dirname a +} : +test cmdah-2.8 {Tcl_FileCmd: dirname} { + testsetplatform win + file dirname a +} . +test cmdah-2.9 {Tcl_FileCmd: dirname} { + testsetplatform unix + file d a/b/c.d +} a/b +test cmdah-2.10 {Tcl_FileCmd: dirname} { + testsetplatform unix + file dirname a/b.c/d +} a/b.c +test cmdah-2.11 {Tcl_FileCmd: dirname} { + testsetplatform unix + file dirname /. +} / +test cmdah-2.12 {Tcl_FileCmd: dirname} { + testsetplatform unix + list [catch {file dirname /} msg] $msg +} {0 /} +test cmdah-2.13 {Tcl_FileCmd: dirname} { + testsetplatform unix + list [catch {file dirname /foo} msg] $msg +} {0 /} +test cmdah-2.14 {Tcl_FileCmd: dirname} { + testsetplatform unix + list [catch {file dirname //foo} msg] $msg +} {0 /} +test cmdah-2.15 {Tcl_FileCmd: dirname} { + testsetplatform unix + list [catch {file dirname //foo/bar} msg] $msg +} {0 /foo} +test cmdah-2.16 {Tcl_FileCmd: dirname} { + testsetplatform unix + list [catch {file dirname {//foo\/bar/baz}} msg] $msg +} {0 {/foo\/bar}} +test cmdah-2.17 {Tcl_FileCmd: dirname} { + testsetplatform unix + list [catch {file dirname {//foo\/bar/baz/blat}} msg] $msg +} {0 {/foo\/bar/baz}} +test cmdah-2.18 {Tcl_FileCmd: dirname} { + testsetplatform unix + list [catch {file dirname /foo//} msg] $msg +} {0 /} +test cmdah-2.19 {Tcl_FileCmd: dirname} { + testsetplatform unix + list [catch {file dirname ./a} msg] $msg +} {0 .} +test cmdah-2.20 {Tcl_FileCmd: dirname} { + testsetplatform unix + list [catch {file dirname a/.a} msg] $msg +} {0 a} +test cmdah-2.21 {Tcl_FileCmd: dirname} { + testsetplatform windows + list [catch {file dirname c:foo} msg] $msg +} {0 c:} +test cmdah-2.22 {Tcl_FileCmd: dirname} { + testsetplatform windows + list [catch {file dirname c:} msg] $msg +} {0 c:} +test cmdah-2.23 {Tcl_FileCmd: dirname} { + testsetplatform windows + list [catch {file dirname c:/} msg] $msg +} {0 c:/} +test cmdah-2.24 {Tcl_FileCmd: dirname} { + testsetplatform windows + list [catch {file dirname {c:\foo}} msg] $msg +} {0 c:/} +test cmdah-2.25 {Tcl_FileCmd: dirname} { + testsetplatform windows + list [catch {file dirname {//foo/bar/baz}} msg] $msg +} {0 //foo/bar} +test cmdah-2.26 {Tcl_FileCmd: dirname} { + testsetplatform windows + list [catch {file dirname {//foo/bar}} msg] $msg +} {0 //foo/bar} +test cmdah-2.27 {Tcl_FileCmd: dirname} { + testsetplatform mac + list [catch {file dirname :} msg] $msg +} {0 :} +test cmdah-2.28 {Tcl_FileCmd: dirname} { + testsetplatform mac + list [catch {file dirname :Foo} msg] $msg +} {0 :} +test cmdah-2.29 {Tcl_FileCmd: dirname} { + testsetplatform mac + list [catch {file dirname Foo:} msg] $msg +} {0 Foo:} +test cmdah-2.30 {Tcl_FileCmd: dirname} { + testsetplatform mac + list [catch {file dirname Foo:bar} msg] $msg +} {0 Foo:} +test cmdah-2.31 {Tcl_FileCmd: dirname} { + testsetplatform mac + list [catch {file dirname :Foo:bar} msg] $msg +} {0 :Foo} +test cmdah-2.32 {Tcl_FileCmd: dirname} { + testsetplatform mac + list [catch {file dirname ::} msg] $msg +} {0 :} +test cmdah-2.33 {Tcl_FileCmd: dirname} { + testsetplatform mac + list [catch {file dirname :::} msg] $msg +} {0 ::} +test cmdah-2.34 {Tcl_FileCmd: dirname} { + testsetplatform mac + list [catch {file dirname /foo/bar/} msg] $msg +} {0 foo:} +test cmdah-2.35 {Tcl_FileCmd: dirname} { + testsetplatform mac + list [catch {file dirname /foo/bar} msg] $msg +} {0 foo:} +test cmdah-2.36 {Tcl_FileCmd: dirname} { + testsetplatform mac + list [catch {file dirname /foo} msg] $msg +} {0 foo:} +test cmdah-2.37 {Tcl_FileCmd: dirname} { + testsetplatform mac + list [catch {file dirname foo} msg] $msg +} {0 :} +test cmdah-2.38 {Tcl_FileCmd: dirname} { + testsetplatform unix + list [catch {file dirname ~/foo} msg] $msg +} {0 ~} +test cmdah-2.39 {Tcl_FileCmd: dirname} { + testsetplatform unix + list [catch {file dirname ~bar/foo} msg] $msg +} {0 ~bar} +test cmdah-2.40 {Tcl_FileCmd: dirname} { + testsetplatform mac + list [catch {file dirname ~bar/foo} msg] $msg +} {0 ~bar:} +test cmdah-2.41 {Tcl_FileCmd: dirname} { + testsetplatform mac + list [catch {file dirname ~/foo} msg] $msg +} {0 ~:} +test cmdah-2.42 {Tcl_FileCmd: dirname} { + testsetplatform mac + list [catch {file dirname ~:baz} msg] $msg +} {0 ~:} +test cmdah-2.43 {Tcl_FileCmd: dirname} { + global env + set temp $env(HOME) + set env(HOME) "/home/test" + testsetplatform unix + set result [list [catch {file dirname ~} msg] $msg] + set env(HOME) $temp + set result +} {0 /home} +test cmdah-2.44 {Tcl_FileCmd: dirname} { + global env + set temp $env(HOME) + set env(HOME) "~" + testsetplatform unix + set result [list [catch {file dirname ~} msg] $msg] + set env(HOME) $temp + set result +} {0 ~} +test cmdah-2.45 {Tcl_FileCmd: dirname} { + global env + set temp $env(HOME) + set env(HOME) "/home/test" + testsetplatform windows + set result [list [catch {file dirname ~} msg] $msg] + set env(HOME) $temp + set result +} {0 /home} +test cmdah-2.46 {Tcl_FileCmd: dirname} { + global env + set temp $env(HOME) + set env(HOME) "/home/test" + testsetplatform mac + set result [list [catch {file dirname ~} msg] $msg] + set env(HOME) $temp + set result +} {0 home:} + +# tail + +test cmdah-3.1 {Tcl_FileCmd: tail} { + testsetplatform unix + list [catch {file tail a b} msg] $msg +} {1 {wrong # args: should be "file tail name"}} +test cmdah-3.2 {Tcl_FileCmd: tail} { + testsetplatform unix + file tail /a/b +} b +test cmdah-3.3 {Tcl_FileCmd: tail} { + testsetplatform unix + file tail {} +} {} +test cmdah-3.4 {Tcl_FileCmd: tail} { + testsetplatform mac + file tail {} +} {} +test cmdah-3.5 {Tcl_FileCmd: tail} { + testsetplatform win + file tail {} +} {} +test cmdah-3.6 {Tcl_FileCmd: tail} { + testsetplatform unix + file tail .def +} .def +test cmdah-3.7 {Tcl_FileCmd: tail} { + testsetplatform mac + file tail a +} a +test cmdah-3.8 {Tcl_FileCmd: tail} { + testsetplatform win + file tail a +} a +test cmdah-3.9 {Tcl_FileCmd: tail} { + testsetplatform unix + file ta a/b/c.d +} c.d +test cmdah-3.10 {Tcl_FileCmd: tail} { + testsetplatform unix + file tail a/b.c/d +} d +test cmdah-3.11 {Tcl_FileCmd: tail} { + testsetplatform unix + file tail /. +} . +test cmdah-3.12 {Tcl_FileCmd: tail} { + testsetplatform unix + file tail / +} {} +test cmdah-3.13 {Tcl_FileCmd: tail} { + testsetplatform unix + file tail /foo +} foo +test cmdah-3.14 {Tcl_FileCmd: tail} { + testsetplatform unix + file tail //foo +} foo +test cmdah-3.15 {Tcl_FileCmd: tail} { + testsetplatform unix + file tail //foo/bar +} bar +test cmdah-3.16 {Tcl_FileCmd: tail} { + testsetplatform unix + file tail {//foo\/bar/baz} +} baz +test cmdah-3.17 {Tcl_FileCmd: tail} { + testsetplatform unix + file tail {//foo\/bar/baz/blat} +} blat +test cmdah-3.18 {Tcl_FileCmd: tail} { + testsetplatform unix + file tail /foo// +} foo +test cmdah-3.19 {Tcl_FileCmd: tail} { + testsetplatform unix + file tail ./a +} a +test cmdah-3.20 {Tcl_FileCmd: tail} { + testsetplatform unix + file tail a/.a +} .a +test cmdah-3.21 {Tcl_FileCmd: tail} { + testsetplatform windows + file tail c:foo +} foo +test cmdah-3.22 {Tcl_FileCmd: tail} { + testsetplatform windows + file tail c: +} {} +test cmdah-3.23 {Tcl_FileCmd: tail} { + testsetplatform windows + file tail c:/ +} {} +test cmdah-3.24 {Tcl_FileCmd: tail} { + testsetplatform windows + file tail {c:\foo} +} foo +test cmdah-3.25 {Tcl_FileCmd: tail} { + testsetplatform windows + file tail {//foo/bar/baz} +} baz +test cmdah-3.26 {Tcl_FileCmd: tail} { + testsetplatform windows + file tail {//foo/bar} +} {} +test cmdah-3.27 {Tcl_FileCmd: tail} { + testsetplatform mac + file tail : +} : +test cmdah-3.28 {Tcl_FileCmd: tail} { + testsetplatform mac + file tail :Foo +} Foo +test cmdah-3.29 {Tcl_FileCmd: tail} { + testsetplatform mac + file tail Foo: +} {} +test cmdah-3.30 {Tcl_FileCmd: tail} { + testsetplatform mac + file tail Foo:bar +} bar +test cmdah-3.31 {Tcl_FileCmd: tail} { + testsetplatform mac + file tail :Foo:bar +} bar +test cmdah-3.32 {Tcl_FileCmd: tail} { + testsetplatform mac + file tail :: +} :: +test cmdah-3.33 {Tcl_FileCmd: tail} { + testsetplatform mac + file tail ::: +} :: +test cmdah-3.34 {Tcl_FileCmd: tail} { + testsetplatform mac + file tail /foo/bar/ +} bar +test cmdah-3.35 {Tcl_FileCmd: tail} { + testsetplatform mac + file tail /foo/bar +} bar +test cmdah-3.36 {Tcl_FileCmd: tail} { + testsetplatform mac + file tail /foo +} {} +test cmdah-3.37 {Tcl_FileCmd: tail} { + testsetplatform mac + file tail foo +} foo +test cmdah-3.38 {Tcl_FileCmd: tail} { + testsetplatform mac + file tail ~:foo +} foo +test cmdah-3.39 {Tcl_FileCmd: tail} { + testsetplatform mac + file tail ~bar:foo +} foo +test cmdah-3.40 {Tcl_FileCmd: tail} { + testsetplatform mac + file tail ~bar/foo +} foo +test cmdah-3.41 {Tcl_FileCmd: tail} { + testsetplatform mac + file tail ~/foo +} foo +test cmdah-3.42 {Tcl_FileCmd: tail} { + global env + set temp $env(HOME) + set env(HOME) "/home/test" + testsetplatform unix + set result [file tail ~] + set env(HOME) $temp + set result +} {} +test cmdah-3.43 {Tcl_FileCmd: tail} { + global env + set temp $env(HOME) + set env(HOME) "~" + testsetplatform unix + set result [file tail ~] + set env(HOME) $temp + set result +} {} +test cmdah-3.44 {Tcl_FileCmd: tail} { + global env + set temp $env(HOME) + set env(HOME) "/home/test" + testsetplatform windows + set result [file tail ~] + set env(HOME) $temp + set result +} {} +test cmdah-3.45 {Tcl_FileCmd: tail} { + global env + set temp $env(HOME) + set env(HOME) "/home/test" + testsetplatform mac + set result [file tail ~] + set env(HOME) $temp + set result +} {} +test cmdah-3.46 {Tcl_FileCmd: tail} { + testsetplatform unix + file tail {f.oo\bar/baz.bat} +} baz.bat +test cmdah-3.47 {Tcl_FileCmd: tail} { + testsetplatform windows + file tail c:foo +} foo +test cmdah-3.48 {Tcl_FileCmd: tail} { + testsetplatform windows + file tail c: +} {} +test cmdah-3.49 {Tcl_FileCmd: tail} { + testsetplatform windows + file tail c:/foo +} foo +test cmdah-3.50 {Tcl_FileCmd: tail} { + testsetplatform windows + file tail {c:/foo\bar} +} bar +test cmdah-3.51 {Tcl_FileCmd: tail} { + testsetplatform windows + file tail {foo\bar} +} bar + +# rootname + +test cmdah-4.1 {Tcl_FileCmd: rootname} { + testsetplatform unix + list [catch {file rootname a b} msg] $msg +} {1 {wrong # args: should be "file rootname name"}} +test cmdah-4.2 {Tcl_FileCmd: rootname} { + testsetplatform unix + file rootname {} +} {} +test cmdah-4.3 {Tcl_FileCmd: rootname} { + testsetplatform unix + file ro foo +} foo +test cmdah-4.4 {Tcl_FileCmd: rootname} { + testsetplatform unix + file rootname foo. +} foo +test cmdah-4.5 {Tcl_FileCmd: rootname} { + testsetplatform unix + file rootname .foo +} {} +test cmdah-4.6 {Tcl_FileCmd: rootname} { + testsetplatform unix + file rootname abc.def +} abc +test cmdah-4.7 {Tcl_FileCmd: rootname} { + testsetplatform unix + file rootname abc.def.ghi +} abc.def +test cmdah-4.8 {Tcl_FileCmd: rootname} { + testsetplatform unix + file rootname a/b/c.d +} a/b/c +test cmdah-4.9 {Tcl_FileCmd: rootname} { + testsetplatform unix + file rootname a/b.c/d +} a/b.c/d +test cmdah-4.10 {Tcl_FileCmd: rootname} { + testsetplatform unix + file rootname a/b.c/ +} a/b.c/ +test cmdah-4.11 {Tcl_FileCmd: rootname} { + testsetplatform mac + file ro foo +} foo +test cmdah-4.12 {Tcl_FileCmd: rootname} { + testsetplatform mac + file rootname {} +} {} +test cmdah-4.13 {Tcl_FileCmd: rootname} { + testsetplatform mac + file rootname foo. +} foo +test cmdah-4.14 {Tcl_FileCmd: rootname} { + testsetplatform mac + file rootname .foo +} {} +test cmdah-4.15 {Tcl_FileCmd: rootname} { + testsetplatform mac + file rootname abc.def +} abc +test cmdah-4.16 {Tcl_FileCmd: rootname} { + testsetplatform mac + file rootname abc.def.ghi +} abc.def +test cmdah-4.17 {Tcl_FileCmd: rootname} { + testsetplatform mac + file rootname a:b:c.d +} a:b:c +test cmdah-4.18 {Tcl_FileCmd: rootname} { + testsetplatform mac + file rootname a:b.c:d +} a:b.c:d +test cmdah-4.19 {Tcl_FileCmd: rootname} { + testsetplatform mac + file rootname a/b/c.d +} a/b/c +test cmdah-4.20 {Tcl_FileCmd: rootname} { + testsetplatform mac + file rootname a/b.c/d +} a/b.c/d +test cmdah-4.21 {Tcl_FileCmd: rootname} { + testsetplatform mac + file rootname /a.b +} /a +test cmdah-4.22 {Tcl_FileCmd: rootname} { + testsetplatform mac + file rootname foo.c: +} foo.c: +test cmdah-4.23 {Tcl_FileCmd: rootname} { + testsetplatform windows + file rootname {} +} {} +test cmdah-4.24 {Tcl_FileCmd: rootname} { + testsetplatform windows + file ro foo +} foo +test cmdah-4.25 {Tcl_FileCmd: rootname} { + testsetplatform windows + file rootname foo. +} foo +test cmdah-4.26 {Tcl_FileCmd: rootname} { + testsetplatform windows + file rootname .foo +} {} +test cmdah-4.27 {Tcl_FileCmd: rootname} { + testsetplatform windows + file rootname abc.def +} abc +test cmdah-4.28 {Tcl_FileCmd: rootname} { + testsetplatform windows + file rootname abc.def.ghi +} abc.def +test cmdah-4.29 {Tcl_FileCmd: rootname} { + testsetplatform windows + file rootname a/b/c.d +} a/b/c +test cmdah-4.30 {Tcl_FileCmd: rootname} { + testsetplatform windows + file rootname a/b.c/d +} a/b.c/d +test cmdah-4.31 {Tcl_FileCmd: rootname} { + testsetplatform windows + file rootname a\\b.c\\ +} a\\b.c\\ +test cmdah-4.32 {Tcl_FileCmd: rootname} { + testsetplatform windows + file rootname a\\b\\c.d +} a\\b\\c +test cmdah-4.33 {Tcl_FileCmd: rootname} { + testsetplatform windows + file rootname a\\b.c\\d +} a\\b.c\\d +test cmdah-4.34 {Tcl_FileCmd: rootname} { + testsetplatform windows + file rootname a\\b.c\\ +} a\\b.c\\ +set num 35 +foreach outer { {} a .a a. a.a } { + foreach inner { {} a .a a. a.a } { + set thing [format %s/%s $outer $inner] + test cmdah-4.$num {Tcl_FileCmd: rootname and extension options} { + testsetplatform unix + format %s%s [file rootname $thing] [file ext $thing] + } $thing + set num [expr $num+1] + } +} + +# extension + +test cmdah-5.1 {Tcl_FileCmd: extension} { + testsetplatform unix + list [catch {file extension a b} msg] $msg +} {1 {wrong # args: should be "file extension name"}} +test cmdah-5.2 {Tcl_FileCmd: extension} { + testsetplatform unix + file extension {} +} {} +test cmdah-5.3 {Tcl_FileCmd: extension} { + testsetplatform unix + file ext foo +} {} +test cmdah-5.4 {Tcl_FileCmd: extension} { + testsetplatform unix + file extension foo. +} . +test cmdah-5.5 {Tcl_FileCmd: extension} { + testsetplatform unix + file extension .foo +} .foo +test cmdah-5.6 {Tcl_FileCmd: extension} { + testsetplatform unix + file extension abc.def +} .def +test cmdah-5.7 {Tcl_FileCmd: extension} { + testsetplatform unix + file extension abc.def.ghi +} .ghi +test cmdah-5.8 {Tcl_FileCmd: extension} { + testsetplatform unix + file extension a/b/c.d +} .d +test cmdah-5.9 {Tcl_FileCmd: extension} { + testsetplatform unix + file extension a/b.c/d +} {} +test cmdah-5.10 {Tcl_FileCmd: extension} { + testsetplatform unix + file extension a/b.c/ +} {} +test cmdah-5.11 {Tcl_FileCmd: extension} { + testsetplatform mac + file ext foo +} {} +test cmdah-5.12 {Tcl_FileCmd: extension} { + testsetplatform mac + file extension {} +} {} +test cmdah-5.13 {Tcl_FileCmd: extension} { + testsetplatform mac + file extension foo. +} . +test cmdah-5.14 {Tcl_FileCmd: extension} { + testsetplatform mac + file extension .foo +} .foo +test cmdah-5.15 {Tcl_FileCmd: extension} { + testsetplatform mac + file extension abc.def +} .def +test cmdah-5.16 {Tcl_FileCmd: extension} { + testsetplatform mac + file extension abc.def.ghi +} .ghi +test cmdah-5.17 {Tcl_FileCmd: extension} { + testsetplatform mac + file extension a:b:c.d +} .d +test cmdah-5.18 {Tcl_FileCmd: extension} { + testsetplatform mac + file extension a:b.c:d +} {} +test cmdah-5.19 {Tcl_FileCmd: extension} { + testsetplatform mac + file extension a/b/c.d +} .d +test cmdah-5.20 {Tcl_FileCmd: extension} { + testsetplatform mac + file extension a/b.c/d +} {} +test cmdah-5.21 {Tcl_FileCmd: extension} { + testsetplatform mac + file extension /a.b +} .b +test cmdah-5.22 {Tcl_FileCmd: extension} { + testsetplatform mac + file extension foo.c: +} {} +test cmdah-5.23 {Tcl_FileCmd: extension} { + testsetplatform windows + file extension {} +} {} +test cmdah-5.24 {Tcl_FileCmd: extension} { + testsetplatform windows + file ext foo +} {} +test cmdah-5.25 {Tcl_FileCmd: extension} { + testsetplatform windows + file extension foo. +} . +test cmdah-5.26 {Tcl_FileCmd: extension} { + testsetplatform windows + file extension .foo +} .foo +test cmdah-5.27 {Tcl_FileCmd: extension} { + testsetplatform windows + file extension abc.def +} .def +test cmdah-5.28 {Tcl_FileCmd: extension} { + testsetplatform windows + file extension abc.def.ghi +} .ghi +test cmdah-5.29 {Tcl_FileCmd: extension} { + testsetplatform windows + file extension a/b/c.d +} .d +test cmdah-5.30 {Tcl_FileCmd: extension} { + testsetplatform windows + file extension a/b.c/d +} {} +test cmdah-5.31 {Tcl_FileCmd: extension} { + testsetplatform windows + file extension a\\b.c\\ +} {} +test cmdah-5.32 {Tcl_FileCmd: extension} { + testsetplatform windows + file extension a\\b\\c.d +} .d +test cmdah-5.33 {Tcl_FileCmd: extension} { + testsetplatform windows + file extension a\\b.c\\d +} {} +test cmdah-5.34 {Tcl_FileCmd: extension} { + testsetplatform windows + file extension a\\b.c\\ +} {} + +# pathtype + +test cmdah-6.1 {Tcl_FileCmd: pathtype} { + testsetplatform unix + list [catch {file pathtype a b} msg] $msg +} {1 {wrong # args: should be "file pathtype name"}} +test cmdah-6.2 {Tcl_FileCmd: pathtype} { + testsetplatform unix + file pathtype /a +} absolute +test cmdah-6.3 {Tcl_FileCmd: pathtype} { + testsetplatform unix + file p a +} relative +test cmdah-6.4 {Tcl_FileCmd: pathtype} { + testsetplatform windows + file pathtype c:a +} volumerelative + +# split + +test cmdah-7.1 {Tcl_FileCmd: split} { + testsetplatform unix + list [catch {file split a b} msg] $msg +} {1 {wrong # args: should be "file split name"}} +test cmdah-7.2 {Tcl_FileCmd: split} { + testsetplatform unix + file split a +} a +test cmdah-7.3 {Tcl_FileCmd: split} { + testsetplatform unix + file split a/b +} {a b} + +# join + +test cmdah-8.1 {Tcl_FileCmd: join} { + testsetplatform unix + file join a +} a +test cmdah-8.2 {Tcl_FileCmd: join} { + testsetplatform unix + file join a b +} a/b +test cmdah-8.3 {Tcl_FileCmd: join} { + testsetplatform unix + file join a b c d +} a/b/c/d + +# error handling of Tcl_TranslateFileName + +test cmdah-9.1 {Tcl_FileCmd} { + testsetplatform unix + list [catch {file readable ~_bad_user} msg] $msg +} {1 {user "_bad_user" doesn't exist}} + +makeFile abcde gorp.file +makeDirectory dir.file + +# readable +# Can't run on macintosh - requires chmod +if {$tcl_platform(platform) != "macintosh"} { + +test cmdah-10.1 {Tcl_FileCmd: readable} { + list [catch {file readable a b} msg] $msg +} {1 {wrong # args: should be "file readable name"}} +catch {exec chmod 444 gorp.file} +test cmdah-10.2 {Tcl_FileCmd: readable} {unixExecs} {file readable gorp.file} 1 +catch {exec chmod 333 gorp.file} +if {$user != "root"} { + test cmdah-10.3 {Tcl_FileCmd: readable} {unixOnly} { + file reada gorp.file + } 0 +} +} + +# writable +# Can't run on macintosh - requires chmod +if {$tcl_platform(platform) != "macintosh"} { + +test cmdah-11.1 {Tcl_FileCmd: writable} { + list [catch {file writable a b} msg] $msg +} {1 {wrong # args: should be "file writable name"}} +catch {exec chmod 555 gorp.file} +if {$user != "root"} { + test cmdah-11.2 {Tcl_FileCmd: writable} {unixExecs} { + file writable gorp.file + } 0 +} +catch {exec chmod 222 gorp.file} +test cmdah-11.3 {Tcl_FileCmd: writable} {unixExecs} {file w gorp.file} 1 +} + +# executable +# Can't run on macintosh - requires chmod +if {$tcl_platform(platform) != "macintosh"} { + +test cmdah-12.1 {Tcl_FileCmd: executable} {unixExecs} { + list [catch {file executable a b} msg] $msg +} {1 {wrong # args: should be "file executable name"}} +catch {exec chmod 000 dir.file} +if {$user != "root"} { + test cmdah-12.2 {Tcl_FileCmd: executable} {unixOnly} { + file executable gorp.file + } 0 +} +catch {exec chmod 775 gorp.file} +test cmdah-12.3 {Tcl_FileCmd: executable} {unixExecs} {file exe gorp.file} 1 +} + +# exists + +test cmdah-13.1 {Tcl_FileCmd: exists} { + list [catch {file exists a b} msg] $msg +} {1 {wrong # args: should be "file exists name"}} +catch {exec chmod 777 dir.file} +removeFile [file join dir.file gorp.file] +removeFile gorp.file +removeDirectory dir.file +removeFile link.file +test cmdah-13.2 {Tcl_FileCmd: exists} {file exists gorp.file} 0 +test cmdah-13.3 {Tcl_FileCmd: exists} { + file exists [file join dir.file gorp.file] +} 0 +catch { + makeFile abcde gorp.file + makeDirectory dir.file + makeFile 12345 [file join dir.file gorp.file] +} +test cmdah-13.4 {Tcl_FileCmd: exists} {unixExecs} {file exists gorp.file} 1 +test cmdah-13.5 {Tcl_FileCmd: exists} {unixExecs} { + file exi [file join dir.file gorp.file] +} 1 + +# The test below has to be done in /tmp rather than the current +# directory in order to guarantee (?) a local file system: some +# NFS file systems won't do the stuff below correctly. + +if {$tcl_platform(platform) == "unix"} { + removeFile /tmp/tcl.foo.dir/file + removeDirectory /tmp/tcl.foo.dir + makeDirectory /tmp/tcl.foo.dir + makeFile 12345 /tmp/tcl.foo.dir/file + exec chmod 000 /tmp/tcl.foo.dir + if {$user != "root"} { + test cmdah-13.3 {Tcl_FileCmd: exists} { + file exists /tmp/tcl.foo.dir/file + } 0 + } + exec chmod 775 /tmp/tcl.foo.dir + removeFile /tmp/tcl.foo.dir/file + removeDirectory /tmp/tcl.foo.dir +} + +# Stat related commands + +removeFile gorp.file +makeFile "Test string" gorp.file +catch {exec chmod 765 gorp.file} + +# atime + +test cmdah-14.1 {Tcl_FileCmd: atime} { + list [catch {file atime a b} msg] $msg +} {1 {wrong # args: should be "file atime name"}} +test cmdah-14.2 {Tcl_FileCmd: atime} { + catch {unset stat} + file stat gorp.file stat + list [expr {[file mtime gorp.file] == $stat(mtime)}] \ + [expr {[file atime gorp.file] == $stat(atime)}] +} {1 1} +test cmdah-12.1 {Tcl_FileCmd: atime} { + string tolower [list [catch {file atime _bogus_} msg] \ + $msg $errorCode] +} {1 {couldn't stat "_bogus_": no such file or directory} {posix enoent {no such file or directory}}} + +# isdirectory + +test cmdah-15.1 {Tcl_FileCmd: isdirectory} { + list [catch {file isdirectory a b} msg] $msg +} {1 {wrong # args: should be "file isdirectory name"}} +test cmdah-15.2 {Tcl_FileCmd: isdirectory} {file isdirectory gorp.file} 0 +test cmdah-15.3 {Tcl_FileCmd: isdirectory} {unixExecs} {file isd dir.file} 1 + +# isfile + +test cmdah-15.4 {Tcl_FileCmd: isfile} { + list [catch {file isfile a b} msg] $msg +} {1 {wrong # args: should be "file isfile name"}} +test cmdah-15.5 {Tcl_FileCmd: isfile} {file isfile gorp.file} 1 +test cmdah-15.6 {Tcl_FileCmd: isfile} {file isfile dir.file} 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} +test cmdah-16.1 {Tcl_FileCmd: lstat} {unixExecs} { + list [catch {file lstat a} msg] $msg +} {1 {wrong # args: should be "file lstat name varName"}} +test cmdah-16.2 {Tcl_FileCmd: lstat} {unixExecs} { + list [catch {file lstat a b c} msg] $msg +} {1 {wrong # args: should be "file lstat name varName"}} +test cmdah-16.3 {Tcl_FileCmd: lstat} {unixOnly nonPortable} { + catch {unset stat} + file lstat link.file stat + lsort [array names stat] +} {atime ctime dev gid ino mode mtime nlink size type uid} +test cmdah-16.4 {Tcl_FileCmd: lstat} {unixOnly nonPortable} { + catch {unset stat} + file lstat link.file stat + list $stat(nlink) [expr $stat(mode)&0777] $stat(type) +} {1 511 link} +test cmdah-16.5 {Tcl_FileCmd: lstat errors} {nonPortable} { + string tolower [list [catch {file lstat _bogus_ stat} msg] \ + $msg $errorCode] +} {1 {couldn't lstat "_bogus_": no such file or directory} {posix enoent {no such file or directory}}} +test cmdah-16.6 {Tcl_FileCmd: lstat errors} {unixExecs nonPortable} { + catch {unset x} + set x 44 + list [catch {file lstat gorp.file x} msg] $msg $errorCode +} {1 {can't set "x(dev)": variable isn't array} NONE} +catch {unset stat} + +# mtime + +test cmdah-17.1 {Tcl_FileCmd: mtime} { + list [catch {file mtime a b} msg] $msg +} {1 {wrong # args: should be "file mtime name"}} +test cmdah-17.2 {Tcl_FileCmd: mtime} {unixExecs} { + set old [file mtime gorp.file] + after 2000 + set f [open gorp.file w] + puts $f "More text" + close $f + set new [file mtime gorp.file] + expr {($new > $old) && ($new <= ($old+5))} +} {1} +test cmdah-17.3 {Tcl_FileCmd: mtime} {unixExecs} { + catch {unset stat} + file stat gorp.file stat + list [expr {[file mtime gorp.file] == $stat(mtime)}] \ + [expr {[file atime gorp.file] == $stat(atime)}] +} {1 1} +test cmdah-17.4 {Tcl_FileCmd: mtime} {unixExecs} { + string tolower [list [catch {file mtime _bogus_} msg] $msg \ + $errorCode] +} {1 {couldn't stat "_bogus_": no such file or directory} {posix enoent {no such file or directory}}} + +# owned + +test cmdah-18.1 {Tcl_FileCmd: owned} { + list [catch {file owned a b} msg] $msg +} {1 {wrong # args: should be "file owned name"}} +test cmdah-18.2 {Tcl_FileCmd: owned} {unixExecs} {file owned gorp.file} 1 +if {$user != "root"} { + test cmdah-18.3 {Tcl_FileCmd: owned} {unixOnly} {file owned /} 0 +} + +# readlink + +test cmdah-19.1 {Tcl_FileCmd: readlink} { + list [catch {file readlink a b} msg] $msg +} {1 {wrong # args: should be "file readlink name"}} +test cmdah-19.2 {Tcl_FileCmd: readlink} {unixOnly nonPortable} { + file readlink link.file +} gorp.file +test cmdah-19.3 {Tcl_FileCmd: readlink errors} {unixOnly nonPortable} { + list [catch {file readlink _bogus_} msg] [string tolower $msg] \ + [string tolower $errorCode] +} {1 {couldn't readlink "_bogus_": no such file or directory} {posix enoent {no such file or directory}}} +test cmdah-19.4 {Tcl_FileCmd: readlink errors} {macOrPc nonPortable} { + list [catch {file readlink _bogus_} msg] [string tolower $msg] \ + [string tolower $errorCode] +} {1 {couldn't readlink "_bogus_": invalid argument} {posix einval {invalid argument}}} + +# size + +test cmdah-20.1 {Tcl_FileCmd: size} { + list [catch {file size a b} msg] $msg +} {1 {wrong # args: should be "file size name"}} +test cmdah-20.2 {Tcl_FileCmd: size} { + set oldsize [file size gorp.file] + set f [open gorp.file a] + fconfigure $f -translation lf -eofchar {} + puts $f "More text" + close $f + expr {[file size gorp.file] - $oldsize} +} {10} +test cmdah-20.3 {Tcl_FileCmd: size} { + string tolower [list [catch {file size _bogus_} msg] $msg \ + $errorCode] +} {1 {couldn't stat "_bogus_": no such file or directory} {posix enoent {no such file or directory}}} + +# stat + +makeFile "Test string" gorp.file +catch {exec chmod 765 gorp.file} + +test cmdah-21.1 {Tcl_FileCmd: stat} { + list [catch {file stat _bogus_} msg] $msg $errorCode +} {1 {wrong # args: should be "file stat name varName"} NONE} +test cmdah-21.2 {Tcl_FileCmd: stat} { + list [catch {file stat _bogus_ a b} msg] $msg $errorCode +} {1 {wrong # args: should be "file stat name varName"} NONE} +test cmdah-21.3 {Tcl_FileCmd: stat} { + catch {unset stat} + file stat gorp.file stat + lsort [array names stat] +} {atime ctime dev gid ino mode mtime nlink size type uid} +test cmdah-21.4 {Tcl_FileCmd: stat} {unixOnly} { + catch {unset stat} + file stat gorp.file stat + list $stat(nlink) $stat(size) [expr $stat(mode)&0777] $stat(type) +} {1 12 501 file} +test cmdah-21.5 {Tcl_FileCmd: stat} { + string tolower [list [catch {file stat _bogus_ stat} msg] \ + $msg $errorCode] +} {1 {couldn't stat "_bogus_": no such file or directory} {posix enoent {no such file or directory}}} +test cmdah-21.6 {Tcl_FileCmd: stat} { + catch {unset x} + set x 44 + list [catch {file stat gorp.file x} msg] $msg $errorCode +} {1 {can't set "x(dev)": variable isn't array} NONE} +catch {unset stat} + +# type + +removeFile link.file + +test cmdah-22.1 {Tcl_FileCmd: type} { + list [catch {file size a b} msg] $msg +} {1 {wrong # args: should be "file size name"}} +test cmdah-22.2 {Tcl_FileCmd: type} {unixExecs} { + file type dir.file +} directory +test cmdah-22.3 {Tcl_FileCmd: type} { + file type gorp.file +} file +test cmdah-22.4 {Tcl_FileCmd: type} {unixOnly nonPortable} { + exec ln -s a/b/c link.file + set result [file type link.file] + removeFile link.file + set result +} link +test cmdah-22.5 {Tcl_FileCmd: type} { + string tolower [list [catch {file type _bogus_} msg] $msg $errorCode] +} {1 {couldn't stat "_bogus_": no such file or directory} {posix enoent {no such file or directory}}} + +# Error conditions + +test cmdah-23.1 {error conditions} { + list [catch {file gorp x} msg] $msg +} {1 {bad option "gorp": should be atime, dirname, executable, exists, extension, isdirectory, isfile, join, lstat, mtime, owned, pathtype, readable, readlink, root, size, split, stat, tail, type, or writable}} +test cmdah-23.2 {error conditions} { + list [catch {file ex x} msg] $msg +} {1 {bad option "ex": should be atime, dirname, executable, exists, extension, isdirectory, isfile, join, lstat, mtime, owned, pathtype, readable, readlink, root, size, split, stat, tail, type, or writable}} +test cmdah-23.3 {error conditions} { + list [catch {file is x} msg] $msg +} {1 {bad option "is": should be atime, dirname, executable, exists, extension, isdirectory, isfile, join, lstat, mtime, owned, pathtype, readable, readlink, root, size, split, stat, tail, type, or writable}} +test cmdah-23.4 {error conditions} { + list [catch {file n x} msg] $msg +} {1 {bad option "n": should be atime, dirname, executable, exists, extension, isdirectory, isfile, join, lstat, mtime, owned, pathtype, readable, readlink, root, size, split, stat, tail, type, or writable}} +test cmdah-23.5 {error conditions} { + list [catch {file read x} msg] $msg +} {1 {bad option "read": should be atime, dirname, executable, exists, extension, isdirectory, isfile, join, lstat, mtime, owned, pathtype, readable, readlink, root, size, split, stat, tail, type, or writable}} +test cmdah-23.6 {error conditions} { + list [catch {file s x} msg] $msg +} {1 {bad option "s": should be atime, dirname, executable, exists, extension, isdirectory, isfile, join, lstat, mtime, owned, pathtype, readable, readlink, root, size, split, stat, tail, type, or writable}} +test cmdah-23.7 {error conditions} { + list [catch {file t x} msg] $msg +} {1 {bad option "t": should be atime, dirname, executable, exists, extension, isdirectory, isfile, join, lstat, mtime, owned, pathtype, readable, readlink, root, size, split, stat, tail, type, or writable}} +test cmdah-23.8 {error conditions} { + list [catch {file dirname ~woohgy} msg] $msg +} {1 {user "woohgy" doesn't exist}} + +catch {exec chmod 777 dir.file} +removeFile dir.file/gorp.file +removeFile gorp.file +removeDirectory dir.file +removeFile link.file + +testsetplatform $platform +catch {unset platform} +concat "" diff --git a/contrib/tcl/tests/cmdInfo.test b/contrib/tcl/tests/cmdInfo.test new file mode 100644 index 0000000..3034929 --- /dev/null +++ b/contrib/tcl/tests/cmdInfo.test @@ -0,0 +1,74 @@ +# Commands covered: none +# +# This file contains a collection of tests for Tcl_GetCommandInfo, +# Tcl_SetCommandInfo, Tcl_CreateCommand, Tcl_DeleteCommand, and +# Tcl_NameOfCommand. Sourcing this file into Tcl runs the tests +# and generates output for errors. No output means no errors were +# found. +# +# Copyright (c) 1993 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: @(#) cmdinfo.test 1.5 96/04/05 15:28:12 + +if {[info commands testcmdinfo] == {}} { + puts "This application hasn't been compiled with the \"testcmdinfo\"" + puts "command, so I can't test Tcl_GetCommandInfo etc." + return +} + +if {[string compare test [info procs test]] == 1} then {source defs} + +test cmdinfo-1.1 {command procedure and clientData} { + testcmdinfo create x1 + testcmdinfo get x1 +} {CmdProc1 original CmdDelProc1 original} +test cmdinfo-1.2 {command procedure and clientData} { + testcmdinfo create x1 + x1 +} {CmdProc1 original} +test cmdinfo-1.3 {command procedure and clientData} { + testcmdinfo create x1 + testcmdinfo modify x1 + testcmdinfo get x1 +} {CmdProc2 new_command_data CmdDelProc2 new_delete_data} +test cmdinfo-1.4 {command procedure and clientData} { + testcmdinfo create x1 + testcmdinfo modify x1 + x1 +} {CmdProc2 new_command_data} + +test cmdinfo-2.1 {command deletion callbacks} { + testcmdinfo create x1 + testcmdinfo delete x1 +} {CmdDelProc1 original} +test cmdinfo-2.2 {command deletion callbacks} { + testcmdinfo create x1 + testcmdinfo modify x1 + testcmdinfo delete x1 +} {CmdDelProc2 new_delete_data} + +test cmdinfo-3.1 {Tcl_Get/SetCommandInfo return values} { + testcmdinfo get non_existent +} {??} +test cmdinfo-3.2 {Tcl_Get/SetCommandInfo return values} { + testcmdinfo create x1 + testcmdinfo modify x1 +} 1 +test cmdinfo-3.3 {Tcl_Get/SetCommandInfo return values} { + testcmdinfo modify non_existent +} 0 + +test cmdinfo-4.1 {Tcl_GetCommandName procedure} { + set x [testcmdtoken create x1] + rename x1 newName + set y [testcmdtoken name $x] + rename newName x1 + lappend y [testcmdtoken name $x] +} {newName x1} + +catch {rename x1 ""} +concat {} diff --git a/contrib/tcl/tests/concat.test b/contrib/tcl/tests/concat.test new file mode 100644 index 0000000..b86aeed --- /dev/null +++ b/contrib/tcl/tests/concat.test @@ -0,0 +1,39 @@ +# Commands covered: concat +# +# 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) 1991-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: @(#) concat.test 1.8 96/02/16 08:55:43 + +if {[string compare test [info procs test]] == 1} then {source defs} + +test concat-1.1 {simple concatenation} { + concat a b c d e f g +} {a b c d e f g} +test concat-1.2 {merging lists together} { + concat a {b c d} {e f g h} +} {a b c d e f g h} +test concat-1.3 {merge lists, retain sub-lists} { + concat a {b {c d}} {{e f}} g h +} {a b {c d} {e f} g h} +test concat-1.4 {special characters} { + concat a\{ {b \{c d} \{d +} "a{ b \\{c d {d" + +test concat-2.1 {error: no arguments} { + list [catch concat msg] $msg +} {0 {}} + +test concat-3.1 {pruning off extra white space} { + concat {} {a b c} +} {a b c} +test concat-3.2 {pruning off extra white space} { + concat x y " a b c \n\t " " " " def " +} {x y a b c def} diff --git a/contrib/tcl/tests/dcall.test b/contrib/tcl/tests/dcall.test new file mode 100644 index 0000000..c7ad1c6 --- /dev/null +++ b/contrib/tcl/tests/dcall.test @@ -0,0 +1,40 @@ +# Commands covered: none +# +# This file contains a collection of tests for Tcl_CallWhenDeleted. +# Sourcing this file into Tcl runs the tests and generates output for +# errors. No output means no errors were found. +# +# 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: @(#) dcall.test 1.6 96/02/16 08:55:44 + +if {[info commands testdcall] == {}} { + puts "This application hasn't been compiled with the \"testdcall\"" + puts "command, so I can't test Tcl_CallWhenDeleted." + return +} + +if {[string compare test [info procs test]] == 1} then {source defs} + +test dcall-1.1 {deletion callbacks} { + lsort -increasing [testdcall 1 2 3] +} {1 2 3} +test dcall-1.2 {deletion callbacks} { + testdcall +} {} +test dcall-1.3 {deletion callbacks} { + lsort -increasing [testdcall 20 21 22 -22] +} {20 21} +test dcall-1.4 {deletion callbacks} { + lsort -increasing [testdcall 20 21 22 -20] +} {21 22} +test dcall-1.5 {deletion callbacks} { + lsort -increasing [testdcall 20 21 22 -21] +} {20 22} +test dcall-1.6 {deletion callbacks} { + lsort -increasing [testdcall 20 21 22 -21 -22 -20] +} {} diff --git a/contrib/tcl/tests/defs b/contrib/tcl/tests/defs new file mode 100644 index 0000000..aaf6cfc --- /dev/null +++ b/contrib/tcl/tests/defs @@ -0,0 +1,346 @@ +# 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. +# +# SCCS: @(#) defs 1.37 96/04/12 13:45:04 + +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 {} +catch {set user [exec whoami]} +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." +} + +# 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. + +set doNonPortableTests [file exists doAllTests] + +# 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. +# 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. +# tempNotPc - The inverse of pcOnly. 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. + +catch {unset testConfig} +if {$tcl_platform(platform) == "unix"} { + set testConfig(unixOnly) 1 + set testConfig(tempNotPc) 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(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(nonPortable) [file exists doAllTests] + +set f [open defs r] +if {[expr [catch {fconfigure $f -blocking off}]] == 0} { + set testConfig(nonBlockFiles) 1 +} else { + set testConfig(nonBlockFiles) 0 +} +close $f + +# 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 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 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 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 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} + } +} + +proc print_verbose {name description script code answer} { + puts stdout "\n" + 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} { + # Empty body + } 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] + foreach constraint $constraints { + if {![info exists testConfig($constraint)] + || !$testConfig($constraint)} { + 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 $script \ + $code $result + } elseif {[string compare $result $answer] == 0} then { + if $VERBOSE then { + if {$VERBOSE > 0} { + print_verbose $name $description $script \ + $code $result + } + puts stdout "++++ $name PASSED" + } + } else { + print_verbose $name $description $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} { + global tcl_platform testConfig + if {$tcl_platform(platform) == "macintosh"} { + catch {rm -f $name} + } else { + catch {exec rm -f $name} + } +} + +proc makeDirectory {name} { + global tcl_platform testConfig + if {$tcl_platform(platform) == "macintosh"} { + catch {mkdir $name} + } else { + catch {exec mkdir $name} + } +} + +proc removeDirectory {name} { + global tcl_platform testConfig + if {$tcl_platform(platform) == "macintosh"} { + catch {rmdir $name} + } else { + catch {exec rm -rf $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 [list [info nameofexecutable]] +if {$tcltest == "{}"} { + set tcltest {} + puts "Unable to find tcltest executable, multiple process tests will fail." +} + + diff --git a/contrib/tcl/tests/dstring.test b/contrib/tcl/tests/dstring.test new file mode 100644 index 0000000..2ae157a --- /dev/null +++ b/contrib/tcl/tests/dstring.test @@ -0,0 +1,247 @@ +# Commands covered: none +# +# This file contains a collection of tests for Tcl's dynamic string +# library procedures. Sourcing this file into Tcl runs the tests and +# generates output for errors. No output means no errors were found. +# +# 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: @(#) dstring.test 1.8 96/02/16 08:55:46 + +if {[info commands testdstring] == {}} { + puts "This application hasn't been compiled with the \"testdstring\"" + puts "command, so I can't test Tcl_DStringAppend et al." + return +} + +if {[string compare test [info procs test]] == 1} then {source defs} + +test dstring-1.1 {appending and retrieving} { + testdstring free + testdstring append "abc" -1 + list [testdstring get] [testdstring length] +} {abc 3} +test dstring-1.2 {appending and retrieving} { + testdstring free + testdstring append "abc" -1 + testdstring append " xyzzy" 3 + testdstring append " 12345" -1 + list [testdstring get] [testdstring length] +} {{abc xy 12345} 12} +test dstring-1.3 {appending and retrieving} { + testdstring free + foreach l {a b c d e f g h i j k l m n o p} { + testdstring append $l$l$l$l$l$l$l$l$l$l$l$l$l$l$l$l$l$l$l$l$l\n -1 + } + list [testdstring get] [testdstring length] +} {{aaaaaaaaaaaaaaaaaaaaa +bbbbbbbbbbbbbbbbbbbbb +ccccccccccccccccccccc +ddddddddddddddddddddd +eeeeeeeeeeeeeeeeeeeee +fffffffffffffffffffff +ggggggggggggggggggggg +hhhhhhhhhhhhhhhhhhhhh +iiiiiiiiiiiiiiiiiiiii +jjjjjjjjjjjjjjjjjjjjj +kkkkkkkkkkkkkkkkkkkkk +lllllllllllllllllllll +mmmmmmmmmmmmmmmmmmmmm +nnnnnnnnnnnnnnnnnnnnn +ooooooooooooooooooooo +ppppppppppppppppppppp +} 352} + +test dstring-2.1 {appending list elements} { + testdstring free + testdstring element "abc" + testdstring element "d e f" + list [testdstring get] [testdstring length] +} {{abc {d e f}} 11} +test dstring-2.2 {appending list elements} { + testdstring free + testdstring element "x" + testdstring element "\{" + testdstring element "ab\}" + testdstring get +} {x \{ ab\}} +test dstring-2.3 {appending list elements} { + testdstring free + foreach l {a b c d e f g h i j k l m n o p} { + testdstring element $l$l$l$l$l$l$l$l$l$l$l$l$l$l$l$l$l$l$l$l$l + } + testdstring get +} {aaaaaaaaaaaaaaaaaaaaa bbbbbbbbbbbbbbbbbbbbb ccccccccccccccccccccc ddddddddddddddddddddd eeeeeeeeeeeeeeeeeeeee fffffffffffffffffffff ggggggggggggggggggggg hhhhhhhhhhhhhhhhhhhhh iiiiiiiiiiiiiiiiiiiii jjjjjjjjjjjjjjjjjjjjj kkkkkkkkkkkkkkkkkkkkk lllllllllllllllllllll mmmmmmmmmmmmmmmmmmmmm nnnnnnnnnnnnnnnnnnnnn ooooooooooooooooooooo ppppppppppppppppppppp} +test dstring-2.4 {appending list elements} { + testdstring free + testdstring append "a\{" -1 + testdstring element abc + testdstring append " \{" -1 + testdstring element xyzzy + testdstring get +} "a{ abc {xyzzy" +test dstring-2.5 {appending list elements} { + testdstring free + testdstring append " \{" -1 + testdstring element abc + testdstring get +} " {abc" +test dstring-2.6 {appending list elements} { + testdstring free + testdstring append " " -1 + testdstring element abc + testdstring get +} { abc} +test dstring-2.7 {appending list elements} { + testdstring free + testdstring append "\\ " -1 + testdstring element abc + testdstring get +} "\\ abc" +test dstring-2.8 {appending list elements} { + testdstring free + testdstring append "x " -1 + testdstring element abc + testdstring get +} {x abc} + +test dstring-3.1 {nested sublists} { + testdstring free + testdstring start + testdstring element foo + testdstring element bar + testdstring end + testdstring element another + testdstring get +} {{foo bar} another} +test dstring-3.2 {nested sublists} { + testdstring free + testdstring start + testdstring start + testdstring element abc + testdstring element def + testdstring end + testdstring end + testdstring element ghi + testdstring get +} {{{abc def}} ghi} +test dstring-3.3 {nested sublists} { + testdstring free + testdstring start + testdstring start + testdstring start + testdstring element foo + testdstring element foo2 + testdstring end + testdstring end + testdstring element foo3 + testdstring end + testdstring element foo4 + testdstring get +} {{{{foo foo2}} foo3} foo4} +test dstring-3.4 {nested sublists} { + testdstring free + testdstring element before + testdstring start + testdstring element during + testdstring element more + testdstring end + testdstring element last + testdstring get +} {before {during more} last} +test dstring-3.4 {nested sublists} { + testdstring free + testdstring element "\{" + testdstring start + testdstring element first + testdstring element second + testdstring end + testdstring get +} {\{ {first second}} + +test dstring-4.1 {truncation} { + testdstring free + testdstring append "abcdefg" -1 + testdstring trunc 3 + list [testdstring get] [testdstring length] +} {abc 3} +test dstring-4.2 {truncation} { + testdstring free + testdstring append "xyzzy" -1 + testdstring trunc 0 + list [testdstring get] [testdstring length] +} {{} 0} + +test dstring-5.1 {copying to result} { + testdstring free + testdstring append xyz -1 + testdstring result +} xyz +test dstring-5.2 {copying to result} { + testdstring free + foreach l {a b c d e f g h i j k l m n o p} { + testdstring append $l$l$l$l$l$l$l$l$l$l$l$l$l$l$l$l$l$l$l$l$l\n -1 + } + set a [testdstring result] + testdstring append abc -1 + list $a [testdstring get] +} {{aaaaaaaaaaaaaaaaaaaaa +bbbbbbbbbbbbbbbbbbbbb +ccccccccccccccccccccc +ddddddddddddddddddddd +eeeeeeeeeeeeeeeeeeeee +fffffffffffffffffffff +ggggggggggggggggggggg +hhhhhhhhhhhhhhhhhhhhh +iiiiiiiiiiiiiiiiiiiii +jjjjjjjjjjjjjjjjjjjjj +kkkkkkkkkkkkkkkkkkkkk +lllllllllllllllllllll +mmmmmmmmmmmmmmmmmmmmm +nnnnnnnnnnnnnnnnnnnnn +ooooooooooooooooooooo +ppppppppppppppppppppp +} abc} + +test dstring-6.1 {Tcl_DStringGetResult} { + testdstring free + list [testdstring gresult staticsmall] [testdstring get] +} {{} short} +test dstring-6.2 {Tcl_DStringGetResult} { + testdstring free + foreach l {a b c d e f g h i j k l m n o p} { + testdstring append $l$l$l$l$l$l$l$l$l$l$l$l$l$l$l$l$l$l$l$l$l\n -1 + } + list [testdstring gresult staticsmall] [testdstring get] +} {{} short} +test dstring-6.3 {Tcl_DStringGetResult} { + set result {} + lappend result [testdstring gresult staticlarge] + testdstring append x 1 + lappend result [testdstring get] +} {{} {first0 first1 first2 first3 first4 first5 first6 first7 first8 first9 +second0 second1 second2 second3 second4 second5 second6 second7 second8 second9 +third0 third1 third2 third3 third4 third5 third6 third7 third8 third9 +fourth0 fourth1 fourth2 fourth3 fourth4 fourth5 fourth6 fourth7 fourth8 fourth9 +fifth0 fifth1 fifth2 fifth3 fifth4 fifth5 fifth6 fifth7 fifth8 fifth9 +sixth0 sixth1 sixth2 sixth3 sixth4 sixth5 sixth6 sixth7 sixth8 sixth9 +seventh0 seventh1 seventh2 seventh3 seventh4 seventh5 seventh6 seventh7 seventh8 seventh9 +x}} +test dstring-6.4 {Tcl_DStringGetResult} { + set result {} + lappend result [testdstring gresult free] + testdstring append y 1 + lappend result [testdstring get] +} {{} {This is a malloc-ed stringy}} +test dstring-6.5 {Tcl_DStringGetResult} { + set result {} + lappend result [testdstring gresult special] + testdstring append z 1 + lappend result [testdstring get] +} {{} {This is a specially-allocated stringz}} + +testdstring free diff --git a/contrib/tcl/tests/env.test b/contrib/tcl/tests/env.test new file mode 100644 index 0000000..22f1284 --- /dev/null +++ b/contrib/tcl/tests/env.test @@ -0,0 +1,108 @@ +# Commands covered: none (tests environment variable implementation) +# +# 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) 1991-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: @(#) env.test 1.9 96/02/16 08:55:47 + +if {[string compare test [info procs test]] == 1} then {source defs} + +# If there is no "printenv" program on this system, then it's just too +# much trouble to run this test (can't necessarily run csh to get the +# environment: on some systems it barfs if there isn't a minimum set +# predefined environment variables. Also, printenv returns a non-zero +# status on some systems, so read the environment using a procedure +# that catches errors. + +set printenv {} +if [info exists env(PATH)] { + set dirs [split $env(PATH) :] +} else { + set dirs {/bin /usr/bin /usr/ucb /usr/local /usr/public /usr/etc} +} +foreach i $dirs { + if [file executable $i/printenv] { + # The following hack is needed because of weirdness with + # environment variables in symbolic lines on Apollos (?!#?). + if ![catch {exec sh -c "cd $i; pwd"} x] { + set printenv $x/printenv + } else { + set printenv $i/printenv + } + break + } +} +if {$printenv == ""} { + puts stdout "Skipping env tests: need \"printenv\" to read environment." + return "" +} +proc getenv {} { + global printenv + catch {exec $printenv} out + if {$out == "child process exited abnormally"} { + set out {} + } + return $out +} + +# Save the current environment variables at the start of the test. + +foreach name [array names env] { + set env2($name) $env($name) + unset env($name) +} + +test env-1.1 {adding environment variables} { + getenv +} {} + +set env(NAME1) "test string" +test env-1.2 {adding environment variables} { + getenv +} {NAME1=test string} + +set env(NAME2) "more" +test env-1.3 {adding environment variables} { + getenv +} {NAME1=test string +NAME2=more} + +set env(XYZZY) "garbage" +test env-1.4 {adding environment variables} { + getenv +} {NAME1=test string +NAME2=more +XYZZY=garbage} + +set env(NAME2) "new value" +test env-2.1 {changing environment variables} { + getenv +} {NAME1=test string +NAME2=new value +XYZZY=garbage} + +unset env(NAME2) +test env-3.1 {unsetting environment variables} { + getenv +} {NAME1=test string +XYZZY=garbage} +unset env(NAME1) +test env-3.2 {unsetting environment variables} { + getenv +} {XYZZY=garbage} + +# Restore the environment variables at the end of the test. + +foreach name [array names env] { + unset env($name) +} +foreach name [array names env2] { + set env($name) $env2($name) +} diff --git a/contrib/tcl/tests/error.test b/contrib/tcl/tests/error.test new file mode 100644 index 0000000..9adbe05 --- /dev/null +++ b/contrib/tcl/tests/error.test @@ -0,0 +1,171 @@ +# Commands covered: error, catch +# +# 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) 1991-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: @(#) error.test 1.14 96/02/16 08:55:48 + +if {[string compare test [info procs test]] == 1} then {source defs} + +proc foo {} { + global errorInfo + set a [catch {format [error glorp2]} b] + error {Human-generated} +} + +proc foo2 {} { + global errorInfo + set a [catch {format [error glorp2]} b] + error {Human-generated} $errorInfo +} + +# Catch errors occurring in commands and errors from "error" command + +test error-1.1 {simple errors from commands} { + catch {format [string compare]} b +} 1 + +test error-1.2 {simple errors from commands} { + catch {format [string compare]} b + set b +} {wrong # args: should be "string compare string1 string2"} + +test error-1.3 {simple errors from commands} { + catch {format [string compare]} b + set errorInfo +} {wrong # args: should be "string compare string1 string2" + while executing +"string compare" + invoked from within +"format [string compare]..."} + +test error-1.4 {simple errors from commands} { + catch {error glorp} b +} 1 + +test error-1.5 {simple errors from commands} { + catch {error glorp} b + set b +} glorp + +test error-1.6 {simple errors from commands} { + catch {catch a b c} b +} 1 + +test error-1.7 {simple errors from commands} { + catch {catch a b c} b + set b +} {wrong # args: should be "catch command ?varName?"} + +test error-2.1 {simple errors from commands} { + catch catch +} 1 + +# Check errors nested in procedures. Also check the optional argument +# to "error" to generate a new error trace. + +test error-2.1 {errors in nested procedures} { + catch foo b +} 1 + +test error-2.2 {errors in nested procedures} { + catch foo b + set b +} {Human-generated} + +test error-2.3 {errors in nested procedures} { + catch foo b + set errorInfo +} {Human-generated + while executing +"error {Human-generated}" + (procedure "foo" line 4) + invoked from within +"foo"} + +test error-2.4 {errors in nested procedures} { + catch foo2 b +} 1 + +test error-2.5 {errors in nested procedures} { + catch foo2 b + set b +} {Human-generated} + +test error-2.6 {errors in nested procedures} { + catch foo2 b + set errorInfo +} {glorp2 + while executing +"error glorp2" + invoked from within +"format [error glorp2]..." + (procedure "foo2" line 1) + invoked from within +"foo2"} + +# Error conditions related to "catch". + +test error-3.1 {errors in catch command} { + list [catch {catch} msg] $msg +} {1 {wrong # args: should be "catch command ?varName?"}} +test error-3.2 {errors in catch command} { + list [catch {catch a b c} msg] $msg +} {1 {wrong # args: should be "catch command ?varName?"}} +test error-3.3 {errors in catch command} { + catch {unset a} + set a(0) 22 + list [catch {catch {format 44} a} msg] $msg +} {1 {couldn't save command result in variable}} +catch {unset a} + +# More tests related to errorInfo and errorCode + +test error-4.1 {errorInfo and errorCode variables} { + list [catch {error msg1 msg2 msg3} msg] $msg $errorInfo $errorCode +} {1 msg1 msg2 msg3} +test error-4.2 {errorInfo and errorCode variables} { + list [catch {error msg1 {} msg3} msg] $msg $errorInfo $errorCode +} {1 msg1 {msg1 + while executing +"error msg1 {} msg3"} msg3} +test error-4.3 {errorInfo and errorCode variables} { + list [catch {error msg1 {}} msg] $msg $errorInfo $errorCode +} {1 msg1 {msg1 + while executing +"error msg1 {}"} NONE} +test error-4.4 {errorInfo and errorCode variables} { + set errorCode bogus + list [catch {error msg1} msg] $msg $errorInfo $errorCode +} {1 msg1 {msg1 + while executing +"error msg1"} NONE} +test error-4.5 {errorInfo and errorCode variables} { + set errorCode bogus + list [catch {error msg1 msg2 {}} msg] $msg $errorInfo $errorCode +} {1 msg1 msg2 {}} + +# Errors in error command itself + +test error-5.1 {errors in error command} { + list [catch {error} msg] $msg +} {1 {wrong # args: should be "error message ?errorInfo? ?errorCode?"}} +test error-5.2 {errors in error command} { + list [catch {error a b c d} msg] $msg +} {1 {wrong # args: should be "error message ?errorInfo? ?errorCode?"}} + +# Make sure that catch resets error information + +test error-6.1 {catch must reset error state} { + catch {error outer [catch {error inner inner.errorInfo inner.errorCode}]} + list $errorCode $errorInfo +} {NONE 1} + +return "" diff --git a/contrib/tcl/tests/eval.test b/contrib/tcl/tests/eval.test new file mode 100644 index 0000000..dcd2ea8 --- /dev/null +++ b/contrib/tcl/tests/eval.test @@ -0,0 +1,55 @@ +# Commands covered: eval +# +# 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) 1991-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: @(#) eval.test 1.7 96/02/16 08:55:49 + +if {[string compare test [info procs test]] == 1} then {source defs} + +test eval-1.1 {single argument} { + eval {format 22} +} 22 +test eval-1.2 {multiple arguments} { + set a {$b} + set b xyzzy + eval format $a +} xyzzy +test eval-1.3 {single argument} { + eval concat a b c d e f g +} {a b c d e f g} + +test eval-2.1 {error: not enough arguments} {catch eval} 1 +test eval-2.2 {error: not enough arguments} { + catch eval msg + set msg +} {wrong # args: should be "eval arg ?arg ...?"} +test eval-2.3 {error in eval'ed command} { + catch {eval {error "test error"}} +} 1 +test eval-2.4 {error in eval'ed command} { + catch {eval {error "test error"}} msg + set msg +} {test error} +test eval-2.5 {error in eval'ed command: setting errorInfo} { + catch {eval { + set a 1 + error "test error" + }} msg + set errorInfo +} "test error + while executing +\"error \"test error\"\" + (\"eval\" body line 3) + invoked from within +\"eval { + set a 1 + error \"test error\" + }\"" diff --git a/contrib/tcl/tests/event.test b/contrib/tcl/tests/event.test new file mode 100644 index 0000000..b48ee22 --- /dev/null +++ b/contrib/tcl/tests/event.test @@ -0,0 +1,927 @@ +# This file contains a collection of tests for the procedures in the file +# tclEvent.c, which includes the "after", "update", and "vwait" Tcl +# commands. Sourcing this file into Tcl runs the tests and generates +# output for errors. No output means no errors were found. +# +# Copyright (c) 1995-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. +# +# "@(#) event.test 1.20 96/04/09 15:54:05" + +if {[string compare test [info procs test]] == 1} then {source defs} + +if {[catch {testfilehandler create 0 off off}] == 0 } { + test event-1.1 {Tcl_CreateFileHandler, reading} { + testfilehandler close + testfilehandler create 0 readable off + testfilehandler clear 0 + testfilehandler oneevent + set result "" + lappend result [testfilehandler counts 0] + testfilehandler fillpartial 0 + testfilehandler oneevent + lappend result [testfilehandler counts 0] + testfilehandler oneevent + lappend result [testfilehandler counts 0] + testfilehandler close + set result + } {{0 0} {1 0} {2 0}} + test event-1.2 {Tcl_CreateFileHandler, writing} {nonPortable} { + # This test is non-portable because on some systems (e.g. + # SunOS 4.1.3) pipes seem to be writable always. + testfilehandler close + testfilehandler create 0 off writable + testfilehandler clear 0 + testfilehandler oneevent + set result "" + lappend result [testfilehandler counts 0] + testfilehandler fillpartial 0 + testfilehandler oneevent + lappend result [testfilehandler counts 0] + testfilehandler fill 0 + testfilehandler oneevent + lappend result [testfilehandler counts 0] + testfilehandler close + set result + } {{0 1} {0 2} {0 2}} + test event-1.3 {Tcl_DeleteFileHandler} { + testfilehandler close + testfilehandler create 2 disabled disabled + testfilehandler create 1 readable writable + testfilehandler create 0 disabled disabled + testfilehandler fillpartial 1 + set result "" + testfilehandler oneevent + lappend result [testfilehandler counts 1] + testfilehandler oneevent + lappend result [testfilehandler counts 1] + testfilehandler oneevent + lappend result [testfilehandler counts 1] + testfilehandler create 1 off off + testfilehandler oneevent + lappend result [testfilehandler counts 1] + testfilehandler close + set result + } {{0 1} {1 1} {1 2} {0 0}} + + test event-2.1 {Tcl_DeleteFileHandler} { + testfilehandler close + testfilehandler create 2 disabled disabled + testfilehandler create 1 readable writable + testfilehandler fillpartial 1 + set result "" + testfilehandler oneevent + lappend result [testfilehandler counts 1] + testfilehandler oneevent + lappend result [testfilehandler counts 1] + testfilehandler oneevent + lappend result [testfilehandler counts 1] + testfilehandler create 1 off off + testfilehandler oneevent + lappend result [testfilehandler counts 1] + testfilehandler close + set result + } {{0 1} {1 1} {1 2} {0 0}} + test event-2.2 {Tcl_DeleteFileHandler, fd reused & events still pending} { + testfilehandler close + testfilehandler create 0 readable writable + testfilehandler fillpartial 0 + set result "" + testfilehandler oneevent + lappend result [testfilehandler counts 0] + testfilehandler close + testfilehandler create 0 readable writable + testfilehandler oneevent + lappend result [testfilehandler counts 0] + testfilehandler close + set result + } {{0 1} {0 0}} + + test event-3.1 {FileHandlerCheckProc, TCL_FILE_EVENTS off } { + testfilehandler close + testfilehandler create 1 readable writable + testfilehandler fillpartial 1 + testfilehandler windowevent + set result [testfilehandler counts 1] + testfilehandler close + set result + } {0 0} + + test event-4.1 {FileHandlerEventProc, race between event and disabling } { + testfilehandler close + testfilehandler create 2 disabled disabled + testfilehandler create 1 readable writable + testfilehandler fillpartial 1 + set result "" + testfilehandler oneevent + lappend result [testfilehandler counts 1] + testfilehandler oneevent + lappend result [testfilehandler counts 1] + testfilehandler oneevent + lappend result [testfilehandler counts 1] + testfilehandler create 1 disabled disabled + testfilehandler oneevent + lappend result [testfilehandler counts 1] + testfilehandler close + set result + } {{0 1} {1 1} {1 2} {0 0}} + test event-4.2 {FileHandlerEventProc, TCL_FILE_EVENTS off } { + testfilehandler close + testfilehandler create 1 readable writable + testfilehandler create 2 readable writable + testfilehandler fillpartial 1 + testfilehandler fillpartial 2 + testfilehandler oneevent + set result "" + lappend result [testfilehandler counts 1] [testfilehandler counts 2] + testfilehandler windowevent + lappend result [testfilehandler counts 1] [testfilehandler counts 2] + testfilehandler close + set result + } {{0 0} {0 1} {0 0} {0 1}} + testfilehandler close + update +} + +test event-5.1 {Tcl_CreateTimerHandler procedure} { + foreach i [after info] { + after cancel $i + } + set x "" + foreach i {100 200 1000 50 150} { + after $i lappend x $i + } + after 200 + update + set x +} {50 100 150 200} + +test event-6.1 {Tcl_DeleteTimerHandler procedure} { + foreach i [after info] { + after cancel $i + } + set x "" + foreach i {100 200 300 50 150} { + after $i lappend x $i + } + after cancel lappend x 150 + after cancel lappend x 50 + after 200 + update + set x +} {100 200} + +if {[info commands testmodal] != ""} { + test event-7.1 {Tcl_CreateModalTimeout and Tcl_DeleteModalTimeout procedures} { + update + set x {} + set result {} + testmodal create 50 first + testmodal create 200 second + after 100 + testmodal eventnotimers + lappend result $x + after 150 + testmodal eventnotimers + lappend result $x + testmodal delete + testmodal eventnotimers + lappend result $x + testmodal eventnotimers + lappend result $x + testmodal delete + testmodal eventnotimers + lappend result $x + } {{} second {second first} {second first first} {second first first}} + + test event-8.1 {TimerHandlerSetupProc procedure, choosing correct timer} { + update + set x {} + after 100 {lappend x normal} + testmodal create 200 modal + vwait x + testmodal delete + set x + } {normal} + test event-8.2 {TimerHandlerSetupProc procedure, choosing correct timer} { + update + set x {} + after 200 {lappend x normal} + testmodal create 100 modal + vwait x + testmodal delete + set x + } {modal} +} + +# No tests for TimerHandlerCheckProc: it's already tested by other tests +# above and below. + +test event-9.1 {TimerHandlerEventProc procedure} { + foreach i [after info] { + after cancel $i + } + foreach i {100 200 300} { + after $i lappend x $i + } + after 100 + set result "" + set x "" + update + lappend result $x + after 100 + update + lappend result $x + after 100 + update + lappend result $x +} {100 {100 200} {100 200 300}} + +# No tests for Tcl_DoWhenIdle: it's already tested by other tests +# below. + +test event-10.1 {Tk_CancelIdleCall procedure} { + foreach i [after info] { + after cancel $i + } + set x before + set y before + set z before + after idle set x after1 + after idle set y after2 + after idle set z after3 + after cancel set y after2 + update idletasks + concat $x $y $z +} {after1 before after3} +test event-10.2 {Tk_CancelIdleCall procedure} { + foreach i [after info] { + after cancel $i + } + set x before + set y before + set z before + after idle set x after1 + after idle set y after2 + after idle set z after3 + after cancel set x after1 + update idletasks + concat $x $y $z +} {before after2 after3} + +test event-11.1 {Tcl_ServiceIdle, self-rescheduling handlers} { + foreach i [after info] { + after cancel $i + } + set x 1 + set y 23 + after idle {incr x; after idle {incr x; after idle {incr x}}} + after idle {incr y} + vwait x + set result "$x $y" + update idletasks + lappend result $x +} {2 24 4} + +test event-12.1 {Tcl_BackgroundError, HandleBgErrors procedures} { + catch {rename bgerror {}} + proc bgerror msg { + global errorInfo errorCode x + lappend x [list $msg $errorInfo $errorCode] + } + after idle {error "a simple error"} + after idle {open non_existent} + after idle {set errorInfo foobar; set errorCode xyzzy} + set x {} + update idletasks + rename bgerror {} + set x +} {{{a simple error} {a simple error + while executing +"error "a simple error"" + ("after" script)} NONE} {{couldn't open "non_existent": no such file or directory} {couldn't open "non_existent": no such file or directory + while executing +"open non_existent" + ("after" script)} {POSIX ENOENT {no such file or directory}}}} +test event-12.2 {Tcl_BackgroundError, HandleBgErrors procedures} { + catch {rename bgerror {}} + proc bgerror msg { + global x + lappend x $msg + return -code break + } + after idle {error "a simple error"} + after idle {open non_existent} + set x {} + update idletasks + rename bgerror {} + set x +} {{a simple error}} + +test event-13.1 {BgErrorDeleteProc procedure} { + catch {interp delete foo} + interp create foo + foo eval { + proc bgerror args { + global errorInfo + set f [open err.out 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 result [read $f] + close $f + removeFile err.out + set result +} {Unmodified +} + +test event-14.1 {tkerror/bgerror backwards compabitility} { + catch {rename bgerror {}} + proc tkerror {x y} { + return [expr $x + $y] + } + list [tkerror 4 7] [bgerror 8 -3] +} {11 5} +test event-14.2 {tkerror/bgerror backwards compabitility} { + proc bgerror {x y} { + return [expr 1 + $x + $y] + } + list [tkerror 6 -2] [bgerror 7 2] +} {5 10} +test event-14.3 {tkerror/bgerror backwards compabitility} { + proc bgerror {x y} { + return [expr 1 + $x + $y] + } + set result [list [info commands bgerror] [info commands tkerror]] + rename tkerror {} + lappend result [info commands bgerror] [info commands tkerror] +} {bgerror tkerror {} {}} +test event-14.4 {tkerror/bgerror backwards compabitility} { + proc tkerror {x y} { + return [expr 1 + $x + $y] + } + set result [list [info commands bgerror] [info commands tkerror]] + rename bgerror {} + lappend result [info commands bgerror] [info commands tkerror] +} {bgerror tkerror {} {}} +test event-14.5 {tkerror/bgerror backwards compabitility} { + proc tkerror {x y} { + return [expr 1 + $x + $y] + } + rename tkerror foo + list [info commands bgerror] [info commands tkerror] [foo 4 3] +} {{} {} 8} +test event-14.6 {tkerror/bgerror backwards compabitility} { + proc bgerror {x y} { + return [expr 1 + $x + $y] + } + catch {rename foo {}} + rename bgerror foo + list [info commands bgerror] [info commands tkerror] [foo 4 3] +} {{} {} 8} +test event-14.7 {tkerror/bgerror backwards compabitility} { + proc foo args {return $args} + catch {rename tkerror {}} + rename foo tkerror + list [info commands bgerror] [info commands tkerror] [info commands foo] [tkerror a b c d] +} {bgerror tkerror {} {a b c d}} +test event-14.8 {tkerror/bgerror backwards compabitility} { + proc foo args {return $args} + catch {rename bgerror {}} + rename foo bgerror + list [info commands bgerror] [info commands tkerror] [info commands foo] [tkerror a b c d] +} {bgerror tkerror {} {a b c d}} +test event-14.9 {tkerror/bgerror backwards compabitility} { + proc bgerror args {return $args} + list [catch {rename bgerror tkerror} msg] $msg +} {1 {can't rename to "tkerror": command already exists}} +rename bgerror {} + +if {[info commands testexithandler] != ""} { + test event-15.1 {Tcl_CreateExitHandler procedure} {unixOrPc} { + set child [open |[list [info nameofexecutable]] r+] + puts $child "testexithandler create 41; testexithandler create 4" + puts $child "testexithandler create 6; exit" + flush $child + set result [read $child] + close $child + set result + } {even 6 +even 4 +odd 41 +} + + test event-16.1 {Tcl_DeleteExitHandler procedure} {unixOrPc} { + set child [open |[list [info nameofexecutable]] r+] + puts $child "testexithandler create 41; testexithandler create 4" + puts $child "testexithandler create 6; testexithandler delete 41" + puts $child "testexithandler create 16; exit" + flush $child + set result [read $child] + close $child + set result + } {even 16 +even 6 +even 4 +} + test event-16.2 {Tcl_DeleteExitHandler procedure} {unixOrPc} { + set child [open |[list [info nameofexecutable]] r+] + puts $child "testexithandler create 41; testexithandler create 4" + puts $child "testexithandler create 6; testexithandler delete 4" + puts $child "testexithandler create 16; exit" + flush $child + set result [read $child] + close $child + set result + } {even 16 +even 6 +odd 41 +} + test event-16.3 {Tcl_DeleteExitHandler procedure} {unixOrPc} { + set child [open |[list [info nameofexecutable]] r+] + puts $child "testexithandler create 41; testexithandler create 4" + puts $child "testexithandler create 6; testexithandler delete 6" + puts $child "testexithandler create 16; exit" + flush $child + set result [read $child] + close $child + set result + } {even 16 +even 4 +odd 41 +} + test event-16.4 {Tcl_DeleteExitHandler procedure} {unixOrPc} { + set child [open |[list [info nameofexecutable]] r+] + puts $child "testexithandler create 41; testexithandler delete 41" + puts $child "testexithandler create 16; exit" + flush $child + set result [read $child] + close $child + set result + } {even 16 +} +} + +test event-17.1 {Tcl_Exit procedure} {unixOrPc} { + set child [open |[list [info nameofexecutable]] r+] + puts $child "exit 3" + list [catch {close $child} msg] $msg [lindex $errorCode 0] \ + [lindex $errorCode 2] +} {1 {child process exited abnormally} CHILDSTATUS 3} + +test event-18.1 {Tcl_AfterCmd procedure, basics} { + list [catch {after} msg] $msg +} {1 {wrong # args: should be "after option ?arg arg ...?"}} +test event-18.2 {Tcl_AfterCmd procedure, basics} { + list [catch {after 2x} msg] $msg +} {1 {expected integer but got "2x"}} +test event-18.3 {Tcl_AfterCmd procedure, basics} { + list [catch {after gorp} msg] $msg +} {1 {bad argument "gorp": must be cancel, idle, info, or a number}} +test event-18.4 {Tcl_AfterCmd procedure, ms argument} { + set x before + after 400 {set x after} + after 200 + update + set y $x + after 400 + update + list $y $x +} {before after} +test event-18.5 {Tcl_AfterCmd procedure, ms argument} { + set x before + after 300 set x after + after 200 + update + set y $x + after 200 + update + list $y $x +} {before after} +test event-18.6 {Tcl_AfterCmd procedure, cancel option} { + list [catch {after cancel} msg] $msg +} {1 {wrong # args: should be "after cancel id|command"}} +test event-18.7 {Tcl_AfterCmd procedure, cancel option} { + after cancel after#1 +} {} +test event-18.8 {Tcl_AfterCmd procedure, cancel option} { + after cancel {foo bar} +} {} +test event-18.9 {Tcl_AfterCmd procedure, cancel option} { + foreach i [after info] { + after cancel $i + } + set x before + set y [after 100 set x after] + after cancel $y + after 200 + update + set x +} {before} +test event-18.10 {Tcl_AfterCmd procedure, cancel option} { + foreach i [after info] { + after cancel $i + } + set x before + after 100 set x after + after cancel {set x after} + after 200 + update + set x +} {before} +test event-18.11 {Tcl_AfterCmd procedure, cancel option} { + foreach i [after info] { + after cancel $i + } + set x before + after 100 set x after + set id [after 300 set x after] + after cancel $id + after 200 + update + set y $x + set x cleared + after 200 + update + list $y $x +} {after cleared} +test event-18.12 {Tcl_AfterCmd procedure, cancel option} { + foreach i [after info] { + after cancel $i + } + set x first + after idle lappend x second + after idle lappend x third + set i [after idle lappend x fourth] + after cancel {lappend x second} + after cancel $i + update idletasks + set x +} {first third} +test event-18.13 {Tcl_AfterCmd procedure, cancel option, multiple arguments for command} { + foreach i [after info] { + after cancel $i + } + set x first + after idle lappend x second + after idle lappend x third + set i [after idle lappend x fourth] + after cancel lappend x second + after cancel $i + update idletasks + set x +} {first third} +test event-18.14 {Tcl_AfterCmd procedure, cancel option, cancel during handler, used to dump core} { + foreach i [after info] { + after cancel $i + } + set id [ + after 100 { + set x done + after cancel $id + } + ] + vwait x +} {} +test event-18.15 {Tcl_AfterCmd procedure, cancel option, multiple interps} { + foreach i [after info] { + after cancel $i + } + interp create x + x eval {set a before; set b before; after idle {set a a-after}; + after idle {set b b-after}} + set result [llength [x eval after info]] + lappend result [llength [after info]] + after cancel {set b b-after} + set a aaa + set b bbb + x eval {after cancel set a a-after} + update idletasks + lappend result $a $b [x eval {list $a $b}] + interp delete x + set result +} {2 0 aaa bbb {before b-after}} +test event-18.16 {Tcl_AfterCmd procedure, idle option} { + list [catch {after idle} msg] $msg +} {1 {wrong # args: should be "after idle script script ..."}} +test event-18.17 {Tcl_AfterCmd procedure, idle option} { + set x before + after idle {set x after} + set y $x + update idletasks + list $y $x +} {before after} +test event-18.18 {Tcl_AfterCmd procedure, idle option} { + set x before + after idle set x after + set y $x + update idletasks + list $y $x +} {before after} +set event1 [after idle event 1] +set event2 [after 1000 event 2] +interp create x +set childEvent [x eval {after idle event in child}] +test event-18.19 {Tcl_AfterCmd, info option} { + lsort [after info] +} "$event1 $event2" +test event-18.20 {Tcl_AfterCmd, info option} { + list [catch {after info a b} msg] $msg +} {1 {wrong # args: should be "after info ?id?"}} +test event-18.21 {Tcl_AfterCmd, info option} { + list [catch {after info $childEvent} msg] $msg +} "1 {event \"$childEvent\" doesn't exist}" +test event-18.22 {Tcl_AfterCmd, info option} { + list [after info $event1] [after info $event2] +} {{{event 1} idle} {{event 2} timer}} +after cancel $event1 +after cancel $event2 +interp delete x + +set event [after idle foo bar] +scan $event after#%d id +test event-19.1 {GetAfterEvent procedure} { + list [catch {after info xfter#$id} msg] $msg +} "1 {event \"xfter#$id\" doesn't exist}" +test event-19.2 {GetAfterEvent procedure} { + list [catch {after info afterx$id} msg] $msg +} "1 {event \"afterx$id\" doesn't exist}" +test event-19.3 {GetAfterEvent procedure} { + list [catch {after info after#ab} msg] $msg +} {1 {event "after#ab" doesn't exist}} +test event-19.4 {GetAfterEvent procedure} { + list [catch {after info after#} msg] $msg +} {1 {event "after#" doesn't exist}} +test event-19.5 {GetAfterEvent procedure} { + list [catch {after info after#${id}x} msg] $msg +} "1 {event \"after#${id}x\" doesn't exist}" +test event-19.6 {GetAfterEvent procedure} { + list [catch {after info afterx[expr $id+1]} msg] $msg +} "1 {event \"afterx[expr $id+1]\" doesn't exist}" +after cancel $event + +test event-20.1 {AfterProc procedure} { + set x before + proc foo {} { + set x untouched + after 100 {set x after} + after 200 + update + return $x + } + list [foo] $x +} {untouched after} +test event-20.2 {AfterProc procedure} { + catch {rename bgerror {}} + proc bgerror msg { + global x errorInfo + set x [list $msg $errorInfo] + } + set x empty + after 100 {error "After error"} + after 200 + set y $x + update + catch {rename bgerror {}} + list $y $x +} {empty {{After error} {After error + while executing +"error "After error"" + ("after" script)}}} +test event-20.3 {AfterProc procedure, deleting handler from itself} { + foreach i [after info] { + after cancel $i + } + proc foo {} { + global x + set x {} + foreach i [after info] { + lappend x [after info $i] + } + after cancel foo + } + after idle foo + after 1000 {error "I shouldn't ever have executed"} + update idletasks + set x +} {{{error "I shouldn't ever have executed"} timer}} +test event-20.4 {AfterProc procedure, deleting handler from itself} { + foreach i [after info] { + after cancel $i + } + proc foo {} { + global x + set x {} + foreach i [after info] { + lappend x [after info $i] + } + after cancel foo + } + after 1000 {error "I shouldn't ever have executed"} + after idle foo + update idletasks + set x +} {{{error "I shouldn't ever have executed"} timer}} + foreach i [after info] { + after cancel $i + } + +test event-21.1 {AfterCleanupProc procedure} { + catch {interp delete x} + interp create x + x eval {after 200 { + lappend x after + puts "part 1: this message should not appear" + }} + after 200 {lappend x after2} + x eval {after 200 { + lappend x after3 + puts "part 2: this message should not appear" + }} + after 200 {lappend x after4} + x eval {after 200 { + lappend x after5 + puts "part 3: this message should not appear" + }} + interp delete x + set x before + after 300 + update + set x +} {before after2 after4} + +test event-22.1 {Tcl_VwaitCmd procedure} { + list [catch {vwait} msg] $msg +} {1 {wrong # args: should be "vwait name"}} +test event-22.2 {Tcl_VwaitCmd procedure} { + list [catch {vwait a b} msg] $msg +} {1 {wrong # args: should be "vwait name"}} +test event-22.3 {Tcl_VwaitCmd procedure} { + foreach i [after info] { + after cancel $i + } + after 100 {set x x-done} + after 200 {set y y-done} + after 300 {set z z-done} + after idle {set q q-done} + set x before + set y before + set z before + set q before + list [vwait y] $x $y $z $q +} {{} x-done y-done before q-done} + +test event-23.1 {Tcl_UpdateCmd procedure} { + list [catch {update a b} msg] $msg +} {1 {wrong # args: should be "update ?idletasks?"}} +test event-23.2 {Tcl_UpdateCmd procedure} { + list [catch {update bogus} msg] $msg +} {1 {bad option "bogus": must be idletasks}} +test event-23.3 {Tcl_UpdateCmd procedure} { + foreach i [after info] { + after cancel $i + } + after 500 {set x after} + after idle {set y after} + after idle {set z "after, y = $y"} + set x before + set y before + set z before + update idletasks + list $x $y $z +} {before after {after, y = after}} +test event-23.4 {Tcl_UpdateCmd procedure} { + foreach i [after info] { + after cancel $i + } + after 200 {set x x-done} + after 500 {set y y-done} + after idle {set z z-done} + set x before + set y before + set z before + after 300 + update + list $x $y $z +} {x-done before z-done} + +if {[info commands testfilehandler] != ""} { + test event-24.1 {Tcl_WaitForFile procedure, readable} unixOnly { + foreach i [after info] { + after cancel $i + } + after 100 set x timeout + testfilehandler close + testfilehandler create 1 off off + set x "no timeout" + set result [testfilehandler wait 1 readable 0] + update + testfilehandler close + list $result $x + } {{} {no timeout}} + test event-24.2 {Tcl_WaitForFile procedure, readable} unixOnly { + foreach i [after info] { + after cancel $i + } + after 100 set x timeout + testfilehandler close + testfilehandler create 1 off off + set x "no timeout" + set result [testfilehandler wait 1 readable 100] + update + testfilehandler close + list $result $x + } {{} timeout} + test event-24.3 {Tcl_WaitForFile procedure, readable} unixOnly { + foreach i [after info] { + after cancel $i + } + after 100 set x timeout + testfilehandler close + testfilehandler create 1 off off + testfilehandler fillpartial 1 + set x "no timeout" + set result [testfilehandler wait 1 readable 100] + update + testfilehandler close + list $result $x + } {readable {no timeout}} + test event-24.4 {Tcl_WaitForFile procedure, writable} {unixOnly nonPortable} { + foreach i [after info] { + after cancel $i + } + after 100 set x timeout + testfilehandler close + testfilehandler create 1 off off + testfilehandler fill 1 + set x "no timeout" + set result [testfilehandler wait 1 writable 0] + update + testfilehandler close + list $result $x + } {{} {no timeout}} + test event-24.5 {Tcl_WaitForFile procedure, writable} {unixOnly nonPortable} { + foreach i [after info] { + after cancel $i + } + after 100 set x timeout + testfilehandler close + testfilehandler create 1 off off + testfilehandler fill 1 + set x "no timeout" + set result [testfilehandler wait 1 writable 100] + update + testfilehandler close + list $result $x + } {{} timeout} + test event-24.6 {Tcl_WaitForFile procedure, writable} unixOnly { + foreach i [after info] { + after cancel $i + } + after 100 set x timeout + testfilehandler close + testfilehandler create 1 off off + set x "no timeout" + set result [testfilehandler wait 1 writable 100] + update + testfilehandler close + list $result $x + } {writable {no timeout}} + test event-24.7 {Tcl_WaitForFile procedure, don't call other event handlers} unixOnly { + foreach i [after info] { + after cancel $i + } + after 100 lappend x timeout + after idle lappend x idle + testfilehandler close + testfilehandler create 1 off off + set x "" + set result [list [testfilehandler wait 1 readable 200] $x] + update + testfilehandler close + lappend result $x + } {{} {} {timeout idle}} + test event-24.8 {Tcl_WaitForFile procedure, waiting indefinitely} unixOnly { + set f [open "|sleep 2" r] + set result "" + lappend result [testfilewait $f readable 100] + lappend result [testfilewait $f readable -1] + close $f + set result + } {{} readable} +} + +foreach i [after info] { + after cancel $i +} diff --git a/contrib/tcl/tests/exec.test b/contrib/tcl/tests/exec.test new file mode 100644 index 0000000..75dd359 --- /dev/null +++ b/contrib/tcl/tests/exec.test @@ -0,0 +1,489 @@ +# Commands covered: exec +# +# 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) 1991-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: @(#) exec.test 1.53 96/04/12 16:33:37 + +if {[string compare test [info procs test]] == 1} then {source defs} + +# If exec is not defined just return with no error +# Some platforms like the Macintosh do not have the exec command +if {[info commands exec] == ""} { + puts "exec not implemented for this machine" + return +} + +# This procedure generates a shell command to be passed to exec +# to mask the differences between Unix and PC shells. + +proc shellCmd {string} { + global tcl_platform + if {$tcl_platform(platform) == "unix"} { + return "sh -c \"$string\"" + } else { + return "sh -c {\"$string\"}" + } +} + +# Basic operations. + +test exec-1.1 {basic exec operation} {unixExecs} { + exec echo a b c +} "a b c" +test exec-1.2 {pipelining} {unixExecs} { + exec echo a b c d | cat | cat +} "a b c d" +test exec-1.3 {pipelining} {unixExecs} { + set a [exec echo a b c d | cat | 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} {unixExecs} { + exec echo $arg +} $arg +set arg {} + +# I/O redirection: input from Tcl command. + +test exec-2.1 {redirecting input from immediate source} {unixExecs} { + exec cat << "Sample text" +} {Sample text} +test exec-2.2 {redirecting input from immediate source} {unixExecs} { + exec << "Sample text" cat | cat +} {Sample text} +test exec-2.3 {redirecting input from immediate source} {unixExecs} { + exec cat << "Sample text" | cat +} {Sample text} +test exec-2.4 {redirecting input from immediate source} {unixExecs} { + exec cat | cat << "Sample text" +} {Sample text} +test exec-2.5 {redirecting input from immediate source} {unixExecs} { + exec cat "<<Joined to arrows" +} {Joined to arrows} + +# I/O redirection: output to file. + +catch {exec rm -f gorp.file} +test exec-3.1 {redirecting output to file} {unixExecs} { + exec echo "Some simple words" > gorp.file + exec cat gorp.file +} "Some simple words" +test exec-3.2 {redirecting output to file} {unixExecs} { + exec echo "More simple words" | >gorp.file cat | cat + exec cat gorp.file +} "More simple words" +test exec-3.3 {redirecting output to file} {unixExecs} { + exec > gorp.file echo "Different simple words" | cat | cat + exec cat gorp.file +} "Different simple words" +test exec-3.4 {redirecting output to file} {unixExecs} { + exec echo "Some simple words" >gorp.file + exec cat gorp.file +} "Some simple words" +test exec-3.5 {redirecting output to file} {unixExecs} { + exec echo "First line" >gorp.file + exec echo "Second line" >> gorp.file + exec cat gorp.file +} "First line\nSecond line" +test exec-3.6 {redirecting output to file} {unixExecs} { + exec echo "First line" >gorp.file + exec echo "Second line" >>gorp.file + exec cat gorp.file +} "First line\nSecond line" +test exec-3.7 {redirecting output to file} {unixExecs} { + set f [open gorp.file w] + puts $f "Line 1" + flush $f + exec echo "More text" >@ $f + exec echo >@$f "Even more" + puts $f "Line 3" + close $f + exec cat gorp.file +} "Line 1\nMore text\nEven more\nLine 3" + +# I/O redirection: output and stderr to file. + +catch {exec rm -f gorp.file} +test exec-4.1 {redirecting output and stderr to file} {unixExecs} { + exec echo "test output" >& gorp.file + exec cat gorp.file +} "test output" +test exec-4.2 {redirecting output and stderr to file} {unixExecs} { + list [eval exec [shellCmd "echo foo bar 1>&2"] >&gorp.file] \ + [exec cat gorp.file] +} {{} {foo bar}} +test exec-4.3 {redirecting output and stderr to file} {unixExecs} { + exec echo "first line" > gorp.file + list [eval exec [shellCmd "echo foo bar 1>&2"] >>&gorp.file] \ + [exec cat gorp.file] +} "{} {first line\nfoo bar}" +test exec-4.4 {redirecting output and stderr to file} {unixExecs} { + set f [open gorp.file w] + puts $f "Line 1" + flush $f + exec echo "More text" >&@ $f + exec echo >&@$f "Even more" + puts $f "Line 3" + close $f + exec cat gorp.file +} "Line 1\nMore text\nEven more\nLine 3" +test exec-4.5 {redirecting output and stderr to file} {unixExecs} { + set f [open gorp.file w] + puts $f "Line 1" + flush $f + eval exec >&@ $f [shellCmd "echo foo bar 1>&2"] + eval exec >&@$f [shellCmd "echo xyzzy 1>&2"] + puts $f "Line 3" + close $f + exec cat gorp.file +} "Line 1\nfoo bar\nxyzzy\nLine 3" + +# I/O redirection: input from file. + +catch {exec echo "Just a few thoughts" > gorp.file} +test exec-5.1 {redirecting input from file} {unixExecs} { + exec cat < gorp.file +} {Just a few thoughts} +test exec-5.2 {redirecting input from file} {unixExecs} { + exec cat | cat < gorp.file +} {Just a few thoughts} +test exec-5.3 {redirecting input from file} {unixExecs} { + exec cat < gorp.file | cat +} {Just a few thoughts} +test exec-5.4 {redirecting input from file} {unixExecs} { + exec < gorp.file cat | cat +} {Just a few thoughts} +test exec-5.5 {redirecting input from file} {unixExecs} { + exec cat <gorp.file +} {Just a few thoughts} +test exec-5.6 {redirecting input from file} {unixExecs} { + set f [open gorp.file r] + set result [exec cat <@ $f] + close $f + set result +} {Just a few thoughts} +test exec-5.7 {redirecting input from file} {unixExecs} { + set f [open gorp.file r] + set result [exec <@$f 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} {unixExecs} { + eval exec [shellCmd "echo foo bar"] |& cat +} "foo bar" +test exec-6.2 {redirecting stderr through a pipeline} {unixExecs} { + eval exec [shellCmd "echo foo bar 1>&2"] |& cat +} "foo bar" +test exec-6.3 {redirecting stderr through a pipeline} {unixExecs} { + eval exec [shellCmd "echo foo bar 1>&2"] \ + |& [shellCmd "echo second msg 1>&2; cat"] |& cat +} "second msg\nfoo bar" + +# I/O redirection: combinations. + +catch {exec rm -f gorp.file2} +test exec-7.1 {multiple I/O redirections} {unixExecs} { + exec << "command input" > gorp.file2 cat < gorp.file + exec cat gorp.file2 +} {Just a few thoughts} +test exec-7.2 {multiple I/O redirections} {unixExecs} { + exec < gorp.file << "command input" cat +} {command input} + +# Long input to command and output from command. + +set a "0123456789 xxxxxxxxx abcdefghi ABCDEFGHIJK\n" +set a [concat $a $a $a $a] +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} {unixExecs} { + exec cat << $a +} $a + +# Commands that return errors. + +test exec-9.1 {commands returning errors} { + 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} {unixExecs} { + string tolower [list [catch {exec 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} {unixExecs} { + list [catch {eval exec sleep 1 | [shellCmd "exit 43"] | sleep 1} msg] $msg +} {1 {child process exited abnormally}} +test exec-9.4 {commands returning errors} {unixExecs} { + list [catch {eval exec [shellCmd "exit 43"] | echo "foo bar"} msg] $msg +} {1 {foo bar +child process exited abnormally}} +test exec-9.5 {commands returning errors} {unixExecs} { + list [catch {exec gorp456 | 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} {unixExecs} { + list [catch {eval exec [shellCmd "echo error msg 1>&2"]} msg] $msg +} {1 {error msg}} +test exec-9.7 {commands returning errors} {unixExecs} { + list [catch {eval exec [shellCmd "echo error msg 1>&2"] \ + | [shellCmd "echo error msg 1>&2"]} msg] $msg +} {1 {error msg +error msg}} + +# Errors in executing the Tcl command, as opposed to errors in the +# processes that are invoked. + +test exec-10.1 {errors in exec invocation} { + list [catch {exec} msg] $msg +} {1 {wrong # args: should be "exec ?switches? arg ?arg ...?"}} +test exec-10.2 {errors in exec invocation} { + list [catch {exec | cat} msg] $msg +} {1 {illegal use of | or |& in command}} +test exec-10.3 {errors in exec invocation} { + list [catch {exec cat |} msg] $msg +} {1 {illegal use of | or |& in command}} +test exec-10.4 {errors in exec invocation} { + list [catch {exec cat | | cat} msg] $msg +} {1 {illegal use of | or |& in command}} +test exec-10.5 {errors in exec invocation} { + list [catch {exec cat | |& cat} msg] $msg +} {1 {illegal use of | or |& in command}} +test exec-10.6 {errors in exec invocation} { + list [catch {exec cat |&} msg] $msg +} {1 {illegal use of | or |& in command}} +test exec-10.7 {errors in exec invocation} { + list [catch {exec cat <} msg] $msg +} {1 {can't specify "<" as last word in command}} +test exec-10.8 {errors in exec invocation} { + list [catch {exec cat >} msg] $msg +} {1 {can't specify ">" as last word in command}} +test exec-10.9 {errors in exec invocation} { + list [catch {exec cat <<} msg] $msg +} {1 {can't specify "<<" as last word in command}} +test exec-10.10 {errors in exec invocation} { + list [catch {exec cat >>} msg] $msg +} {1 {can't specify ">>" as last word in command}} +test exec-10.11 {errors in exec invocation} { + list [catch {exec cat >&} msg] $msg +} {1 {can't specify ">&" as last word in command}} +test exec-10.12 {errors in exec invocation} { + list [catch {exec cat >>&} msg] $msg +} {1 {can't specify ">>&" as last word in command}} +test exec-10.13 {errors in exec invocation} { + list [catch {exec cat >@} msg] $msg +} {1 {can't specify ">@" as last word in command}} +test exec-10.14 {errors in exec invocation} { + list [catch {exec cat <@} msg] $msg +} {1 {can't specify "<@" as last word in command}} +test exec-10.15 {errors in exec invocation} {unixExecs} { + 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} {unixExecs} { + 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} {unixExecs} { + 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} { + 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} { + 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} { + 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} {unixExecs} { + list [catch {exec 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} {unixExecs} { + set x [lindex [time {exec sleep 2 &}] 0] + expr $x<1000000 +} 1 +test exec-11.2 {commands in background} {unixExecs} { + list [catch {exec echo a &b} msg] $msg +} {0 {a &b}} +test exec-11.3 {commands in background} {unixExecs} { + llength [exec sleep 1 &] +} 1 +test exec-11.4 {commands in background} {unixExecs} { + llength [exec sleep 1 | sleep 1 | sleep 1 &] +} 3 +test exec-11.5 {commands in background} {unixExecs} { + set f [open gorp.file w] + puts $f { catch { exec echo foo & } } + close $f + string compare "foo" [exec [info nameofexecutable] gorp.file] +} 0 + +# Make sure that background commands are properly reaped when +# they eventually die. + +catch {exec sleep 3} +test exec-12.1 {reaping background processes} {unixOnly nonPortable} { + for {set i 0} {$i < 20} {incr i} { + exec echo foo > /dev/null & + } + exec sleep 1 + catch {exec ps | fgrep "echo foo" | fgrep -v fgrep | wc} msg + lindex $msg 0 +} 0 +test exec-12.2 {reaping background processes} {unixExecs 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] + exec sleep 3 + catch {exec ps | fgrep -i "sleep" | fgrep -i -v fgrep | wc} msg + list $x [lindex $msg 0] +} {3 0} +test exec-12.3 {reaping background processes} {unixOnly nonPortable} { + exec sleep 1000 & + exec sleep 1000 & + set x [exec ps | fgrep "sleep" | fgrep -v fgrep] + set pids {} + foreach i [split $x \n] { + lappend pids [lindex $i 0] + } + foreach i $pids { + catch {exec kill -STOP $i} + } + catch {exec ps | fgrep "sleep" | fgrep -v fgrep | wc} msg + set x [lindex $msg 0] + + foreach i $pids { + catch {exec kill -KILL $i} + } + catch {exec ps | fgrep "sleep" | fgrep -v fgrep | wc} msg + list $x [lindex $msg 0] +} {2 0} + +# Make sure "errorCode" is set correctly. + +test exec-13.1 {setting errorCode variable} {unixExecs} { + list [catch {exec cat < a/b/c} msg] [string tolower $errorCode] +} {1 {posix enoent {no such file or directory}}} +test exec-13.2 {setting errorCode variable} {unixExecs} { + list [catch {exec cat > a/b/c} msg] [string tolower $errorCode] +} {1 {posix enoent {no such file or directory}}} +test exec-13.3 {setting errorCode variable} { + set x [catch {exec _weird_cmd_} msg] + list $x [string tolower $msg] [lindex $errorCode 0] \ + [string tolower [lrange $errorCode 2 end]] +} {1 {couldn't execute "_weird_cmd_": no such file or directory} POSIX {{no such file or directory}}} + +# Switches before the first argument + +test exec-14.1 {-keepnewline switch} {unixExecs} { + exec -keepnewline echo foo +} "foo\n" +test exec-14.2 {-keepnewline switch} { + list [catch {exec -keepnewline} msg] $msg +} {1 {wrong # args: should be "exec ?switches? arg ?arg ...?"}} +test exec-14.3 {unknown switch} { + list [catch {exec -gorp} msg] $msg +} {1 {bad switch "-gorp": must be -keepnewline or --}} +test exec-14.4 {-- switch} { + 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} {unixExecs} { + exec echo "First line" > gorp.file + list [eval exec [shellCmd "echo foo bar 1>&2"] 2> gorp.file] \ + [exec cat gorp.file] +} {{} {foo bar}} +test exec-15.2 {standard error redirection} {unixExecs} { + list [eval exec [shellCmd "echo foo bar 1>&2"] | echo biz baz >gorp.file \ + 2> gorp.file2] [exec cat gorp.file] \ + [exec cat gorp.file2] +} {{} {biz baz} {foo bar}} +test exec-15.3 {standard error redirection} {unixExecs} { + list [eval exec [shellCmd "echo foo bar 1>&2"] | echo biz baz 2>gorp.file \ + > gorp.file2] [exec cat gorp.file] \ + [exec cat gorp.file2] +} {{} {foo bar} {biz baz}} +test exec-15.4 {standard error redirection} {unixExecs} { + set f [open gorp.file w] + puts $f "Line 1" + flush $f + eval exec [shellCmd "echo foo bar 1>&2"] 2>@ $f + puts $f "Line 3" + close $f + exec cat gorp.file +} {Line 1 +foo bar +Line 3} +test exec-15.5 {standard error redirection} {unixExecs} { + exec echo "First line" > gorp.file + eval exec [shellCmd "echo foo bar 1>&2"] 2>> gorp.file + exec cat gorp.file +} {First line +foo bar} +test exec-15.6 {standard error redirection} {unixExecs} { + eval exec [shellCmd "echo foo bar 1>&2"] > gorp.file2 2> gorp.file \ + >& gorp.file 2> gorp.file2 | echo biz baz + list [exec cat gorp.file] [exec cat gorp.file2] +} {{biz baz} {foo bar}} + +test exec-16.1 {flush output before exec} {unixExecs} { + set f [open gorp.file w] + puts $f "First line" + exec echo "Second line" >@ $f + puts $f "Third line" + close $f + exec cat gorp.file +} {First line +Second line +Third line} +test exec-16.2 {flush output before exec} {unixExecs} { + set f [open gorp.file w] + puts $f "First line" + eval exec [shellCmd "echo Second line 1>&2"] >&@ $f > gorp.file2 + puts $f "Third line" + close $f + exec cat gorp.file +} {First line +Second line +Third line} + +test exec-17.1 { inheriting standard I/O } {unixOrPc unixExecs} { + set f [open script w] + puts $f {close stdout + set f [open gorp.file w] + catch {exec echo foobar &} + exec sleep 2 + close $f + } + close $f + catch {eval exec $tcltest script} result + set f [open gorp.file r] + lappend result [read $f] + close $f + set result +} {{foobar +}} + +removeFile script +removeFile gorp.file +removeFile gorp.file2 + +return {} diff --git a/contrib/tcl/tests/expr.test b/contrib/tcl/tests/expr.test new file mode 100644 index 0000000..d5dbab5 --- /dev/null +++ b/contrib/tcl/tests/expr.test @@ -0,0 +1,890 @@ +# Commands covered: expr +# +# 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) 1991-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: @(#) expr.test 1.48 96/02/16 08:55:51 + +if {[string compare test [info procs test]] == 1} then {source defs} + +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 +} + +# First, test all of the integer operators individually. + +test expr-1.1 {integer operators} {expr -4} -4 +test expr-1.2 {integer operators} {expr -(1+4)} -5 +test expr-1.3 {integer operators} {expr ~3} -4 +test expr-1.4 {integer operators} {expr !2} 0 +test expr-1.5 {integer operators} {expr !0} 1 +test expr-1.6 {integer operators} {expr 4*6} 24 +test expr-1.7 {integer operators} {expr 36/12} 3 +test expr-1.8 {integer operators} {expr 27/4} 6 +test expr-1.9 {integer operators} {expr 27%4} 3 +test expr-1.10 {integer operators} {expr 2+2} 4 +test expr-1.11 {integer operators} {expr 2-6} -4 +test expr-1.12 {integer operators} {expr 1<<3} 8 +test expr-1.13 {integer operators} {expr 0xff>>2} 63 +test expr-1.14 {integer operators} {expr -1>>2} -1 +test expr-1.15 {integer operators} {expr 3>2} 1 +test expr-1.16 {integer operators} {expr 2>2} 0 +test expr-1.17 {integer operators} {expr 1>2} 0 +test expr-1.18 {integer operators} {expr 3<2} 0 +test expr-1.19 {integer operators} {expr 2<2} 0 +test expr-1.20 {integer operators} {expr 1<2} 1 +test expr-1.21 {integer operators} {expr 3>=2} 1 +test expr-1.22 {integer operators} {expr 2>=2} 1 +test expr-1.23 {integer operators} {expr 1>=2} 0 +test expr-1.24 {integer operators} {expr 3<=2} 0 +test expr-1.25 {integer operators} {expr 2<=2} 1 +test expr-1.26 {integer operators} {expr 1<=2} 1 +test expr-1.27 {integer operators} {expr 3==2} 0 +test expr-1.28 {integer operators} {expr 2==2} 1 +test expr-1.29 {integer operators} {expr 3!=2} 1 +test expr-1.30 {integer operators} {expr 2!=2} 0 +test expr-1.31 {integer operators} {expr 7&0x13} 3 +test expr-1.32 {integer operators} {expr 7^0x13} 20 +test expr-1.33 {integer operators} {expr 7|0x13} 23 +test expr-1.34 {integer operators} {expr 0&&1} 0 +test expr-1.35 {integer operators} {expr 0&&0} 0 +test expr-1.36 {integer operators} {expr 1&&3} 1 +test expr-1.37 {integer operators} {expr 0||1} 1 +test expr-1.38 {integer operators} {expr 3||0} 1 +test expr-1.39 {integer operators} {expr 0||0} 0 +test expr-1.40 {integer operators} {expr 3>2?44:66} 44 +test expr-1.41 {integer operators} {expr 2>3?44:66} 66 +test expr-1.42 {integer operators} {expr 36/5} 7 +test expr-1.43 {integer operators} {expr 36%5} 1 +test expr-1.44 {integer operators} {expr -36/5} -8 +test expr-1.45 {integer operators} {expr -36%5} 4 +test expr-1.46 {integer operators} {expr 36/-5} -8 +test expr-1.47 {integer operators} {expr 36%-5} -4 +test expr-1.48 {integer operators} {expr -36/-5} 7 +test expr-1.49 {integer operators} {expr -36%-5} -1 +test expr-1.50 {integer operators} {expr +36} 36 +test expr-1.51 {integer operators} {expr +--++36} 36 +test expr-1.52 {integer operators} {expr +36%+5} 1 + +# Check the floating-point operators individually, along with +# automatic conversion to integers where needed. + +test expr-2.1 {floating-point operators} {expr -4.2} -4.2 +test expr-2.2 {floating-point operators} {expr -(1.1+4.2)} -5.3 +test expr-2.3 {floating-point operators} {expr +5.7} 5.7 +test expr-2.4 {floating-point operators} {expr +--+-62.0} -62.0 +test expr-2.5 {floating-point operators} {expr !2.1} 0 +test expr-2.6 {floating-point operators} {expr !0.0} 1 +test expr-2.7 {floating-point operators} {expr 4.2*6.3} 26.46 +test expr-2.8 {floating-point operators} {expr 36.0/12.0} 3.0 +test expr-2.9 {floating-point operators} {expr 27/4.0} 6.75 +test expr-2.10 {floating-point operators} {expr 2.3+2.1} 4.4 +test expr-2.11 {floating-point operators} {expr 2.3-6.5} -4.2 +test expr-2.12 {floating-point operators} {expr 3.1>2.1} 1 +test expr-2.13 {floating-point operators} {expr {2.1 > 2.1}} 0 +test expr-2.14 {floating-point operators} {expr 1.23>2.34e+1} 0 +test expr-2.15 {floating-point operators} {expr 3.45<2.34} 0 +test expr-2.16 {floating-point operators} {expr 0.002e3<--200e-2} 0 +test expr-2.17 {floating-point operators} {expr 1.1<2.1} 1 +test expr-2.18 {floating-point operators} {expr 3.1>=2.2} 1 +test expr-2.19 {floating-point operators} {expr 2.345>=2.345} 1 +test expr-2.20 {floating-point operators} {expr 1.1>=2.2} 0 +test expr-2.21 {floating-point operators} {expr 3.0<=2.0} 0 +test expr-2.22 {floating-point operators} {expr 2.2<=2.2} 1 +test expr-2.23 {floating-point operators} {expr 2.2<=2.2001} 1 +test expr-2.24 {floating-point operators} {expr 3.2==2.2} 0 +test expr-2.25 {floating-point operators} {expr 2.2==2.2} 1 +test expr-2.26 {floating-point operators} {expr 3.2!=2.2} 1 +test expr-2.27 {floating-point operators} {expr 2.2!=2.2} 0 +test expr-2.28 {floating-point operators} {expr 0.0&&0.0} 0 +test expr-2.29 {floating-point operators} {expr 0.0&&1.3} 0 +test expr-2.30 {floating-point operators} {expr 1.3&&0.0} 0 +test expr-2.31 {floating-point operators} {expr 1.3&&3.3} 1 +test expr-2.32 {floating-point operators} {expr 0.0||0.0} 0 +test expr-2.33 {floating-point operators} {expr 0.0||1.3} 1 +test expr-2.34 {floating-point operators} {expr 1.3||0.0} 1 +test expr-2.35 {floating-point operators} {expr 3.3||0.0} 1 +test expr-2.36 {floating-point operators} {expr 3.3>2.3?44.3:66.3} 44.3 +test expr-2.37 {floating-point operators} {expr 2.3>3.3?44.3:66.3} 66.3 +test expr-2.38 {floating-point operators} { + list [catch {expr 028.1 + 09.2} msg] $msg +} {0 37.3} + +# Operators that aren't legal on floating-point numbers + +test expr-3.1 {illegal floating-point operations} { + list [catch {expr ~4.0} msg] $msg +} {1 {can't use floating-point value as operand of "~"}} +test expr-3.2 {illegal floating-point operations} { + list [catch {expr 27%4.0} msg] $msg +} {1 {can't use floating-point value as operand of "%"}} +test expr-3.3 {illegal floating-point operations} { + list [catch {expr 27.0%4} msg] $msg +} {1 {can't use floating-point value as operand of "%"}} +test expr-3.4 {illegal floating-point operations} { + list [catch {expr 1.0<<3} msg] $msg +} {1 {can't use floating-point value as operand of "<<"}} +test expr-3.5 {illegal floating-point operations} { + list [catch {expr 3<<1.0} msg] $msg +} {1 {can't use floating-point value as operand of "<<"}} +test expr-3.6 {illegal floating-point operations} { + list [catch {expr 24.0>>3} msg] $msg +} {1 {can't use floating-point value as operand of ">>"}} +test expr-3.7 {illegal floating-point operations} { + list [catch {expr 24>>3.0} msg] $msg +} {1 {can't use floating-point value as operand of ">>"}} +test expr-3.8 {illegal floating-point operations} { + list [catch {expr 24&3.0} msg] $msg +} {1 {can't use floating-point value as operand of "&"}} +test expr-3.9 {illegal floating-point operations} { + list [catch {expr 24.0|3} msg] $msg +} {1 {can't use floating-point value as operand of "|"}} +test expr-3.10 {illegal floating-point operations} { + list [catch {expr 24.0^3} msg] $msg +} {1 {can't use floating-point value as operand of "^"}} + +# Check the string operators individually. + +test expr-4.1 {string operators} {expr {"abc" > "def"}} 0 +test expr-4.2 {string operators} {expr {"def" > "def"}} 0 +test expr-4.3 {string operators} {expr {"g" > "def"}} 1 +test expr-4.4 {string operators} {expr {"abc" < "abd"}} 1 +test expr-4.5 {string operators} {expr {"abd" < "abd"}} 0 +test expr-4.6 {string operators} {expr {"abe" < "abd"}} 0 +test expr-4.7 {string operators} {expr {"abc" >= "def"}} 0 +test expr-4.8 {string operators} {expr {"def" >= "def"}} 1 +test expr-4.9 {string operators} {expr {"g" >= "def"}} 1 +test expr-4.10 {string operators} {expr {"abc" <= "abd"}} 1 +test expr-4.11 {string operators} {expr {"abd" <= "abd"}} 1 +test expr-4.12 {string operators} {expr {"abe" <= "abd"}} 0 +test expr-4.13 {string operators} {expr {"abc" == "abd"}} 0 +test expr-4.14 {string operators} {expr {"abd" == "abd"}} 1 +test expr-4.15 {string operators} {expr {"abc" != "abd"}} 1 +test expr-4.16 {string operators} {expr {"abd" != "abd"}} 0 +test expr-4.17 {string operators} {expr {"0y" < "0x12"}} 1 +test expr-4.18 {string operators} {expr {"." < " "}} 0 + +# The following tests are non-portable because on some systems "+" +# and "-" can be parsed as numbers. + +test expr-4.19 {string operators} {nonPortable} {expr {"0" == "+"}} 0 +test expr-4.20 {string operators} {nonPortable} {expr {"0" == "-"}} 0 +test expr-4.21 {string operators} {expr {1?"foo":"bar"}} foo +test expr-4.22 {string operators} {expr {0?"foo":"bar"}} bar + +# Operators that aren't legal on string operands. + +test expr-5.1 {illegal string operations} { + list [catch {expr {-"a"}} msg] $msg +} {1 {can't use non-numeric string as operand of "-"}} +test expr-5.2 {illegal string operations} { + list [catch {expr {+"a"}} msg] $msg +} {1 {can't use non-numeric string as operand of "+"}} +test expr-5.3 {illegal string operations} { + list [catch {expr {~"a"}} msg] $msg +} {1 {can't use non-numeric string as operand of "~"}} +test expr-5.4 {illegal string operations} { + list [catch {expr {!"a"}} msg] $msg +} {1 {can't use non-numeric string as operand of "!"}} +test expr-5.5 {illegal string operations} { + list [catch {expr {"a"*"b"}} msg] $msg +} {1 {can't use non-numeric string as operand of "*"}} +test expr-5.6 {illegal string operations} { + list [catch {expr {"a"/"b"}} msg] $msg +} {1 {can't use non-numeric string as operand of "/"}} +test expr-5.7 {illegal string operations} { + list [catch {expr {"a"%"b"}} msg] $msg +} {1 {can't use non-numeric string as operand of "%"}} +test expr-5.8 {illegal string operations} { + list [catch {expr {"a"+"b"}} msg] $msg +} {1 {can't use non-numeric string as operand of "+"}} +test expr-5.9 {illegal string operations} { + list [catch {expr {"a"-"b"}} msg] $msg +} {1 {can't use non-numeric string as operand of "-"}} +test expr-5.10 {illegal string operations} { + list [catch {expr {"a"<<"b"}} msg] $msg +} {1 {can't use non-numeric string as operand of "<<"}} +test expr-5.11 {illegal string operations} { + list [catch {expr {"a">>"b"}} msg] $msg +} {1 {can't use non-numeric string as operand of ">>"}} +test expr-5.12 {illegal string operations} { + list [catch {expr {"a"&"b"}} msg] $msg +} {1 {can't use non-numeric string as operand of "&"}} +test expr-5.13 {illegal string operations} { + list [catch {expr {"a"^"b"}} msg] $msg +} {1 {can't use non-numeric string as operand of "^"}} +test expr-5.14 {illegal string operations} { + list [catch {expr {"a"|"b"}} msg] $msg +} {1 {can't use non-numeric string as operand of "|"}} +test expr-5.15 {illegal string operations} { + list [catch {expr {"a"&&"b"}} msg] $msg +} {1 {can't use non-numeric string as operand of "&&"}} +test expr-5.16 {illegal string operations} { + list [catch {expr {"a"||"b"}} msg] $msg +} {1 {can't use non-numeric string as operand of "||"}} +test expr-5.17 {illegal string operations} { + list [catch {expr {"a"?4:2}} msg] $msg +} {1 {can't use non-numeric string as operand of "?"}} + +# Check precedence pairwise. + +test expr-6.1 {precedence checks} {expr -~3} 4 +test expr-6.2 {precedence checks} {expr -!3} 0 +test expr-6.3 {precedence checks} {expr -~0} 1 + +test expr-7.1 {precedence checks} {expr 2*4/6} 1 +test expr-7.2 {precedence checks} {expr 24/6*3} 12 +test expr-7.3 {precedence checks} {expr 24/6/2} 2 + +test expr-8.1 {precedence checks} {expr -2+4} 2 +test expr-8.2 {precedence checks} {expr -2-4} -6 +test expr-8.3 {precedence checks} {expr +2-4} -2 + +test expr-9.1 {precedence checks} {expr 2*3+4} 10 +test expr-9.2 {precedence checks} {expr 8/2+4} 8 +test expr-9.3 {precedence checks} {expr 8%3+4} 6 +test expr-9.4 {precedence checks} {expr 2*3-1} 5 +test expr-9.5 {precedence checks} {expr 8/2-1} 3 +test expr-9.6 {precedence checks} {expr 8%3-1} 1 + +test expr-10.1 {precedence checks} {expr 6-3-2} 1 + +test expr-11.1 {precedence checks} {expr 7+1>>2} 2 +test expr-11.2 {precedence checks} {expr 7+1<<2} 32 +test expr-11.3 {precedence checks} {expr 7>>3-2} 3 +test expr-11.4 {precedence checks} {expr 7<<3-2} 14 + +test expr-12.1 {precedence checks} {expr 6>>1>4} 0 +test expr-12.2 {precedence checks} {expr 6>>1<2} 0 +test expr-12.3 {precedence checks} {expr 6>>1>=3} 1 +test expr-12.4 {precedence checks} {expr 6>>1<=2} 0 +test expr-12.5 {precedence checks} {expr 6<<1>5} 1 +test expr-12.6 {precedence checks} {expr 6<<1<5} 0 +test expr-12.7 {precedence checks} {expr 5<=6<<1} 1 +test expr-12.8 {precedence checks} {expr 5>=6<<1} 0 + +test expr-13.1 {precedence checks} {expr 2<3<4} 1 +test expr-13.2 {precedence checks} {expr 0<4>2} 0 +test expr-13.3 {precedence checks} {expr 4>2<1} 0 +test expr-13.4 {precedence checks} {expr 4>3>2} 0 +test expr-13.5 {precedence checks} {expr 4>3>=2} 0 +test expr-13.6 {precedence checks} {expr 4>=3>2} 0 +test expr-13.7 {precedence checks} {expr 4>=3>=2} 0 +test expr-13.8 {precedence checks} {expr 0<=4>=2} 0 +test expr-13.9 {precedence checks} {expr 4>=2<=0} 0 +test expr-13.10 {precedence checks} {expr 2<=3<=4} 1 + +test expr-14.1 {precedence checks} {expr 1==4>3} 1 +test expr-14.2 {precedence checks} {expr 0!=4>3} 1 +test expr-14.3 {precedence checks} {expr 1==3<4} 1 +test expr-14.4 {precedence checks} {expr 0!=3<4} 1 +test expr-14.5 {precedence checks} {expr 1==4>=3} 1 +test expr-14.6 {precedence checks} {expr 0!=4>=3} 1 +test expr-14.7 {precedence checks} {expr 1==3<=4} 1 +test expr-14.8 {precedence checks} {expr 0!=3<=4} 1 + +test expr-15.1 {precedence checks} {expr 1==3==3} 0 +test expr-15.2 {precedence checks} {expr 3==3!=2} 1 +test expr-15.3 {precedence checks} {expr 2!=3==3} 0 +test expr-15.4 {precedence checks} {expr 2!=1!=1} 0 + +test expr-16.1 {precedence checks} {expr 2&3==2} 0 +test expr-16.2 {precedence checks} {expr 1&3!=3} 0 + +test expr-17.1 {precedence checks} {expr 7&3^0x10} 19 +test expr-17.2 {precedence checks} {expr 7^0x10&3} 7 + +test expr-18.1 {precedence checks} {expr 7^0x10|3} 23 +test expr-18.2 {precedence checks} {expr 7|0x10^3} 23 + +test expr-19.1 {precedence checks} {expr 7|3&&1} 1 +test expr-19.2 {precedence checks} {expr 1&&3|7} 1 +test expr-19.3 {precedence checks} {expr 0&&1||1} 1 +test expr-19.4 {precedence checks} {expr 1||1&&0} 1 + +test expr-20.1 {precedence checks} {expr 1||0?3:4} 3 +test expr-20.2 {precedence checks} {expr 1?0:4||1} 0 +test expr-20.3 {precedence checks} {expr 1?2:0?3:4} 2 +test expr-20.4 {precedence checks} {expr 0?2:0?3:4} 4 +test expr-20.5 {precedence checks} {expr 1?2?3:4:0} 3 +test expr-20.6 {precedence checks} {expr 0?2?3:4:0} 0 + +# Parentheses. + +test expr-21.1 {parenthesization} {expr (2+4)*6} 36 +test expr-21.2 {parenthesization} {expr (1?0:4)||1} 1 +test expr-21.3 {parenthesization} {expr +(3-4)} -1 + +# Embedded commands and variable names. + +set a 16 +test expr-22.1 {embedded variables} {expr {2*$a}} 32 +test expr-22.2 {embedded variables} { + set x -5 + set y 10 + expr {$x + $y} +} {5} +test expr-22.3 {embedded variables} { + set x " -5" + set y " +10" + expr {$x + $y} +} {5} +test expr-22.4 {embedded commands and variables} {expr {[set a] - 14}} 2 +test expr-22.5 {embedded commands and variables} { + list [catch {expr {12 - [bad_command_name]}} msg] $msg +} {1 {invalid command name "bad_command_name"}} + +# Double-quotes and things inside them. + +test expr-23.1 {double quotes} {expr {"abc"}} abc +test expr-23.2 {double quotes} { + set a 189 + expr {"$a.bc"} +} 189.bc +test expr-23.3 {double quotes} { + set b2 xyx + expr {"$b2$b2$b2.[set b2].[set b2]"} +} xyxxyxxyx.xyx.xyx +test expr-23.4 {double quotes} {expr {"11\}\}22"}} 11}}22 +test expr-23.5 {double quotes} {expr {"\*bc"}} {*bc} +test expr-23.6 {double quotes} { + catch {unset bogus__} + list [catch {expr {"$bogus__"}} msg] $msg +} {1 {can't read "bogus__": no such variable}} +test expr-23.7 {double quotes} { + list [catch {expr {"a[error Testing]bc"}} msg] $msg +} {1 Testing} +test expr-23.8 {double quotes} { + list [catch {expr {"12398712938788234-1298379" != ""}} msg] $msg +} {0 1} + +# Numbers in various bases. + +test expr-24.1 {numbers in different bases} {expr 0x20} 32 +test expr-24.2 {numbers in different bases} {expr 015} 13 + +# Conversions between various data types. + +test expr-25.1 {type conversions} {expr 2+2.5} 4.5 +test expr-25.2 {type conversions} {expr 2.5+2} 4.5 +test expr-25.3 {type conversions} {expr 2-2.5} -0.5 +test expr-25.4 {type conversions} {expr 2/2.5} 0.8 +test expr-25.5 {type conversions} {expr 2>2.5} 0 +test expr-25.6 {type conversions} {expr 2.5>2} 1 +test expr-25.7 {type conversions} {expr 2<2.5} 1 +test expr-25.8 {type conversions} {expr 2>=2.5} 0 +test expr-25.9 {type conversions} {expr 2<=2.5} 1 +test expr-25.10 {type conversions} {expr 2==2.5} 0 +test expr-25.11 {type conversions} {expr 2!=2.5} 1 +test expr-25.12 {type conversions} {expr 2>"ab"} 0 +test expr-25.13 {type conversions} {expr {2>" "}} 1 +test expr-25.14 {type conversions} {expr {"24.1a" > 24.1}} 1 +test expr-25.15 {type conversions} {expr {24.1 > "24.1a"}} 0 +test expr-25.16 {type conversions} {expr 2+2.5} 4.5 +test expr-25.17 {type conversions} {expr 2+2.5} 4.5 +test expr-25.18 {type conversions} {expr 2.0e2} 200.0 +test expr-25.19 {type conversions} {expr 2.0e15} 2e+15 +test expr-25.20 {type conversions} {expr 10.0} 10.0 + +# Various error conditions. + +test expr-26.1 {error conditions} { + list [catch {expr 2+"a"} msg] $msg +} {1 {can't use non-numeric string as operand of "+"}} +test expr-26.2 {error conditions} { + list [catch {expr 2+4*} msg] $msg +} {1 {syntax error in expression "2+4*"}} +test expr-26.3 {error conditions} { + list [catch {expr 2+4*(} msg] $msg +} {1 {syntax error in expression "2+4*("}} +catch {unset _non_existent_} +test expr-26.4 {error conditions} { + list [catch {expr 2+$_non_existent_} msg] $msg +} {1 {can't read "_non_existent_": no such variable}} +set a xx +test expr-26.5 {error conditions} { + list [catch {expr {2+$a}} msg] $msg +} {1 {can't use non-numeric string as operand of "+"}} +test expr-26.6 {error conditions} { + list [catch {expr {2+[set a]}} msg] $msg +} {1 {can't use non-numeric string as operand of "+"}} +test expr-26.7 {error conditions} { + list [catch {expr {2+(4}} msg] $msg +} {1 {unmatched parentheses in expression "2+(4"}} +test expr-26.8 {error conditions} { + list [catch {expr 2/0} msg] $msg $errorCode +} {1 {divide by zero} {ARITH DIVZERO {divide by zero}}} +test expr-26.9 {error conditions} { + list [catch {expr 2%0} msg] $msg $errorCode +} {1 {divide by zero} {ARITH DIVZERO {divide by zero}}} +test expr-26.10 {error conditions} { + list [catch {expr 2.0/0.0} msg] $msg $errorCode +} {1 {divide by zero} {ARITH DIVZERO {divide by zero}}} +test expr-26.11 {error conditions} { + list [catch {expr 2#} msg] $msg +} {1 {syntax error in expression "2#"}} +test expr-26.12 {error conditions} { + list [catch {expr a.b} msg] $msg +} {1 {syntax error in expression "a.b"}} +test expr-26.13 {error conditions} { + list [catch {expr {"a"/"b"}} msg] $msg +} {1 {can't use non-numeric string as operand of "/"}} +test expr-26.14 {error conditions} { + list [catch {expr 2:3} msg] $msg +} {1 {can't have : operator without ? first}} +test expr-26.15 {error conditions} { + list [catch {expr a@b} msg] $msg +} {1 {syntax error in expression "a@b"}} +test expr-26.16 {error conditions} { + list [catch {expr a[b} msg] $msg +} {1 {missing close-bracket}} +test expr-26.17 {error conditions} { + list [catch {expr a`b} msg] $msg +} {1 {syntax error in expression "a`b"}} +test expr-26.18 {error conditions} { + list [catch {expr \"a\"\{b} msg] $msg +} {1 {missing close-brace}} +test expr-26.19 {error conditions} { + list [catch {expr a} msg] $msg +} {1 {syntax error in expression "a"}} +test expr-26.20 {error conditions} { + list [catch expr msg] $msg +} {1 {wrong # args: should be "expr arg ?arg ...?"}} + +# Cancelled evaluation. + +test expr-27.1 {cancelled evaluation} { + set a 1 + expr {0&&[set a 2]} + set a +} 1 +test expr-27.2 {cancelled evaluation} { + set a 1 + expr {1||[set a 2]} + set a +} 1 +test expr-27.3 {cancelled evaluation} { + set a 1 + expr {0?[set a 2]:1} + set a +} 1 +test expr-27.4 {cancelled evaluation} { + set a 1 + expr {1?2:[set a 2]} + set a +} 1 +catch {unset x} +test expr-27.5 {cancelled evaluation} { + list [catch {expr {[info exists x] && $x}} msg] $msg +} {0 0} +test expr-27.6 {cancelled evaluation} { + list [catch {expr {0 && [concat $x]}} msg] $msg +} {0 0} +test expr-27.7 {cancelled evaluation} { + set one 1 + list [catch {expr {1 || 1/$one}} msg] $msg +} {0 1} +test expr-27.8 {cancelled evaluation} { + list [catch {expr {1 || -"string"}} msg] $msg +} {0 1} +test expr-27.9 {cancelled evaluation} { + list [catch {expr {1 || ("string" * ("x" && "y"))}} msg] $msg +} {0 1} +test expr-27.10 {cancelled evaluation} { + set x -1.0 + list [catch {expr {($x > 0) ? round(log($x)) : 0}} msg] $msg +} {0 0} + +# Tcl_ExprBool as used in "if" statements + +test expr-28.1 {Tcl_ExprBoolean usage} { + set a 1 + if {2} {set a 2} + set a +} 2 +test expr-28.2 {Tcl_ExprBoolean usage} { + set a 1 + if {0} {set a 2} + set a +} 1 +test expr-28.3 {Tcl_ExprBoolean usage} { + set a 1 + if {1.2} {set a 2} + set a +} 2 +test expr-28.4 {Tcl_ExprBoolean usage} { + set a 1 + if {-1.1} {set a 2} + set a +} 2 +test expr-28.5 {Tcl_ExprBoolean usage} { + set a 1 + if {0.0} {set a 2} + set a +} 1 +test expr-28.6 {Tcl_ExprBoolean usage} { + set a 1 + if {"YES"} {set a 2} + set a +} 2 +test expr-28.7 {Tcl_ExprBoolean usage} { + set a 1 + if {"no"} {set a 2} + set a +} 1 +test expr-28.8 {Tcl_ExprBoolean usage} { + set a 1 + if {"true"} {set a 2} + set a +} 2 +test expr-28.9 {Tcl_ExprBoolean usage} { + set a 1 + if {"fAlse"} {set a 2} + set a +} 1 +test expr-28.10 {Tcl_ExprBoolean usage} { + set a 1 + if {"on"} {set a 2} + set a +} 2 +test expr-28.11 {Tcl_ExprBoolean usage} { + set a 1 + if {"Off"} {set a 2} + set a +} 1 +test expr-28.12 {Tcl_ExprBool usage} { + list [catch {if {"abc"} {}} msg] $msg +} {1 {expected boolean value but got "abc"}} +test expr-28.13 {Tcl_ExprBool usage} { + list [catch {if {"ogle"} {}} msg] $msg +} {1 {expected boolean value but got "ogle"}} +test expr-28.14 {Tcl_ExprBool usage} { + list [catch {if {"o"} {}} msg] $msg +} {1 {expected boolean value but got "o"}} + +# Operands enclosed in braces + +test expr-29.1 {braces} {expr {{abc}}} abc +test expr-29.2 {braces} {expr {{00010}}} 8 +test expr-29.3 {braces} {expr {{3.1200000}}} 3.12 +test expr-29.4 {braces} {expr {{a{b}{1 {2 3}}c}}} "a{b}{1 {2 3}}c" +test expr-29.5 {braces} { + list [catch {expr "\{abc"} msg] $msg +} {1 {missing close-brace}} + +# Very long values + +test expr-30.1 {long values} { + set a "0000 1111 2222 3333 4444" + set a "$a | $a | $a | $a | $a" + set a "$a || $a || $a || $a || $a" + expr {$a} +} {0000 1111 2222 3333 4444 | 0000 1111 2222 3333 4444 | 0000 1111 2222 3333 4444 | 0000 1111 2222 3333 4444 | 0000 1111 2222 3333 4444 || 0000 1111 2222 3333 4444 | 0000 1111 2222 3333 4444 | 0000 1111 2222 3333 4444 | 0000 1111 2222 3333 4444 | 0000 1111 2222 3333 4444 || 0000 1111 2222 3333 4444 | 0000 1111 2222 3333 4444 | 0000 1111 2222 3333 4444 | 0000 1111 2222 3333 4444 | 0000 1111 2222 3333 4444 || 0000 1111 2222 3333 4444 | 0000 1111 2222 3333 4444 | 0000 1111 2222 3333 4444 | 0000 1111 2222 3333 4444 | 0000 1111 2222 3333 4444 || 0000 1111 2222 3333 4444 | 0000 1111 2222 3333 4444 | 0000 1111 2222 3333 4444 | 0000 1111 2222 3333 4444 | 0000 1111 2222 3333 4444} +test expr-30.2 {long values} { + set a "000000000000000000000000000000" + set a "$a$a$a$a$a$a$a$a$a$a$a$a$a$a$a$a${a}5" + expr $a +} 5 + +# Expressions spanning multiple arguments + +test expr-31.1 {multiple arguments to expr command} { + expr 4 + ( 6 *12) -3 +} 73 +test expr-31.2 {multiple arguments to expr command} { + list [catch {expr 2 + (3 + 4} msg] $msg +} {1 {unmatched parentheses in expression "2 + (3 + 4"}} +test expr-31.3 {multiple arguments to expr command} { + list [catch {expr 2 + 3 +} msg] $msg +} {1 {syntax error in expression "2 + 3 +"}} +test expr-31.4 {multiple arguments to expr command} { + list [catch {expr 2 + 3 )} msg] $msg +} {1 {syntax error in expression "2 + 3 )"}} + +# Math functions + +test expr-32.1 {math functions in expressions} { + expr acos(0.5) +} {1.0472} +test expr-32.2 {math functions in expressions} { + expr asin(0.5) +} {0.523599} +test expr-32.3 {math functions in expressions} { + expr atan(1.0) +} {0.785398} +test expr-32.4 {math functions in expressions} { + expr atan2(2.0, 2.0) +} {0.785398} +test expr-32.5 {math functions in expressions} { + expr ceil(1.999) +} {2.0} +test expr-32.6 {math functions in expressions} { + expr cos(.1) +} {0.995004} +test expr-32.7 {math functions in expressions} { + expr cosh(.1) +} {1.005} +test expr-32.8 {math functions in expressions} { + expr exp(1.0) +} {2.71828} +test expr-32.9 {math functions in expressions} { + expr floor(2.000) +} {2.0} +test expr-32.10 {math functions in expressions} { + expr floor(2.001) +} {2.0} +test expr-32.11 {math functions in expressions} { + expr fmod(7.3, 3.2) +} {0.9} +test expr-32.12 {math functions in expressions} { + expr hypot(3.0, 4.0) +} {5.0} +test expr-32.13 {math functions in expressions} { + expr log(2.8) +} {1.02962} +test expr-32.14 {math functions in expressions} { + expr log10(2.8) +} {0.447158} +test expr-32.15 {math functions in expressions} { + expr pow(2.1, 3.1) +} {9.97424} +test expr-32.16 {math functions in expressions} { + expr sin(.1) +} {0.0998334} +test expr-32.17 {math functions in expressions} { + expr sinh(.1) +} {0.100167} +test expr-32.18 {math functions in expressions} { + expr sqrt(2.0) +} {1.41421} +test expr-32.19 {math functions in expressions} { + expr tan(0.8) +} {1.02964} +test expr-32.20 {math functions in expressions} { + expr tanh(0.8) +} {0.664037} +test expr-32.21 {math functions in expressions} { + expr abs(-1.8) +} {1.8} +test expr-32.22 {math functions in expressions} { + expr abs(10.0) +} {10.0} +test expr-32.23 {math functions in expressions} { + expr abs(-4) +} {4} +test expr-32.24 {math functions in expressions} { + expr abs(66) +} {66} +test expr-32.25 {math functions in expressions} {nonPortable} { + list [catch {expr abs(0x80000000)} msg] $msg +} {1 {integer value too large to represent}} +test expr-32.26 {math functions in expressions} { + expr double(1) +} {1.0} +test expr-32.27 {math functions in expressions} { + expr double(1.1) +} {1.1} +test expr-32.28 {math functions in expressions} { + expr int(1) +} {1} +test expr-32.29 {math functions in expressions} { + expr int(1.4) +} {1} +test expr-32.30 {math functions in expressions} { + expr int(1.6) +} {1} +test expr-32.31 {math functions in expressions} { + expr int(-1.4) +} {-1} +test expr-32.32 {math functions in expressions} { + expr int(-1.6) +} {-1} +test expr-32.33 {math functions in expressions} { + list [catch {expr int(1e60)} msg] $msg +} {1 {integer value too large to represent}} +test expr-32.34 {math functions in expressions} { + list [catch {expr int(-1e60)} msg] $msg +} {1 {integer value too large to represent}} +test expr-32.35 {math functions in expressions} { + expr round(1.49) +} {1} +test expr-32.36 {math functions in expressions} { + expr round(1.51) +} {2} +test expr-32.37 {math functions in expressions} { + expr round(-1.49) +} {-1} +test expr-32.38 {math functions in expressions} { + expr round(-1.51) +} {-2} +test expr-32.39 {math functions in expressions} { + list [catch {expr round(1e60)} msg] $msg +} {1 {integer value too large to represent}} +test expr-32.40 {math functions in expressions} { + list [catch {expr round(-1e60)} msg] $msg +} {1 {integer value too large to represent}} +test expr-32.41 {math functions in expressions} { + list [catch {expr pow(1.0 + 3.0 - 2, .8 * 5)} msg] $msg +} {0 16.0} +test expr-32.42 {math functions in expressions} { + list [catch {expr hypot(5*.8,3)} msg] $msg +} {0 5.0} +if $gotT1 { + test expr-32.43 {math functions in expressions} { + expr 2*T1() + } 246 + test expr-32.44 {math functions in expressions} { + expr T2()*3 + } 1035 +} + +test expr-33.1 {conversions and fancy args to math functions} { + expr hypot ( 3 , 4 ) +} 5.0 +test expr-33.2 {conversions and fancy args to math functions} { + expr hypot ( (2.0+1.0) , 4 ) +} 5.0 +test expr-33.3 {conversions and fancy args to math functions} { + expr hypot ( 3 , (3.0 + 1.0) ) +} 5.0 +test expr-33.4 {conversions and fancy args to math functions} { + expr cos(acos(0.1)) +} 0.1 + +test expr-34.1 {errors in math functions} { + list [catch {expr func_2(1.0)} msg] $msg +} {1 {unknown math function "func_2"}} +test expr-34.2 {errors in math functions} { + list [catch {expr func|(1.0)} msg] $msg +} {1 {syntax error in expression "func|(1.0)"}} +test expr-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-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)"}} +test expr-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"}} +test expr-34.6 {errors in math functions} { + list [catch {expr hypot(1.0 ,} msg] $msg +} {1 {syntax error in expression "hypot(1.0 ,"}} +test expr-34.7 {errors in math functions} { + list [catch {expr hypot(1.0)} msg] $msg +} {1 {too few arguments for math function}} +test expr-34.8 {errors in math functions} { + list [catch {expr hypot(1.0, 2.0, 3.0)} msg] $msg +} {1 {too many arguments for math function}} +test expr-34.9 {errors in math functions} { + list [catch {expr acos(-2.0)} msg] $msg $errorCode +} {1 {domain error: argument not in valid range} {ARITH DOMAIN {domain error: argument not in valid range}}} +test expr-34.10 {errors in math functions} {nonPortable} { + list [catch {expr pow(-3, 1000001)} msg] $msg $errorCode +} {1 {floating-point value too large to represent} {ARITH OVERFLOW {floating-point value too large to represent}}} +test expr-34.11 {errors in math functions} { + list [catch {expr pow(3, 1000001)} msg] $msg $errorCode +} {1 {floating-point value too large to represent} {ARITH OVERFLOW {floating-point value too large to represent}}} +test expr-34.12 {errors in math functions} { + list [catch {expr -14.0*exp(100000)} msg] $msg $errorCode +} {1 {floating-point value too large to represent} {ARITH OVERFLOW {floating-point value too large to represent}}} +test expr-34.13 {errors in math functions} { + list [catch {expr int(1.0e30)} msg] $msg $errorCode +} {1 {integer value too large to represent} {ARITH IOVERFLOW {integer value too large to represent}}} +test expr-34.14 {errors in math functions} { + list [catch {expr int(-1.0e30)} msg] $msg $errorCode +} {1 {integer value too large to represent} {ARITH IOVERFLOW {integer value too large to represent}}} +test expr-34.15 {errors in math functions} { + list [catch {expr round(1.0e30)} msg] $msg $errorCode +} {1 {integer value too large to represent} {ARITH IOVERFLOW {integer value too large to represent}}} +test expr-34.16 {errors in math functions} { + list [catch {expr round(-1.0e30)} msg] $msg $errorCode +} {1 {integer value too large to represent} {ARITH IOVERFLOW {integer value too large to represent}}} +if $gotT1 { + test expr-34.17 {errors in math functions} { + list [catch {expr T1(4)} msg] $msg + } {1 {syntax error in expression "T1(4)"}} +} + +catch {unset tcl_precision} +test expr-35.1 {tcl_precision variable} { + expr 2.0/3 +} 0.666667 +set tcl_precision 1 +test expr-35.2 {tcl_precision variable} { + expr 2.0/3 +} 0.7 +test expr-35.3 {tcl_precision variable} { + expr 2.0/3 +} 0.7 +test expr-35.4 {tcl_precision variable} { + list [catch {set tcl_precision 0} msg] $msg [expr 2.0/3] +} {1 {can't set "tcl_precision": improper value for precision} 0.7} +test expr-35.5 {tcl_precision variable} { + list [catch {set tcl_precision 101} msg] $msg [expr 2.0/3] +} {1 {can't set "tcl_precision": improper value for precision} 0.7} +test expr-35.6 {tcl_precision variable} { + list [catch {set tcl_precision {}} msg] $msg [expr 2.0/3] +} {1 {can't set "tcl_precision": improper value for precision} 0.7} +test expr-35.7 {tcl_precision variable} { + list [catch {set tcl_precision {1 2 3}} msg] $msg [expr 2.0/3] +} {1 {can't set "tcl_precision": improper value for precision} 0.7} +catch {unset tcl_precision} +test expr-35.8 {tcl_precision variable} { + expr 2.0/3 +} 0.666667 + +test expr-36.1 {ExprLooksLikeInt procedure} { + list [catch {expr 0289} msg] $msg +} {1 {syntax error in expression "0289"}} +test expr-36.2 {ExprLooksLikeInt procedure} { + set x 0289 + list [catch {expr {$x+1}} msg] $msg +} {1 {can't use non-numeric string as operand of "+"}} +test expr-36.3 {ExprLooksLikeInt procedure} { + list [catch {expr 0289.1} msg] $msg +} {0 289.1} +test expr-36.4 {ExprLooksLikeInt procedure} { + set x 0289.1 + list [catch {expr {$x+1}} msg] $msg +} {0 290.1} +test expr-36.5 {ExprLooksLikeInt procedure} { + set x { +22} + list [catch {expr {$x+1}} msg] $msg +} {0 23} +test expr-36.6 {ExprLooksLikeInt procedure} { + set x { -22} + list [catch {expr {$x+1}} msg] $msg +} {0 -21} +test expr-36.7 {ExprLooksLikeInt procedure} {nonPortable unixOnly} { + list [catch {expr nan} msg] $msg +} {1 {domain error: argument not in valid range}} +test expr-36.8 {ExprLooksLikeInt procedure} { + list [catch {expr 78e1} msg] $msg +} {0 780.0} +test expr-36.9 {ExprLooksLikeInt procedure} { + list [catch {expr 24E1} msg] $msg +} {0 240.0} +test expr-36.10 {ExprLooksLikeInt procedure} {nonPortable unixOnly} { + list [catch {expr 78e} msg] $msg +} {1 {syntax error in expression "78e"}} + + +# Special test for Pentium arithmetic bug of 1994: + +if {(4195835.0 - (4195835.0/3145727.0)*3145727.0) == 256.0} { + puts "Warning: this machine contains a defective Pentium processor" + puts "that performs arithmetic incorrectly. I recommend that you" + puts "call Intel customer service immediately at 1-800-628-8686" + puts "to request a replacement processor." +} diff --git a/contrib/tcl/tests/fhandle.test b/contrib/tcl/tests/fhandle.test new file mode 100644 index 0000000..18fdb90 --- /dev/null +++ b/contrib/tcl/tests/fhandle.test @@ -0,0 +1,63 @@ +# This file tests the functions in tclFHandle.c file. +# +# 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) 1995-1996 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. +# +# SCCS: @(#) fhandle.test 1.3 96/03/26 11:49:04 + +if {[string compare test [info procs test]] == 1} then {source defs} + +if {[info commands testfhandle] == {}} { + puts "This application hasn't been compiled with the \"testfhandle\"" + puts "command, so I can't test the procedures in tclFHandle.c." + return +} + +test fhandle-1.1 {file handle creation/retrieval} { + testfhandle get 0 2 3 + testfhandle get 1 2 3 + set result [testfhandle compare 0 1] + testfhandle free 0 + set result +} {equal} +test fhandle-1.2 {file handle creation/retrieval} { + testfhandle get 0 2 3 + testfhandle get 1 2 4 + set result [testfhandle compare 0 1] + testfhandle free 0 + set result +} {notequal} +test fhandle-1.3 {file handle creation/retrieval} { + testfhandle get 0 2 3 + testfhandle get 1 2 4 + set result [testfhandle compare 0 1] + testfhandle free 0 + testfhandle free 1 + set result +} {notequal} +test fhandle-1.4 {file handle creation/retrieval} { + testfhandle get 0 2 3 + testfhandle get 1 5 3 + set result [testfhandle compare 0 1] + testfhandle free 0 + testfhandle free 1 + set result +} {notequal} +test fhandle-1.5 {file handle creation/retrieval} { + testfhandle get 0 5 6 + set result [testfhandle info2 0] + testfhandle free 0 + set result +} {5 6} +test fhandle-1.6 {file handle creation/retrieval} { + testfhandle get 0 5 6 + set result [testfhandle info1 0] + testfhandle free 0 + set result +} {5} diff --git a/contrib/tcl/tests/fileName.test b/contrib/tcl/tests/fileName.test new file mode 100644 index 0000000..26e84d9 --- /dev/null +++ b/contrib/tcl/tests/fileName.test @@ -0,0 +1,1401 @@ +# This file tests the filename manipulation routines. +# +# 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) 1995-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: @(#) fileName.test 1.20 96/04/19 12:36:13 + +if {[string compare test [info procs test]] == 1} then {source defs} + +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." + return +} + +global env +set platform [testgetplatform] + +test filename-1.1 {Tcl_GetPathType: unix} { + testsetplatform unix + file pathtype / +} absolute +test filename-1.2 {Tcl_GetPathType: unix} { + testsetplatform unix + file pathtype /foo +} absolute +test filename-1.3 {Tcl_GetPathType: unix} { + testsetplatform unix + file pathtype foo +} relative +test filename-1.4 {Tcl_GetPathType: unix} { + testsetplatform unix + file pathtype c:/foo +} relative +test filename-1.5 {Tcl_GetPathType: unix} { + testsetplatform unix + file pathtype ~ +} absolute +test filename-1.6 {Tcl_GetPathType: unix} { + testsetplatform unix + file pathtype ~/foo +} absolute +test filename-1.7 {Tcl_GetPathType: unix} { + testsetplatform unix + file pathtype ~foo +} absolute +test filename-1.8 {Tcl_GetPathType: unix} { + testsetplatform unix + file pathtype ./~foo +} relative + +test filename-2.1 {Tcl_GetPathType: mac, denerate names} { + testsetplatform mac + file pathtype / +} relative +test filename-2.2 {Tcl_GetPathType: mac, denerate names} { + testsetplatform mac + file pathtype /. +} relative +test filename-2.3 {Tcl_GetPathType: mac, denerate names} { + testsetplatform mac + file pathtype /.. +} relative +test filename-2.4 {Tcl_GetPathType: mac, denerate names} { + testsetplatform mac + file pathtype //.// +} relative +test filename-2.5 {Tcl_GetPathType: mac, denerate names} { + testsetplatform mac + file pathtype //.//../. +} relative +test filename-2.6 {Tcl_GetPathType: mac, tilde names} { + testsetplatform mac + file pathtype ~ +} absolute +test filename-2.7 {Tcl_GetPathType: mac, tilde names} { + testsetplatform mac + file pathtype ~: +} absolute +test filename-2.8 {Tcl_GetPathType: mac, tilde names} { + testsetplatform mac + file pathtype ~:foo +} absolute +test filename-2.9 {Tcl_GetPathType: mac, tilde names} { + testsetplatform mac + file pathtype ~/ +} absolute +test filename-2.10 {Tcl_GetPathType: mac, tilde names} { + testsetplatform mac + file pathtype ~/foo +} absolute +test filename-2.11 {Tcl_GetPathType: mac, unix-style names} { + testsetplatform mac + file pathtype /foo +} absolute +test filename-2.12 {Tcl_GetPathType: mac, unix-style names} { + testsetplatform mac + file pathtype /./foo +} absolute +test filename-2.13 {Tcl_GetPathType: mac, unix-style names} { + testsetplatform mac + file pathtype /..//./foo +} absolute +test filename-2.14 {Tcl_GetPathType: mac, unix-style names} { + testsetplatform mac + file pathtype /foo/bar +} absolute +test filename-2.15 {Tcl_GetPathType: mac, unix-style names} { + testsetplatform mac + file pathtype foo/bar +} relative +test filename-2.16 {Tcl_GetPathType: mac, mac-style names} { + testsetplatform mac + file pathtype : +} relative +test filename-2.17 {Tcl_GetPathType: mac, mac-style names} { + testsetplatform mac + file pathtype :foo +} relative +test filename-2.18 {Tcl_GetPathType: mac, mac-style names} { + testsetplatform mac + file pathtype foo: +} absolute +test filename-2.19 {Tcl_GetPathType: mac, mac-style names} { + testsetplatform mac + file pathtype foo:bar +} absolute +test filename-2.20 {Tcl_GetPathType: mac, mac-style names} { + testsetplatform mac + file pathtype :foo:bar +} relative +test filename-2.21 {Tcl_GetPathType: mac, mac-style names} { + testsetplatform mac + file pathtype ::foo:bar +} relative +test filename-2.22 {Tcl_GetPathType: mac, mac-style names} { + testsetplatform mac + file pathtype ~foo +} absolute +test filename-2.23 {Tcl_GetPathType: mac, mac-style names} { + testsetplatform mac + file pathtype :~foo +} relative +test filename-2.24 {Tcl_GetPathType: mac, mac-style names} { + testsetplatform mac + file pathtype ~foo: +} absolute +test filename-2.25 {Tcl_GetPathType: mac, mac-style names} { + testsetplatform mac + file pathtype foo/bar: +} absolute +test filename-2.26 {Tcl_GetPathType: mac, mac-style names} { + testsetplatform mac + file pathtype /foo: +} absolute +test filename-2.27 {Tcl_GetPathType: mac, mac-style names} { + testsetplatform mac + file pathtype foo +} relative + +test filename-3.1 {Tcl_GetPathType: windows} { + testsetplatform windows + file pathtype / +} volumerelative +test filename-3.2 {Tcl_GetPathType: windows} { + testsetplatform windows + file pathtype \\ +} volumerelative +test filename-3.3 {Tcl_GetPathType: windows} { + testsetplatform windows + file pathtype /foo +} volumerelative +test filename-3.4 {Tcl_GetPathType: windows} { + testsetplatform windows + file pathtype \\foo +} volumerelative +test filename-3.5 {Tcl_GetPathType: windows} { + testsetplatform windows + file pathtype c:/ +} absolute +test filename-3.6 {Tcl_GetPathType: windows} { + testsetplatform windows + file pathtype c:\\ +} absolute +test filename-3.7 {Tcl_GetPathType: windows} { + testsetplatform windows + file pathtype c:/foo +} absolute +test filename-3.8 {Tcl_GetPathType: windows} { + testsetplatform windows + file pathtype c:\\foo +} absolute +test filename-3.9 {Tcl_GetPathType: windows} { + testsetplatform windows + file pathtype c: +} volumerelative +test filename-3.10 {Tcl_GetPathType: windows} { + testsetplatform windows + file pathtype c:foo +} volumerelative +test filename-3.11 {Tcl_GetPathType: windows} { + testsetplatform windows + file pathtype foo +} relative +test filename-3.12 {Tcl_GetPathType: windows} { + testsetplatform windows + file pathtype //foo/bar +} absolute +test filename-3.13 {Tcl_GetPathType: windows} { + testsetplatform windows + file pathtype ~foo +} absolute +test filename-3.14 {Tcl_GetPathType: windows} { + testsetplatform windows + file pathtype ~ +} absolute +test filename-3.15 {Tcl_GetPathType: windows} { + testsetplatform windows + file pathtype ~/foo +} absolute +test filename-3.16 {Tcl_GetPathType: windows} { + testsetplatform windows + file pathtype ./~foo +} relative + +test filename-4.1 {Tcl_SplitPath: unix} { + testsetplatform unix + file split / +} {/} +test filename-4.2 {Tcl_SplitPath: unix} { + testsetplatform unix + file split /foo +} {/ foo} +test filename-4.3 {Tcl_SplitPath: unix} { + testsetplatform unix + file split /foo/bar +} {/ foo bar} +test filename-4.4 {Tcl_SplitPath: unix} { + testsetplatform unix + file split /foo/bar/baz +} {/ foo bar baz} +test filename-4.5 {Tcl_SplitPath: unix} { + testsetplatform unix + file split foo/bar +} {foo bar} +test filename-4.6 {Tcl_SplitPath: unix} { + testsetplatform unix + file split ./foo/bar +} {. foo bar} +test filename-4.7 {Tcl_SplitPath: unix} { + testsetplatform unix + file split /foo/../././foo/bar +} {/ foo .. . . foo bar} +test filename-4.8 {Tcl_SplitPath: unix} { + testsetplatform unix + file split ../foo/bar +} {.. foo bar} +test filename-4.9 {Tcl_SplitPath: unix} { + testsetplatform unix + file split {} +} {} +test filename-4.10 {Tcl_SplitPath: unix} { + testsetplatform unix + file split . +} {.} +test filename-4.11 {Tcl_SplitPath: unix} { + testsetplatform unix + file split ../ +} {..} +test filename-4.12 {Tcl_SplitPath: unix} { + testsetplatform unix + file split ../.. +} {.. ..} +test filename-4.13 {Tcl_SplitPath: unix} { + testsetplatform unix + file split //foo +} {/ foo} +test filename-4.14 {Tcl_SplitPath: unix} { + testsetplatform unix + file split foo//bar +} {foo bar} +test filename-4.15 {Tcl_SplitPath: unix} { + testsetplatform unix + file split ~foo +} {~foo} +test filename-4.16 {Tcl_SplitPath: unix} { + testsetplatform unix + file split ~foo/~bar +} {~foo ./~bar} +test filename-4.17 {Tcl_SplitPath: unix} { + testsetplatform unix + file split ~foo/~bar/~baz +} {~foo ./~bar ./~baz} +test filename-4.18 {Tcl_SplitPath: unix} { + testsetplatform unix + file split foo/bar~/baz +} {foo bar~ baz} + +test filename-5.1 {Tcl_SplitPath: mac} { + testsetplatform mac + file split a:b +} {a: b} +test filename-5.2 {Tcl_SplitPath: mac} { + testsetplatform mac + file split a:b:c +} {a: b c} +test filename-5.3 {Tcl_SplitPath: mac} { + testsetplatform mac + file split a:b:c: +} {a: b c} +test filename-5.4 {Tcl_SplitPath: mac} { + testsetplatform mac + file split a: +} {a:} +test filename-5.5 {Tcl_SplitPath: mac} { + testsetplatform mac + file split a:: +} {a: ::} +test filename-5.6 {Tcl_SplitPath: mac} { + testsetplatform mac + file split a::: +} {a: :: ::} +test filename-5.7 {Tcl_SplitPath: mac} { + testsetplatform mac + file split :a +} {a} +test filename-5.8 {Tcl_SplitPath: mac} { + testsetplatform mac + file split :a:: +} {a ::} +test filename-5.9 {Tcl_SplitPath: mac} { + testsetplatform mac + file split : +} {:} +test filename-5.10 {Tcl_SplitPath: mac} { + testsetplatform mac + file split :: +} {::} +test filename-5.11 {Tcl_SplitPath: mac} { + testsetplatform mac + file split ::: +} {:: ::} +test filename-5.12 {Tcl_SplitPath: mac} { + testsetplatform mac + file split a:::b +} {a: :: :: b} +test filename-5.13 {Tcl_SplitPath: mac} { + testsetplatform mac + file split /a:b +} {/a: b} +test filename-5.14 {Tcl_SplitPath: mac} { + testsetplatform mac + file split ~: +} {~:} +test filename-5.15 {Tcl_SplitPath: mac} { + testsetplatform mac + file split ~/: +} {~/:} +test filename-5.16 {Tcl_SplitPath: mac} { + testsetplatform mac + file split ~:foo +} {~: foo} +test filename-5.17 {Tcl_SplitPath: mac} { + testsetplatform mac + file split ~/foo +} {~: foo} +test filename-5.18 {Tcl_SplitPath: mac} { + testsetplatform mac + file split ~foo: +} {~foo:} +test filename-5.19 {Tcl_SplitPath: mac} { + testsetplatform mac + file split a:~foo +} {a: :~foo} +test filename-5.20 {Tcl_SplitPath: mac} { + testsetplatform mac + file split / +} {:/} +test filename-5.21 {Tcl_SplitPath: mac} { + testsetplatform mac + file split a:b/c +} {a: :b/c} +test filename-5.22 {Tcl_SplitPath: mac} { + testsetplatform mac + file split /foo +} {foo:} +test filename-5.23 {Tcl_SplitPath: mac} { + testsetplatform mac + file split /a/b +} {a: b} +test filename-5.24 {Tcl_SplitPath: mac} { + testsetplatform mac + file split /a/b/foo +} {a: b foo} +test filename-5.25 {Tcl_SplitPath: mac} { + testsetplatform mac + file split a/b +} {a b} +test filename-5.26 {Tcl_SplitPath: mac} { + testsetplatform mac + file split ./foo/bar +} {: foo bar} +test filename-5.27 {Tcl_SplitPath: mac} { + testsetplatform mac + file split ../foo/bar +} {:: foo bar} +test filename-5.28 {Tcl_SplitPath: mac} { + testsetplatform mac + file split {} +} {} +test filename-5.29 {Tcl_SplitPath: mac} { + testsetplatform mac + file split . +} {:} +test filename-5.30 {Tcl_SplitPath: mac} { + testsetplatform mac + file split ././ +} {: :} +test filename-5.31 {Tcl_SplitPath: mac} { + testsetplatform mac + file split ././. +} {: : :} +test filename-5.32 {Tcl_SplitPath: mac} { + testsetplatform mac + file split ../ +} {::} +test filename-5.33 {Tcl_SplitPath: mac} { + testsetplatform mac + file split .. +} {::} +test filename-5.34 {Tcl_SplitPath: mac} { + testsetplatform mac + file split ../.. +} {:: ::} +test filename-5.35 {Tcl_SplitPath: mac} { + testsetplatform mac + file split //foo +} {foo:} +test filename-5.36 {Tcl_SplitPath: mac} { + testsetplatform mac + file split foo//bar +} {foo bar} +test filename-5.37 {Tcl_SplitPath: mac} { + testsetplatform mac + file split ~foo +} {~foo:} +test filename-5.38 {Tcl_SplitPath: mac} { + testsetplatform mac + file split ~ +} {~:} +test filename-5.39 {Tcl_SplitPath: mac} { + testsetplatform mac + file split foo +} {foo} +test filename-5.40 {Tcl_SplitPath: mac} { + testsetplatform mac + file split ~/ +} {~:} +test filename-5.41 {Tcl_SplitPath: mac} { + testsetplatform mac + file split ~foo/~bar +} {~foo: :~bar} +test filename-5.42 {Tcl_SplitPath: mac} { + testsetplatform mac + file split ~foo/~bar/~baz +} {~foo: :~bar :~baz} +test filename-5.43 {Tcl_SplitPath: mac} { + testsetplatform mac + file split foo/bar~/baz +} {foo bar~ baz} +test filename-5.44 {Tcl_SplitPath: mac} { + testsetplatform mac + file split a/../b +} {a :: b} +test filename-5.45 {Tcl_SplitPath: mac} { + testsetplatform mac + file split a/../../b +} {a :: :: b} +test filename-5.46 {Tcl_SplitPath: mac} { + testsetplatform mac + file split a/.././../b +} {a :: : :: b} +test filename-5.47 {Tcl_SplitPath: mac} { + testsetplatform mac + file split /../bar +} {bar:} +test filename-5.48 {Tcl_SplitPath: mac} { + testsetplatform mac + file split /./bar +} {bar:} +test filename-5.49 {Tcl_SplitPath: mac} { + testsetplatform mac + file split //.//.././bar +} {bar:} +test filename-5.50 {Tcl_SplitPath: mac} { + testsetplatform mac + file split /.. +} {:/..} +test filename-5.51 {Tcl_SplitPath: mac} { + testsetplatform mac + file split //.//.././ +} {://.//.././} + +test filename-6.1 {Tcl_SplitPath: win} { + testsetplatform win + file split / +} {/} +test filename-6.2 {Tcl_SplitPath: win} { + testsetplatform win + file split /foo +} {/ foo} +test filename-6.3 {Tcl_SplitPath: win} { + testsetplatform win + file split /foo/bar +} {/ foo bar} +test filename-6.4 {Tcl_SplitPath: win} { + testsetplatform win + file split /foo/bar/baz +} {/ foo bar baz} +test filename-6.5 {Tcl_SplitPath: win} { + testsetplatform win + file split foo/bar +} {foo bar} +test filename-6.6 {Tcl_SplitPath: win} { + testsetplatform win + file split ./foo/bar +} {. foo bar} +test filename-6.7 {Tcl_SplitPath: win} { + testsetplatform win + file split /foo/../././foo/bar +} {/ foo .. . . foo bar} +test filename-6.8 {Tcl_SplitPath: win} { + testsetplatform win + file split ../foo/bar +} {.. foo bar} +test filename-6.9 {Tcl_SplitPath: win} { + testsetplatform win + file split {} +} {} +test filename-6.10 {Tcl_SplitPath: win} { + testsetplatform win + file split . +} {.} +test filename-6.11 {Tcl_SplitPath: win} { + testsetplatform win + file split ../ +} {..} +test filename-6.12 {Tcl_SplitPath: win} { + testsetplatform win + file split ../.. +} {.. ..} +test filename-6.13 {Tcl_SplitPath: win} { + testsetplatform win + file split //foo +} {/ foo} +test filename-6.14 {Tcl_SplitPath: win} { + testsetplatform win + file split foo//bar +} {foo bar} +test filename-6.15 {Tcl_SplitPath: win} { + testsetplatform win + file split /\\/foo//bar +} {//foo/bar} +test filename-6.16 {Tcl_SplitPath: win} { + testsetplatform win + file split /\\/foo//bar +} {//foo/bar} +test filename-6.17 {Tcl_SplitPath: win} { + testsetplatform win + file split /\\/foo//bar +} {//foo/bar} +test filename-6.18 {Tcl_SplitPath: win} { + testsetplatform win + file split \\\\foo\\bar +} {//foo/bar} +test filename-6.19 {Tcl_SplitPath: win} { + testsetplatform win + file split \\\\foo\\bar/baz +} {//foo/bar baz} +test filename-6.20 {Tcl_SplitPath: win} { + testsetplatform win + file split c:/foo +} {c:/ foo} +test filename-6.21 {Tcl_SplitPath: win} { + testsetplatform win + file split c:foo +} {c: foo} +test filename-6.22 {Tcl_SplitPath: win} { + testsetplatform win + file split c: +} {c:} +test filename-6.23 {Tcl_SplitPath: win} { + testsetplatform win + file split c:\\ +} {c:/} +test filename-6.24 {Tcl_SplitPath: win} { + testsetplatform win + file split c:/ +} {c:/} +test filename-6.25 {Tcl_SplitPath: win} { + testsetplatform win + file split c:/./.. +} {c:/ . ..} +test filename-6.26 {Tcl_SplitPath: win} { + testsetplatform win + file split ~foo +} {~foo} +test filename-6.27 {Tcl_SplitPath: win} { + testsetplatform win + file split ~foo/~bar +} {~foo ./~bar} +test filename-6.28 {Tcl_SplitPath: win} { + testsetplatform win + file split ~foo/~bar/~baz +} {~foo ./~bar ./~baz} +test filename-6.29 {Tcl_SplitPath: win} { + testsetplatform win + file split foo/bar~/baz +} {foo bar~ baz} +test filename-6.30 {Tcl_SplitPath: win} { + testsetplatform win + file split c:~foo +} {c: ./~foo} + +test filename-7.1 {Tcl_JoinPath: unix} { + testsetplatform unix + file join / a +} {/a} +test filename-7.2 {Tcl_JoinPath: unix} { + testsetplatform unix + file join a b +} {a/b} +test filename-7.3 {Tcl_JoinPath: unix} { + testsetplatform unix + file join /a c /b d +} {/b/d} +test filename-7.4 {Tcl_JoinPath: unix} { + testsetplatform unix + file join / +} {/} +test filename-7.5 {Tcl_JoinPath: unix} { + testsetplatform unix + file join a +} {a} +test filename-7.6 {Tcl_JoinPath: unix} { + testsetplatform unix + file join {} +} {} +test filename-7.7 {Tcl_JoinPath: unix} { + testsetplatform unix + file join /a/ b +} {/a/b} +test filename-7.8 {Tcl_JoinPath: unix} { + testsetplatform unix + file join /a// b +} {/a/b} +test filename-7.9 {Tcl_JoinPath: unix} { + testsetplatform unix + file join /a/./../. b +} {/a/./.././b} +test filename-7.10 {Tcl_JoinPath: unix} { + testsetplatform unix + file join ~ a +} {~/a} +test filename-7.11 {Tcl_JoinPath: unix} { + testsetplatform unix + file join ~a ~b +} {~b} +test filename-7.12 {Tcl_JoinPath: unix} { + testsetplatform unix + file join ./~a b +} {./~a/b} +test filename-7.13 {Tcl_JoinPath: unix} { + testsetplatform unix + file join ./~a ~b +} {~b} +test filename-7.14 {Tcl_JoinPath: unix} { + testsetplatform unix + file join ./~a ./~b +} {./~a/~b} +test filename-7.15 {Tcl_JoinPath: unix} { + testsetplatform unix + file join a . b +} {a/./b} +test filename-7.16 {Tcl_JoinPath: unix} { + testsetplatform unix + file join a . ./~b +} {a/./~b} +test filename-7.17 {Tcl_JoinPath: unix} { + testsetplatform unix + file join //a b +} {/a/b} +test filename-7.18 {Tcl_JoinPath: unix} { + testsetplatform unix + file join /// a b +} {/a/b} + +test filename-8.1 {Tcl_JoinPath: mac} { + testsetplatform mac + file join a b +} {:a:b} +test filename-8.2 {Tcl_JoinPath: mac} { + testsetplatform mac + file join :a b +} {:a:b} +test filename-8.3 {Tcl_JoinPath: mac} { + testsetplatform mac + file join a b: +} {b:} +test filename-8.4 {Tcl_JoinPath: mac} { + testsetplatform mac + file join a: :b +} {a:b} +test filename-8.5 {Tcl_JoinPath: mac} { + testsetplatform mac + file join a: :b: +} {a:b} +test filename-8.6 {Tcl_JoinPath: mac} { + testsetplatform mac + file join a :: b +} {:a::b} +test filename-8.7 {Tcl_JoinPath: mac} { + testsetplatform mac + file join a :: :: b +} {:a:::b} +test filename-8.8 {Tcl_JoinPath: mac} { + testsetplatform mac + file join a ::: b +} {:a:::b} +test filename-8.9 {Tcl_JoinPath: mac} { + testsetplatform mac + file join a: b: +} {b:} +test filename-8.10 {Tcl_JoinPath: mac} { + testsetplatform mac + file join /a/b +} {a:b} +test filename-8.11 {Tcl_JoinPath: mac} { + testsetplatform mac + file join /a/b c/d +} {a:b:c:d} +test filename-8.12 {Tcl_JoinPath: mac} { + testsetplatform mac + file join /a/b :c:d +} {a:b:c:d} +test filename-8.13 {Tcl_JoinPath: mac} { + testsetplatform mac + file join ~ foo +} {~:foo} +test filename-8.14 {Tcl_JoinPath: mac} { + testsetplatform mac + file join :: :: +} {:::} +test filename-8.15 {Tcl_JoinPath: mac} { + testsetplatform mac + file join a: :: +} {a::} +test filename-8.16 {Tcl_JoinPath: mac} { + testsetplatform mac + file join a {} b +} {:a:b} +test filename-8.17 {Tcl_JoinPath: mac} { + testsetplatform mac + file join a::: b +} {a:::b} +test filename-8.18 {Tcl_JoinPath: mac} { + testsetplatform mac + file join a : : : +} {:a} +test filename-8.19 {Tcl_JoinPath: mac} { + testsetplatform mac + file join : +} {:} +test filename-8.20 {Tcl_JoinPath: mac} { + testsetplatform mac + file join : a +} {:a} +test filename-8.21 {Tcl_JoinPath: mac} { + testsetplatform mac + file join a: :b/c +} {a:b/c} +test filename-8.22 {Tcl_JoinPath: mac} { + testsetplatform mac + file join :a :b/c +} {:a:b/c} + +test filename-9.1 {Tcl_JoinPath: win} { + testsetplatform win + file join a b +} {a/b} +test filename-9.2 {Tcl_JoinPath: win} { + testsetplatform win + file join /a b +} {/a/b} +test filename-9.3 {Tcl_JoinPath: win} { + testsetplatform win + file join /a /b +} {/b} +test filename-9.4 {Tcl_JoinPath: win} { + testsetplatform win + file join c: foo +} {c:foo} +test filename-9.5 {Tcl_JoinPath: win} { + testsetplatform win + file join c:/ foo +} {c:/foo} +test filename-9.6 {Tcl_JoinPath: win} { + testsetplatform win + file join c:\\bar foo +} {c:/bar/foo} +test filename-9.7 {Tcl_JoinPath: win} { + testsetplatform win + file join /foo c:bar +} {c:bar} +test filename-9.8 {Tcl_JoinPath: win} { + testsetplatform win + file join ///host//share dir +} {//host/share/dir} +test filename-9.9 {Tcl_JoinPath: win} { + testsetplatform win + file join ~ foo +} {~/foo} +test filename-9.10 {Tcl_JoinPath: win} { + testsetplatform win + file join ~/~foo +} {~/~foo} +test filename-9.11 {Tcl_JoinPath: win} { + testsetplatform win + file join ~ ./~foo +} {~/~foo} +test filename-9.12 {Tcl_JoinPath: win} { + testsetplatform win + file join / ~foo +} {~foo} +test filename-9.13 {Tcl_JoinPath: win} { + testsetplatform win + file join ./a/ b c +} {./a/b/c} +test filename-9.14 {Tcl_JoinPath: win} { + testsetplatform win + file join ./~a/ b c +} {./~a/b/c} +test filename-9.15 {Tcl_JoinPath: win} { + testsetplatform win + file join // host share path +} {/host/share/path} +test filename-9.16 {Tcl_JoinPath: win} { + testsetplatform win + file join foo . bar +} {foo/./bar} +test filename-9.17 {Tcl_JoinPath: win} { + testsetplatform win + file join foo .. bar +} {foo/../bar} +test filename-9.18 {Tcl_JoinPath: win} { + testsetplatform win + file join foo/./bar +} {foo/./bar} + +test filename-10.1 {Tcl_TranslateFileName} { + testsetplatform unix + list [catch {testtranslatefilename foo} msg] $msg +} {0 foo} +test filename-10.2 {Tcl_TranslateFileName} { + testsetplatform windows + list [catch {testtranslatefilename {c:/foo}} msg] $msg +} {0 {c:\foo}} +test filename-10.3 {Tcl_TranslateFileName} { + testsetplatform windows + list [catch {testtranslatefilename {c:/\\foo/}} msg] $msg +} {0 {c:\foo}} +test filename-10.4 {Tcl_TranslateFileName} { + testsetplatform mac + list [catch {testtranslatefilename foo} msg] $msg +} {0 :foo} +test filename-10.5 {Tcl_TranslateFileName} { + testsetplatform mac + list [catch {testtranslatefilename :~foo} msg] $msg +} {0 :~foo} +test filename-10.6 {Tcl_TranslateFileName} { + global env + set temp $env(HOME) + set env(HOME) "/home/test" + testsetplatform unix + set result [list [catch {testtranslatefilename ~/foo} msg] $msg] + set env(HOME) $temp + set result +} {0 /home/test/foo} +test filename-10.7 {Tcl_TranslateFileName} { + global env + set temp $env(HOME) + unset env(HOME) + testsetplatform unix + set result [list [catch {testtranslatefilename ~/foo} msg] $msg] + set env(HOME) $temp + set result +} {1 {couldn't find HOME environment variable to expand path}} +test filename-10.8 {Tcl_TranslateFileName} { + global env + set temp $env(HOME) + set env(HOME) "/home/test" + testsetplatform unix + set result [list [catch {testtranslatefilename ~} msg] $msg] + set env(HOME) $temp + set result +} {0 /home/test} +test filename-10.9 {Tcl_TranslateFileName} { + global env + set temp $env(HOME) + set env(HOME) "/home/test/" + testsetplatform unix + set result [list [catch {testtranslatefilename ~} msg] $msg] + set env(HOME) $temp + set result +} {0 /home/test} +test filename-10.10 {Tcl_TranslateFileName} { + global env + set temp $env(HOME) + set env(HOME) "/home/test/" + testsetplatform unix + set result [list [catch {testtranslatefilename ~/foo} msg] $msg] + set env(HOME) $temp + set result +} {0 /home/test/foo} +test filename-10.11 {Tcl_TranslateFileName} { + global env + set temp $env(HOME) + set env(HOME) "Root:" + testsetplatform mac + set result [list [catch {testtranslatefilename ~/foo} msg] $msg] + set env(HOME) $temp + set result +} {0 Root:foo} +test filename-10.12 {Tcl_TranslateFileName} { + global env + set temp $env(HOME) + set env(HOME) "Root:home" + testsetplatform mac + set result [list [catch {testtranslatefilename ~/foo} msg] $msg] + set env(HOME) $temp + set result +} {0 Root:home:foo} +test filename-10.13 {Tcl_TranslateFileName} { + global env + set temp $env(HOME) + set env(HOME) "Root:home" + testsetplatform mac + set result [list [catch {testtranslatefilename ~::foo} msg] $msg] + set env(HOME) $temp + set result +} {0 Root:home::foo} +test filename-10.14 {Tcl_TranslateFileName} { + global env + set temp $env(HOME) + set env(HOME) "Root:home" + testsetplatform mac + set result [list [catch {testtranslatefilename ~} msg] $msg] + set env(HOME) $temp + set result +} {0 Root:home} +test filename-10.15 {Tcl_TranslateFileName} { + global env + set temp $env(HOME) + set env(HOME) "Root:home:" + testsetplatform mac + set result [list [catch {testtranslatefilename ~::foo} msg] $msg] + set env(HOME) $temp + set result +} {0 Root:home::foo} +test filename-10.16 {Tcl_TranslateFileName} { + global env + set temp $env(HOME) + set env(HOME) "Root:home::" + testsetplatform mac + set result [list [catch {testtranslatefilename ~::foo} msg] $msg] + set env(HOME) $temp + set result +} {0 Root:home:::foo} +test filename-10.17 {Tcl_TranslateFileName} { + global env + set temp $env(HOME) + set env(HOME) "\\home\\" + testsetplatform windows + set result [list [catch {testtranslatefilename ~/foo} msg] $msg] + set env(HOME) $temp + set result +} {0 {\home\foo}} +test filename-10.18 {Tcl_TranslateFileName} { + global env + set temp $env(HOME) + set env(HOME) "\\home\\" + testsetplatform windows + set result [list [catch {testtranslatefilename ~/foo\\bar} msg] $msg] + set env(HOME) $temp + set result +} {0 {\home\foo\bar}} +test filename-10.19 {Tcl_TranslateFileName} { + global env + set temp $env(HOME) + set env(HOME) "c:" + testsetplatform windows + set result [list [catch {testtranslatefilename ~/foo} msg] $msg] + set env(HOME) $temp + set result +} {0 c:foo} +test filename-10.20 {Tcl_TranslateFileName} { + list [catch {testtranslatefilename ~blorp/foo} msg] $msg +} {1 {user "blorp" doesn't exist}} +test filename-10.21 {Tcl_TranslateFileName} { + global env + set temp $env(HOME) + set env(HOME) "c:\\" + testsetplatform windows + set result [list [catch {testtranslatefilename ~/foo} msg] $msg] + set env(HOME) $temp + set result +} {0 {c:\foo}} +test filename-10.22 {Tcl_TranslateFileName} { + testsetplatform windows + list [catch {testtranslatefilename foo//bar} msg] $msg +} {0 {foo\bar}} + +testsetplatform $platform + +test filename-10.23 {Tcl_TranslateFileName} {nonPortable unixOnly} { + # this test fails if ~ouster is not /home/ouster + list [catch {testtranslatefilename ~ouster} msg] $msg +} {0 /home/ouster} +test filename-10.24 {Tcl_TranslateFileName} {nonPortable unixOnly} { + # this test fails if ~ouster is not /home/ouster + list [catch {testtranslatefilename ~ouster/foo} msg] $msg +} {0 /home/ouster/foo} + + +test filename-11.1 {Tcl_GlobCmd} { + list [catch {glob} msg] $msg +} {1 {wrong # args: should be "glob ?switches? name ?name ...?"}} +test filename-11.2 {Tcl_GlobCmd} { + list [catch {glob -gorp} msg] $msg +} {1 {bad switch "-gorp": must be -nocomplain or --}} +test filename-11.3 {Tcl_GlobCmd} { + list [catch {glob -nocomplai} msg] $msg +} {1 {bad switch "-nocomplai": must be -nocomplain or --}} +test filename-11.4 {Tcl_GlobCmd} { + list [catch {glob -nocomplain} msg] $msg +} {1 {wrong # args: should be "glob ?switches? name ?name ...?"}} +test filename-11.5 {Tcl_GlobCmd} { + list [catch {glob -nocomplain ~xyqrszzz} msg] $msg +} {0 {}} +test filename-11.6 {Tcl_GlobCmd} { + list [catch {glob ~xyqrszzz} msg] $msg +} {1 {user "xyqrszzz" doesn't exist}} +test filename-11.7 {Tcl_GlobCmd} { + list [catch {glob -- -nocomplain} msg] $msg +} {1 {no files matched glob patterns "-nocomplain"}} +test filename-11.8 {Tcl_GlobCmd} { + list [catch {glob -nocomplain -- -nocomplain} msg] $msg +} {0 {}} +test filename-11.9 {Tcl_GlobCmd} { + testsetplatform unix + list [catch {glob ~\\xyqrszzz/bar} msg] $msg +} {1 {globbing characters not supported in user names}} +test filename-11.10 {Tcl_GlobCmd} { + testsetplatform unix + list [catch {glob -nocomplain ~\\xyqrszzz/bar} msg] $msg +} {0 {}} +test filename-11.11 {Tcl_GlobCmd} { + testsetplatform unix + list [catch {glob ~xyqrszzz\\/\\bar} msg] $msg +} {1 {user "xyqrszzz" doesn't exist}} +test filename-11.12 {Tcl_GlobCmd} { + testsetplatform unix + set home $env(HOME) + unset env(HOME) + set x [list [catch {glob ~/*} msg] $msg] + set env(HOME) $home + set x +} {1 {couldn't find HOME environment variable to expand path}} + +testsetplatform $platform + +test filename-11.13 {Tcl_GlobCmd} { + list [catch {glob ~} msg] $msg +} [list 0 [list $env(HOME)]] + +# The following tests will work on Windows platforms only if MKS +# toolkit is installed. + +catch { + set oldhome $env(HOME) + set env(HOME) [pwd] + removeDirectory globTest + makeDirectory globTest + makeDirectory globTest/a1 + makeDirectory globTest/a2 + makeDirectory globTest/a3 + makeDirectory globTest/a1/b1 + makeDirectory globTest/a1/b2 + makeDirectory globTest/a2/b3 + close [open globTest/x1.c w] + close [open globTest/y1.c w] + close [open globTest/z1.c w] + close [open globTest/x,z1.c w] + close [open "globTest/weird name.c" w] + close [open globTest/.1 w] + close [open globTest/a1/b1/x2.c w] + close [open globTest/a1/b2/y2.c w] +} + +test filename-11.14 {Tcl_GlobCmd} {unixExecs} { + list [catch {glob ~/globTest} msg] $msg +} [list 0 [list [file join $env(HOME) globTest]]] +test filename-11.15 {Tcl_GlobCmd} {unixExecs} { + list [catch {glob ~\\/globTest} msg] $msg +} [list 0 [list [file join $env(HOME) globTest]]] +test filename-11.16 {Tcl_GlobCmd} {unixExecs} { + list [catch {glob globTest} msg] $msg +} {0 globTest} + +test filename-12.1 {simple globbing} {unixOrPc} { + list [catch {glob {}} msg] $msg +} {0 .} +test filename-12.2 {simple globbing} {macOnly} { + list [catch {glob {}} msg] $msg +} {0 :} +test filename-12.3 {simple globbing} { + list [catch {glob -nocomplain \{a1,a2\}} msg] $msg +} {0 {}} + +if {$tcl_platform(platform) == "macintosh"} { + set globPreResult :globTest: +} else { + set globPreResult globTest/ +} +set x1 x1.c +set y1 y1.c +test filename-12.4 {simple globbing} {unixOrPC} { + lsort [glob globTest/x1.c globTest/y1.c globTest/foo] +} "$globPreResult$x1 $globPreResult$y1" +test filename-12.5 {simple globbing} {unixExecs} { + list [catch {glob globTest\\/x1.c} msg] $msg +} "0 $globPreResult$x1" +test filename-12.6 {simple globbing} {unixExecs} { + list [catch {glob globTest\\/\\x1.c} msg] $msg +} "0 $globPreResult$x1" + +test filename-13.1 {globbing with brace substitution} {unixExecs} { + list [catch {glob globTest/\{\}} msg] $msg +} "0 $globPreResult" +test filename-13.2 {globbing with brace substitution} { + list [catch {glob globTest/\{} msg] $msg +} {1 {unmatched open-brace in file name}} +test filename-13.3 {globbing with brace substitution} { + list [catch {glob globTest/\{\\\}} msg] $msg +} {1 {unmatched open-brace in file name}} +test filename-13.4 {globbing with brace substitution} { + list [catch {glob globTest/\{\\} msg] $msg +} {1 {unmatched open-brace in file name}} +test filename-13.5 {globbing with brace substitution} { + list [catch {glob globTest/\}} msg] $msg +} {1 {unmatched close-brace in file name}} +test filename-13.6 {globbing with brace substitution} {unixExecs} { + list [catch {glob globTest/\{\}x1.c} msg] $msg +} "0 $globPreResult$x1" +test filename-13.7 {globbing with brace substitution} {unixExecs} { + list [catch {glob globTest/\{x\}1.c} msg] $msg +} "0 $globPreResult$x1" +test filename-13.8 {globbing with brace substitution} {unixExecs} { + list [catch {glob globTest/\{x\{\}\}1.c} msg] $msg +} "0 $globPreResult$x1" +test filename-13.9 {globbing with brace substitution} {unixExecs} { + list [lsort [catch {glob globTest/\{x,y\}1.c} msg]] $msg +} [list 0 [list $globPreResult$x1 $globPreResult$y1]] +test filename-13.10 {globbing with brace substitution} {unixExecs} { + list [lsort [catch {glob globTest/\{x,,y\}1.c} msg]] $msg +} [list 0 [list $globPreResult$x1 $globPreResult$y1]] +test filename-13.11 {globbing with brace substitution} {unixOrPc unixExecs} { + list [lsort [catch {glob globTest/\{x,x\\,z,z\}1.c} msg]] $msg +} {0 {globTest/x1.c globTest/x,z1.c globTest/z1.c}} +test filename-13.11 {globbing with brace substitution} {macOnly} { + list [lsort [catch {glob globTest/\{x,x\\,z,z\}1.c} msg]] $msg +} {0 {:globTest:x1.c :globTest:x,z1.c :globTest:z1.c}} +test filename-13.12 {globbing with brace substitution} {unixExecs} { + lsort [glob globTest/{a,b,x,y}1.c] +} [list $globPreResult$x1 $globPreResult$y1] +test filename-13.13 {globbing with brace substitution} {unixOrPc unixExecs} { + lsort [glob {globTest/{x1,y2,weird name}.c}] +} {{globTest/weird name.c} globTest/x1.c} +test filename-13.13 {globbing with brace substitution} {macOnly} { + lsort [glob {globTest/{x1,y2,weird name}.c}] +} {{:globTest:weird name.c} :globTest:x1.c} +test filename-13.14 {globbing with brace substitution} {unixOrPc unixExecs} { + lsort [glob globTest/{x1.c,a1/*}] +} {globTest/a1/b1 globTest/a1/b2 globTest/x1.c} +test filename-13.14 {globbing with brace substitution} {macOnly} { + lsort [glob globTest/{x1.c,a1/*}] +} {:globTest:a1:b1 :globTest:a1:b2 :globTest:x1.c} +test filename-13.15 {globbing with brace substitution} {unixOrPc unixExecs} { + lsort [glob globTest/{x1.c,{a},a1/*}] +} {globTest/a1/b1 globTest/a1/b2 globTest/x1.c} +test filename-13.15 {globbing with brace substitution} {macOnly} { + lsort [glob globTest/{x1.c,{a},a1/*}] +} {:globTest:a1:b1 :globTest:a1:b2 :globTest:x1.c} +test filename-13.16 {globbing with brace substitution} {unixOrPc unixExecs} { + lsort [glob globTest/{a,x}1/*/{x,y}*] +} {globTest/a1/b1/x2.c globTest/a1/b2/y2.c} +test filename-13.16 {globbing with brace substitution} {macOnly} { + lsort [glob globTest/{a,x}1/*/{x,y}*] +} {:globTest:a1:b1:x2.c :globTest:a1:b2:y2.c} +test filename-13.17 {globbing with brace substitution} {unixExecs} { + list [catch {glob globTest/\{a,x\}1/*/\{} msg] $msg +} {1 {unmatched open-brace in file name}} + +test filename-14.1 {asterisks, question marks, and brackets} {unixExecs unixOrPc} { + lsort [glob g*/*.c] +} {{globTest/weird name.c} globTest/x,z1.c globTest/x1.c globTest/y1.c globTest/z1.c} +test filename-14.1 {asterisks, question marks, and brackets} {macOnly} { + lsort [glob g*/*.c] +} {{:globTest:weird name.c} :globTest:x,z1.c :globTest:x1.c :globTest:y1.c :globTest:z1.c} +test filename-14.2 {asterisks, question marks, and brackets} {unixExecs unixOrPc} { + lsort [glob globTest/?1.c] +} {globTest/x1.c globTest/y1.c globTest/z1.c} +test filename-14.2 {asterisks, question marks, and brackets} {macOnly} { + lsort [glob globTest/?1.c] +} {:globTest:x1.c :globTest:y1.c :globTest:z1.c} +test filename-14.3 {asterisks, question marks, and brackets} {unixExecs unixOrPc} { + lsort [glob */*/*/*.c] +} {globTest/a1/b1/x2.c globTest/a1/b2/y2.c} +test filename-14.3 {asterisks, question marks, and brackets} {macOnly} { + lsort [glob */*/*/*.c] +} {:globTest:a1:b1:x2.c :globTest:a1:b2:y2.c} +test filename-14.4 {asterisks, question marks, and brackets} {unixExecs unixOrPc} { + 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.4 {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.5 {asterisks, question marks, and brackets} {unixExecs unixOrPc} { + lsort [glob globTest/.*] +} {globTest/. globTest/.. globTest/.1} +test filename-14.5 {asterisks, question marks, and brackets} {macOnly} { + lsort [glob globTest/.*] +} {:globTest:.1} +test filename-14.6 {asterisks, question marks, and brackets} {unixExecs unixOrPc} { + lsort [glob globTest/*/*] +} {globTest/a1/b1 globTest/a1/b2 globTest/a2/b3} +test filename-14.6 {asterisks, question marks, and brackets} {macOnly} { + lsort [glob globTest/*/*] +} {:globTest:a1:b1 :globTest:a1:b2 :globTest:a2:b3} +test filename-14.7 {asterisks, question marks, and brackets} {unixExecs unixOrPc} { + lsort [glob {globTest/[xyab]1.*}] +} {globTest/x1.c globTest/y1.c} +test filename-14.7 {asterisks, question marks, and brackets} {macOnly} { + lsort [glob {globTest/[xyab]1.*}] +} {:globTest:x1.c :globTest:y1.c} +test filename-14.8 {asterisks, question marks, and brackets} {unixExecs unixOrPc} { + lsort [glob globTest/*/] +} {globTest/a1/ globTest/a2/ globTest/a3/} +test filename-14.8 {asterisks, question marks, and brackets} {macOnly} { + lsort [glob globTest/*/] +} {:globTest:a1: :globTest:a2: :globTest:a3:} +test filename-14.9 {asterisks, question marks, and brackets} {unixExecs} { + global env + set temp $env(HOME) + set env(HOME) [file join $env(HOME) globTest] + set result [list [catch {glob ~/z*} msg] $msg] + set env(HOME) $temp + set result +} [list 0 [list [file join $env(HOME) globTest z1.c]]] +test filename-14.10 {asterisks, question marks, and brackets} {unixExecs unixOrPc} { + list [catch {lsort [glob globTest/*.c goo/*]} msg] $msg +} {0 {{globTest/weird name.c} globTest/x,z1.c globTest/x1.c globTest/y1.c globTest/z1.c}} +test filename-14.10 {asterisks, question marks, and brackets} {macOnly} { + list [catch {lsort [glob globTest/*.c goo/*]} msg] $msg +} {0 {{:globTest:weird name.c} :globTest:x,z1.c :globTest:x1.c :globTest:y1.c :globTest:z1.c}} +test filename-14.11 {asterisks, question marks, and brackets} { + list [catch {glob -nocomplain goo/*} msg] $msg +} {0 {}} +test filename-14.12 {asterisks, question marks, and brackets} { + list [catch {glob globTest/*/gorp} msg] $msg +} {1 {no files matched glob pattern "globTest/*/gorp"}} +test filename-14.13 {asterisks, question marks, and brackets} { + list [catch {glob goo/* x*z foo?q} msg] $msg +} {1 {no files matched glob patterns "goo/* x*z foo?q"}} +test filename-14.14 {slash globbing} {unixOrPc} { + glob / +} / +test filename-14.15 {slash globbing} {pcOnly} { + glob {\\} +} / + +# The following tests are only valid for Unix systems. + +if {$tcl_platform(platform) == "unix"} { + # On some systems, like AFS, "000" protection doesn't prevent + # access by owner, so the following test is not portable. + + exec chmod 000 globTest + test filename-15.1 {unix specific globbing} {nonPortable} { + string tolower [list [catch {glob globTest/*} msg] $msg $errorCode] + } {1 {couldn't read directory "globtest": permission denied} {posix eacces {permission denied}}} + exec chmod 755 globTest + + test filename-15.2 {unix specific globbing} {nonPortable} { + glob ~ouster/.csh* + } "/home/ouster/.cshrc" + close [open globTest/odd\\\[\]*?\{\}name w] + test filename-15.3 {unix specific globbing} { + global env + set temp $env(HOME) + set env(HOME) $env(HOME)/globTest/odd\\\[\]*?\{\}name + set result [list [catch {glob ~} msg] $msg] + set env(HOME) $temp + set result + } [list 0 [list [glob ~]/globTest/odd\\\[\]*?\{\}name]] + exec rm -f globTest/odd\\\[\]*?\{\}name +} + +# The following tests are only valid for Windows systems. + +if {$tcl_platform(platform) == "windows"} { + set temp [pwd] + cd c:/ + exec rm -rf globTest + catch { + exec mkdir globTest + close [open globTest/x1.BAT w] + close [open globTest/y1.Bat w] + close [open globTest/z1.bat w] + } + + test filename-16.1 {windows specific globbing} {unixExecs} { + lsort [glob globTest/*.bat] + } {globTest/x1.BAT globTest/y1.Bat globTest/z1.bat} + test filename-16.2 {windows specific globbing} { + glob c: + } c: + test filename-16.3 {windows specific globbing} {unixExecs} { + glob c:\\\\ + } c:/ + test filename-16.4 {windows specific globbing} { + glob c:/ + } c:/ + test filename-16.5 {windows specific globbing} {unixExecs} { + glob c:*Test + } c:globTest + test filename-16.6 {windows specific globbing} {unixExecs} { + glob c:\\\\*Test + } c:/globTest + test filename-16.7 {windows specific globbing} {unixExecs} { + glob c:/*Test + } c:/globTest + test filename-16.8 {windows specific globbing} {unixExecs} { + lsort [glob c:globTest/*.bat] + } {c:globTest/x1.BAT c:globTest/y1.Bat c:globTest/z1.bat} + test filename-16.9 {windows specific globbing} {unixExecs} { + lsort [glob c:/globTest/*.bat] + } {c:/globTest/x1.BAT c:/globTest/y1.Bat c:/globTest/z1.bat} + test filename-16.10 {windows specific globbing} {unixExecs} { + lsort [glob c:globTest\\\\*.bat] + } {c:globTest/x1.BAT c:globTest/y1.Bat c:globTest/z1.bat} + test filename-16.11 {windows specific globbing} {unixExecs} { + lsort [glob c:\\\\globTest\\\\*.bat] + } {c:/globTest/x1.BAT c:/globTest/y1.Bat c:/globTest/z1.bat} + + exec rm -rf globTest + + if $testConfig(nonPortable) { + cd //gaspode/d + exec rm -rf globTest + exec mkdir globTest + + close [open globTest/x1.BAT w] + close [open globTest/y1.Bat w] + close [open globTest/z1.bat w] + + test filename-16.12 {windows specific globbing} { + glob //gaspode/d/*Test + } //gaspode/d/globTest + test filename-16.13 {windows specific globbing} { + glob {\\\\gaspode\\d\\*Test} + } //gaspode/d/globTest + + exec rm -rf globTest + } + + cd $temp +} + +removeDirectory globTest +set env(HOME) $oldhome + +testsetplatform $platform +catch {unset oldhome platform temp result} +concat "" diff --git a/contrib/tcl/tests/for.test b/contrib/tcl/tests/for.test new file mode 100644 index 0000000..16d8c9c --- /dev/null +++ b/contrib/tcl/tests/for.test @@ -0,0 +1,211 @@ +# Commands covered: foreach, for, continue, break +# +# 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) 1991-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: @(#) for.test 1.11 96/02/16 08:55:55 + +if {[string compare test [info procs test]] == 1} then {source defs} + +# Basic "foreach" operation. + +test for-1.1 {basic foreach tests} { + set a {} + foreach i {a b c d} { + set a [concat $a $i] + } + set a +} {a b c d} +test for-1.2 {basic foreach tests} { + set a {} + foreach i {a b {{c d} e} {123 {{x}}}} { + set a [concat $a $i] + } + set a +} {a b {c d} e 123 {{x}}} +test for-1.3 {basic foreach tests} {catch {foreach} msg} 1 +test for-1.4 {basic foreach tests} { + catch {foreach} msg + set msg +} {wrong # args: should be "foreach varList list ?varList list ...? command"} +test for-1.5 {basic foreach tests} {catch {foreach i} msg} 1 +test for-1.6 {basic foreach tests} { + catch {foreach i} msg + set msg +} {wrong # args: should be "foreach varList list ?varList list ...? command"} +test for-1.7 {basic foreach tests} {catch {foreach i j} msg} 1 +test for-1.8 {basic foreach tests} { + catch {foreach i j} msg + set msg +} {wrong # args: should be "foreach varList list ?varList list ...? command"} +test for-1.9 {basic foreach tests} {catch {foreach i j k l} msg} 1 +test for-1.10 {basic foreach tests} { + catch {foreach i j k l} msg + set msg +} {wrong # args: should be "foreach varList list ?varList list ...? command"} +test for-1.11 {basic foreach tests} { + set a {} + foreach i {} { + set a [concat $a $i] + } + set a +} {} +test for-1.11 {foreach errors} { + list [catch {foreach {{a}{b}} {1 2 3} {}} msg] $msg +} {1 {list element in braces followed by "{b}" instead of space}} +test for-1.12 {foreach errors} { + list [catch {foreach a {{1 2}3} {}} msg] $msg +} {1 {list element in braces followed by "3" instead of space}} +catch {unset a} +test for-1.13 {foreach errors} { + catch {unset a} + set a(0) 44 + list [catch {foreach a {1 2 3} {}} msg] $msg +} {1 {couldn't set loop variable: "a"}} +catch {unset a} +test for-1.14 {parallel foreach tests} { + set x {} + foreach {a b} {1 2 3 4} { + append x $b $a + } + set x +} {2143} +test for-1.15 {parallel foreach tests} { + set x {} + foreach {a b} {1 2 3 4 5} { + append x $b $a + } + set x +} {21435} +test for-1.16 {parallel foreach tests} { + set x {} + foreach a {1 2 3} b {4 5 6} { + append x $b $a + } + set x +} {415263} +test for-1.17 {parallel foreach tests} { + set x {} + foreach a {1 2 3} b {4 5 6 7 8} { + append x $b $a + } + set x +} {41526378} +test for-1.18 {parallel foreach tests} { + set x {} + foreach {a b} {a b A B aa bb} c {c C cc CC} { + append x $a $b $c + } + set x +} {abcABCaabbccCC} +test for-1.19 {parallel foreach tests} { + set x {} + foreach a {1 2 3} b {1 2 3} c {1 2 3} d {1 2 3} e {1 2 3} { + append x $a $b $c $d $e + } + set x +} {111112222233333} +test for-1.20 {parallel foreach tests} { + set x {} + foreach a {} b {1 2 3} c {1 2} d {1 2 3 4} e {{1 2}} { + append x $a $b $c $d $e + } + set x +} {1111 2222334} + +# Check "continue". + +test for-2.1 {continue tests} {catch continue} 4 +test for-2.2 {continue tests} { + set a {} + foreach i {a b c d} { + if {[string compare $i "b"] == 0} continue + set a [concat $a $i] + } + set a +} {a c d} +test for-2.3 {continue tests} { + set a {} + foreach i {a b c d} { + if {[string compare $i "b"] != 0} continue + set a [concat $a $i] + } + set a +} {b} +test for-2.4 {continue tests} {catch {continue foo} msg} 1 +test for-2.5 {continue tests} { + catch {continue foo} msg + set msg +} {wrong # args: should be "continue"} + +# Check "break". + +test for-3.1 {break tests} {catch break} 3 +test for-3.2 {break tests} { + set a {} + foreach i {a b c d} { + if {[string compare $i "c"] == 0} break + set a [concat $a $i] + } + set a +} {a b} +test for-3.3 {break tests} {catch {break foo} msg} 1 +test for-3.4 {break tests} { + catch {break foo} msg + set msg +} {wrong # args: should be "break"} + +# Check "for" and its use of continue and break. + +test for-4.1 {for tests} { + set a {} + for {set i 1} {$i<6} {set i [expr $i+1]} { + set a [concat $a $i] + } + set a +} {1 2 3 4 5} +test for-4.2 {for tests} { + set a {} + for {set i 1} {$i<6} {set i [expr $i+1]} { + if $i==4 continue + set a [concat $a $i] + } + set a +} {1 2 3 5} +test for-4.3 {for tests} { + set a {} + for {set i 1} {$i<6} {set i [expr $i+1]} { + if $i==4 break + set a [concat $a $i] + } + set a +} {1 2 3} +test for-4.4 {for tests} {catch {for 1 2 3} msg} 1 +test for-4.5 {for tests} { + catch {for 1 2 3} msg + set msg +} {wrong # args: should be "for start test next command"} +test for-4.6 {for tests} {catch {for 1 2 3 4 5} msg} 1 +test for-4.7 {for tests} { + catch {for 1 2 3 4 5} msg + set msg +} {wrong # args: should be "for start test next command"} +test for-4.8 {for tests} { + set a {xyz} + for {set i 1} {$i<6} {set i [expr $i+1]} {} + set a +} xyz +test for-4.9 {for tests} { + set a {} + for {set i 1} {$i<6} {set i [expr $i+1]; if $i==4 break} { + set a [concat $a $i] + } + set a +} {1 2 3} diff --git a/contrib/tcl/tests/format.test b/contrib/tcl/tests/format.test new file mode 100644 index 0000000..3fe4eb5 --- /dev/null +++ b/contrib/tcl/tests/format.test @@ -0,0 +1,366 @@ +# Commands covered: format +# +# 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) 1991-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: @(#) format.test 1.22 96/02/16 08:55:56 + +if {[string compare test [info procs test]] == 1} then {source defs} + +# The following code is needed because some versions of SCO Unix have +# a round-off error in sprintf which would cause some of the tests to +# 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 +} + +test format-1.1 {integer formatting} { + format "%*d %d %d %d" 6 34 16923 -12 -1 +} { 34 16923 -12 -1} +test format-1.2 {integer formatting} {nonPortable} { + format "%4d %4d %4d %4d %d %#x %#X" 6 34 16923 -12 -1 14 12 +} { 6 34 16923 -12 -1 0xe 0XC} + +# %u output depends on word length, so this test is not portable. + +test format-1.3 {integer formatting} {nonPortable} { + format "%4u %4u %4u %4u %d %#o" 6 34 16923 -12 -1 0 +} { 6 34 16923 4294967284 -1 0} +test format-1.4 {integer formatting} { + format "%-4d %-4i %-4d %-4ld" 6 34 16923 -12 -1 +} {6 34 16923 -12 } +test format-1.5 {integer formatting} { + format "%04d %04d %04d %04i" 6 34 16923 -12 -1 +} {0006 0034 16923 -012} +test format-1.6 {integer formatting} { + format "%00*d" 6 34 +} {000034} + +# Printing negative numbers in hex or octal format depends on word +# length, so these tests are not portable. + +test format-1.7 {integer formatting} {nonPortable} { + format "%4x %4x %4x %4x" 6 34 16923 -12 -1 +} { 6 22 421b fffffff4} +test format-1.8 {integer formatting} {nonPortable} { + format "%#x %#X %#X %#x" 6 34 16923 -12 -1 +} {0x6 0X22 0X421B 0xfffffff4} +test format-1.9 {integer formatting} {nonPortable} { + format "%#20x %#20x %#20x %#20x" 6 34 16923 -12 -1 +} { 0x6 0x22 0x421b 0xfffffff4} +test format-1.10 {integer formatting} {nonPortable} { + format "%-#20x %-#20x %-#20x %-#20x" 6 34 16923 -12 -1 +} {0x6 0x22 0x421b 0xfffffff4 } +test format-1.11 {integer formatting} {nonPortable} { + format "%-#20o %#-20o %#-20o %#-20o" 6 34 16923 -12 -1 +} {06 042 041033 037777777764 } + +test format-2.1 {string formatting} { + format "%s %s %c %s" abcd {This is a very long test string.} 120 x +} {abcd This is a very long test string. x x} +test format-2.2 {string formatting} { + format "%20s %20s %20c %20s" abcd {This is a very long test string.} 120 x +} { abcd This is a very long test string. x x} +test format-2.3 {string formatting} { + format "%.10s %.10s %c %.10s" abcd {This is a very long test string.} 120 x +} {abcd This is a x x} +test format-2.4 {string formatting} { + format "%s %s %% %c %s" abcd {This is a very long test string.} 120 x +} {abcd This is a very long test string. % x x} + +test format-3.1 {e and f formats} { + format "%e %e %e %e" 34.2e12 68.514 -.125 -16000. .000053 +} {3.420000e+13 6.851400e+01 -1.250000e-01 -1.600000e+04} +test format-3.2 {e and f formats} { + 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-3.3 {e and f formats} { + 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-3.4 {e and f formats} { + 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-3.5 {e and f formats} { + 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-3.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-3.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} +test format-3.8 {e and f formats} { + format "%.4e %.5e %.6e" -9.99996 -9.99996 9.99996 +} {-1.0000e+01 -9.99996e+00 9.999960e+00} +test format-3.9 {e and f formats} { + format "%.4f %.5f %.6f" -9.99996 -9.99996 9.99996 +} {-10.0000 -9.99996 9.999960} +test format-3.10 {e and f formats} { + format "%20f %-20f %020f" -9.99996 -9.99996 9.99996 +} { -9.999960 -9.999960 0000000000009.999960} +test format-3.11 {e and f formats} { + format "%-020f %020f" -9.99996 -9.99996 9.99996 +} {-9.999960 -000000000009.999960} +test format-3.12 {e and f formats} { + format "%.0e %#.0e" -9.99996 -9.99996 9.99996 +} {-1e+01 -1.e+01} +test format-3.13 {e and f formats} { + format "%.0f %#.0f" -9.99996 -9.99996 9.99996 +} {-10 -10.} +test format-3.14 {e and f formats} { + format "%.4f %.5f %.6f" -9.99996 -9.99996 9.99996 +} {-10.0000 -9.99996 9.999960} +test format-3.15 {e and f formats} { + format "%3.0f %3.0f %3.0f %3.0f" 1.0 1.1 1.01 1.001 +} { 1 1 1 1} +test format-3.16 {e and f formats} { + format "%3.1f %3.1f %3.1f %3.1f" 0.0 0.1 0.01 0.001 +} {0.0 0.1 0.0 0.0} + +test format-4.1 {g-format} { + format "%.3g" 12341.0 +} {1.23e+04} +test format-4.2 {g-format} { + format "%.3G" 1234.12345 +} {1.23E+03} +test format-4.3 {g-format} { + format "%.3g" 123.412345 +} {123} +test format-4.4 {g-format} { + format "%.3g" 12.3412345 +} {12.3} +test format-4.5 {g-format} { + format "%.3g" 1.23412345 +} {1.23} +test format-4.6 {g-format} { + format "%.3g" 1.23412345 +} {1.23} +test format-4.7 {g-format} { + format "%.3g" .123412345 +} {0.123} +test format-4.8 {g-format} { + format "%.3g" .012341 +} {0.0123} +test format-4.9 {g-format} { + format "%.3g" .0012341 +} {0.00123} +test format-4.10 {g-format} { + format "%.3g" .00012341 +} {0.000123} +test format-4.11 {g-format} { + format "%.3g" .00001234 +} {1.23e-05} +test format-4.12 {g-format} { + format "%.4g" 9999.6 +} {1e+04} +test format-4.13 {g-format} { + format "%.4g" 999.96 +} {1000} +test format-4.14 {g-format} { + format "%.3g" 1.0 +} {1} +test format-4.15 {g-format} { + format "%.3g" .1 +} {0.1} +test format-4.16 {g-format} { + format "%.3g" .01 +} {0.01} +test format-4.17 {g-format} { + format "%.3g" .001 +} {0.001} +test format-4.19 {g-format} { + format "%.3g" .00001 +} {1e-05} +test format-4.20 {g-format} { + format "%#.3g" 1234.0 +} {1.23e+03} +test format-4.21 {g-format} { + format "%#.3G" 9999.5 +} {1.00E+04} + +test format-5.1 {floating-point zeroes} { + format "%e %f %g" 0.0 0.0 0.0 0.0 +} {0.000000e+00 0.000000 0} +test format-5.2 {floating-point zeroes} { + format "%.4e %.4f %.4g" 0.0 0.0 0.0 0.0 +} {0.0000e+00 0.0000 0} +test format-5.3 {floating-point zeroes} { + format "%#.4e %#.4f %#.4g" 0.0 0.0 0.0 0.0 +} {0.0000e+00 0.0000 0.000} +test format-5.4 {floating-point zeroes} { + format "%.0e %.0f %.0g" 0.0 0.0 0.0 0.0 +} {0e+00 0 0} +test format-5.5 {floating-point zeroes} { + format "%#.0e %#.0f %#.0g" 0.0 0.0 0.0 0.0 +} {0.e+00 0. 0.} +test format-5.6 {floating-point zeroes} { + format "%3.0f %3.0f %3.0f %3.0f" 0.0 0.0 0.0 0.0 +} { 0 0 0 0} +test format-5.7 {floating-point zeroes} { + format "%3.0f %3.0f %3.0f %3.0f" 1.0 1.1 1.01 1.001 +} { 1 1 1 1} +test format-5.8 {floating-point zeroes} { + format "%3.1f %3.1f %3.1f %3.1f" 0.0 0.1 0.01 0.001 +} {0.0 0.1 0.0 0.0} + +test format-6.1 {various syntax features} { + format "%*.*f" 12 3 12.345678901 +} { 12.346} +test format-6.2 {various syntax features} { + format "%0*.*f" 12 3 12.345678901 +} {00000012.346} +test format-6.3 {various syntax features} { + format "\*\t\\n" +} {* \n} + +test format-7.1 {error conditions} { + catch format +} 1 +test format-7.2 {error conditions} { + catch format msg + set msg +} {wrong # args: should be "format formatString ?arg arg ...?"} +test format-7.3 {error conditions} { + catch {format %*d} +} 1 +test format-7.4 {error conditions} { + catch {format %*d} msg + set msg +} {not enough arguments for all format specifiers} +test format-7.5 {error conditions} { + catch {format %*.*f 12} +} 1 +test format-7.6 {error conditions} { + catch {format %*.*f 12} msg + set msg +} {not enough arguments for all format specifiers} +test format-7.7 {error conditions} { + catch {format %*.*f 12 3} +} 1 +test format-7.8 {error conditions} { + catch {format %*.*f 12 3} msg + set msg +} {not enough arguments for all format specifiers} +test format-7.9 {error conditions} { + list [catch {format %*d x 3} msg] $msg +} {1 {expected integer but got "x"}} +test format-7.10 {error conditions} { + list [catch {format %*.*f 2 xyz 3} msg] $msg +} {1 {expected integer but got "xyz"}} +test format-7.11 {error conditions} { + catch {format %d 2a} +} 1 +test format-7.12 {error conditions} { + catch {format %d 2a} msg + set msg +} {expected integer but got "2a"} +test format-7.13 {error conditions} { + catch {format %c 2x} +} 1 +test format-7.14 {error conditions} { + catch {format %c 2x} msg + set msg +} {expected integer but got "2x"} +test format-7.15 {error conditions} { + catch {format %f 2.1z} +} 1 +test format-7.16 {error conditions} { + catch {format %f 2.1z} msg + set msg +} {expected floating-point number but got "2.1z"} +test format-7.17 {error conditions} { + catch {format ab%} +} 1 +test format-7.18 {error conditions} { + catch {format ab% 12} msg + set msg +} {format string ended in middle of field specifier} +test format-7.19 {error conditions} { + catch {format %q x} +} 1 +test format-7.20 {error conditions} { + catch {format %q x} msg + set msg +} {bad field specifier "q"} +test format-7.21 {error conditions} { + catch {format %d} +} 1 +test format-7.22 {error conditions} { + catch {format %d} msg + set msg +} {not enough arguments for all format specifiers} + +test format-8.1 {long result} { + set a {1234567890abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ 1 2 3 4 5 6 7 8 9 0 a b c d e f g h i j k l m n o p q r s t u v w x y z A B C D E F G H I J K L M N O P Q R S T U V W X Y Z} + format {1111 2222 3333 4444 5555 6666 7777 8888 9999 aaaa bbbb cccc dddd eeee ffff gggg hhhh iiii jjjj kkkk llll mmmm nnnn oooo pppp qqqq rrrr ssss tttt uuuu vvvv wwww xxxx yyyy zzzz AAAA BBBB CCCC DDDD EEEE FFFF GGGG %s %s %s} $a $a $a +} {1111 2222 3333 4444 5555 6666 7777 8888 9999 aaaa bbbb cccc dddd eeee ffff gggg hhhh iiii jjjj kkkk llll mmmm nnnn oooo pppp qqqq rrrr ssss tttt uuuu vvvv wwww xxxx yyyy zzzz AAAA BBBB CCCC DDDD EEEE FFFF GGGG 1234567890abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ 1 2 3 4 5 6 7 8 9 0 a b c d e f g h i j k l m n o p q r s t u v w x y z A B C D E F G H I J K L M N O P Q R S T U V W X Y Z 1234567890abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ 1 2 3 4 5 6 7 8 9 0 a b c d e f g h i j k l m n o p q r s t u v w x y z A B C D E F G H I J K L M N O P Q R S T U V W X Y Z 1234567890abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ 1 2 3 4 5 6 7 8 9 0 a b c d e f g h i j k l m n o p q r s t u v w x y z A B C D E F G H I J K L M N O P Q R S T U V W X Y Z} + +test format-9.1 {"h" format specifier} {nonPortable} { + format %hd 0xffff +} -1 +test format-9.2 {"h" format specifier} {nonPortable} { + format %hx 0x10fff +} fff +test format-9.3 {"h" format specifier} {nonPortable} { + format %hd 0x10000 +} 0 + +test format-10.1 {XPG3 %$n specifiers} { + format {%2$d %1$d} 4 5 +} {5 4} +test format-10.2 {XPG3 %$n specifiers} { + format {%2$d %1$d %1$d %3$d} 4 5 6 +} {5 4 4 6} +test format-10.3 {XPG3 %$n specifiers} { + list [catch {format {%2$d %3$d} 4 5} msg] $msg +} {1 {"%n$" argument index out of range}} +test format-10.4 {XPG3 %$n specifiers} { + list [catch {format {%2$d %0$d} 4 5 6} msg] $msg +} {1 {"%n$" argument index out of range}} +test format-10.5 {XPG3 %$n specifiers} { + list [catch {format {%d %1$d} 4 5 6} msg] $msg +} {1 {cannot mix "%" and "%n$" conversion specifiers}} +test format-10.6 {XPG3 %$n specifiers} { + list [catch {format {%2$d %d} 4 5 6} msg] $msg +} {1 {cannot mix "%" and "%n$" conversion specifiers}} +test format-10.7 {XPG3 %$n specifiers} { + list [catch {format {%2$d %3d} 4 5 6} msg] $msg +} {1 {cannot mix "%" and "%n$" conversion specifiers}} +test format-10.8 {XPG3 %$n specifiers} { + format {%2$*d %3$d} 1 10 4 +} { 4 4} +test format-10.9 {XPG3 %$n specifiers} { + format {%2$.*s %4$d} 1 5 abcdefghijklmnop 44 +} {abcde 44} +test format-10.10 {XPG3 %$n specifiers} { + list [catch {format {%2$*d} 4} msg] $msg +} {1 {"%n$" argument index out of range}} +test format-10.11 {XPG3 %$n specifiers} { + list [catch {format {%2$*d} 4 5} msg] $msg +} {1 {"%n$" argument index out of range}} +test format-10.12 {XPG3 %$n specifiers} { + list [catch {format {%2$*d} 4 5 6} msg] $msg +} {0 { 6}} + +test format-11.1 {enormous width specifiers} { + format "%077777777d" 77777777 +} {0000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000077777777} +test format-11.2 {enormous width specifiers} { + format "%*d" 123456789 77777777 +} { 77777777} +test format-11.3 {negative width specifiers} { + format "%*d" -47 25 +} {25} diff --git a/contrib/tcl/tests/get.test b/contrib/tcl/tests/get.test new file mode 100644 index 0000000..0713861 --- /dev/null +++ b/contrib/tcl/tests/get.test @@ -0,0 +1,72 @@ +# Commands covered: none +# +# This file contains a collection of tests for the procedures in the +# file tclGet.c. Sourcing this file into Tcl runs the tests and +# generates output for errors. No output means no errors were found. +# +# Copyright (c) 1995-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: @(#) get.test 1.5 96/04/09 15:54:33 + +if {[string compare test [info procs test]] == 1} then {source defs} + +test get-1.1 {Tcl_GetInt procedure} { + set x 44 + incr x { 22} +} {66} +test get-1.2 {Tcl_GetInt procedure} { + set x 44 + incr x -3 +} {41} +test get-1.3 {Tcl_GetInt procedure} { + set x 44 + incr x +8 +} {52} +test get-1.4 {Tcl_GetInt procedure} { + set x 44 + list [catch {incr x foo} msg] $msg +} {1 {expected integer but got "foo"}} +test get-1.5 {Tcl_GetInt procedure} { + set x 44 + list [catch {incr x {16 }} msg] $msg +} {0 60} +test get-1.6 {Tcl_GetInt procedure} { + set x 44 + list [catch {incr x {16 x}} msg] $msg +} {1 {expected integer but got "16 x"}} + +# The following tests are non-portable because they depend on +# word size. + +test get-1.7 {Tcl_GetInt procedure} {nonPortable unixOnly} { + 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} {nonPortable} { + set x 0 + list [catch {incr x 4294967294} msg] $msg +} {0 -2} +test get-1.8 {Tcl_GetInt procedure} {nonPortable} { + set x 0 + list [catch {incr x +4294967294} msg] $msg +} {0 -2} +test get-1.9 {Tcl_GetInt procedure} {nonPortable} { + set x 0 + list [catch {incr x -4294967294} msg] $msg +} {0 2} + +test get-2.1 {Tcl_GetInt procedure} { + format %g 1.23 +} {1.23} +test get-2.2 {Tcl_GetInt procedure} { + format %g { 1.23 } +} {1.23} +test get-2.3 {Tcl_GetInt procedure} { + list [catch {format %g clip} msg] $msg +} {1 {expected floating-point number but got "clip"}} +test get-2.4 {Tcl_GetInt procedure} {nonPortable} { + list [catch {format %g .000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000001} msg] $msg $errorCode +} {1 {floating-point value too small to represent} {ARITH UNDERFLOW {floating-point value too small to represent}}} diff --git a/contrib/tcl/tests/history.test b/contrib/tcl/tests/history.test new file mode 100644 index 0000000..d5921b6 --- /dev/null +++ b/contrib/tcl/tests/history.test @@ -0,0 +1,386 @@ +# Commands covered: history +# +# 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) 1991-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: @(#) history.test 1.11 96/02/16 08:55:57 + +if {[info commands history] == ""} { + puts stdout "This version of Tcl was built without the history command;\n" + puts stdout "history tests will be skipped.\n" + return +} + +if {[string compare test [info procs test]] == 1} then {source defs} + +set num [history nextid] +history keep 3 +history add {set a 12345} +history add {set b [format {A test %s} string]} +history add {Another test} + +# "history event" + +test history-1.1 {event option} {history event -1} \ + {set b [format {A test %s} string]} +test history-1.2 {event option} {history event $num} \ + {set a 12345} +test history-1.3 {event option} {history event [expr $num+2]} \ + {Another test} +test history-1.4 {event option} {history event set} \ + {set b [format {A test %s} string]} +test history-1.5 {event option} {history e "* a*"} \ + {set a 12345} +test history-1.6 {event option} {catch {history event *gorp} msg} 1 +test history-1.7 {event option} { + catch {history event *gorp} msg + set msg +} {no event matches "*gorp"} +test history-1.8 {event option} {history event} \ + {set b [format {A test %s} string]} +test history-1.9 {event option} {catch {history event 123 456} msg} 1 +test history-1.10 {event option} { + catch {history event 123 456} msg + set msg +} {wrong # args: should be "history event ?event?"} + +# "history redo" + +set a 0 +history redo -2 +test history-2.1 {redo option} {set a} 12345 +set b 0 +history redo +test history-2.2 {redo option} {set b} {A test string} +test history-2.3 {redo option} {catch {history redo -3 -4}} 1 +test history-2.4 {redo option} { + catch {history redo -3 -4} msg + set msg +} {wrong # args: should be "history redo ?event?"} + +# "history add" + +history add "set a 444" exec +test history-3.1 {add option} {set a} 444 +test history-3.2 {add option} {catch {history add "set a 444" execGorp}} 1 +test history-3.3 {add option} { + catch {history add "set a 444" execGorp} msg + set msg +} {bad argument "execGorp": should be "exec"} +test history-3.4 {add option} {catch {history add "set a 444" a} msg} 1 +test history-3.5 {add option} { + catch {history add "set a 444" a} msg + set msg +} {bad argument "a": should be "exec"} +history add "set a 555" e +test history-3.6 {add option} {set a} 555 +history add "set a 666" +test history-3.7 {add option} {set a} 555 +test history-3.8 {add option} {catch {history add "set a 666" e f} msg} 1 +test history-3.9 {add option} { + catch {history add "set a 666" e f} msg + set msg +} {wrong # args: should be "history add event ?exec?"} + +# "history change" + +history change "A test value" +test history-4.1 {change option} {history event [expr {[history n]-1}]} \ + "A test value" +history c "Another test" -1 +test history-4.2 {change option} {history e} "Another test" +test history-4.3 {change option} {history event [expr {[history n]-1}]} \ + "A test value" +test history-4.4 {change option} {catch {history change Foo 4 10}} 1 +test history-4.5 {change option} { + catch {history change Foo 4 10} msg + set msg +} {wrong # args: should be "history change newValue ?event?"} +test history-4.6 {change option} { + catch {history change Foo [expr {[history n]-4}]} +} 1 +test history-4.7 {change option} { + catch {history change Foo [expr {[history n]-4}]} + set msg +} {wrong # args: should be "history change newValue ?event?"} + +# "history info" + +set num [history n] +history add set\ a\ {b\nc\ d\ e} +history add {set b 1234} +history add set\ c\ {a\nb\nc} +test history-5.1 {info option} {history info} [format {%6d set a {b + c d e} +%6d set b 1234 +%6d set c {a + b + c}} $num [expr $num+1] [expr $num+2]] +test history-5.2 {info option} {history i 2} [format {%6d set b 1234 +%6d set c {a + b + c}} [expr $num+1] [expr $num+2]] +test history-5.3 {info option} {catch {history i 2 3}} 1 +test history-5.4 {info option} { + catch {history i 2 3} msg + set msg +} {wrong # args: should be "history info ?count?"} +test history-5.5 {info option} {history} [format {%6d set a {b + c d e} +%6d set b 1234 +%6d set c {a + b + c}} $num [expr $num+1] [expr $num+2]] + +# "history keep" + +history add "foo1" +history add "foo2" +history add "foo3" +history keep 2 +test history-6.1 {keep option} {history event [expr [history n]-1]} foo3 +test history-6.2 {keep option} {history event -1} foo2 +test history-6.3 {keep option} {catch {history event -3}} 1 +test history-6.4 {keep option} { + catch {history event -3} msg + set msg +} {event "-3" is too far in the past} +history k 5 +test history-6.5 {keep option} {history event -1} foo2 +test history-6.6 {keep option} {history event -2} {} +test history-6.7 {keep option} {history event -3} {} +test history-6.8 {keep option} {history event -4} {} +test history-6.9 {keep option} {catch {history event -5}} 1 +test history-6.10 {keep option} {catch {history keep 4 6}} 1 +test history-6.11 {keep option} { + catch {history keep 4 6} msg + set msg +} {wrong # args: should be "history keep number"} +test history-6.12 {keep option} {catch {history keep}} 1 +test history-6.13 {keep option} { + catch {history keep} msg + set msg +} {wrong # args: should be "history keep number"} +test history-6.14 {keep option} {catch {history keep -3}} 1 +test history-6.15 {keep option} { + catch {history keep -3} msg + set msg +} {illegal keep count "-3"} + +# "history nextid" + +set num [history n] +history add "Testing" +history add "Testing2" +test history-7.1 {nextid option} {history event} "Testing" +test history-7.2 {nextid option} {history next} [expr $num+2] +test history-7.3 {nextid option} {catch {history nextid garbage}} 1 +test history-7.4 {nextid option} { + catch {history nextid garbage} msg + set msg +} {wrong # args: should be "history nextid"} + +# "history substitute" + +test history-8.1 {substitute option} { + history add "set a {test foo test b c test}" + history add "Test command 2" + set a 0 + history substitute foo bar -1 + set a +} {test bar test b c test} +test history-8.2 {substitute option} { + history add "set a {test foo test b c test}" + history add "Test command 2" + set a 0 + history substitute test gorp + set a +} {gorp foo gorp b c gorp} +test history-8.3 {substitute option} { + history add "set a {test foo test b c test}" + history add "Test command 2" + set a 0 + history sub " te" to + set a +} {test footost b ctost} +test history-8.4 {substitute option} {catch {history sub xxx yyy}} 1 +test history-8.5 {substitute option} { + catch {history sub xxx yyy} msg + set msg +} {"xxx" doesn't appear in event} +test history-8.6 {substitute option} {catch {history s a b -10}} 1 +test history-8.7 {substitute option} { + catch {history s a b -10} msg + set msg +} {event "-10" is too far in the past} +test history-8.8 {substitute option} {catch {history s a b -1 20}} 1 +test history-8.9 {substitute option} { + catch {history s a b -1 20} msg + set msg +} {wrong # args: should be "history substitute old new ?event?"} + +# "history words" + +test history-9.1 {words option} { + history add {word0 word1 word2 a b c word6} + history add foo + history words 0-$ +} {word0 word1 word2 a b c word6} +test history-9.2 {words option} { + history add {word0 word1 word2 a b c word6} + history add foo + history w 2 -1 +} word2 +test history-9.3 {words option} { + history add {word0 word1 word2 a b c word6} + history add foo + history wo $ +} word6 +test history-9.4 {words option} {catch {history w 1--1} msg} 1 +test history-9.5 {words option} { + catch {history w 1--1} msg + set msg +} {bad word selector "1--1": should be num-num or pattern} +test history-9.6 {words option} { + history add {word0 word1 word2 a b c word6} + history add foo + history w w +} {} +test history-9.7 {words option} { + history add {word0 word1 word2 a b c word6} + history add foo + history w *2 +} word2 +test history-9.8 {words option} { + history add {word0 word1 word2 a b c word6} + history add foo + history w *or* +} {word0 word1 word2 word6} +test history-9.9 {words option} {catch {history words 10}} 1 +test history-9.10 {words option} { + catch {history words 10} msg + set msg +} {word selector "10" specified non-existent words} +test history-9.11 {words option} {catch {history words 1 -1 20}} 1 +test history-9.12 {words option} { + catch {history words 1 -1 20} msg + set msg +} {wrong # args: should be "history words num-num/pat ?event?"} + +# history revision + +test history-10.1 {history revision} { + set a 0 + history a {set a 12345} + history a {set a [history e]} exec + set a +} {set a 12345} +test history-10.2 {history revision} { + set a 0 + history a {set a 12345} + history a {set a [history e]} exec + history a foo + history ev -1 +} {set a {set a 12345}} +test history-10.3 {history revision} { + set a 0 + history a {set a 12345} + history a {set a [history e]} exec + history a foo + history a {history r -2} exec + history a {set a 12345} + history ev -1 +} {set a {set a 12345}} +test history-10.4 {history revision} { + history a {set a 12345} + history a {history s 123 999} exec + history a foo + history ev -1 +} {set a 99945} +test history-10.5 {history revision} { + history add {word0 word1 word2 a b c word6} + history add {set [history w 3] [list [history w 0] [history w {[ab]}]]} exec + set a +} {word0 {a b}} +test history-10.6 {history revision} { + history add {word0 word1 word2 a b c word6} + history add {set [history w 3] [list [history w 0] [history w {[ab]}]]} exec + history add foo + history ev +} {set a [list word0 {a b}]} +test history-10.7 {history revision} { + history add {word0 word1 word2 a b c word6} + history add {set [history w 3] [list [history w 0] [history w {[ab]}]]} exec + history add {format b} + history add {word0 word1 word2 a b c word6} + set a 0 + history add {set [history subs b a -2] [list abc [history r -2] [history w 1-3]]} exec + history add foo + history ev +} {set [format a] [list abc [format b] {word1 word2 a}]} +test history-10.8 {history revision} { + history add {set a 12345} + concat a b c + history add {history redo; set b 44} exec + history add foo + history ev +} {set a 12345; set b 44} +test history-10.9 {history revision} { + history add {set a 12345} + history add {history redo; history change "A simple test"; history subs 45 xx} exec + set a +} 123xx +test history-10.10 {history revision} { + history add {set a 12345} + history add {history redo; history change "A simple test"; history subs 45 xx} exec + history add foo + history e +} {A simple test} +test history-10.11 {history revision} { + history add {word0 word1 $ a b c word6} + history add {set a [history w 4-[history word 2]]} exec + set a +} {b c word6} +test history-10.12 {history revision} { + history add {word0 word1 $ a b c word6} + history add {set a [history w 4-[history word 2]]} exec + history add foo + history e +} {set a {b c word6}} +test history-10.13 {history revision} { + history add {history word 0} exec + history add foo + history e +} {history word 0} +test history-10.14 {history revision} { + history add {set a [history word 0; format c]} exec + history add foo + history e +} {set a [history word 0; format c]} +test history-10.15 {history revision even when nested} { + proc x {a b} {history word $a $b} + history add {word1 word2 word3 word4} + history add {set a [x 1-3 -1]} exec + history add foo + history e +} {set a {word2 word3 word4}} +test history-10.16 {disable history revision in nested history evals} { + history add {word1 word2 word3 word4} + history add {set a [history words 0]; history add foo; set a [history words 0]} exec + history e +} {set a word1; history add foo; set a [history words 0]} + +# miscellaneous + +test history-11.1 {miscellaneous} {catch {history gorp} msg} 1 +test history-11.2 {miscellaneous} { + catch {history gorp} msg + set msg +} {bad option "gorp": must be add, change, event, info, keep, nextid, redo, substitute, or words} diff --git a/contrib/tcl/tests/if.test b/contrib/tcl/tests/if.test new file mode 100644 index 0000000..e5b9ed2 --- /dev/null +++ b/contrib/tcl/tests/if.test @@ -0,0 +1,148 @@ +# Commands covered: if +# +# 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) 1991-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: @(#) if.test 1.8 96/02/16 08:55:59 + +if {[string compare test [info procs test]] == 1} then {source defs} + +test if-1.1 {taking proper branch} { + set a {} + if 0 {set a 1} else {set a 2} + set a +} 2 +test if-1.2 {taking proper branch} { + set a {} + if 1 {set a 1} else {set a 2} + set a +} 1 +test if-1.3 {taking proper branch} { + set a {} + if 1<2 {set a 1} + set a +} 1 +test if-1.4 {taking proper branch} { + set a {} + if 1>2 {set a 1} + set a +} {} +test if-1.5 {taking proper branch} { + set a {} + if 0 {set a 1} else {} + set a +} {} +test if-1.5 {taking proper branch} { + set a {} + if 0 {set a 1} elseif 1 {set a 2} elseif 1 {set a 3} else {set a 4} + set a +} {2} +test if-1.6 {taking proper branch} { + set a {} + if 0 {set a 1} elseif 0 {set a 2} elseif 1 {set a 3} else {set a 4} + set a +} {3} +test if-1.7 {taking proper branch} { + set a {} + if 0 {set a 1} elseif 0 {set a 2} elseif 0 {set a 3} else {set a 4} + set a +} {4} + + +test if-2.1 {optional then-else args} { + set a 44 + if 0 then {set a 1} elseif 0 then {set a 3} else {set a 2} + set a +} 2 +test if-2.2 {optional then-else args} { + set a 44 + if 1 then {set a 1} else {set a 2} + set a +} 1 +test if-2.3 {optional then-else args} { + set a 44 + if 0 {set a 1} else {set a 2} + set a +} 2 +test if-2.4 {optional then-else args} { + set a 44 + if 1 {set a 1} else {set a 2} + set a +} 1 +test if-2.5 {optional then-else args} { + set a 44 + if 0 then {set a 1} {set a 2} + set a +} 2 +test if-2.6 {optional then-else args} { + set a 44 + if 1 then {set a 1} {set a 2} + set a +} 1 +test if-2.7 {optional then-else args} { + set a 44 + if 0 then {set a 1} else {set a 2} + set a +} 2 +test if-2.8 {optional then-else args} { + set a 44 + if 0 then {set a 1} elseif 0 {set a 2} elseif 0 {set a 3} {set a 4} + set a +} 4 + +test if-3.1 {return value} { + if 1 then {set a 22; concat abc} +} abc +test if-3.2 {return value} { + if 0 then {set a 22; concat abc} elseif 1 {concat def} {concat ghi} +} def +test if-3.3 {return value} { + if 0 then {set a 22; concat abc} else {concat def} +} def +test if-3.4 {return value} { + if 0 then {set a 22; concat abc} +} {} +test if-3.5 {return value} { + if 0 then {set a 22; concat abc} elseif 0 {concat def} +} {} + +test if-4.1 {error conditions} { + list [catch {if} msg] $msg +} {1 {wrong # args: no expression after "if" argument}} +test if-4.2 {error conditions} { + list [catch {if {[error "error in condition"]}} msg] $msg +} {1 {error in condition}} +test if-4.3 {error conditions} { + list [catch {if 2} msg] $msg +} {1 {wrong # args: no script following "2" argument}} +test if-4.4 {error conditions} { + list [catch {if 2 then} msg] $msg +} {1 {wrong # args: no script following "then" argument}} +test if-4.5 {error conditions} { + list [catch {if 2 the} msg] $msg +} {1 {invalid command name "the"}} +test if-4.6 {error conditions} { + list [catch {if 2 then {[error "error in then clause"]}} msg] $msg +} {1 {error in then clause}} +test if-4.7 {error conditions} { + list [catch {if 0 then foo elseif} msg] $msg +} {1 {wrong # args: no expression after "elseif" argument}} +test if-4.8 {error conditions} { + list [catch {if 0 then foo elsei} msg] $msg +} {1 {invalid command name "elsei"}} +test if-4.9 {error conditions} { + list [catch {if 0 then foo elseif 0 bar else} msg] $msg +} {1 {wrong # args: no script following "else" argument}} +test if-4.10 {error conditions} { + list [catch {if 0 then foo elseif 0 bar els} msg] $msg +} {1 {invalid command name "els"}} +test if-4.11 {error conditions} { + list [catch {if 0 then foo elseif 0 bar else {[error "error in else clause"]}} msg] $msg +} {1 {error in else clause}} diff --git a/contrib/tcl/tests/incr.test b/contrib/tcl/tests/incr.test new file mode 100644 index 0000000..b9b7fba --- /dev/null +++ b/contrib/tcl/tests/incr.test @@ -0,0 +1,88 @@ +# Commands covered: lreplace +# +# 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) 1991-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: @(#) incr.test 1.8 96/02/16 08:56:00 + +if {[string compare test [info procs test]] == 1} then {source defs} + +catch {unset x} + +test incr-1.1 {basic incr operation} { + set x 23 + list [incr x] $x +} {24 24} +test incr-1.2 {basic incr operation} { + set x 106 + list [incr x -5] $x +} {101 101} +test incr-1.3 {basic incr operation} { + set x " -106" + list [incr x 1] $x +} {-105 -105} +test incr-1.3 {basic incr operation} { + set x " +106" + list [incr x 1] $x +} {107 107} + +test incr-2.1 {incr errors} { + list [catch incr msg] $msg +} {1 {wrong # args: should be "incr varName ?increment?"}} +test incr-2.2 {incr errors} { + list [catch {incr a b c} msg] $msg +} {1 {wrong # args: should be "incr varName ?increment?"}} +test incr-2.3 {incr errors} { + catch {unset x} + list [catch {incr x} msg] $msg $errorInfo +} {1 {can't read "x": no such variable} {can't read "x": no such variable + while executing +"incr x"}} +test incr-2.4 {incr errors} { + set x abc + list [catch {incr x} msg] $msg $errorInfo +} {1 {expected integer but got "abc"} {expected integer but got "abc" + (reading value of variable to increment) + invoked from within +"incr x"}} +test incr-2.5 {incr errors} { + set x 123 + list [catch {incr x 1a} msg] $msg $errorInfo +} {1 {expected integer but got "1a"} {expected integer but got "1a" + (reading increment) + invoked from within +"incr x 1a"}} +test incr-2.6 {incr errors} { + proc readonly args {error "variable is read-only"} + set x 123 + trace var x w readonly + list [catch {incr x 1} msg] $msg $errorInfo +} {1 {can't set "x": variable is read-only} {can't set "x": variable is read-only + while executing +"incr x 1"}} +catch {unset x} +test incr-2.7 {incr errors} { + set x - + list [catch {incr x 1} msg] $msg +} {1 {expected integer but got "-"}} +test incr-2.8 {incr errors} { + set x { - } + list [catch {incr x 1} msg] $msg +} {1 {expected integer but got " - "}} +test incr-2.9 {incr errors} { + set x + + list [catch {incr x 1} msg] $msg +} {1 {expected integer but got "+"}} +test incr-2.10 {incr errors} { + set x {20 x} + list [catch {incr x 1} msg] $msg +} {1 {expected integer but got "20 x"}} + +concat {} diff --git a/contrib/tcl/tests/info.test b/contrib/tcl/tests/info.test new file mode 100644 index 0000000..9e8f012 --- /dev/null +++ b/contrib/tcl/tests/info.test @@ -0,0 +1,555 @@ +# Commands covered: info +# +# 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) 1991-1994 The Regents of the University of California. +# Copyright (c) 1994-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: @(#) info.test 1.33 96/03/22 12:12:48 + +if {[string compare test [info procs test]] == 1} then {source defs} + +test info-1.1 {info args option} { + proc t1 {a bbb c} {return foo} + info args t1 +} {a bbb c} +test info-1.2 {info args option} { + proc t1 {{a default1} {bbb default2} {c default3} args} {return foo} + info a t1 +} {a bbb c args} +test info-1.3 {info args option} { + proc t1 "" {return foo} + info args t1 +} {} +test info-1.4 {info args option} { + catch {rename t1 {}} + list [catch {info args t1} msg] $msg +} {1 {"t1" isn't a procedure}} +test info-1.5 {info args option} { + list [catch {info args set} msg] $msg +} {1 {"set" isn't a procedure}} + +test info-2.1 {info body option} { + proc t1 {} {body of t1} + info body t1 +} {body of t1} +test info-2.2 {info body option} { + list [catch {info body set} msg] $msg +} {1 {"set" isn't a procedure}} +test info-2.3 {info body option} { + list [catch {info args set 1} msg] $msg +} {1 {wrong # args: should be "info args procname"}} + +test info-3.1 {info cmdcount option} { + set x [info cmdcount] + set y 12345 + set z [info cm] + expr $z-$x +} 3 +test info-3.2 {info body option} { + list [catch {info cmdcount 1} msg] $msg +} {1 {wrong # args: should be "info cmdcount"}} + +test info-4.1 {info commands option} { + proc t1 {} {} + proc t2 {} {} + set x " [info commands] " + list [string match {* t1 *} $x] [string match {* t2 *} $x] \ + [string match {* set *} $x] [string match {* list *} $x] +} {1 1 1 1} +test info-4.2 {info commands option} { + proc t1 {} {} + rename t1 {} + set x [info comm] + string match {* t1 *} $x +} 0 +test info-4.3 {info commands option} { + proc _t1_ {} {} + proc _t2_ {} {} + info commands _t1_ +} _t1_ +test info-4.4 {info commands option} { + proc _t1_ {} {} + proc _t2_ {} {} + lsort [info commands _t*] +} {_t1_ _t2_} +catch {rename _t1_ {}} +catch {rename _t2_ {}} +test info-4.5 {info commands option} { + list [catch {info commands a b} msg] $msg +} {1 {wrong # args: should be "info commands ?pattern?"}} + +test info-5.1 {info complete option} { + info complete "" +} 1 +test info-5.2 {info complete option} { + info complete " \n" +} 1 +test info-5.3 {info complete option} { + info complete "abc def" +} 1 +test info-5.4 {info complete option} { + info complete "a b c d e f \t\n" +} 1 +test info-5.5 {info complete option} { + info complete {a b c"d} +} 1 +test info-5.6 {info complete option} { + info complete {a b "c d" e} +} 1 +test info-5.7 {info complete option} { + info complete {a b "c d"} +} 1 +test info-5.8 {info complete option} { + info complete {a b "c d"} +} 1 +test info-5.9 {info complete option} { + info complete {a b "c d} +} 0 +test info-5.10 {info complete option} { + info complete {a b "} +} 0 +test info-5.11 {info complete option} { + info complete {a b "cd"xyz} +} 1 +test info-5.12 {info complete option} { + info complete {a b "c $d() d"} +} 1 +test info-5.13 {info complete option} { + info complete {a b "c $dd("} +} 0 +test info-5.14 {info complete option} { + info complete {a b "c \"} +} 0 +test info-5.15 {info complete option} { + info complete {a b "c [d e f]"} +} 1 +test info-5.16 {info complete option} { + info complete {a b "c [d e f] g"} +} 1 +test info-5.17 {info complete option} { + info complete {a b "c [d e f"} +} 0 +test info-5.18 {info complete option} { + info complete {a {b c d} e} +} 1 +test info-5.19 {info complete option} { + info complete {a {b c d}} +} 1 +test info-5.20 {info complete option} { + info complete "a b\{c d" +} 1 +test info-5.21 {info complete option} { + info complete "a b \{c" +} 0 +test info-5.22 {info complete option} { + info complete "a b \{c{ }" +} 0 +test info-5.23 {info complete option} { + info complete "a b {c d e}xxx" +} 1 +test info-5.24 {info complete option} { + info complete "a b {c \\\{d e}xxx" +} 1 +test info-5.25 {info complete option} { + info complete {a b [ab cd ef]} +} 1 +test info-5.26 {info complete option} { + info complete {a b x[ab][cd][ef] gh} +} 1 +test info-5.27 {info complete option} { + info complete {a b x[ab][cd[ef] gh} +} 0 +test info-5.28 {info complete option} { + info complete {a b x[ gh} +} 0 +test info-5.29 {info complete option} { + info complete {[]]]} +} 1 +test info-5.30 {info complete option} { + info complete {abc x$yyy} +} 1 +test info-5.31 {info complete option} { + info complete "abc x\${abc\[\\d} xyz" +} 1 +test info-5.32 {info complete option} { + info complete "abc x\$\{ xyz" +} 0 +test info-5.33 {info complete option} { + info complete {word $a(xyz)} +} 1 +test info-5.34 {info complete option} { + info complete {word $a(} +} 0 +test info-5.35 {info complete option} { + info complete "set a \\\n" +} 0 +test info-5.36 {info complete option} { + info complete "set a \\n " +} 1 +test info-5.37 {info complete option} { + info complete "set a \\" +} 1 +test info-5.38 {info complete option} { + info complete "foo \\\n\{" +} 0 +test info-5.39 {info complete option} { + info complete " # \{" +} 1 +test info-5.40 {info complete option} { + info complete "foo bar;# \{" +} 1 +test info-5.41 {info complete option} { + info complete "a\nb\n# \{\n# \{\nc\n" +} 1 +test info-5.42 {info complete option} { + info complete "#Incomplete comment\\\n" +} 0 +test info-5.43 {info complete option} { + info complete "#Incomplete comment\\\nBut now it's complete.\n" +} 1 +test info-5.44 {info complete option} { + info complete "# Complete comment\\\\\n" +} 1 +test info-5.45 {info complete option} { + info complete "abc\\\n def" +} 1 +test info-5.46 {info complete option} { + info complete "abc\\\n " +} 1 +test info-5.47 {info complete option} { + info complete "abc\\\n" +} 0 + +test info-6.1 {info default option} { + proc t1 {a b {c d} {e "long default value"}} {} + info default t1 a value +} 0 +test info-6.2 {info default option} { + proc t1 {a b {c d} {e "long default value"}} {} + set value 12345 + info d t1 a value + set value +} {} +test info-6.3 {info default option} { + proc t1 {a b {c d} {e "long default value"}} {} + info default t1 c value +} 1 +test info-6.4 {info default option} { + proc t1 {a b {c d} {e "long default value"}} {} + set value 12345 + info default t1 c value + set value +} d +test info-6.5 {info default option} { + proc t1 {a b {c d} {e "long default value"}} {} + set value 12345 + set x [info default t1 e value] + list $x $value +} {1 {long default value}} +test info-6.6 {info default option} { + list [catch {info default a b} msg] $msg +} {1 {wrong # args: should be "info default procname arg varname"}} +test info-6.7 {info default option} { + list [catch {info default _nonexistent_ a b} msg] $msg +} {1 {"_nonexistent_" isn't a procedure}} +test info-6.8 {info default option} { + proc t1 {a b} {} + list [catch {info default t1 x value} msg] $msg +} {1 {procedure "t1" doesn't have an argument "x"}} +test info-6.9 {info default option} { + catch {unset a} + set a(0) 88 + proc t1 {a b} {} + list [catch {info default t1 a a} msg] $msg +} {1 {couldn't store default value in variable "a"}} +test info-6.10 {info default option} { + catch {unset a} + set a(0) 88 + proc t1 {{a 18} b} {} + list [catch {info default t1 a a} msg] $msg +} {1 {couldn't store default value in variable "a"}} +catch {unset a} + +test info-7.1 {info exists option} { + set value foo + info exists value +} 1 +catch {unset _nonexistent_} +test info-7.2 {info exists option} { + info exists _nonexistent_ +} 0 +test info-7.3 {info exists option} { + proc t1 {x} {return [info exists x]} + t1 2 +} 1 +test info-7.4 {info exists option} { + proc t1 {x} { + global _nonexistent_ + return [info exists _nonexistent_] + } + t1 2 +} 0 +test info-7.5 {info exists option} { + proc t1 {x} { + set y 47 + return [info exists y] + } + t1 2 +} 1 +test info-7.6 {info exists option} { + proc t1 {x} {return [info exists value]} + t1 2 +} 0 +test info-7.7 {info exists option} { + catch {unset x} + set x(2) 44 + list [info exists x] [info exists x(1)] [info exists x(2)] +} {1 0 1} +catch {unset x} +test info-7.8 {info exists option} { + list [catch {info exists} msg] $msg +} {1 {wrong # args: should be "info exists varName"}} +test info-7.9 {info exists option} { + list [catch {info exists 1 2} msg] $msg +} {1 {wrong # args: should be "info exists varName"}} + +test info-8.1 {info globals option} { + set x 1 + set y 2 + set value 23 + set a " [info globals] " + list [string match {* x *} $a] [string match {* y *} $a] \ + [string match {* value *} $a] [string match {* _foobar_ *} $a] +} {1 1 1 0} +test info-8.2 {info globals option} { + set _xxx1 1 + set _xxx2 2 + lsort [info g _xxx*] +} {_xxx1 _xxx2} +test info-8.3 {info globals option} { + list [catch {info globals 1 2} msg] $msg +} {1 {wrong # args: should be "info globals ?pattern?"}} + +test info-9.1 {info level option} { + info level +} 0 +test info-9.2 {info level option} { + proc t1 {a b} { + set x [info le] + set y [info level 1] + list $x $y + } + t1 146 testString +} {1 {t1 146 testString}} +test info-9.3 {info level option} { + proc t1 {a b} { + t2 [expr $a*2] $b + } + proc t2 {x y} { + list [info level] [info level 1] [info level 2] [info level -1] \ + [info level 0] + } + t1 146 {a {b c} {{{c}}}} +} {2 {t1 146 {a {b c} {{{c}}}}} {t2 292 {a {b c} {{{c}}}}} {t1 146 {a {b c} {{{c}}}}} {t2 292 {a {b c} {{{c}}}}}} +test info-9.4 {info level option} { + proc t1 {} { + set x [info level] + set y [info level 1] + list $x $y + } + t1 +} {1 t1} +test info-9.5 {info level option} { + list [catch {info level 1 2} msg] $msg +} {1 {wrong # args: should be "info level [number]"}} +test info-9.6 {info level option} { + list [catch {info level 123a} msg] $msg +} {1 {expected integer but got "123a"}} +test info-9.7 {info level option} { + list [catch {info level 0} msg] $msg +} {1 {bad level "0"}} +test info-9.8 {info level option} { + proc t1 {} {info level -1} + list [catch {t1} msg] $msg +} {1 {bad level "-1"}} +test info-9.9 {info level option} { + proc t1 {x} {info level $x} + list [catch {t1 -3} msg] $msg +} {1 {bad level "-3"}} + +set savedLibrary tcl_library +test info-10.1 {info library option} { + list [catch {info library x} msg] $msg +} {1 {wrong # args: should be "info library"}} +test info-10.2 {info library option} { + set tcl_library 12345 + info library +} {12345} +test info-10.3 {info library option} { + unset tcl_library + list [catch {info library} msg] $msg +} {1 {no library has been specified for Tcl}} +set tcl_library $savedLibrary + +test info-11.1 {info loaded option} { + list [catch {info loaded a b} msg] $msg +} {1 {wrong # args: should be "info loaded ?interp?"}} +test info-11.2 {info loaded option} { + list [catch {info loaded {}}] [catch {info loaded gorp} msg] $msg +} {0 1 {couldn't find slave interpreter named "gorp"}} + +test info-12.1 {info locals option} { + set a 22 + proc t1 {x y} { + set b 13 + set c testing + global a + return [info locals] + } + lsort [t1 23 24] +} {b c x y} +test info-12.2 {info locals option} { + proc t1 {x y} { + set xx1 2 + set xx2 3 + set y 4 + return [info loc x*] + } + lsort [t1 2 3] +} {x xx1 xx2} +test info-12.3 {info locals option} { + list [catch {info locals 1 2} msg] $msg +} {1 {wrong # args: should be "info locals ?pattern?"}} +test info-12.4 {info locals option} { + info locals +} {} +test info-12.5 {info locals option} { + proc t1 {} {return [info locals]} + t1 +} {} + +test info-13.1 {info nameofexecutable option} { + list [catch {info nameofexecutable foo} msg] $msg +} {1 {wrong # args: should be "info nameofexecutable"}} + +test info-14.1 {info patchlevel option} { + set a [info patchlevel] + regexp {[0-9]+\.[0-9]+([p[0-9]+)?} $a +} 1 +test info-14.2 {info patchlevel option} { + list [catch {info patchlevel a} msg] $msg +} {1 {wrong # args: should be "info patchlevel"}} +test info-14.3 {info patchlevel option} { + set t $tcl_patchLevel + unset tcl_patchLevel + set result [list [catch {info patchlevel} msg] $msg] + set tcl_patchLevel $t + set result +} {1 {can't read "tcl_patchLevel": no such variable}} + +test info-15.1 {info procs option} { + proc t1 {} {} + proc t2 {} {} + set x " [info procs] " + list [string match {* t1 *} $x] [string match {* t2 *} $x] \ + [string match {* _undefined_ *} $x] +} {1 1 0} +test info-15.2 {info procs option} { + proc _tt1 {} {} + proc _tt2 {} {} + lsort [info pr _tt*] +} {_tt1 _tt2} +catch {rename _tt1 {}} +catch {rename _tt2 {}} +test info-15.3 {info procs option} { + list [catch {info procs 2 3} msg] $msg +} {1 {wrong # args: should be "info procs ?pattern?"}} + +test info-16.1 {info script option} { + list [catch {info script x} msg] $msg +} {1 {wrong # args: should be "info script"}} +test info-16.2 {info script option} { + file tail [info sc] +} info.test +removeFile gorp.info +makeFile "info script\n" gorp.info +test info-16.3 {info script option} { + list [source gorp.info] [file tail [info script]] +} {gorp.info info.test} +test info-16.4 {resetting "info script" after errors} { + catch {source ~_nobody_/foo} + file tail [info script] +} {info.test} +test info-16.5 {resetting "info script" after errors} { + catch {source _nonexistent_} + file tail [info script] +} {info.test} +removeFile gorp.info + +test info-17.1 {info sharedlibextension option} { + list [catch {info sharedlibextension foo} msg] $msg +} {1 {wrong # args: should be "info sharedlibextension"}} + +test info-18.1 {info tclversion option} { + set x [info tclversion] + scan $x "%d.%d%c" a b c +} 2 +test info-18.2 {info tclversion option} { + list [catch {info t 2} msg] $msg +} {1 {wrong # args: should be "info tclversion"}} +test info-18.3 {info tclversion option} { + set t $tcl_version + unset tcl_version + set result [list [catch {info tclversion} msg] $msg] + set tcl_version $t + set result +} {1 {can't read "tcl_version": no such variable}} + +test info-19.1 {info vars option} { + set a 1 + set b 2 + proc t1 {x y} { + global a b + set c 33 + return [info vars] + } + lsort [t1 18 19] +} {a b c x y} +test info-19.2 {info vars option} { + set xxx1 1 + set xxx2 2 + proc t1 {xxa y} { + global xxx1 xxx2 + set c 33 + return [info vars x*] + } + lsort [t1 18 19] +} {xxa xxx1 xxx2} +test info-19.3 {info vars option} { + lsort [info vars] +} [lsort [info globals]] +test info-19.4 {info vars option} { + list [catch {info vars a b} msg] $msg +} {1 {wrong # args: should be "info vars ?pattern?"}} + +test info-20.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} { + list [catch {info gorp} msg] $msg +} {1 {bad option "gorp": should 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} { + list [catch {info c} msg] $msg +} {1 {bad option "c": should 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} { + list [catch {info l} msg] $msg +} {1 {bad option "l": should 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} { + list [catch {info s} msg] $msg +} {1 {bad option "s": should be args, body, cmdcount, commands, complete, default, exists, globals, hostname, level, library, loaded, locals, nameofexecutable, patchlevel, procs, script, sharedlibextension, tclversion, or vars}} diff --git a/contrib/tcl/tests/interp.test b/contrib/tcl/tests/interp.test new file mode 100644 index 0000000..c82b901 --- /dev/null +++ b/contrib/tcl/tests/interp.test @@ -0,0 +1,570 @@ +# This file tests the multiple interpreter facility of Tcl +# +# 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) 1995-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: @(#) interp.test 1.24 96/03/27 10:23:29 + +if {[string compare test [info procs test]] == 1} then {source defs} + +foreach i [interp slaves] { + interp delete $i +} + +proc equiv {x} {return $x} + +# Part 0: Check out options for interp command +test interp-1.1 {options for interp command} { + list [catch {interp} msg] $msg +} {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": should be alias, aliases, create, delete, exists, eval, issafe, share, slaves, target or transfer}} +test interp-1.3 {options for interp command} { + interp delete +} "" +test interp-1.4 {options for interp command} { + list [catch {interp delete foo bar} msg] $msg +} {1 {interpreter named "foo" not found}} +test interp-1.5 {options for interp command} { + list [catch {interp exists foo bar} msg] $msg +} {1 {wrong # args: should be "interp exists ?path?"}} +# +# test interp-0.6 was removed +# +test interp-1.6 {options for interp command} { + list [catch {interp slaves foo bar zop} msg] $msg +} {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": should be alias, aliases, create, delete, exists, eval, issafe, share, slaves, target or transfer}} +test interp-1.8 {options for interp command} { + list [catch {interp -froboz} msg] $msg +} {1 {bad option "-froboz": should be alias, aliases, create, delete, exists, eval, issafe, share, slaves, target or transfer}} +test interp-1.9 {options for interp command} { + list [catch {interp -froboz -safe} msg] $msg +} {1 {bad option "-froboz": should be alias, aliases, create, delete, exists, eval, issafe, share, slaves, 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 +} a +test interp-2.2 {basic interpreter creation} { + catch {interp create} +} 0 +test interp-2.3 {basic interpreter creation} { + catch {interp create -safe} +} 0 +test interp-2.4 {basic interpreter creation} { + list [catch {interp create a} msg] $msg +} {1 {interpreter named "a" already exists, cannot create}} +test interp-2.5 {basic interpreter creation} { + interp create b -safe +} b +test interp-2.6 {basic interpreter creation} { + interp create d -safe +} d +test interp-2.7 {basic interpreter creation} { + list [catch {interp create -froboz} msg] $msg +} {1 {bad option "-froboz": should be -safe}} +test interp-2.8 {basic interpreter creation} { + interp create -- -froboz +} -froboz +test interp-2.9 {basic interpreter creation} { + interp create -safe -- -froboz1 +} -froboz1 +test interp-2.10 {basic interpreter creation} { + interp create {a x1} + interp create {a x2} + interp create {a x3} -safe +} {a x3} + +foreach i [interp slaves] { + interp delete $i +} + +# Part 2: Testing "interp slaves" and "interp exists" +test interp-3.1 {testing interp exists and interp slaves} { + interp slaves +} "" +test interp-3.2 {testing interp exists and interp slaves} { + interp create a + interp exists a +} 1 +test interp-3.3 {testing interp exists and interp slaves} { + interp exists nonexistent +} 0 +test interp-3.4 {testing interp exists and interp slaves} { + list [catch {interp slaves a b c} msg] $msg +} {1 {wrong # args: should be "interp slaves ?path?"}} +test interp-3.5 {testing interp exists and interp slaves} { + list [catch {interp exists a b c} msg] $msg +} {1 {wrong # args: should be "interp exists ?path?"}} +test interp-3.6 {testing interp exists and interp slaves} { + interp exists +} 1 +test interp-3.7 {testing interp exists and interp slaves} { + interp slaves +} a +test interp-3.8 {testing interp exists and interp slaves} { + list [catch {interp slaves a b c} msg] $msg +} {1 {wrong # args: should be "interp slaves ?path?"}} +test interp-3.9 {testing interp exists and interp slaves} { + interp create {a a2} -safe + interp slaves a +} {a2} +test interp-3.10 {testing interp exists and interp slaves} { + interp exists {a a2} +} 1 + +# Part 3: Testing "interp delete" +test interp-3.11 {testing interp delete} { + interp delete +} "" +test interp-4.1 {testing interp delete} { + interp delete a +} "" +test interp-4.2 {testing interp delete} { + list [catch {interp delete nonexistent} msg] $msg +} {1 {interpreter named "nonexistent" not found}} +test interp-4.3 {testing interp delete} { + list [catch {interp delete x y z} msg] $msg +} {1 {interpreter named "x" not found}} +test interp-4.4 {testing interp delete} { + interp delete +} "" +test interp-4.5 {testing interp delete} { + interp create a + interp create {a x1} + interp delete {a x1} + interp slaves a +} "" +test interp-4.6 {testing interp delete} { + interp create c1 + interp create c2 + interp create c3 + interp delete c1 c2 c3 +} "" +test interp-4.7 {testing interp delete} { + interp create c1 + interp create c2 + list [catch {interp delete c1 c2 c3} msg] $msg +} {1 {interpreter named "c3" not found}} + +foreach i [interp slaves] { + interp delete $i +} + +# Part 4: Consistency checking - all nondeleted interpreters should be +# there: +test interp-5.1 {testing consistency} { + interp slaves +} "" +test interp-5.2 {testing consistency} { + interp exists a +} 0 +test interp-5.3 {testing consistency} { + interp exists nonexistent +} 0 + +# Recreate interpreter "a" +interp create a + +# Part 5: Testing eval in interpreter object command and with interp command +test interp-6.1 {testing eval} { + a eval expr 3 + 5 +} 8 +test interp-6.2 {testing eval} { + list [catch {a eval foo} msg] $msg +} {1 {invalid command name "foo"}} +test interp-6.3 {testing eval} { + a eval {proc foo {} {expr 3 + 5}} + a eval foo +} 8 +test interp-6.4 {testing eval} { + interp eval a foo +} 8 + +test interp-6.5 {testing eval} { + interp create {a x2} + interp eval {a x2} {proc frob {} {expr 4 * 9}} + interp eval {a x2} frob +} 36 +test interp-6.6 {testing eval} { + list [catch {interp eval {a x2} foo} msg] $msg +} {1 {invalid command name "foo"}} + +# UTILITY PROCEDURE RUNNING IN MASTER INTERPRETER: +proc in_master {args} { + return [list seen in master: $args] +} + +# Part 6: Testing basic alias creation +test interp-7.1 {testing basic alias creation} { + a alias foo in_master +} foo +test interp-7.2 {testing basic alias creation} { + a alias bar in_master a1 a2 a3 +} bar +# Test 6.3 has been deleted. +test interp-7.3 {testing basic alias creation} { + a alias foo +} in_master +test interp-7.4 {testing basic alias creation} { + a alias bar +} {in_master a1 a2 a3} +test interp-7.5 {testing basic alias creation} { + a aliases +} {foo bar} + +# Part 7: testing basic alias invocation +test interp-8.1 {testing basic alias invocation} { + a eval foo s1 s2 s3 +} {seen in master: {s1 s2 s3}} +test interp-8.2 {testing basic alias invocation} { + a eval bar s1 s2 s3 +} {seen in master: {a1 a2 a3 s1 s2 s3}} + +# Part 8: Testing aliases for non-existent targets +test interp-9.1 {testing aliases for non-existent targets} { + a alias zop nonexistent-command-in-master + list [catch {a eval zop} msg] $msg +} {1 {aliased target "nonexistent-command-in-master" for "zop" not found}} +test interp-9.2 {testing aliases for non-existent targets} { + proc nonexistent-command-in-master {} {return i_exist!} + a eval zop +} i_exist! + +if {[info command nonexistent-command-in-master] != ""} { + rename nonexistent-command-in-master {} +} + +# Recreate interpreter b.. +if {![interp exists b]} { + interp create b +} + +# Part 9: Aliasing between interpreters +test interp-10.1 {testing aliasing between interpreters} { + interp alias a a_alias b b_alias 1 2 3 +} a_alias +test interp-10.2 {testing aliasing between interpreters} { + b eval {proc b_alias {args} {return [list got $args]}} + a eval a_alias a b c +} {got {1 2 3 a b c}} +test interp-10.3 {testing aliasing between interpreters} { + b eval {rename b_alias {}} + list [catch {a eval a_alias a b c} msg] $msg +} {1 {aliased target "b_alias" for "a_alias" not found}} +test interp-10.4 {testing aliasing between interpreters} { + a aliases +} {foo zop bar a_alias} +test interp-10.5 {testing aliasing between interpreters} { + interp delete b + a aliases +} {foo zop bar} + +# Recreate interpreter b.. +if {![interp exists b]} { + interp create b +} + +test interp-10.6 {testing aliasing between interpreters} { + interp alias a a_command b b_command a1 a2 a3 + b alias b_command in_master b1 b2 b3 + a eval a_command m1 m2 m3 +} {seen in master: {b1 b2 b3 a1 a2 a3 m1 m2 m3}} +test interp-10.7 {testing aliases between interpreters} { + interp alias "" foo a zoppo + a eval {proc zoppo {x} {list $x $x $x}} + set x [foo 33] + a eval {rename zoppo {}} + interp alias "" foo a {} + equiv $x +} {33 33 33} + +# Part 10: Testing "interp target" +test interp-11.1 {testing interp target} { + list [catch {interp target} msg] $msg +} {1 {wrong # args: should be "interp target path alias"}} +test interp-11.2 {testing interp target} { + list [catch {interp target nosuchinterpreter foo} msg] $msg +} {1 {could not find interpreter "nosuchinterpreter"}} +test interp-11.3 {testing interp target} { + a alias boo no_command + interp target a boo +} "" +test interp-11.4 {testing interp target} { + interp create x1 + x1 eval interp create x2 + x1 eval x2 eval interp create x3 + interp create y1 + y1 eval interp create y2 + y1 eval y2 eval interp create y3 + interp alias {x1 x2 x3} xcommand {y1 y2 y3} ycommand + interp target {x1 x2 x3} xcommand +} {y1 y2 y3} +test interp-11.5 {testing interp target} { + list [catch {x1 eval {interp target {x2 x3} xcommand}} msg] $msg +} {1 {target interpreter for alias "xcommand" in path "x2 x3" is not my descendant}} + +# Part 11: testing "interp issafe" +test interp-12.1 {testing interp issafe} { + interp issafe +} 0 +test interp-12.2 {testing interp issafe} { + interp issafe a +} 0 +test interp-12.3 {testing interp issafe} { + interp create {a x3} -safe + interp issafe {a x3} +} 1 +test interp-12.4 {testing interp issafe} { + interp create {a x3 foo} + interp issafe {a x3 foo} +} 1 + +# Part 12: testing interpreter object command "issafe" sub-command +test interp-13.1 {testing foo issafe} { + a issafe +} 0 +test interp-13.2 {testing foo issafe} { + a eval x3 issafe +} 1 +test interp-13.3 {testing foo issafe} { + a eval x3 eval foo issafe +} 1 + +# part 13: testing interp aliases +test interp-14.1 {testing interp aliases} { + interp aliases +} "" +test interp-14.2 {testing interp aliases} { + interp aliases a +} {boo foo zop bar a_command} +test interp-14.3 {testing interp aliases} { + interp alias {a x3} froboz "" puts + interp aliases {a x3} +} froboz + +test interp-15.1 {testing file sharing} { + interp create z + z eval close stdout + list [catch {z eval puts hello} msg] $msg +} {1 {can not find channel named "stdout"}} +test interp-15.2 {testing file sharing} { + set f [open foo w] + interp share "" $f z + z eval puts $f hello + z eval close $f + close $f +} "" +test interp-15.3 {testing file sharing} { + interp create xsafe -safe + list [catch {xsafe eval puts hello} msg] $msg +} {1 {can not find channel named "stdout"}} +test interp-15.4 {testing file sharing} { + set f [open foo w] + interp share "" $f xsafe + xsafe eval puts $f hello + xsafe eval close $f + close $f +} "" +test interp-15.5 {testing file sharing} { + interp share "" stdout xsafe + list [catch {xsafe eval gets stdout} msg] $msg +} {1 {channel "stdout" wasn't opened for reading}} +test interp-15.6 {testing file sharing} { + set f [open foo w] + interp share "" $f xsafe + set x [list [catch [list xsafe eval gets $f] msg] $msg] + close $f + string compare [string tolower $x] \ + [list 1 [format "channel \"%s\" wasn't opened for reading" $f]] +} 0 +test interp-15.7 {testing file transferring} { + set f [open foo w] + interp transfer "" $f xsafe + xsafe eval puts $f hello + xsafe eval close $f +} "" +test interp-15.8 {testing file transferring} { + set f [open foo 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 +removeFile foo + +# +# Torture tests for interpreter deletion order +# +proc kill {} {interp delete xxx} + +test interp-15.9 {testing deletion order} { + interp create xxx + xxx alias kill kill + list [catch {xxx eval kill} msg] $msg +} {0 {}} +test interp-16.1 {testing deletion order} { + interp create xxx + interp create {xxx yyy} + interp alias {xxx yyy} kill "" kill + list [catch {interp eval {xxx yyy} kill} msg] $msg +} {0 {}} +test interp-16.2 {testing deletion order} { + interp create xxx + interp create {xxx yyy} + interp alias {xxx yyy} kill "" kill + list [catch {xxx eval yyy eval kill} msg] $msg +} {0 {}} +test interp-16.3 {testing deletion order} { + interp create xxx + interp create ddd + xxx alias kill kill + interp alias ddd kill xxx kill + set x [ddd eval kill] + interp delete ddd + set x +} "" +test interp-16.4 {testing deletion order} { + interp create xxx + interp create {xxx yyy} + interp alias {xxx yyy} kill "" kill + interp create ddd + interp alias ddd kill {xxx yyy} kill + set x [ddd eval kill] + interp delete ddd + set x +} "" + +# +# Alias loop prevention testing. +# + +test interp-16.5 {alias loop prevention} { + list [catch {interp alias {} a {} a} msg] $msg +} {1 {cannot define or rename alias "a": would create a loop}} +test interp-17.1 {alias loop prevention} { + catch {interp delete x} + interp create x + x alias a loop + list [catch {interp alias {} loop x a} msg] $msg +} {1 {cannot define or rename alias "loop": would create a loop}} +test interp-17.2 {alias loop prevention} { + catch {interp delete x} + interp create x + interp alias x a x b + list [catch {interp alias x b x a} msg] $msg +} {1 {cannot define or rename alias "b": would create a loop}} +test interp-17.3 {alias loop prevention} { + catch {interp delete x} + interp create x + interp alias x b x a + list [catch {x eval rename b a} msg] $msg +} {1 {cannot define or rename alias "b": would create a loop}} +test interp-17.4 {alias loop prevention} { + catch {interp delete x} + interp create x + x alias z l1 + interp alias {} l2 x z + list [catch {rename l2 l1} msg] $msg +} {1 {cannot define or rename alias "l2": would create a loop}} + +# +# Test robustness of Tcl_DeleteInterp when applied to a slave interpreter. +# If there are bugs in the implementation these tests are likely to expose +# the bugs as a core dump. +# + +if {[info commands testinterpdelete] != ""} { + test interp-17.5 {testing Tcl_DeleteInterp vs slaves} { + list [catch {testinterpdelete} msg] $msg + } {1 {wrong # args: should be "testinterpdelete path"}} + test interp-18.1 {testing Tcl_DeleteInterp vs slaves} { + catch {interp delete a} + interp create a + testinterpdelete a + } "" + test interp-18.2 {testing Tcl_DeleteInterp vs slaves} { + catch {interp delete a} + interp create a + interp create {a b} + testinterpdelete {a b} + } "" + test interp-18.3 {testing Tcl_DeleteInterp vs slaves} { + catch {interp delete a} + interp create a + interp create {a b} + testinterpdelete a + } "" + test interp-18.4 {testing Tcl_DeleteInterp vs slaves} { + catch {interp delete a} + interp create a + interp create {a b} + interp alias {a b} dodel {} dodel + proc dodel {x} {testinterpdelete $x} + list [catch {interp eval {a b} {dodel {a b}}} msg] $msg + } {0 {}} + test interp-18.5 {testing Tcl_DeleteInterp vs slaves} { + catch {interp delete a} + interp create a + interp create {a b} + interp alias {a b} dodel {} dodel + proc dodel {x} {testinterpdelete $x} + list [catch {interp eval {a b} {dodel a}} msg] $msg + } {0 {}} + test interp-18.6 {eval in deleted interp} { + catch {interp delete a} + interp create a + a eval { + proc dodel {} { + delme + dosomething else + } + proc dosomething args { + puts "I should not have been called!!" + } + } + a alias delme dela + proc dela {} {interp delete a} + list [catch {a eval dodel} msg] $msg + } {1 {attempt to call eval in deleted interpreter}} + test interp-18.7 {eval in deleted interp} { + catch {interp delete a} + interp create a + a eval { + interp create b + b eval { + proc dodel {} { + dela + } + } + proc foo {} { + b eval dela + dosomething else + } + proc dosomething args { + puts "I should not have been called!!" + } + } + interp alias {a b} dela {} dela + proc dela {} {interp delete a} + list [catch {a eval foo} msg] $msg + } {1 {attempt to call eval in deleted interpreter}} +} + +foreach i [interp slaves] { + interp delete $i +} diff --git a/contrib/tcl/tests/io.test b/contrib/tcl/tests/io.test new file mode 100644 index 0000000..60b75cd --- /dev/null +++ b/contrib/tcl/tests/io.test @@ -0,0 +1,4341 @@ +# Functionality covered: operation of all IO commands, and all procedures +# defined in generic/tclIO.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 +# 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-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. +# +# "@(#) io.test 1.75 96/04/18 09:58:51" + +if {[string compare test [info procs test]] == 1} then {source defs} + +removeFile test1 +removeFile pipe + +# These tests are disabled until we decide what to do with "unsupported0". +# +#test io-1.7 {unsupported0 command} { +# removeFile test1 +# set f1 [open iocmd.test] +# set f2 [open test1 w] +# unsupported0 $f1 $f2 +# close $f1 +# catch {close $f2} +# set s1 [file size io.test] +# set s2 [file size test1] +# set x ok +# if {"$s1" != "$s2"} { +# set x broken +# } +# set x +#} ok +#test io-1.8 {unsupported0 command} { +# removeFile test1 +# set f1 [open io.test] +# set f2 [open test1 w] +# unsupported0 $f1 $f2 40 +# close $f1 +# close $f2 +# file size test1 +#} 40 +#test io-1.9 {unsupported0 command} { +# removeFile test1 +# set f1 [open io.test] +# set f2 [open test1 w] +# unsupported0 $f1 $f2 -1 +# close $f1 +# close $f2 +# set x ok +# set s1 [file size io.test] +# set s2 [file size test1] +# if {$s1 != $s2} { +# set x broken +# } +# set x +#} ok +#test io-1.10 {unsupported0 command} {unixOrPc} { +# removeFile pipe +# removeFile test1 +# set f1 [open pipe w] +# puts $f1 {puts ready} +# puts $f1 {gets stdin} +# puts $f1 {set f1 [open io.test r]} +# puts $f1 {puts [read $f1 100]} +# puts $f1 {close $f1} +# close $f1 +# set f1 [open "|$tcltest pipe" r+] +# gets $f1 +# puts $f1 ready +# flush $f1 +# set f2 [open test1 w] +# set c [unsupported0 $f1 $f2 40] +# catch {close $f1} +# close $f2 +# set s1 [file size test1] +# set x ok +# if {$s1 != "40"} { +# set x broken +# } +# list $c $x +#} {40 ok} + +# Test standard handle management. The functions tested are +# Tcl_SetStdChannel and Tcl_GetStdChannel. Incidentally we are +# also testing channel table management. + +if {$tcl_platform(platform) == "macintosh"} { + set consoleFileNames [list console0 console1 console2] +} else { + set consoleFileNames [lsort [testchannel open]] +} +test io-1.1 {Tcl_SetStdChannel and Tcl_GetStdChannel} { + set l "" + lappend l [fconfigure stdin -buffering] + lappend l [fconfigure stdout -buffering] + lappend l [fconfigure stderr -buffering] + lappend l [lsort [testchannel open]] + set l +} [list line line none $consoleFileNames] +test io-1.2 {Tcl_SetStdChannel and Tcl_GetStdChannel} { + interp create x + set l "" + lappend l [x eval {fconfigure stdin -buffering}] + lappend l [x eval {fconfigure stdout -buffering}] + lappend l [x eval {fconfigure stderr -buffering}] + interp delete x + set l +} {line line none} +test io-1.3 {Tcl_SetStdChannel & Tcl_GetStdChannel} {unixOrPc} { + set f [open test1 w] + puts $f { + close stdin + close stdout + close stderr + set f [open test1 r] + set f2 [open test2 w] + set f3 [open test3 w] + puts stdout [gets stdin] + puts stdout out + puts stderr err + close $f + close $f2 + close $f3 + } + close $f + set result [eval exec $tcltest test1] + set f [open test2 r] + set f2 [open test3 r] + lappend result [read $f] [read $f2] + close $f + close $f2 + set result +} {{ +out +} {err +}} +# This test relies on the fact that the smallest available fd is used first. +test io-1.4 {Tcl_SetStdChannel & Tcl_GetStdChannel} {unixOnly} { + set f [open test1 w] + puts $f { close stdin + close stdout + close stderr + set f [open test1 r] + set f2 [open test2 w] + set f3 [open test3 w] + puts stdout [gets stdin] + puts stdout $f2 + puts stderr $f3 + close $f + close $f2 + close $f3 + } + close $f + set result [eval exec $tcltest test1] + set f [open test2 r] + set f2 [open test3 r] + lappend result [read $f] [read $f2] + close $f + close $f2 + set result +} {{ close stdin +file1 +} {file2 +}} +catch {interp delete z} +test io-1.5 {Tcl_GetChannel: stdio name translation} { + interp create z + eof stdin + catch {z eval flush stdin} msg1 + catch {z eval close stdin} msg2 + catch {z eval flush stdin} msg3 + set result [list $msg1 $msg2 $msg3] + interp delete z + set result +} {{channel "stdin" wasn't opened for writing} {} {can not find channel named "stdin"}} +test io-1.6 {Tcl_GetChannel: stdio name translation} { + interp create z + eof stdout + catch {z eval flush stdout} msg1 + catch {z eval close stdout} msg2 + catch {z eval flush stdout} msg3 + set result [list $msg1 $msg2 $msg3] + interp delete z + set result +} {{} {} {can not find channel named "stdout"}} +test io-1.7 {Tcl_GetChannel: stdio name translation} { + interp create z + eof stderr + catch {z eval flush stderr} msg1 + catch {z eval close stderr} msg2 + catch {z eval flush stderr} msg3 + set result [list $msg1 $msg2 $msg3] + interp delete z + set result +} {{} {} {can not find channel named "stderr"}} + +# Must add test function for testing Tcl_CreateCloseHandler and +# Tcl_DeleteCloseHandler. + +# Test channel table management. The functions tested are +# GetChannelTable, DeleteChannelTable, Tcl_RegisterChannel, +# Tcl_UnregisterChannel, Tcl_GetChannel and Tcl_CreateChannel. + +test io-3.1 {GetChannelTable, DeleteChannelTable on std handles} { + interp create x + set l "" + lappend l [testchannel refcount stdin] + x eval {eof stdin} + lappend l [testchannel refcount stdin] + interp delete x + lappend l [testchannel refcount stdin] + set l +} {2 2 1} +test io-3.2 {GetChannelTable, DeleteChannelTable on std handles} { + interp create x + set l "" + lappend l [testchannel refcount stdout] + x eval {eof stdout} + lappend l [testchannel refcount stdout] + interp delete x + lappend l [testchannel refcount stdout] + set l +} {2 2 1} +test io-3.3 {GetChannelTable, DeleteChannelTable on std handles} { + interp create x + set l "" + lappend l [testchannel refcount stderr] + x eval {eof stderr} + lappend l [testchannel refcount stderr] + interp delete x + lappend l [testchannel refcount stderr] + set l +} {2 2 1} +test io-3.4 {Tcl_RegisterChannel, Tcl_UnregisterChannel} { + removeFile test1 + set l "" + set f [open test1 w] + lappend l [lindex [testchannel info $f] 15] + close $f + if {[catch {lindex [testchannel info $f] 15} msg]} { + lappend l $msg + } else { + lappend l "very broken: $f found after being closed" + } + string compare [string tolower $l] \ + [list 1 [format "can not find channel named \"%s\"" $f]] +} 0 +test io-3.5 {Tcl_RegisterChannel, Tcl_UnregisterChannel} { + removeFile test1 + set l "" + set f [open test1 w] + lappend l [lindex [testchannel info $f] 15] + interp create x + interp share "" $f x + lappend l [lindex [testchannel info $f] 15] + x eval close $f + lappend l [lindex [testchannel info $f] 15] + interp delete x + lappend l [lindex [testchannel info $f] 15] + close $f + if {[catch {lindex [testchannel info $f] 15} msg]} { + lappend l $msg + } else { + lappend l "very broken: $f found after being closed" + } + string compare [string tolower $l] \ + [list 1 2 1 1 [format "can not find channel named \"%s\"" $f]] +} 0 +test io-3.6 {Tcl_RegisterChannel, Tcl_UnregisterChannel} { + removeFile test1 + set l "" + set f [open test1 w] + lappend l [lindex [testchannel info $f] 15] + interp create x + interp share "" $f x + lappend l [lindex [testchannel info $f] 15] + interp delete x + lappend l [lindex [testchannel info $f] 15] + close $f + if {[catch {lindex [testchannel info $f] 15} msg]} { + lappend l $msg + } else { + lappend l "very broken: $f found after being closed" + } + string compare [string tolower $l] \ + [list 1 2 1 [format "can not find channel named \"%s\"" $f]] +} 0 +test io-3.7 {Tcl_GetChannel->Tcl_GetStdChannel, standard handles} { + eof stdin +} 0 +test io-3.6 {testing Tcl_GetChannel, user opened handle} { + removeFile test1 + set f [open test1 w] + set x [eof $f] + close $f + set x +} 0 +test io-3.8 {Tcl_GetChannel, channel not found} { + list [catch {eof file34} msg] $msg +} {1 {can not find channel named "file34"}} +test io-3.9 {Tcl_CreateChannel, insertion into channel table} { + removeFile test1 + set f [open test1 w] + set l "" + lappend l [eof $f] + close $f + if {[catch {lindex [testchannel info $f] 15} msg]} { + lappend l $msg + } else { + lappend l "very broken: $f found after being closed" + } + string compare [string tolower $l] \ + [list 0 [format "can not find channel named \"%s\"" $f]] +} 0 + +# Test management of attributes associated with a channel, such as +# its default translation, its name and type, etc. The functions +# tested in this group are Tcl_GetChannelName, +# Tcl_GetChannelType and Tcl_GetChannelFile. Tcl_GetChannelInstanceData +# not tested because files do not use the instance data. + +test io-4.1 {Tcl_GetChannelName} { + removeFile test1 + set f [open test1 w] + set n [testchannel name $f] + close $f + string compare $n $f +} 0 +test io-4.2 {Tcl_GetChannelType} { + removeFile test1 + set f [open test1 w] + set t [testchannel type $f] + close $f + string compare $t file +} 0 +test io-4.3 {Tcl_GetChannelFile, input} { + set f [open io.test r] + gets $f + set l "" + lappend l [testchannel inputbuffered $f] + lappend l [tell $f] + close $f + set l +} {4022 74} +test io-4.4 {Tcl_GetChannelFile, output} { + removeFile test1 + set f [open test1 w] + fconfigure $f -translation lf + puts $f hello + set l "" + lappend l [testchannel outputbuffered $f] + lappend l [tell $f] + flush $f + lappend l [testchannel outputbuffered $f] + lappend l [tell $f] + close $f + removeFile test1 + set l +} {6 6 0 6} + +# Test flushing. The functions tested here are FlushChannel. + +test io-5.1 {FlushChannel, no output buffered} { + removeFile test1 + set f [open test1 w] + flush $f + set s [file size test1] + close $f + set s +} 0 +test io-5.2 {FlushChannel, some output buffered} { + removeFile test1 + set f [open test1 w] + fconfigure $f -translation lf -eofchar {} + set l "" + puts $f hello + lappend l [file size test1] + flush $f + lappend l [file size test1] + close $f + lappend l [file size test1] + set l +} {0 6 6} +test io-5.3 {FlushChannel, implicit flush on close} { + removeFile test1 + set f [open test1 w] + fconfigure $f -translation lf -eofchar {} + set l "" + puts $f hello + lappend l [file size test1] + close $f + lappend l [file size test1] + set l +} {0 6} +test io-5.4 {FlushChannel, implicit flush when buffer fills} { + removeFile test1 + set f [open test1 w] + fconfigure $f -translation lf -eofchar {} + fconfigure $f -buffersize 60 + set l "" + lappend l [file size test1] + for {set i 0} {$i < 12} {incr i} { + puts $f hello + } + lappend l [file size test1] + flush $f + lappend l [file size test1] + close $f + set l +} {0 60 72} +test io-5.5 {FlushChannel, implicit flush when buffer fills and on close} {unixOrPc} { + removeFile test1 + set f [open test1 w] + fconfigure $f -translation lf -buffersize 60 -eofchar {} + set l "" + lappend l [file size test1] + for {set i 0} {$i < 12} {incr i} { + puts $f hello + } + lappend l [file size test1] + close $f + lappend l [file size test1] + set l +} {0 60 72} +test io-5.6 {FlushChannel, async flushing, async close} {unixOrPc asyncPipeClose} { + removeFile pipe + removeFile output + set f [open pipe w] + puts $f { + set f [open output w] + fconfigure $f -translation lf -buffering none -eofchar {} + while {![eof stdin]} { + after 20 + puts -nonewline $f [read stdin 1024] + } + close $f + } + close $f + set x 01234567890123456789012345678901 + for {set i 0} {$i < 11} {incr i} { + set x "$x$x" + } + set f [open output w] + close $f + set f [open "|$tcltest pipe" w] + fconfigure $f -blocking off + puts -nonewline $f $x + close $f + set counter 0 + while {([file size output] < 65536) && ($counter < 1000)} { + incr counter + after 20 + update + } + if {$counter == 1000} { + set result probably_broken + } else { + set result ok + } +} ok + +# Tests closing a channel. The functions tested are CloseChannel and Tcl_Close. + +test io-6.1 {CloseChannel called when all references are dropped} { + removeFile test1 + set f [open test1 w] + interp create x + interp share "" $f x + set l "" + lappend l [testchannel refcount $f] + x eval close $f + interp delete x + lappend l [testchannel refcount $f] + close $f + set l +} {2 1} +test io-6.2 {CloseChannel called when all references are dropped} { + removeFile test1 + set f [open test1 w] + interp create x + interp share "" $f x + puts -nonewline $f abc + close $f + x eval puts $f def + x eval close $f + interp delete x + set f [open test1 r] + set l [gets $f] + close $f + set l +} abcdef +test io-6.3 {CloseChannel, not called before output queue is empty} {unixOrPc asyncPipeClose tempNotPc nonPortable} { + removeFile pipe + removeFile output + set f [open pipe w] + puts $f { + + # Need to not have eof char appended on close, because the other + # side of the pipe already closed, so that writing would cause an + # error "invalid file". + + fconfigure stdout -eofchar {} + fconfigure stderr -eofchar {} + + set f [open output w] + fconfigure $f -translation lf -buffering none + for {set x 0} {$x < 20} {incr x} { + after 20 + puts -nonewline $f [read stdin 1024] + } + close $f + } + close $f + set x 01234567890123456789012345678901 + for {set i 0} {$i < 11} {incr i} { + set x "$x$x" + } + set f [open output w] + close $f + set f [open "|$tcltest pipe" r+] + fconfigure $f -blocking off -eofchar {} + puts -nonewline $f $x + close $f + set counter 0 + while {([file size output] < 20480) && ($counter < 1000)} { + incr counter + after 20 + update + } + if {$counter == 1000} { + set result probably_broken + } else { + set result ok + } + # + # Wait for the flush to finish + # + catch {vwait x} + set result +} ok +test io-6.4 {Tcl_Close} { + removeFile test1 + set l "" + lappend l [lsort [testchannel open]] + set f [open test1 w] + lappend l [lsort [testchannel open]] + close $f + lappend l [lsort [testchannel open]] + set x [list $consoleFileNames \ + [lsort [eval list $consoleFileNames $f]] \ + $consoleFileNames] + string compare $l $x +} 0 +test io-6.5 {Tcl_Close vs standard handles} {unixOnly} { + removeFile script + set f [open script w] + puts $f { + close stdin + puts [testchannel open] + } + close $f + set f [open "|$tcltest script" r] + set l [gets $f] + close $f + set l +} {file1 file2} + +# Test output on channels. The functions tested are Tcl_Write +# and Tcl_Flush. + +test io-7.1 {Tcl_Write, channel not writable} { + list [catch {puts stdin hello} msg] $msg +} {1 {channel "stdin" wasn't opened for writing}} +test io-7.2 {Tcl_Write, empty string} { + removeFile test1 + set f [open test1 w] + fconfigure $f -eofchar {} + puts -nonewline $f "" + close $f + file size test1 +} 0 +test io-7.3 {Tcl_Write, nonempty string} { + removeFile test1 + set f [open test1 w] + fconfigure $f -eofchar {} + puts -nonewline $f hello + close $f + file size test1 +} 5 +test io-7.4 {Tcl_Write, buffering in full buffering mode} { + removeFile test1 + set f [open test1 w] + fconfigure $f -translation lf -buffering full -eofchar {} + puts $f hello + set l "" + lappend l [testchannel outputbuffered $f] + lappend l [file size test1] + flush $f + lappend l [testchannel outputbuffered $f] + lappend l [file size test1] + close $f + set l +} {6 0 0 6} +test io-7.5 {Tcl_Write, buffering in line buffering mode} { + removeFile test1 + set f [open 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] + puts $f hello + lappend l [testchannel outputbuffered $f] + lappend l [file size test1] + close $f + set l +} {5 0 0 11} +test io-7.6 {Tcl_Write, buffering in no buffering mode} { + removeFile test1 + set f [open 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] + puts $f hello + lappend l [testchannel outputbuffered $f] + lappend l [file size test1] + close $f + set l +} {0 5 0 11} +test io-7.7 {Tcl_Flush, full buffering} { + removeFile test1 + set f [open 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] + puts $f hello + lappend l [testchannel outputbuffered $f] + lappend l [file size test1] + flush $f + lappend l [testchannel outputbuffered $f] + lappend l [file size test1] + close $f + set l +} {5 0 11 0 0 11} +test io-7.8 {Tcl_Flush, full buffering} { + removeFile test1 + set f [open test1 w] + fconfigure $f -translation lf -buffering line + puts -nonewline $f hello + set l "" + lappend l [testchannel outputbuffered $f] + lappend l [file size test1] + flush $f + lappend l [testchannel outputbuffered $f] + lappend l [file size test1] + puts $f hello + lappend l [testchannel outputbuffered $f] + lappend l [file size test1] + flush $f + lappend l [testchannel outputbuffered $f] + lappend l [file size test1] + close $f + set l +} {5 0 0 5 0 11 0 11} +test io-7.9 {Tcl_Flush, channel not writable} { + list [catch {flush stdin} msg] $msg +} {1 {channel "stdin" wasn't opened for writing}} +test io-7.10 {Tcl_Write, looping and buffering} { + removeFile test1 + set f1 [open test1 w] + fconfigure $f1 -translation lf -eofchar {} + set f2 [open io.test r] + for {set x 0} {$x < 10} {incr x} { + puts $f1 [gets $f2] + } + close $f2 + close $f1 + file size test1 +} 439 +test io-7.11 {Tcl_Write, no newline, implicit flush} { + removeFile test1 + set f1 [open test1 w] + fconfigure $f1 -eofchar {} + set f2 [open io.test r] + for {set x 0} {$x < 10} {incr x} { + puts -nonewline $f1 [gets $f2] + } + close $f1 + close $f2 + file size test1 +} 429 +test io-7.12 {Tcl_Write on a pipe} {unixOrPc} { + removeFile test1 + removeFile pipe + set f1 [open pipe w] + puts $f1 { + set f1 [open io.test r] + for {set x 0} {$x < 10} {incr x} { + puts [gets $f1] + } + } + close $f1 + set f1 [open "|$tcltest pipe" r] + set f2 [open io.test r] + set y ok + for {set x 0} {$x < 10} {incr x} { + set l1 [gets $f1] + set l2 [gets $f2] + if {"$l1" != "$l2"} { + set y broken + } + } + close $f1 + close $f2 + set y +} ok +test io-7.13 {Tcl_Write to a pipe, line buffered} {unixOrPc} { + removeFile test1 + removeFile pipe + set f1 [open pipe w] + puts $f1 { + puts [gets stdin] + puts [gets stdin] + } + close $f1 + set y ok + set f1 [open "|$tcltest pipe" r+] + fconfigure $f1 -buffering line + set f2 [open io.test r] + set line [gets $f2] + puts $f1 $line + set backline [gets $f1] + if {"$line" != "$backline"} { + set y broken + } + set line [gets $f2] + puts $f1 $line + set backline [gets $f1] + if {"$line" != "$backline"} { + set y broken + } + close $f1 + close $f2 + set y +} ok +test io-7.14 {Tcl_Write, buffering and implicit flush at close} { + removeFile test3 + set f [open test3 w] + puts -nonewline $f "Text1" + puts -nonewline $f " Text 2" + puts $f " Text 3" + close $f + set f [open test3 r] + set x [gets $f] + close $f + set x +} {Text1 Text 2 Text 3} +test io-7.15 {Tcl_Flush, channel not open for writing} { + removeFile test1 + set fd [open test1 w] + close $fd + set fd [open 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-7.16 {Tcl_Flush on pipe opened only for reading} {unixOrPc unixExecs} { + set fd [open "|cat io.test" r] + set x [list [catch {flush $fd} msg] $msg] + catch {close $fd} + string compare $x \ + [list 1 "channel \"$fd\" wasn't opened for writing"] +} 0 +test io-7.17 {Tcl_Write buffers, then Tcl_Flush flushes} { + removeFile test1 + set f1 [open test1 w] + fconfigure $f1 -translation lf + puts $f1 hello + puts $f1 hello + puts $f1 hello + flush $f1 + set x [file size test1] + close $f1 + set x +} 18 +test io-7.18 {Tcl_Write and Tcl_Flush intermixed} { + removeFile test1 + set x "" + set f1 [open test1 w] + fconfigure $f1 -translation lf + puts $f1 hello + puts $f1 hello + puts $f1 hello + flush $f1 + lappend x [file size test1] + puts $f1 hello + flush $f1 + lappend x [file size test1] + puts $f1 hello + flush $f1 + lappend x [file size test1] + close $f1 + set x +} {18 24 30} +test io-7.19 {Explicit and implicit flushes} { + removeFile test1 + set f1 [open 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] + puts $f1 hello + flush $f1 + lappend x [file size test1] + puts $f1 hello + close $f1 + lappend x [file size test1] + set x +} {18 24 30} +test io-7.20 {Implicit flush when buffer is full} { + removeFile test1 + set f1 [open 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] + for {set x 0} {$x < 100} {incr x} { + puts $f1 $line + } + lappend z [file size test1] + close $f1 + lappend z [file size test1] + set z +} {4096 12288 12600} +test io-7.21 {Tcl_Flush to pipe} {unixOrPc} { + removeFile pipe + set f1 [open 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 "|$tcltest pipe" r+] + puts $f1 hello + flush $f1 + set x [gets $f1] + catch {close $f1} + set x +} "read 6 characters" +test io-7.22 {Tcl_Flush called at other end of pipe} {unixOrPc} { + removeFile pipe + set f1 [open pipe w] + puts $f1 { + fconfigure stdout -buffering full + puts hello + puts hello + flush stdout + gets stdin + puts bye + flush stdout + } + close $f1 + set f1 [open "|$tcltest pipe" r+] + set x "" + lappend x [gets $f1] + lappend x [gets $f1] + puts $f1 hello + flush $f1 + lappend x [gets $f1] + close $f1 + set x +} {hello hello bye} +test io-7.23 {Tcl_Flush and line buffering at end of pipe} {unixOrPc} { + removeFile pipe + set f1 [open pipe w] + puts $f1 { + puts hello + puts hello + gets stdin + puts bye + } + close $f1 + set f1 [open "|$tcltest pipe" r+] + set x "" + lappend x [gets $f1] + lappend x [gets $f1] + puts $f1 hello + flush $f1 + lappend x [gets $f1] + close $f1 + set x +} {hello hello bye} +test io-7.24 {Tcl_Write and Tcl_Flush move end of file} { + set f [open test3 w] + puts $f "Line 1" + puts $f "Line 2" + set f2 [open test3] + set x {} + lappend x [read -nonewline $f2] + close $f2 + flush $f + set f2 [open test3] + lappend x [read -nonewline $f2] + close $f2 + close $f + set x +} {{} {Line 1 +Line 2}} +test io-7.25 {Implicit flush with Tcl_Flush to command pipelines} {unixOrPc unixExecs} { + removeFile test3 + set f [open "| cat | cat > test3" w] + puts $f "Line 1" + puts $f "Line 2" + close $f + after 100 + set f [open test3 r] + set x [read $f] + close $f + set x +} {Line 1 +Line 2 +} +test io-7.26 {Tcl_Flush, Tcl_Write on bidirectional pipelines} {unixOrPc unixExecs} { + set f [open "| cat -u" r+] + puts $f "Line1" + flush $f + set x [gets $f] + close $f + set x +} {Line1} +test io-7.27 {Tcl_Flush on closed pipeline} {unixOrPc tempNotPc} { + removeFile pipe + set f [open pipe w] + puts $f {exit} + close $f + set f [open "|$tcltest pipe" r+] + gets $f + puts $f output + after 50 + # + # The flush below will get a SIGPIPE. This is an expected part of + # test and indicates that the test operates correctly. If you run + # this test under a debugger, the signal will by intercepted unless + # you disable the debugger's signal interception. + # + if {[catch {flush $f} msg]} { + set x [list 1 $msg $errorCode] + catch {close $f} + } else { + if {[catch {close $f} msg]} { + set x [list 1 $msg $errorCode] + } else { + set x {this was supposed to fail and did not} + } + } + regsub {".*":} $x {"":} x + string tolower $x +} {1 {error flushing "": broken pipe} {posix epipe {broken pipe}}} +test io-7.28 {Tcl_Write, lf mode} { + removeFile test1 + set f [open test1 w] + fconfigure $f -translation lf -eofchar {} + puts $f hello\nthere\nand\nhere + flush $f + set s [file size test1] + close $f + set s +} 21 +test io-7.29 {Tcl_Write, cr mode} { + removeFile test1 + set f [open test1 w] + fconfigure $f -translation cr -eofchar {} + puts $f hello\nthere\nand\nhere + close $f + file size test1 +} 21 +test io-7.30 {Tcl_Write, crlf mode} { + removeFile test1 + set f [open test1 w] + fconfigure $f -translation crlf -eofchar {} + puts $f hello\nthere\nand\nhere + close $f + file size test1 +} 25 +test io-7.31 {Tcl_Write, background flush} {unixOrPc} { + removeFile pipe + removeFile output + set f [open pipe w] + puts $f {set f [open output w]} + puts $f {fconfigure $f -translation lf} + set x [list while {![eof stdin]}] + set x "$x {" + puts $f $x + puts $f { puts -nonewline $f [read stdin 4096]} + puts $f { flush $f} + puts $f "}" + puts $f {close $f} + close $f + set x 01234567890123456789012345678901 + for {set i 0} {$i < 11} {incr i} { + set x "$x$x" + } + set f [open output w] + close $f + set f [open "|$tcltest pipe" r+] + fconfigure $f -blocking off + puts -nonewline $f $x + close $f + set counter 0 + while {([file size output] < 65536) && ($counter < 1000)} { + incr counter + after 5 + update + } + if {$counter == 1000} { + set result probably_broken + } else { + set result ok + } +} ok +test io-7.32 {Tcl_Write, background flush to slow reader} {unixOrPc asyncPipeClose} { + removeFile pipe + removeFile output + set f [open pipe w] + puts $f {set f [open output w]} + puts $f {fconfigure $f -translation lf} + set x [list while {![eof stdin]}] + set x "$x {" + puts $f $x + puts $f { after 20} + puts $f { puts -nonewline $f [read stdin 1024]} + puts $f { flush $f} + puts $f "}" + puts $f {close $f} + close $f + set x 01234567890123456789012345678901 + for {set i 0} {$i < 11} {incr i} { + set x "$x$x" + } + set f [open output w] + close $f + set f [open "|$tcltest pipe" r+] + fconfigure $f -blocking off + puts -nonewline $f $x + close $f + set counter 0 + while {([file size output] < 65536) && ($counter < 1000)} { + incr counter + after 20 + update + } + if {$counter == 1000} { + set result probably_broken + } else { + set result ok + } +} ok + +# Test end of line translations. Procedures tested are Tcl_Write, Tcl_Read. + +test io-8.1 {Tcl_Write lf, Tcl_Read lf} { + removeFile test1 + set f [open test1 w] + fconfigure $f -translation lf + puts $f hello\nthere\nand\nhere + close $f + set f [open test1 r] + fconfigure $f -translation lf + set x [read $f] + close $f + set x +} "hello\nthere\nand\nhere\n" +test io-8.2 {Tcl_Write lf, Tcl_Read cr} { + removeFile test1 + set f [open test1 w] + fconfigure $f -translation lf + puts $f hello\nthere\nand\nhere + close $f + set f [open test1 r] + fconfigure $f -translation cr + set x [read $f] + close $f + set x +} "hello\nthere\nand\nhere\n" +test io-8.3 {Tcl_Write lf, Tcl_Read crlf} { + removeFile test1 + set f [open test1 w] + fconfigure $f -translation lf + puts $f hello\nthere\nand\nhere + close $f + set f [open test1 r] + fconfigure $f -translation crlf + set x [read $f] + close $f + set x +} "hello\nthere\nand\nhere\n" +test io-8.4 {Tcl_Write cr, Tcl_Read cr} { + removeFile test1 + set f [open test1 w] + fconfigure $f -translation cr + puts $f hello\nthere\nand\nhere + close $f + set f [open test1 r] + fconfigure $f -translation cr + set x [read $f] + close $f + set x +} "hello\nthere\nand\nhere\n" +test io-8.5 {Tcl_Write cr, Tcl_Read lf} { + removeFile test1 + set f [open test1 w] + fconfigure $f -translation cr + puts $f hello\nthere\nand\nhere + close $f + set f [open test1 r] + fconfigure $f -translation lf + set x [read $f] + close $f + set x +} "hello\rthere\rand\rhere\r" +test io-8.6 {Tcl_Write cr, Tcl_Read crlf} { + removeFile test1 + set f [open test1 w] + fconfigure $f -translation cr + puts $f hello\nthere\nand\nhere + close $f + set f [open test1 r] + fconfigure $f -translation crlf + set x [read $f] + close $f + set x +} "hello\rthere\rand\rhere\r" +test io-8.7 {Tcl_Write crlf, Tcl_Read crlf} { + removeFile test1 + set f [open test1 w] + fconfigure $f -translation crlf + puts $f hello\nthere\nand\nhere + close $f + set f [open test1 r] + fconfigure $f -translation crlf + set x [read $f] + close $f + set x +} "hello\nthere\nand\nhere\n" +test io-8.8 {Tcl_Write crlf, Tcl_Read lf} { + removeFile test1 + set f [open test1 w] + fconfigure $f -translation crlf + puts $f hello\nthere\nand\nhere + close $f + set f [open test1 r] + fconfigure $f -translation lf + set x [read $f] + close $f + set x +} "hello\r\nthere\r\nand\r\nhere\r\n" +test io-8.9 {Tcl_Write crlf, Tcl_Read cr} { + removeFile test1 + set f [open test1 w] + fconfigure $f -translation crlf + puts $f hello\nthere\nand\nhere + close $f + set f [open test1 r] + fconfigure $f -translation cr + set x [read $f] + close $f + set x +} "hello\n\nthere\n\nand\n\nhere\n\n" +test io-8.10 {Tcl_Write lf, Tcl_Read auto} { + removeFile test1 + set f [open test1 w] + fconfigure $f -translation lf + puts $f hello\nthere\nand\nhere + close $f + set f [open test1 r] + set c [read $f] + set x [fconfigure $f -translation] + close $f + list $c $x +} {{hello +there +and +here +} auto} +test io-8.11 {Tcl_Write cr, Tcl_Read auto} { + removeFile test1 + set f [open test1 w] + fconfigure $f -translation cr + puts $f hello\nthere\nand\nhere + close $f + set f [open test1 r] + set c [read $f] + set x [fconfigure $f -translation] + close $f + list $c $x +} {{hello +there +and +here +} auto} +test io-8.12 {Tcl_Write crlf, Tcl_Read auto} { + removeFile test1 + set f [open test1 w] + fconfigure $f -translation crlf + puts $f hello\nthere\nand\nhere + close $f + set f [open test1 r] + set c [read $f] + set x [fconfigure $f -translation] + close $f + list $c $x +} {{hello +there +and +here +} auto} + +test io-8.13 {Tcl_Write crlf on block boundary, Tcl_Read auto} { + removeFile test1 + set f [open test1 w] + fconfigure $f -translation crlf + set line "123456789ABCDE" ;# 14 char plus crlf + puts -nonewline $f x ;# shift crlf across block boundary + for {set i 0} {$i < 700} {incr i} { + puts $f $line + } + close $f + set f [open test1 r] + fconfigure $f -translation auto + set c [read $f] + close $f + string length $c +} [expr 700*15+1] + +test io-8.14 {Tcl_Write crlf on block boundary, Tcl_Read crlf} { + removeFile test1 + set f [open test1 w] + fconfigure $f -translation crlf + set line "123456789ABCDE" ;# 14 char plus crlf + puts -nonewline $f x ;# shift crlf across block boundary + for {set i 0} {$i < 700} {incr i} { + puts $f $line + } + close $f + set f [open test1 r] + fconfigure $f -translation crlf + set c [read $f] + close $f + string length $c +} [expr 700*15+1] + +test io-8.15 {Tcl_Write mixed, Tcl_Read auto} { + removeFile test1 + set f [open test1 w] + fconfigure $f -translation lf + puts $f hello\nthere\nand\rhere + close $f + set f [open test1 r] + fconfigure $f -translation auto + set c [read $f] + close $f + set c +} {hello +there +and +here +} +test io-8.16 {Tcl_Write ^Z at end, Tcl_Read auto} { + removeFile test1 + set f [open test1 w] + fconfigure $f -translation lf + puts -nonewline $f hello\nthere\nand\rhere\n\x1a + close $f + set f [open test1 r] + fconfigure $f -eofchar \x1a -translation auto + set c [read $f] + close $f + set c +} {hello +there +and +here +} +test io-8.17 {Tcl_Write, implicit ^Z at end, Tcl_Read auto} {pcOnly} { + removeFile test1 + set f [open test1 w] + fconfigure $f -eofchar \x1a -translation lf + puts $f hello\nthere\nand\rhere + close $f + set f [open test1 r] + fconfigure $f -eofchar \x1a -translation auto + set c [read $f] + close $f + set c +} {hello +there +and +here +} +test io-8.18 {Tcl_Write, ^Z in middle, Tcl_Read auto} { + removeFile test1 + set f [open 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] + fconfigure $f -eofchar \x1a -translation auto + set l "" + lappend l [gets $f] + lappend l [gets $f] + lappend l [eof $f] + lappend l [gets $f] + lappend l [eof $f] + lappend l [gets $f] + lappend l [eof $f] + close $f + set l +} {abc def 0 {} 1 {} 1} +test io-8.19 {Tcl_Write, ^Z no newline in middle, Tcl_Read auto} { + removeFile test1 + set f [open 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] + fconfigure $f -eofchar \x1a -translation auto + set l "" + lappend l [gets $f] + lappend l [gets $f] + lappend l [eof $f] + lappend l [gets $f] + lappend l [eof $f] + lappend l [gets $f] + lappend l [eof $f] + close $f + set l +} {abc def 0 {} 1 {} 1} +test io-8.20 {Tcl_Write, ^Z in middle ignored, Tcl_Read lf} { + removeFile test1 + set f [open 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] + fconfigure $f -translation lf -eofchar {} + set l "" + lappend l [gets $f] + lappend l [gets $f] + lappend l [eof $f] + lappend l [gets $f] + lappend l [eof $f] + lappend l [gets $f] + lappend l [eof $f] + lappend l [gets $f] + lappend l [eof $f] + close $f + set l +} "abc def 0 \x1aghi 0 qrs 0 {} 1" +test io-8.21 {Tcl_Write, ^Z in middle ignored, Tcl_Read cr} { + removeFile test1 + set f [open 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] + fconfigure $f -translation cr -eofchar {} + set l "" + set x [gets $f] + lappend l [string compare $x "abc\ndef\n\x1aghi\nqrs"] + lappend l [eof $f] + lappend l [gets $f] + lappend l [eof $f] + close $f + set l +} {0 1 {} 1} +test io-8.22 {Tcl_Write, ^Z in middle ignored, Tcl_Read crlf} { + removeFile test1 + set f [open 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] + fconfigure $f -translation crlf -eofchar {} + set l "" + set x [gets $f] + lappend l [string compare $x "abc\ndef\n\x1aghi\nqrs"] + lappend l [eof $f] + lappend l [gets $f] + lappend l [eof $f] + close $f + set l +} {0 1 {} 1} +test io-8.23 {Tcl_Write lf, ^Z in middle, Tcl_Read auto} { + removeFile test1 + set f [open 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] + fconfigure $f -translation auto -eofchar \x1a + set c [string length [read $f]] + set e [eof $f] + close $f + list $c $e +} {8 1} +test io-8.24 {Tcl_Write lf, ^Z in middle, Tcl_Read lf} { + removeFile test1 + set f [open 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] + fconfigure $f -translation lf -eofchar \x1a + set c [string length [read $f]] + set e [eof $f] + close $f + list $c $e +} {8 1} +test io-8.25 {Tcl_Write cr, ^Z in middle, Tcl_Read auto} { + removeFile test1 + set f [open 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] + fconfigure $f -translation auto -eofchar \x1a + set c [string length [read $f]] + set e [eof $f] + close $f + list $c $e +} {8 1} +test io-8.26 {Tcl_Write cr, ^Z in middle, Tcl_Read cr} { + removeFile test1 + set f [open 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] + fconfigure $f -translation cr -eofchar \x1a + set c [string length [read $f]] + set e [eof $f] + close $f + list $c $e +} {8 1} +test io-8.27 {Tcl_Write crlf, ^Z in middle, Tcl_Read auto} { + removeFile test1 + set f [open 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] + fconfigure $f -translation auto -eofchar \x1a + set c [string length [read $f]] + set e [eof $f] + close $f + list $c $e +} {8 1} +test io-8.28 {Tcl_Write crlf, ^Z in middle, Tcl_Read crlf} { + removeFile test1 + set f [open 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] + fconfigure $f -translation crlf -eofchar \x1a + set c [string length [read $f]] + set e [eof $f] + close $f + list $c $e +} {8 1} + +# Test end of line translations. Functions tested are Tcl_Write and Tcl_Gets. + +test io-9.1 {Tcl_Write lf, Tcl_Gets auto} { + removeFile test1 + set f [open test1 w] + fconfigure $f -translation lf + puts $f hello\nthere\nand\nhere + close $f + set f [open test1 r] + set l "" + lappend l [gets $f] + lappend l [tell $f] + lappend l [fconfigure $f -translation] + lappend l [gets $f] + lappend l [tell $f] + lappend l [fconfigure $f -translation] + close $f + set l +} {hello 6 auto there 12 auto} +test io-9.2 {Tcl_Write cr, Tcl_Gets auto} { + removeFile test1 + set f [open test1 w] + fconfigure $f -translation cr + puts $f hello\nthere\nand\nhere + close $f + set f [open test1 r] + set l "" + lappend l [gets $f] + lappend l [tell $f] + lappend l [fconfigure $f -translation] + lappend l [gets $f] + lappend l [tell $f] + lappend l [fconfigure $f -translation] + close $f + set l +} {hello 6 auto there 12 auto} +test io-9.3 {Tcl_Write crlf, Tcl_Gets auto} { + removeFile test1 + set f [open test1 w] + fconfigure $f -translation crlf + puts $f hello\nthere\nand\nhere + close $f + set f [open test1 r] + set l "" + lappend l [gets $f] + lappend l [tell $f] + lappend l [fconfigure $f -translation] + lappend l [gets $f] + lappend l [tell $f] + lappend l [fconfigure $f -translation] + close $f + set l +} {hello 7 auto there 14 auto} +test io-9.4 {Tcl_Write lf, Tcl_Gets lf} { + removeFile test1 + set f [open test1 w] + fconfigure $f -translation lf + puts $f hello\nthere\nand\nhere + close $f + set f [open test1 r] + fconfigure $f -translation lf + set l "" + lappend l [gets $f] + lappend l [tell $f] + lappend l [fconfigure $f -translation] + lappend l [gets $f] + lappend l [tell $f] + lappend l [fconfigure $f -translation] + close $f + set l +} {hello 6 lf there 12 lf} +test io-9.5 {Tcl_Write lf, Tcl_Gets cr} { + removeFile test1 + set f [open test1 w] + fconfigure $f -translation lf + puts $f hello\nthere\nand\nhere + close $f + set f [open test1 r] + fconfigure $f -translation cr + set l "" + lappend l [string length [gets $f]] + lappend l [tell $f] + lappend l [fconfigure $f -translation] + lappend l [eof $f] + lappend l [gets $f] + lappend l [tell $f] + lappend l [fconfigure $f -translation] + lappend l [eof $f] + close $f + set l +} {20 21 cr 1 {} 21 cr 1} +test io-9.6 {Tcl_Write lf, Tcl_Gets crlf} { + removeFile test1 + set f [open test1 w] + fconfigure $f -translation lf + puts $f hello\nthere\nand\nhere + close $f + set f [open test1 r] + fconfigure $f -translation crlf + set l "" + lappend l [string length [gets $f]] + lappend l [tell $f] + lappend l [fconfigure $f -translation] + lappend l [eof $f] + lappend l [gets $f] + lappend l [tell $f] + lappend l [fconfigure $f -translation] + lappend l [eof $f] + close $f + set l +} {20 21 crlf 1 {} 21 crlf 1} +test io-9.7 {Tcl_Write cr, Tcl_Gets cr} { + removeFile test1 + set f [open test1 w] + fconfigure $f -translation cr + puts $f hello\nthere\nand\nhere + close $f + set f [open test1 r] + fconfigure $f -translation cr + set l "" + lappend l [gets $f] + lappend l [tell $f] + lappend l [fconfigure $f -translation] + lappend l [eof $f] + lappend l [gets $f] + lappend l [tell $f] + lappend l [fconfigure $f -translation] + lappend l [eof $f] + close $f + set l +} {hello 6 cr 0 there 12 cr 0} +test io-9.8 {Tcl_Write cr, Tcl_Gets lf} { + removeFile test1 + set f [open test1 w] + fconfigure $f -translation cr + puts $f hello\nthere\nand\nhere + close $f + set f [open test1 r] + fconfigure $f -translation lf + set l "" + lappend l [string length [gets $f]] + lappend l [tell $f] + lappend l [fconfigure $f -translation] + lappend l [eof $f] + lappend l [gets $f] + lappend l [tell $f] + lappend l [fconfigure $f -translation] + lappend l [eof $f] + close $f + set l +} {21 21 lf 1 {} 21 lf 1} +test io-9.9 {Tcl_Write cr, Tcl_Gets crlf} { + removeFile test1 + set f [open test1 w] + fconfigure $f -translation cr + puts $f hello\nthere\nand\nhere + close $f + set f [open test1 r] + fconfigure $f -translation crlf + set l "" + lappend l [string length [gets $f]] + lappend l [tell $f] + lappend l [fconfigure $f -translation] + lappend l [eof $f] + lappend l [gets $f] + lappend l [tell $f] + lappend l [fconfigure $f -translation] + lappend l [eof $f] + close $f + set l +} {21 21 crlf 1 {} 21 crlf 1} +test io-9.10 {Tcl_Write crlf, Tcl_Gets crlf} { + removeFile test1 + set f [open test1 w] + fconfigure $f -translation crlf + puts $f hello\nthere\nand\nhere + close $f + set f [open test1 r] + fconfigure $f -translation crlf + set l "" + lappend l [gets $f] + lappend l [tell $f] + lappend l [fconfigure $f -translation] + lappend l [eof $f] + lappend l [gets $f] + lappend l [tell $f] + lappend l [fconfigure $f -translation] + lappend l [eof $f] + close $f + set l +} {hello 7 crlf 0 there 14 crlf 0} +test io-9.11 {Tcl_Write crlf, Tcl_Gets cr} { + removeFile test1 + set f [open test1 w] + fconfigure $f -translation crlf + puts $f hello\nthere\nand\nhere + close $f + set f [open test1 r] + fconfigure $f -translation cr + set l "" + lappend l [gets $f] + lappend l [tell $f] + lappend l [fconfigure $f -translation] + lappend l [eof $f] + lappend l [string length [gets $f]] + lappend l [tell $f] + lappend l [fconfigure $f -translation] + lappend l [eof $f] + close $f + set l +} {hello 6 cr 0 6 13 cr 0} +test io-9.12 {Tcl_Write crlf, Tcl_Gets lf} { + removeFile test1 + set f [open test1 w] + fconfigure $f -translation crlf + puts $f hello\nthere\nand\nhere + close $f + set f [open test1 r] + fconfigure $f -translation lf + set l "" + lappend l [string length [gets $f]] + lappend l [tell $f] + lappend l [fconfigure $f -translation] + lappend l [eof $f] + lappend l [string length [gets $f]] + lappend l [tell $f] + lappend l [fconfigure $f -translation] + lappend l [eof $f] + close $f + set l +} {6 7 lf 0 6 14 lf 0} +test io-9.13 {binary mode is synonym of lf mode} { + removeFile test1 + set f [open test1 w] + fconfigure $f -translation binary + set x [fconfigure $f -translation] + close $f + set x +} lf +# +# Test io-9.14 has been removed because "auto" output translation mode is +# not supoprted. +# +test io-9.15 {Tcl_Write mixed, Tcl_Gets auto} { + removeFile test1 + set f [open test1 w] + fconfigure $f -translation lf + puts $f hello\nthere\rand\r\nhere + close $f + set f [open test1 r] + fconfigure $f -translation auto + set l "" + lappend l [gets $f] + lappend l [gets $f] + lappend l [gets $f] + lappend l [gets $f] + lappend l [eof $f] + lappend l [gets $f] + lappend l [eof $f] + close $f + set l +} {hello there and here 0 {} 1} +test io-9.16 {Tcl_Write mixed, Tcl_Gets auto} { + removeFile test1 + set f [open test1 w] + fconfigure $f -translation lf + puts -nonewline $f hello\nthere\rand\r\nhere\r + close $f + set f [open test1 r] + fconfigure $f -translation auto + set l "" + lappend l [gets $f] + lappend l [gets $f] + lappend l [gets $f] + lappend l [gets $f] + lappend l [eof $f] + lappend l [gets $f] + lappend l [eof $f] + close $f + set l +} {hello there and here 0 {} 1} +test io-9.17 {Tcl_Write mixed, Tcl_Gets auto} { + removeFile test1 + set f [open test1 w] + fconfigure $f -translation lf + puts -nonewline $f hello\nthere\rand\r\nhere\n + close $f + set f [open test1 r] + set l "" + lappend l [gets $f] + lappend l [gets $f] + lappend l [gets $f] + lappend l [gets $f] + lappend l [eof $f] + lappend l [gets $f] + lappend l [eof $f] + close $f + set l +} {hello there and here 0 {} 1} +test io-9.18 {Tcl_Write mixed, Tcl_Gets auto} { + removeFile test1 + set f [open test1 w] + fconfigure $f -translation lf + puts -nonewline $f hello\nthere\rand\r\nhere\r\n + close $f + set f [open test1 r] + fconfigure $f -translation auto + set l "" + lappend l [gets $f] + lappend l [gets $f] + lappend l [gets $f] + lappend l [gets $f] + lappend l [eof $f] + lappend l [gets $f] + lappend l [eof $f] + close $f + set l +} {hello there and here 0 {} 1} +test io-9.19 {Tcl_Write ^Z at end, Tcl_Gets auto} { + removeFile test1 + set f [open 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] + fconfigure $f -eofchar \x1a -translation auto + set l "" + lappend l [gets $f] + lappend l [gets $f] + lappend l [gets $f] + lappend l [gets $f] + lappend l [eof $f] + lappend l [gets $f] + lappend l [eof $f] + close $f + set l +} {hello there and here 0 {} 1} +test io-9.20 {Tcl_Write, implicit ^Z at end, Tcl_Gets auto} { + removeFile test1 + set f [open test1 w] + fconfigure $f -eofchar \x1a -translation lf + puts $f hello\nthere\nand\rhere + close $f + set f [open test1 r] + fconfigure $f -eofchar \x1a -translation auto + set l "" + lappend l [gets $f] + lappend l [gets $f] + lappend l [gets $f] + lappend l [gets $f] + lappend l [eof $f] + lappend l [gets $f] + lappend l [eof $f] + close $f + set l +} {hello there and here 0 {} 1} +test io-9.21 {Tcl_Write, ^Z in middle, Tcl_Gets auto, eofChar} { + removeFile test1 + set f [open 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] + fconfigure $f -eofchar \x1a + fconfigure $f -translation auto + set l "" + lappend l [gets $f] + lappend l [gets $f] + lappend l [eof $f] + lappend l [gets $f] + lappend l [eof $f] + close $f + set l +} {abc def 0 {} 1} +test io-9.22 {Tcl_Write, no newline ^Z in middle, Tcl_Gets auto, eofChar} { + removeFile test1 + set f [open 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] + fconfigure $f -eofchar \x1a -translation auto + set l "" + lappend l [gets $f] + lappend l [gets $f] + lappend l [eof $f] + lappend l [gets $f] + lappend l [eof $f] + close $f + set l +} {abc def 0 {} 1} +test io-9.23 {Tcl_Write, ^Z in middle ignored, Tcl_Gets lf} { + removeFile test1 + set f [open 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] + fconfigure $f -translation lf -eofchar {} + set l "" + lappend l [gets $f] + lappend l [gets $f] + lappend l [eof $f] + lappend l [gets $f] + lappend l [eof $f] + lappend l [gets $f] + lappend l [eof $f] + lappend l [gets $f] + lappend l [eof $f] + close $f + set l +} "abc def 0 \x1aqrs 0 tuv 0 {} 1" +test io-9.24 {Tcl_Write, ^Z in middle ignored, Tcl_Gets cr} { + removeFile test1 + set f [open 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] + fconfigure $f -translation cr -eofchar {} + set l "" + lappend l [gets $f] + lappend l [gets $f] + lappend l [eof $f] + lappend l [gets $f] + lappend l [eof $f] + lappend l [gets $f] + lappend l [eof $f] + lappend l [gets $f] + lappend l [eof $f] + close $f + set l +} "abc def 0 \x1aqrs 0 tuv 0 {} 1" +test io-9.25 {Tcl_Write, ^Z in middle ignored, Tcl_Gets crlf} { + removeFile test1 + set f [open 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] + fconfigure $f -translation crlf -eofchar {} + set l "" + lappend l [gets $f] + lappend l [gets $f] + lappend l [eof $f] + lappend l [gets $f] + lappend l [eof $f] + lappend l [gets $f] + lappend l [eof $f] + lappend l [gets $f] + lappend l [eof $f] + close $f + set l +} "abc def 0 \x1aqrs 0 tuv 0 {} 1" +test io-9.26 {Tcl_Write lf, ^Z in middle, Tcl_Gets auto} { + removeFile test1 + set f [open 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] + fconfigure $f -translation auto -eofchar \x1a + set l "" + lappend l [gets $f] + lappend l [gets $f] + lappend l [eof $f] + lappend l [gets $f] + lappend l [eof $f] + close $f + set l +} {abc def 0 {} 1} +test io-9.27 {Tcl_Write lf, ^Z in middle, Tcl_Gets lf} { + removeFile test1 + set f [open 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] + fconfigure $f -translation lf -eofchar \x1a + set l "" + lappend l [gets $f] + lappend l [gets $f] + lappend l [eof $f] + lappend l [gets $f] + lappend l [eof $f] + close $f + set l +} {abc def 0 {} 1} +test io-9.28 {Tcl_Write cr, ^Z in middle, Tcl_Gets auto} { + removeFile test1 + set f [open 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] + fconfigure $f -translation auto -eofchar \x1a + set l "" + lappend l [gets $f] + lappend l [gets $f] + lappend l [eof $f] + lappend l [gets $f] + lappend l [eof $f] + close $f + set l +} {abc def 0 {} 1} +test io-9.29 {Tcl_Write cr, ^Z in middle, Tcl_Gets cr} { + removeFile test1 + set f [open 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] + fconfigure $f -translation cr -eofchar \x1a + set l "" + lappend l [gets $f] + lappend l [gets $f] + lappend l [eof $f] + lappend l [gets $f] + lappend l [eof $f] + close $f + set l +} {abc def 0 {} 1} +test io-9.30 {Tcl_Write crlf, ^Z in middle, Tcl_Gets auto} { + removeFile test1 + set f [open 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] + fconfigure $f -translation auto -eofchar \x1a + set l "" + lappend l [gets $f] + lappend l [gets $f] + lappend l [eof $f] + lappend l [gets $f] + lappend l [eof $f] + close $f + set l +} {abc def 0 {} 1} +test io-9.31 {Tcl_Write crlf, ^Z in middle, Tcl_Gets crlf} { + removeFile test1 + set f [open 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] + fconfigure $f -translation crlf -eofchar \x1a + set l "" + lappend l [gets $f] + lappend l [gets $f] + lappend l [eof $f] + lappend l [gets $f] + lappend l [eof $f] + close $f + set l +} {abc def 0 {} 1} +test io-9.32 {Tcl_Write crlf on block boundary, Tcl_Gets auto} { + removeFile test1 + set f [open test1 w] + fconfigure $f -translation crlf + set line "123456789ABCDE" ;# 14 char plus crlf + puts -nonewline $f x ;# shift crlf across block boundary + for {set i 0} {$i < 700} {incr i} { + puts $f $line + } + close $f + set f [open test1 r] + fconfigure $f -translation auto + set c "" + while {[gets $f line] >= 0} { + append c $line\n + } + close $f + string length $c +} [expr 700*15+1] +test io-9.33 {Tcl_Write crlf on block boundary, Tcl_Gets auto} { + removeFile test1 + set f [open test1 w] + fconfigure $f -translation crlf + set line "123456789ABCDE" ;# 14 char plus crlf + puts -nonewline $f x ;# shift crlf across block boundary + for {set i 0} {$i < 256} {incr i} { + puts $f $line + } + close $f + set f [open test1 r] + fconfigure $f -translation auto + set c "" + while {[gets $f line] >= 0} { + append c $line\n + } + close $f + string length $c +} [expr 256*15+1] + + +# Test Tcl_Read and buffering. + +test io-10.1 {Tcl_Read, channel not readable} { + list [catch {read stdout} msg] $msg +} {1 {channel "stdout" wasn't opened for reading}} +test io-10.2 {Tcl_Read, zero byte count} { + read stdin 0 +} "" +test io-10.3 {Tcl_Read, negative byte count} { + set f [open io.test r] + set l [list [catch {read $f -1} msg] $msg] + close $f + set l +} {1 {bad argument "-1": should be "nonewline"}} +test io-10.4 {Tcl_Read, positive byte count} { + set f [open io.test r] + set x [read $f 1024] + set s [string length $x] + unset x + close $f + set s +} 1024 +test io-10.5 {Tcl_Read, multiple buffers} { + set f [open io.test r] + fconfigure $f -buffersize 100 + set x [read $f 1024] + set s [string length $x] + unset x + close $f + set s +} 1024 +test io-10.6 {Tcl_Read, very large read} { + set f1 [open io.test r] + set z [read $f1 1000000] + close $f1 + set l [string length $z] + set x ok + set z [file size io.test] + if {$z != $l} { + set x broken + } + set x +} ok +test io-10.7 {Tcl_Read, nonblocking, file} {nonBlockFiles} { + set f1 [open io.test r] + fconfigure $f1 -blocking off + set z [read $f1 20] + close $f1 + set l [string length $z] + set x ok + if {$l != 20} { + set x broken + } + set x +} ok +test io-10.8 {Tcl_Read, nonblocking, file} {nonBlockFiles} { + set f1 [open io.test r] + fconfigure $f1 -blocking off + set z [read $f1 1000000] + close $f1 + set x ok + set l [string length $z]] + set z [file size io.test]] + if {$z != $l} { + set x broken + } + set x +} ok +test io-10.9 {Tcl_Read, read to end of file} { + set f1 [open io.test r] + set z [read $f1] + close $f1 + set l [string length $z] + set x ok + set z [file size io.test] + if {$z != $l} { + set x broken + } + set x +} ok +test io-10.10 {Tcl_Read from a pipe} {unixOrPc} { + removeFile pipe + set f1 [open pipe w] + puts $f1 {puts [gets stdin]} + close $f1 + set f1 [open "|$tcltest pipe" r+] + puts $f1 hello + flush $f1 + set x [read $f1] + close $f1 + set x +} "hello\n" +test io-10.11 {Tcl_Read from a pipe} {unixOrPc} { + removeFile pipe + set f1 [open pipe w] + puts $f1 {puts [gets stdin]} + puts $f1 {puts [gets stdin]} + close $f1 + set f1 [open "|$tcltest pipe" r+] + puts $f1 hello + flush $f1 + set x "" + lappend x [read $f1 6] + puts $f1 hello + flush $f1 + lappend x [read $f1] + close $f1 + set x +} {{hello +} {hello +}} +test io-10.12 {Tcl_Read, -nonewline} { + removeFile test1 + set f1 [open test1 w] + puts $f1 hello + puts $f1 bye + close $f1 + set f1 [open test1 r] + set c [read -nonewline $f1] + close $f1 + set c +} {hello +bye} +test io-10.13 {Tcl_Read, -nonewline} { + removeFile test1 + set f1 [open test1 w] + puts $f1 hello + puts $f1 bye + close $f1 + set f1 [open test1 r] + set c [read -nonewline $f1] + close $f1 + list [string length $c] $c +} {9 {hello +bye}} +test io-10.14 {Tcl_Read, reading in small chunks} { + removeFile test1 + set f [open test1 w] + puts $f "Two lines: this one" + puts $f "and this one" + close $f + set f [open test1] + set x [list [read $f 1] [read $f 2] [read $f]] + close $f + set x +} {T wo { lines: this one +and this one +}} +test io-10.15 {Tcl_Read, asking for more input than available} { + removeFile test1 + set f [open test1 w] + puts $f "Two lines: this one" + puts $f "and this one" + close $f + set f [open test1] + set x [read $f 100] + close $f + set x +} {Two lines: this one +and this one +} +test io-10.16 {Tcl_Read, read to end of file with -nonewline} { + removeFile test1 + set f [open test1 w] + puts $f "Two lines: this one" + puts $f "and this one" + close $f + set f [open test1] + set x [read -nonewline $f] + close $f + set x +} {Two lines: this one +and this one} + +# Test Tcl_Gets. + +test io-11.1 {Tcl_Gets, reading what was written} { + removeFile test1 + set f1 [open test1 w] + set y "first line" + puts $f1 $y + close $f1 + set f1 [open test1 r] + set x [gets $f1] + set z ok + if {"$x" != "$y"} { + set z broken + } + close $f1 + set z +} ok +test io-11.2 {Tcl_Gets into variable} { + set f1 [open io.test r] + set c [gets $f1 x] + set l [string length x] + set z ok + if {$l != $l} { + set z broken + } + close $f1 + set z +} ok +test io-11.3 {Tcl_Gets from pipe} {unixOrPc} { + removeFile pipe + set f1 [open pipe w] + puts $f1 {puts [gets stdin]} + close $f1 + set f1 [open "|$tcltest pipe" r+] + puts $f1 hello + flush $f1 + set x [gets $f1] + close $f1 + set z ok + if {"$x" != "hello"} { + set z broken + } + set z +} ok +test io-11.4 {Tcl_Gets with long line} { + removeFile test3 + set f [open 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 x [gets $f] + close $f + set x +} {abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ} +test io-11.5 {Tcl_Gets with long line} { + set f [open test3] + set x [gets $f y] + close $f + list $x $y +} {260 abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ} +test io-11.6 {Tcl_Gets and end of file} { + removeFile test3 + set f [open test3 w] + puts -nonewline $f "Test1\nTest2" + close $f + set f [open test3] + set x {} + set y {} + lappend x [gets $f y] $y + set y {} + lappend x [gets $f y] $y + set y {} + lappend x [gets $f y] $y + close $f + set x +} {5 Test1 5 Test2 -1 {}} +test io-11.7 {Tcl_Gets and bad variable} { + set f [open test3 w] + puts $f "Line 1" + puts $f "Line 2" + close $f + catch {unset x} + set x 24 + set f [open 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-11.8 {Tcl_Gets, exercising double buffering} { + set f [open 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] + fconfigure $f -translation lf + for {set y 0} {$y < 100} {incr y} {gets $f} + close $f + set y +} 100 +test io-11.9 {Tcl_Gets, exercising double buffering} { + set f [open 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] + fconfigure $f -translation lf + for {set y 0} {$y < 200} {incr y} {gets $f} + close $f + set y +} 200 +test io-11.10 {Tcl_Gets, exercising double buffering} { + set f [open 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] + fconfigure $f -translation lf + for {set y 0} {$y < 300} {incr y} {gets $f} + close $f + set y +} 300 + +# Test Tcl_Seek and Tcl_Tell. + +test io-12.1 {Tcl_Seek to current position at start of file} { + set f1 [open io.test r] + seek $f1 0 current + set c [tell $f1] + close $f1 + set c +} 0 +test io-12.2 {Tcl_Seek to offset from start} { + removeFile test1 + set f1 [open test1 w] + fconfigure $f1 -translation lf -eofchar {} + puts $f1 "abcdefghijklmnopqrstuvwxyz" + puts $f1 "abcdefghijklmnopqrstuvwxyz" + close $f1 + set f1 [open test1 r] + seek $f1 10 start + set c [tell $f1] + close $f1 + set c +} 10 +test io-12.3 {Tcl_Seek to end of file} { + removeFile test1 + set f1 [open test1 w] + fconfigure $f1 -translation lf -eofchar {} + puts $f1 "abcdefghijklmnopqrstuvwxyz" + puts $f1 "abcdefghijklmnopqrstuvwxyz" + close $f1 + set f1 [open test1 r] + seek $f1 0 end + set c [tell $f1] + close $f1 + set c +} 54 +test io-12.4 {Tcl_Seek to offset from end of file} { + removeFile test1 + set f1 [open test1 w] + fconfigure $f1 -translation lf -eofchar {} + puts $f1 "abcdefghijklmnopqrstuvwxyz" + puts $f1 "abcdefghijklmnopqrstuvwxyz" + close $f1 + set f1 [open test1 r] + seek $f1 -10 end + set c [tell $f1] + close $f1 + set c +} 44 +test io-12.5 {Tcl_Seek to offset from current position} { + removeFile test1 + set f1 [open test1 w] + fconfigure $f1 -translation lf -eofchar {} + puts $f1 "abcdefghijklmnopqrstuvwxyz" + puts $f1 "abcdefghijklmnopqrstuvwxyz" + close $f1 + set f1 [open test1 r] + seek $f1 10 current + seek $f1 10 current + set c [tell $f1] + close $f1 + set c +} 20 +test io-12.6 {Tcl_Seek to offset from end of file} { + removeFile test1 + set f1 [open test1 w] + fconfigure $f1 -translation lf -eofchar {} + puts $f1 "abcdefghijklmnopqrstuvwxyz" + puts $f1 "abcdefghijklmnopqrstuvwxyz" + close $f1 + set f1 [open test1 r] + seek $f1 -10 end + set c [tell $f1] + set r [read $f1] + close $f1 + list $c $r +} {44 {rstuvwxyz +}} +test io-12.7 {Tcl_Seek to offset from end of file, then to current position} { + removeFile test1 + set f1 [open test1 w] + fconfigure $f1 -translation lf -eofchar {} + puts $f1 "abcdefghijklmnopqrstuvwxyz" + puts $f1 "abcdefghijklmnopqrstuvwxyz" + close $f1 + set f1 [open test1 r] + seek $f1 -10 end + set c1 [tell $f1] + set r1 [read $f1 5] + seek $f1 0 current + set c2 [tell $f1] + close $f1 + list $c1 $r1 $c2 +} {44 rstuv 49} +test io-12.8 {Tcl_Seek on pipes: not supported} {unixOrPc} { + set f1 [open "|$tcltest" r+] + set x [list [catch {seek $f1 0 current} msg] $msg] + close $f1 + regsub {".*":} $x {"":} x + string tolower $x +} {1 {error during seek on "": invalid argument}} +test io-12.9 {Tcl_Seek, testing buffered input flushing} { + removeFile test3 + set f [open test3 w] + fconfigure $f -eofchar {} + puts -nonewline $f "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ" + close $f + set f [open test3 RDWR] + set x [read $f 1] + seek $f 3 + lappend x [read $f 1] + seek $f 0 start + lappend x [read $f 1] + seek $f 10 current + lappend x [read $f 1] + seek $f -2 end + lappend x [read $f 1] + seek $f 50 end + lappend x [read $f 1] + seek $f 1 + lappend x [read $f 1] + close $f + set x +} {a d a l Y {} b} +test io-12.10 {Tcl_Seek testing flushing of buffered input} { + set f [open test3 w] + fconfigure $f -translation lf + puts $f xyz\n123 + close $f + set f [open test3 r+] + fconfigure $f -translation lf + set x [gets $f] + seek $f 0 current + puts $f 456 + close $f + list $x [viewFile test3] +} "xyz {xyz +456}" +test io-12.11 {Tcl_Seek testing flushing of buffered output} { + set f [open test3 w] + puts $f xyz\n123 + close $f + set f [open test3 w+] + puts $f xyzzy + seek $f 2 + set x [gets $f] + close $f + list $x [viewFile test3] +} "zzy xyzzy" +test io-12.12 {Tcl_Seek testing combination of write, seek back and read} { + set f [open test3 w] + fconfigure $f -translation lf -eofchar {} + puts $f xyz\n123 + close $f + set f [open test3 a+] + fconfigure $f -translation lf -eofchar {} + puts $f xyzzy + flush $f + set x [tell $f] + seek $f -4 cur + set y [gets $f] + close $f + list $x [viewFile test3] $y +} {14 {xyz +123 +xyzzy} zzy} +test io-12.13 {Tcl_Tell at start of file} { + removeFile test1 + set f1 [open test1 w] + set p [tell $f1] + close $f1 + set p +} 0 +test io-12.14 {Tcl_Tell after seek to end of file} { + removeFile test1 + set f1 [open test1 w] + fconfigure $f1 -translation lf -eofchar {} + puts $f1 "abcdefghijklmnopqrstuvwxyz" + puts $f1 "abcdefghijklmnopqrstuvwxyz" + close $f1 + set f1 [open test1 r] + seek $f1 0 end + set c1 [tell $f1] + close $f1 + set c1 +} 54 +test io-12.15 {Tcl_Tell combined with seeking} { + removeFile test1 + set f1 [open test1 w] + fconfigure $f1 -translation lf -eofchar {} + puts $f1 "abcdefghijklmnopqrstuvwxyz" + puts $f1 "abcdefghijklmnopqrstuvwxyz" + close $f1 + set f1 [open test1 r] + seek $f1 10 start + set c1 [tell $f1] + seek $f1 10 current + set c2 [tell $f1] + close $f1 + list $c1 $c2 +} {10 20} +test io-12.16 {Tcl_tell on pipe: always -1} {unixOrPc} { + set f1 [open "|$tcltest" r+] + set c [tell $f1] + close $f1 + set c +} -1 +test io-12.17 {Tcl_Tell on pipe: always -1} {unixOrPc} { + set f1 [open "|$tcltest" r+] + puts $f1 {puts hello} + flush $f1 + set c [tell $f1] + gets $f1 + close $f1 + set c +} -1 +test io-12.18 {Tcl_Tell combined with seeking and reading} { + removeFile test2 + set f [open test2 w] + fconfigure $f -translation lf -eofchar {} + puts -nonewline $f "line1\nline2\nline3\nline4\nline5\n" + close $f + set f [open test2] + fconfigure $f -translation lf + set x [tell $f] + read $f 3 + lappend x [tell $f] + seek $f 2 + lappend x [tell $f] + seek $f 10 current + lappend x [tell $f] + seek $f 0 end + lappend x [tell $f] + close $f + set x +} {0 3 2 12 30} +test io-12.19 {Tcl_Tell combined with opening in append mode} { + set f [open test3 w] + fconfigure $f -translation lf -eofchar {} + puts $f "abcdefghijklmnopqrstuvwxyz" + puts $f "abcdefghijklmnopqrstuvwxyz" + close $f + set f [open test3 a] + set c [tell $f] + close $f + set c +} 54 +test io-12.20 {Tcl_Tell combined with writing} { + set f [open test3 w] + set l "" + seek $f 29 start + lappend l [tell $f] + puts -nonewline $f a + seek $f 39 start + lappend l [tell $f] + puts -nonewline $f a + lappend l [tell $f] + seek $f 407 end + lappend l [tell $f] + close $f + set l +} {29 39 40 447} + +# Test Tcl_Eof + +test io-13.1 {Tcl_Eof} { + removeFile test1 + set f [open test1 w] + puts $f hello + puts $f hello + close $f + set f [open test1] + set x [eof $f] + lappend x [eof $f] + gets $f + lappend x [eof $f] + gets $f + lappend x [eof $f] + gets $f + lappend x [eof $f] + lappend x [eof $f] + close $f + set x +} {0 0 0 0 1 1} +test io-13.2 {Tcl_Eof with pipe} {unixOrPc} { + removeFile pipe + set f1 [open pipe w] + puts $f1 {gets stdin} + puts $f1 {puts hello} + close $f1 + set f1 [open "|$tcltest pipe" r+] + puts $f1 hello + set x [eof $f1] + flush $f1 + lappend x [eof $f1] + gets $f1 + lappend x [eof $f1] + gets $f1 + lappend x [eof $f1] + close $f1 + set x +} {0 0 0 1} +test io-13.3 {Tcl_Eof with pipe} {unixOrPc} { + removeFile pipe + set f1 [open pipe w] + puts $f1 {gets stdin} + puts $f1 {puts hello} + close $f1 + set f1 [open "|$tcltest pipe" r+] + puts $f1 hello + set x [eof $f1] + flush $f1 + lappend x [eof $f1] + gets $f1 + lappend x [eof $f1] + gets $f1 + lappend x [eof $f1] + gets $f1 + lappend x [eof $f1] + gets $f1 + lappend x [eof $f1] + close $f1 + set x +} {0 0 0 1 1 1} +test io-13.4 {Tcl_Eof, eof detection on nonblocking file} {nonBlockFiles} { + removeFile test1 + set f [open test1 w] + close $f + set f [open test1 r] + fconfigure $f -blocking off + set l "" + lappend l [gets $f] + lappend l [eof $f] + close $f + set l +} {{} 1} +test io-13.5 {Tcl_Eof, eof detection on nonblocking pipe} {unixOrPc} { + removeFile pipe + set f [open pipe w] + puts $f { + exit + } + close $f + set f [open "|$tcltest pipe" r] + set l "" + lappend l [gets $f] + lappend l [eof $f] + close $f + set l +} {{} 1} +test io-13.6 {Tcl_Eof, eof char, lf write, auto read} { + removeFile test1 + set f [open test1 w] + fconfigure $f -translation lf -eofchar \x1a + puts $f abc\ndef + close $f + set s [file size test1] + set f [open test1 r] + fconfigure $f -translation auto -eofchar \x1a + set l [string length [read $f]] + set e [eof $f] + close $f + list $s $l $e +} {9 8 1} +test io-13.7 {Tcl_Eof, eof char, lf write, lf read} { + removeFile test1 + set f [open test1 w] + fconfigure $f -translation lf -eofchar \x1a + puts $f abc\ndef + close $f + set s [file size test1] + set f [open test1 r] + fconfigure $f -translation lf -eofchar \x1a + set l [string length [read $f]] + set e [eof $f] + close $f + list $s $l $e +} {9 8 1} +test io-13.8 {Tcl_Eof, eof char, cr write, auto read} { + removeFile test1 + set f [open test1 w] + fconfigure $f -translation cr -eofchar \x1a + puts $f abc\ndef + close $f + set s [file size test1] + set f [open test1 r] + fconfigure $f -translation auto -eofchar \x1a + set l [string length [read $f]] + set e [eof $f] + close $f + list $s $l $e +} {9 8 1} +test io-13.9 {Tcl_Eof, eof char, cr write, cr read} { + removeFile test1 + set f [open test1 w] + fconfigure $f -translation cr -eofchar \x1a + puts $f abc\ndef + close $f + set s [file size test1] + set f [open test1 r] + fconfigure $f -translation cr -eofchar \x1a + set l [string length [read $f]] + set e [eof $f] + close $f + list $s $l $e +} {9 8 1} +test io-13.10 {Tcl_Eof, eof char, crlf write, auto read} { + removeFile test1 + set f [open test1 w] + fconfigure $f -translation crlf -eofchar \x1a + puts $f abc\ndef + close $f + set s [file size test1] + set f [open test1 r] + fconfigure $f -translation auto -eofchar \x1a + set l [string length [read $f]] + set e [eof $f] + close $f + list $s $l $e +} {11 8 1} +test io-13.11 {Tcl_Eof, eof char, crlf write, crlf read} { + removeFile test1 + set f [open test1 w] + fconfigure $f -translation crlf -eofchar \x1a + puts $f abc\ndef + close $f + set s [file size test1] + set f [open test1 r] + fconfigure $f -translation crlf -eofchar \x1a + set l [string length [read $f]] + set e [eof $f] + close $f + list $s $l $e +} {11 8 1} +test io-13.12 {Tcl_Eof, eof char in middle, lf write, auto read} { + removeFile test1 + set f [open 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] + fconfigure $f -translation auto -eofchar \x1a + set l [string length [read $f]] + set e [eof $f] + close $f + list $c $l $e +} {17 8 1} +test io-13.13 {Tcl_Eof, eof char in middle, lf write, lf read} { + removeFile test1 + set f [open 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] + fconfigure $f -translation lf -eofchar \x1a + set l [string length [read $f]] + set e [eof $f] + close $f + list $c $l $e +} {17 8 1} +test io-13.14 {Tcl_Eof, eof char in middle, cr write, auto read} { + removeFile test1 + set f [open 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] + fconfigure $f -translation auto -eofchar \x1a + set l [string length [read $f]] + set e [eof $f] + close $f + list $c $l $e +} {17 8 1} +test io-13.15 {Tcl_Eof, eof char in middle, cr write, cr read} { + removeFile test1 + set f [open 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] + fconfigure $f -translation cr -eofchar \x1a + set l [string length [read $f]] + set e [eof $f] + close $f + list $c $l $e +} {17 8 1} +test io-13.16 {Tcl_Eof, eof char in middle, crlf write, auto read} { + removeFile test1 + set f [open 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] + fconfigure $f -translation auto -eofchar \x1a + set l [string length [read $f]] + set e [eof $f] + close $f + list $c $l $e +} {21 8 1} +test io-13.17 {Tcl_Eof, eof char in middle, crlf write, crlf read} { + removeFile test1 + set f [open 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] + fconfigure $f -translation crlf -eofchar \x1a + set l [string length [read $f]] + set e [eof $f] + close $f + list $c $l $e +} {21 8 1} + +# Test Tcl_InputBlocked + +test io-14.1 {Tcl_InputBlocked on nonblocking pipe} {unixOrPc tempNotPc} { + set f1 [open "|$tcltest" r+] + puts $f1 {puts hello_from_pipe} + flush $f1 + gets $f1 + fconfigure $f1 -blocking off -buffering full + puts $f1 {puts hello} + set x "" + lappend x [gets $f1] + lappend x [fblocked $f1] + flush $f1 + after 200 + lappend x [gets $f1] + lappend x [fblocked $f1] + lappend x [gets $f1] + lappend x [fblocked $f1] + close $f1 + set x +} {{} 1 hello 0 {} 1} +test io-14.2 {Tcl_InputBlocked on blocking pipe} {unixOrPc tempNotPc} { + set f1 [open "|$tcltest" r+] + fconfigure $f1 -buffering line + puts $f1 {puts hello_from_pipe} + set x "" + lappend x [gets $f1] + lappend x [fblocked $f1] + puts $f1 {exit} + lappend x [gets $f1] + lappend x [fblocked $f1] + lappend x [eof $f1] + close $f1 + set x +} {hello_from_pipe 0 {} 0 1} +test io-14.3 {Tcl_InputBlocked vs files, short read} { + removeFile test1 + set f [open test1 w] + puts $f abcdefghijklmnop + close $f + set f [open test1 r] + set l "" + lappend l [fblocked $f] + lappend l [read $f 3] + lappend l [fblocked $f] + lappend l [read -nonewline $f] + lappend l [fblocked $f] + lappend l [eof $f] + close $f + set l +} {0 abc 0 defghijklmnop 0 1} +test io-14.4 {Tcl_InputBlocked vs files, event driven read} { + proc in {f} { + global l + lappend l [read $f 3] + if {[eof $f]} {lappend l eof; close $f} + } + removeFile test1 + set f [open test1 w] + puts $f abcdefghijklmnop + close $f + set f [open test1 r] + set l "" + fileevent $f readable [list in $f] + update + set l +} {abc def ghi jkl mno {p +} eof} +test io-14.5 {Tcl_InputBlocked vs files, short read, nonblocking} {nonBlockFiles} { + removeFile test1 + set f [open test1 w] + puts $f abcdefghijklmnop + close $f + set f [open test1 r] + fconfigure $f -blocking off + set l "" + lappend l [fblocked $f] + lappend l [read $f 3] + lappend l [fblocked $f] + lappend l [read -nonewline $f] + lappend l [fblocked $f] + lappend l [eof $f] + close $f + set l +} {0 abc 0 defghijklmnop 0 1} +test io-14.6 {Tcl_InputBlocked vs files, event driven read} {nonBlockFiles} { + proc in {f} { + global l + lappend l [read $f 3] + if {[eof $f]} {lappend l eof; close $f} + } + removeFile test1 + set f [open test1 w] + puts $f abcdefghijklmnop + close $f + set f [open test1 r] + fconfigure $f -blocking off + set l "" + fileevent $f readable [list in $f] + update + set l +} {abc def ghi jkl mno {p +} eof} + +# Test Tcl_InputBuffered + +test io-15.1 {Tcl_InputBuffered} { + set f [open io.test r] + fconfigure $f -buffersize 4096 + read $f 3 + set l "" + lappend l [testchannel inputbuffered $f] + lappend l [tell $f] + close $f + set l +} {4093 3} +test io-15.2 {Tcl_InputBuffered, test input flushing on seek} { + set f [open io.test r] + fconfigure $f -buffersize 4096 + read $f 3 + set l "" + lappend l [testchannel inputbuffered $f] + lappend l [tell $f] + seek $f 0 current + lappend l [testchannel inputbuffered $f] + lappend l [tell $f] + close $f + set l +} {4093 3 0 3} + +# Test Tcl_SetChannelBufferSize, Tcl_GetChannelBufferSize + +test io-16.1 {Tcl_GetChannelBufferSize, default buffer size} { + set f [open io.test r] + set s [fconfigure $f -buffersize] + close $f + set s +} 4096 +test io-16.2 {Tcl_SetChannelBufferSize, Tcl_GetChannelBufferSize} { + set f [open io.test r] + set l "" + lappend l [fconfigure $f -buffersize] + fconfigure $f -buffersize 10000 + lappend l [fconfigure $f -buffersize] + fconfigure $f -buffersize 1 + lappend l [fconfigure $f -buffersize] + fconfigure $f -buffersize -1 + lappend l [fconfigure $f -buffersize] + fconfigure $f -buffersize 0 + lappend l [fconfigure $f -buffersize] + fconfigure $f -buffersize 100000 + lappend l [fconfigure $f -buffersize] + fconfigure $f -buffersize 10000000 + lappend l [fconfigure $f -buffersize] + close $f + set l +} {4096 10000 4096 4096 4096 100000 4096} + +# Test Tcl_SetChannelOption, Tcl_GetChannelOption + +test io-17.1 {Tcl_GetChannelOption} { + removeFile test1 + set f1 [open test1 w] + set x [fconfigure $f1 -blocking] + close $f1 + set x +} 1 +# +# Test 17.2 was removed. +# +test io-17.3 {Tcl_GetChannelOption} { + removeFile test1 + set f1 [open test1 w] + set x [fconfigure $f1 -buffering] + close $f1 + set x +} full +test io-17.4 {Tcl_GetChannelOption} { + removeFile test1 + set f1 [open test1 w] + fconfigure $f1 -buffering line + set x [fconfigure $f1 -buffering] + close $f1 + set x +} line +test io-17.5 {Tcl_GetChannelOption, Tcl_SetChannelOption} { + removeFile test1 + set f1 [open test1 w] + set l "" + lappend l [fconfigure $f1 -buffering] + fconfigure $f1 -buffering line + lappend l [fconfigure $f1 -buffering] + fconfigure $f1 -buffering none + lappend l [fconfigure $f1 -buffering] + fconfigure $f1 -buffering line + lappend l [fconfigure $f1 -buffering] + fconfigure $f1 -buffering full + lappend l [fconfigure $f1 -buffering] + close $f1 + set l +} {full line none line full} +test io-17.6 {Tcl_GetChannelOption, invariance} { + removeFile test1 + set f1 [open test1 w] + set l "" + lappend l [fconfigure $f1 -buffering] + lappend l [list [catch {fconfigure $f1 -buffering green} msg] $msg] + lappend l [fconfigure $f1 -buffering] + close $f1 + set l +} {full {1 {bad value for -buffering: must be one of full, line, or none}} full} +test io-17.7 {Tcl_SetChannelOption, multiple options} { + removeFile test1 + set f1 [open test1 w] + fconfigure $f1 -translation lf -buffering line + puts $f1 hello + puts $f1 bye + set x [file size test1] + close $f1 + set x +} 10 +test io-17.8 {Tcl_SetChannelOption, buffering, translation} { + removeFile test1 + set f1 [open test1 w] + fconfigure $f1 -translation lf + puts $f1 hello + puts $f1 bye + set x "" + fconfigure $f1 -buffering line + lappend x [file size test1] + puts $f1 really_bye + lappend x [file size test1] + close $f1 + set x +} {0 21} +test io-17.9 {Tcl_SetChannelOption, different buffering options} { + removeFile test1 + set f1 [open test1 w] + set l "" + fconfigure $f1 -translation lf -buffering none -eofchar {} + puts -nonewline $f1 hello + lappend l [file size test1] + puts -nonewline $f1 hello + lappend l [file size test1] + fconfigure $f1 -buffering full + puts -nonewline $f1 hello + lappend l [file size test1] + fconfigure $f1 -buffering none + lappend l [file size test1] + puts -nonewline $f1 hello + lappend l [file size test1] + close $f1 + lappend l [file size test1] + set l +} {5 10 10 10 20 20} +test io-17.10 {Tcl_SetChannelOption, blocking mode} {nonBlockFiles} { + removeFile test1 + set f1 [open test1 w] + close $f1 + set f1 [open test1 r] + set x "" + lappend x [fconfigure $f1 -blocking] + fconfigure $f1 -blocking off + lappend x [fconfigure $f1 -blocking] + lappend x [gets $f1] + lappend x [read $f1 1000] + lappend x [fblocked $f1] + lappend x [eof $f1] + close $f1 + set x +} {1 0 {} {} 0 1} +test io-17.11 {Tcl_SetChannelOption, blocking mode} {unixOrPc tempNotPc} { + removeFile pipe + set f1 [open pipe w] + puts $f1 {gets stdin} + puts $f1 {after 100} + puts $f1 {puts hi} + puts $f1 {gets stdin} + close $f1 + set x "" + set f1 [open "|$tcltest pipe" r+] + fconfigure $f1 -blocking off -buffering line + lappend x [fconfigure $f1 -blocking] + lappend x [gets $f1] + lappend x [fblocked $f1] + puts $f1 hello + lappend x [gets $f1] + lappend x [fblocked $f1] + puts $f1 bye + lappend x [gets $f1] + lappend x [fblocked $f1] + fconfigure $f1 -blocking on + lappend x [fconfigure $f1 -blocking] + lappend x [gets $f1] + lappend x [fblocked $f1] + lappend x [eof $f1] + lappend x [gets $f1] + lappend x [eof $f1] + close $f1 + set x +} {0 {} 1 {} 1 {} 1 1 hi 0 0 {} 1} +test io-17.12 {Tcl_SetChannelOption, Tcl_GetChannelOption, buffer size} { + removeFile test1 + set f [open test1 w] + fconfigure $f -buffersize -10 + set x [fconfigure $f -buffersize] + close $f + set x +} 4096 +test io-17.13 {Tcl_SetChannelOption, Tcl_GetChannelOption buffer size} { + removeFile test1 + set f [open test1 w] + fconfigure $f -buffersize 10000000 + set x [fconfigure $f -buffersize] + close $f + set x +} 4096 +test io-17.14 {Tcl_SetChannelOption, Tcl_GetChannelOption, buffer size} { + removeFile test1 + set f [open test1 w] + fconfigure $f -buffersize 40000 + set x [fconfigure $f -buffersize] + close $f + set x +} 40000 + +test io-18.1 {POSIX open access modes: RDWR} { + removeFile test3 + set f [open test3 w] + puts $f xyzzy + close $f + set f [open test3 RDWR] + puts -nonewline $f "ab" + seek $f 0 current + set x [gets $f] + close $f + set f [open test3 r] + lappend x [gets $f] + close $f + set x +} {zzy abzzy} +test io-18.2 {POSIX open access modes: CREAT} {unixOnly} { + removeFile test3 + set f [open test3 {WRONLY CREAT} 0600] + file stat test3 stats + set x [format "0%o" [expr $stats(mode)&0777]] + puts $f "line 1" + close $f + set f [open test3 r] + lappend x [gets $f] + close $f + set x +} {0600 {line 1}} +test io-18.3 {POSIX open access modes: CREAT} {unixOnly nonPortable} { + # This test only works if your umask is 2, like ouster's. + removeFile test3 + set f [open test3 {WRONLY CREAT}] + close $f + file stat test3 stats + format "0%o" [expr $stats(mode)&0777] +} 0664 +test io-18.4 {POSIX open access modes: CREAT} { + removeFile test3 + set f [open test3 w] + fconfigure $f -eofchar {} + puts $f xyzzy + close $f + set f [open test3 {WRONLY CREAT}] + fconfigure $f -eofchar {} + puts -nonewline $f "ab" + close $f + set f [open test3 r] + set x [gets $f] + close $f + set x +} abzzy +test io-18.5 {POSIX open access modes: APPEND} { + removeFile test3 + set f [open test3 w] + fconfigure $f -translation lf -eofchar {} + puts $f xyzzy + close $f + set f [open test3 {WRONLY APPEND}] + fconfigure $f -translation lf + puts $f "new line" + seek $f 0 + puts $f "abc" + close $f + set f [open test3 r] + fconfigure $f -translation lf + set x "" + seek $f 6 current + lappend x [gets $f] + lappend x [gets $f] + close $f + set x +} {{new line} abc} +test io-18.6 {POSIX open access modes: EXCL} { + removeFile test3 + set f [open test3 w] + puts $f xyzzy + close $f + set msg [list [catch {open test3 {WRONLY CREAT EXCL}} msg] $msg] + regsub " already " $msg " " msg + string tolower $msg +} {1 {couldn't open "test3": file exists}} +test io-18.7 {POSIX open access modes: EXCL} { + removeFile test3 + set f [open test3 {WRONLY CREAT EXCL}] + fconfigure $f -eofchar {} + puts $f "A test line" + close $f + viewFile test3 +} {A test line} +test io-18.8 {POSIX open access modes: TRUNC} { + removeFile test3 + set f [open test3 w] + puts $f xyzzy + close $f + set f [open test3 {WRONLY TRUNC}] + puts $f abc + close $f + set f [open test3 r] + set x [gets $f] + close $f + set x +} abc +test io-18.9 {POSIX open access modes: NONBLOCK} {nonPortable} { + removeFile test3 + set f [open test3 {WRONLY NONBLOCK CREAT}] + puts $f "NONBLOCK test" + close $f + set f [open test3 r] + set x [gets $f] + close $f + set x +} {NONBLOCK test} +test io-18.10 {POSIX open access modes: RDONLY} { + set f [open test1 w] + puts $f "two lines: this one" + puts $f "and this" + close $f + set f [open test1 RDONLY] + set x [list [gets $f] [catch {puts $f Test} msg] $msg] + close $f + string compare [string tolower $x] \ + [list {two lines: this one} 1 \ + [format "channel \"%s\" wasn't opened for writing" $f]] +} 0 +test io-18.11 {POSIX open access modes: RDONLY} { + removeFile test3 + string tolower [list [catch {open test3 RDONLY} msg] $msg] +} {1 {couldn't open "test3": no such file or directory}} +test io-18.12 {POSIX open access modes: WRONLY} { + removeFile test3 + string tolower [list [catch {open test3 WRONLY} msg] $msg] +} {1 {couldn't open "test3": no such file or directory}} +test io-18.13 {POSIX open access modes: WRONLY} { + makeFile xyzzy test3 + set f [open test3 WRONLY] + fconfigure $f -eofchar {} + puts -nonewline $f "ab" + seek $f 0 current + set x [list [catch {gets $f} msg] $msg] + close $f + lappend x [viewFile test3] + string compare [string tolower $x] \ + [list 1 "channel \"$f\" wasn't opened for reading" abzzy] +} 0 +test io-18.14 {POSIX open access modes: RDWR} { + removeFile test3 + string tolower [list [catch {open test3 RDWR} msg] $msg] +} {1 {couldn't open "test3": no such file or directory}} +test io-18.15 {POSIX open access modes: RDWR} { + makeFile xyzzy test3 + set f [open test3 RDWR] + puts -nonewline $f "ab" + seek $f 0 current + set x [gets $f] + close $f + lappend x [viewFile test3] +} {zzy abzzy} +if {![file exists ~/_test_] && [file writable ~]} { + test io-18.16 {tilde substitution in open} { + set f [open ~/_test_ w] + puts $f "Some text" + close $f + set x [file exists [file join $env(HOME) _test_]] + removeFile [file join $env(HOME) _test_] + set x + } 1 +} +test io-18.17 {tilde substitution in open} { + set home $env(HOME) + unset env(HOME) + set x [list [catch {open ~/foo} msg] $msg] + set env(HOME) $home + set x +} {1 {couldn't find HOME environment variable to expand path}} + +test io-19.1 {Tcl_FileeventCmd: errors} { + list [catch {fileevent foo} msg] $msg +} {1 {wrong # args: must be "fileevent channelId event ?script?}} +test io-19.2 {Tcl_FileeventCmd: errors} { + list [catch {fileevent foo bar baz q} msg] $msg +} {1 {wrong # args: must be "fileevent channelId event ?script?}} +test io-19.3 {Tcl_FileeventCmd: errors} { + list [catch {fileevent gorp readable} msg] $msg +} {1 {can not find channel named "gorp"}} +test io-19.4 {Tcl_FileeventCmd: errors} { + list [catch {fileevent gorp writable} msg] $msg +} {1 {can not find channel named "gorp"}} +test io-19.5 {Tcl_FileeventCmd: errors} { + list [catch {fileevent gorp who-knows} msg] $msg +} {1 {bad event name "who-knows": must be readable or writable}} + +# +# Test fileevent on a file +# + +set f [open foo w+] + +test io-20.1 {Tcl_FileeventCmd: creating, deleting, querying} { + list [fileevent $f readable] [fileevent $f writable] +} {{} {}} +test io-20.2 {Tcl_FileeventCmd: replacing} { + set result {} + fileevent $f r "first script" + lappend result [fileevent $f readable] + fileevent $f r "new script" + lappend result [fileevent $f readable] + fileevent $f r "yet another" + lappend result [fileevent $f readable] + fileevent $f r "" + lappend result [fileevent $f readable] +} {{first script} {new script} {yet another} {}} + +# +# Test fileevent on a pipe +# + +if {($tcl_platform(platform) != "macintosh") && \ + ($testConfig(unixExecs) == 1)} { + +catch {set f2 [open {|cat -u} r+]} +catch {set f3 [open {|cat -u} r+]} + +test io-21.1 {Tcl_FileeventCmd: creating, deleting, querying} { + set result {} + fileevent $f readable "script 1" + lappend result [fileevent $f readable] [fileevent $f writable] + fileevent $f writable "write script" + lappend result [fileevent $f readable] [fileevent $f writable] + fileevent $f readable {} + lappend result [fileevent $f readable] [fileevent $f writable] + fileevent $f writable {} + lappend result [fileevent $f readable] [fileevent $f writable] +} {{script 1} {} {script 1} {write script} {} {write script} {} {}} +test io-21.2 {Tcl_FileeventCmd: deleting when many present} { + set result {} + lappend result [fileevent $f r] [fileevent $f2 r] [fileevent $f3 r] + fileevent $f r "read f" + fileevent $f2 r "read f2" + fileevent $f3 r "read f3" + lappend result [fileevent $f r] [fileevent $f2 r] [fileevent $f3 r] + fileevent $f2 r {} + lappend result [fileevent $f r] [fileevent $f2 r] [fileevent $f3 r] + fileevent $f3 r {} + lappend result [fileevent $f r] [fileevent $f2 r] [fileevent $f3 r] + fileevent $f r {} + lappend result [fileevent $f r] [fileevent $f2 r] [fileevent $f3 r] +} {{} {} {} {read f} {read f2} {read f3} {read f} {} {read f3} {read f} {} {} {} {} {}} + +test io-22.1 {FileEventProc procedure: normal read event} { + fileevent $f2 readable { + set x [gets $f2]; fileevent $f2 readable {} + } + puts $f2 text; flush $f2 + after 200 + set x initial + update + set x +} {text} +test io-22.2 {FileEventProc procedure: error in read event} { + proc bgerror args { + global x + set x $args + } + fileevent $f2 readable {error bogus} + puts $f2 text; flush $f2 + after 200 + set x initial + update + rename bgerror {} + list $x [fileevent $f2 readable] +} {bogus {}} +test io-22.3 {FileEventProc procedure: normal write event} { + fileevent $f2 writable { + lappend x "triggered" + incr count -1 + if {$count <= 0} { + fileevent $f2 writable {} + } + } + set x initial + set count 3 + update + set x +} {initial triggered triggered triggered} +test io-22.4 {FileEventProc procedure: eror in write event} { + proc bgerror args { + global x + set x $args + } + fileevent $f2 writable {error bad-write} + set x initial + update + rename bgerror {} + list $x [fileevent $f2 writable] +} {bad-write {}} +test io-22.5 {FileEventProc procedure: end of file} {unixOrPc unixExecs} { + set f4 [open {|cat << foo} r] + fileevent $f4 readable { + if {[gets $f4 line] < 0} { + lappend x eof + fileevent $f4 readable {} + } else { + lappend x $line + } + } + after 200 + set x initial + update + close $f4 + set x +} {initial foo eof} + +catch {close $f2} +catch {close $f3} + +} # Closes if {($platform(platform) != "macintosh") && \ + # ($testConfig(unixExecs) == 1)} clause + +close $f +makeFile "foo bar" foo +test io-23.1 {DeleteFileEvent, cleanup on close} { + set f [open foo r] + fileevent $f readable { + lappend x "binding triggered: \"[gets $f]\"" + fileevent $f readable {} + } + close $f + set x initial + update + set x +} {initial} +test io-23.2 {DeleteFileEvent, cleanup on close} { + set f [open foo r] + set f2 [open foo r] + fileevent $f readable { + lappend x "f triggered: \"[gets $f]\"" + fileevent $f readable {} + } + fileevent $f2 readable { + lappend x "f2 triggered: \"[gets $f2]\"" + fileevent $f2 readable {} + } + close $f + set x initial + update + close $f2 + set x +} {initial {f2 triggered: "foo bar"}} + +test io-23.3 {DeleteFileEvent, cleanup on close} { + set f [open foo r] + set f2 [open foo r] + set f3 [open foo r] + fileevent $f readable {f script} + fileevent $f2 readable {f2 script} + fileevent $f3 readable {f3 script} + set x {} + close $f2 + lappend x [catch {fileevent $f readable} msg] $msg \ + [catch {fileevent $f2 readable}] \ + [catch {fileevent $f3 readable} msg] $msg + close $f3 + lappend x [catch {fileevent $f readable} msg] $msg \ + [catch {fileevent $f2 readable}] \ + [catch {fileevent $f3 readable}] + close $f + lappend x [catch {fileevent $f readable}] \ + [catch {fileevent $f2 readable}] \ + [catch {fileevent $f3 readable}] +} {0 {f script} 1 0 {f3 script} 0 {f script} 1 1 1 1 1} + +if {[info commands testfevent] == ""} { + break +} + +test io-24.1 {Tcl event loop vs multiple interpreters} { + testfevent create + testfevent cmd { + set f [open foo r] + set x "no event" + fileevent $f readable { + set x "f triggered: [gets $f]" + fileevent $f readable {} + } + } + update + testfevent cmd {close $f} + list [testfevent cmd {set x}] [testfevent cmd {info commands after}] +} {{f triggered: foo bar} after} +test io-24.2 {Tcl event loop vs multiple interpreters} { + testfevent create + testfevent cmd { + set x 0 + after 100 {set x triggered} + vwait x + set x + } +} {triggered} +test io-24.3 {Tcl event loop vs multiple interpreters} { + testfevent create + testfevent cmd { + set x 0 + after 10 {lappend x timer} + after 30 + set result $x + update idletasks + lappend result $x + update + lappend result $x + } +} {0 0 {0 timer}} + +test io-25.1 {fileevent vs multiple interpreters} { + set f [open foo r] + set f2 [open foo r] + set f3 [open foo r] + fileevent $f readable {script 1} + testfevent create + testfevent share $f2 + testfevent cmd "fileevent $f2 readable {script 2}" + fileevent $f3 readable {sript 3} + set x {} + lappend x [fileevent $f2 readable] + testfevent delete + lappend x [fileevent $f readable] [fileevent $f2 readable] \ + [fileevent $f3 readable] + close $f + close $f2 + close $f3 + set x +} {{} {script 1} {} {sript 3}} +test io-25.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] + fileevent $f readable {script 1} + testfevent create + testfevent share $f2 + testfevent share $f3 + testfevent cmd "fileevent $f2 readable {script 2} + fileevent $f3 readable {script 3}" + fileevent $f4 readable {script 4} + testfevent delete + set x [list [fileevent $f readable] [fileevent $f2 readable] \ + [fileevent $f3 readable] [fileevent $f4 readable]] + close $f + close $f2 + close $f3 + close $f4 + set x +} {{script 1} {} {} {script 4}} +test io-25.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] + testfevent create + testfevent share $f3 + testfevent share $f4 + fileevent $f readable {script 1} + fileevent $f2 readable {script 2} + testfevent cmd "fileevent $f3 readable {script 3} + fileevent $f4 readable {script 4}" + testfevent delete + set x [list [fileevent $f readable] [fileevent $f2 readable] \ + [fileevent $f3 readable] [fileevent $f4 readable]] + close $f + close $f2 + close $f3 + close $f4 + set x +} {{script 1} {script 2} {} {}} +test io-25.4 {file events on shared files and multiple interpreters} { + set f [open foo r] + set f2 [open foo r] + testfevent create + testfevent share $f + testfevent cmd "fileevent $f readable {script 1}" + fileevent $f readable {script 2} + fileevent $f2 readable {script 3} + set x [list [fileevent $f2 readable] \ + [testfevent cmd "fileevent $f readable"] \ + [fileevent $f readable]] + testfevent delete + close $f + close $f2 + set x +} {{script 3} {script 1} {script 2}} +test io-25.5 {file events on shared files, deleting file events} { + set f [open foo r] + testfevent create + testfevent share $f + testfevent cmd "fileevent $f readable {script 1}" + fileevent $f readable {script 2} + testfevent cmd "fileevent $f readable {}" + set x [list [testfevent cmd "fileevent $f readable"] \ + [fileevent $f readable]] + testfevent delete + close $f + set x +} {{} {script 2}} +test io-25.6 {file events on shared files, deleting file events} { + set f [open foo r] + testfevent create + testfevent share $f + testfevent cmd "fileevent $f readable {script 1}" + fileevent $f readable {script 2} + fileevent $f readable {} + set x [list [testfevent cmd "fileevent $f readable"] \ + [fileevent $f readable]] + testfevent delete + close $f + set x +} {{script 1} {}} + +test io-26.1 {testing readability conditions} { + set f [open 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] + proc consume {f} { + global x l + lappend l called + if {[eof $f]} { + close $f + set x done + } else { + gets $f + } + } + set l "" + set x not_done + vwait x + list $x $l +} {done {called called called called called called called}} +test io-26.2 {testing readability conditions} {nonBlockFiles} { + set f [open 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] + fconfigure $f -blocking off + proc consume {f} { + global x l + lappend l called + if {[eof $f]} { + close $f + set x done + } else { + gets $f + } + } + set l "" + set x not_done + vwait x + list $x $l +} {done {called called called called called called called}} +test io-26.3 {testing readability conditions} {unixOnly nonBlockFiles} { + set f [open 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] + puts $f { + proc copy_slowly {f} { + while {![eof $f]} { + puts [gets $f] + after 200 + } + close $f + } + } + close $f + set f [open |$tcltest r+] + fileevent $f readable [list consume $f] + fconfigure $f -buffering line + fconfigure $f -blocking off + proc consume {f} { + global x l + if {[eof $f]} { + set x done + } else { + gets $f + lappend l [fblocked $f] + gets $f + lappend l [fblocked $f] + } + } + set l "" + set x not_done + puts $f {source my_script} + puts $f {set f [open bar r]} + puts $f {copy_slowly $f} + puts $f {exit} + vwait x + close $f + list $x $l +} {done {0 1 0 1 0 1 0 1 0 1 0 1 0 0}} +test io-26.4 {lf write, testing readability, ^Z termination, auto read mode} { + removeFile test1 + set f [open 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 + if {[eof $f]} { + set x done + close $f + } else { + lappend l [gets $f] + incr c + } + } + set c 0 + set l "" + set f [open test1 r] + fconfigure $f -translation auto -eofchar \x1a + fileevent $f readable [list consume $f] + vwait x + list $c $l +} {3 {abc def {}}} +test io-26.5 {lf write, testing readability, ^Z in middle, auto read mode} { + removeFile test1 + set f [open 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 + if {[eof $f]} { + set x done + close $f + } else { + lappend l [gets $f] + incr c + } + } + set c 0 + set l "" + set f [open test1 r] + fconfigure $f -eofchar \x1a -translation auto + fileevent $f readable [list consume $f] + vwait x + list $c $l +} {3 {abc def {}}} +test io-26.6 {cr write, testing readability, ^Z termination, auto read mode} { + removeFile test1 + set f [open 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 + if {[eof $f]} { + set x done + close $f + } else { + lappend l [gets $f] + incr c + } + } + set c 0 + set l "" + set f [open test1 r] + fconfigure $f -translation auto -eofchar \x1a + fileevent $f readable [list consume $f] + vwait x + list $c $l +} {3 {abc def {}}} +test io-26.7 {cr write, testing readability, ^Z in middle, auto read mode} { + removeFile test1 + set f [open 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 + if {[eof $f]} { + set x done + close $f + } else { + lappend l [gets $f] + incr c + } + } + set c 0 + set l "" + set f [open test1 r] + fconfigure $f -eofchar \x1a -translation auto + fileevent $f readable [list consume $f] + vwait x + list $c $l +} {3 {abc def {}}} +test io-26.8 {crlf write, testing readability, ^Z termination, auto read mode} { + removeFile test1 + set f [open 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 + if {[eof $f]} { + set x done + close $f + } else { + lappend l [gets $f] + incr c + } + } + set c 0 + set l "" + set f [open test1 r] + fconfigure $f -translation auto -eofchar \x1a + fileevent $f readable [list consume $f] + vwait x + list $c $l +} {3 {abc def {}}} +test io-26.9 {crlf write, testing readability, ^Z in middle, auto read mode} { + removeFile test1 + set f [open 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 + if {[eof $f]} { + set x done + close $f + } else { + lappend l [gets $f] + incr c + } + } + set c 0 + set l "" + set f [open test1 r] + fconfigure $f -eofchar \x1a -translation auto + fileevent $f readable [list consume $f] + vwait x + list $c $l +} {3 {abc def {}}} +test io-26.10 {lf write, testing readability, ^Z in middle, lf read mode} { + removeFile test1 + set f [open 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 + if {[eof $f]} { + set x done + close $f + } else { + lappend l [gets $f] + incr c + } + } + set c 0 + set l "" + set f [open test1 r] + fconfigure $f -eofchar \x1a -translation lf + fileevent $f readable [list consume $f] + vwait x + list $c $l +} {3 {abc def {}}} +test io-26.11 {lf write, testing readability, ^Z termination, lf read mode} { + removeFile test1 + set f [open 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 + if {[eof $f]} { + set x done + close $f + } else { + lappend l [gets $f] + incr c + } + } + set c 0 + set l "" + set f [open test1 r] + fconfigure $f -translation lf -eofchar \x1a + fileevent $f readable [list consume $f] + vwait x + list $c $l +} {3 {abc def {}}} +test io-26.12 {cr write, testing readability, ^Z in middle, cr read mode} { + removeFile test1 + set f [open 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 + if {[eof $f]} { + set x done + close $f + } else { + lappend l [gets $f] + incr c + } + } + set c 0 + set l "" + set f [open test1 r] + fconfigure $f -eofchar \x1a -translation cr + fileevent $f readable [list consume $f] + vwait x + list $c $l +} {3 {abc def {}}} +test io-26.13 {cr write, testing readability, ^Z termination, cr read mode} { + removeFile test1 + set f [open 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 + if {[eof $f]} { + set x done + close $f + } else { + lappend l [gets $f] + incr c + } + } + set c 0 + set l "" + set f [open test1 r] + fconfigure $f -translation cr -eofchar \x1a + fileevent $f readable [list consume $f] + vwait x + list $c $l +} {3 {abc def {}}} +test io-26.14 {crlf write, testing readability, ^Z in middle, crlf read mode} { + removeFile test1 + set f [open 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 + if {[eof $f]} { + set x done + close $f + } else { + lappend l [gets $f] + incr c + } + } + set c 0 + set l "" + set f [open test1 r] + fconfigure $f -eofchar \x1a -translation crlf + fileevent $f readable [list consume $f] + vwait x + list $c $l +} {3 {abc def {}}} +test io-26.15 {crlf write, testing readability, ^Z termi, crlf read mode} { + removeFile test1 + set f [open 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 + if {[eof $f]} { + set x done + close $f + } else { + lappend l [gets $f] + incr c + } + } + set c 0 + set l "" + set f [open test1 r] + fconfigure $f -translation crlf -eofchar \x1a + fileevent $f readable [list consume $f] + vwait x + list $c $l +} {3 {abc def {}}} + +test io-27.1 {testing handler deletion} { + removeFile test1 + set f [open test1 w] + close $f + set f [open test1 r] + testchannelevent $f add readable [list delhandler $f] + proc delhandler {f} { + global z + set z called + testchannelevent $f delete 0 + } + set z not_called + update + close $f + set z +} called +test io-27.2 {testing handler deletion with multiple handlers} { + removeFile test1 + set f [open 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] + proc delhandler {f i} { + global z + lappend z "called delhandler $f $i" + testchannelevent $f delete 0 + } + set z "" + update + close $f + string compare [string tolower $z] \ + [list [list called delhandler $f 0] [list called delhandler $f 1]] +} 0 +test io-27.3 {testing handler deletion with multiple handlers} { + removeFile test1 + set f [open 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 z "" + proc notcalled {f i} { + global z + lappend z "notcalled was called!! $f $i" + } + proc delhandler {f i} { + global z + testchannelevent $f delete 1 + lappend z "delhandler $f $i called" + testchannelevent $f delete 0 + lappend z "delhandler $f $i deleted myself" + } + set z "" + update + close $f + string compare [string tolower $z] \ + [list [list delhandler $f 0 called] \ + [list delhandler $f 0 deleted myself]] +} 0 +test io-27.4 {testing handler deletion vs reentrant calls} { + removeFile test1 + set f [open test1 w] + close $f + set f [open test1 r] + testchannelevent $f add readable [list delrecursive $f] + proc delrecursive {f} { + global z u + if {"$u" == "recursive"} { + testchannelevent $f delete 0 + lappend z "delrecursive deleting recursive" + } else { + lappend z "delrecursive calling recursive" + set u recursive + update + } + } + set u toplevel + set z "" + update + close $f + string compare [string tolower $z] \ + {{delrecursive calling recursive} {delrecursive deleting recursive}} +} 0 +test io-27.5 {testing handler deletion vs reentrant calls} { + removeFile test1 + set f [open test1 w] + close $f + set f [open test1 r] + testchannelevent $f add readable [list notcalled $f] + testchannelevent $f add readable [list del $f] + proc notcalled {f} { + global z + lappend z "notcalled was called!! $f" + } + proc del {f} { + global z u + if {"$u" == "recursive"} { + testchannelevent $f delete 1 + testchannelevent $f delete 0 + lappend z "del deleted notcalled" + lappend z "del deleted myself" + } else { + set u recursive + lappend z "del calling recursive" + update + lappend z "del after update" + } + } + set z "" + set u toplevel + update + close $f + string compare [string tolower $z] \ + [list {del calling recursive} {del deleted notcalled} \ + {del deleted myself} {del after update}] +} 0 +test io-27.6 {testing handler deletion vs reentrant calls} { + removeFile test1 + set f [open test1 w] + close $f + set f [open test1 r] + testchannelevent $f add readable [list second $f] + testchannelevent $f add readable [list first $f] + proc first {f} { + global u z + if {"$u" == "toplevel"} { + lappend z "first called" + set u first + update + lappend z "first after update" + } else { + lappend z "first called not toplevel" + } + } + proc second {f} { + global u z + if {"$u" == "first"} { + lappend z "second called, first time" + set u second + testchannelevent $f delete 0 + } elseif {"$u" == "second"} { + lappend z "second called, second time" + testchannelevent $f delete 0 + } else { + lappend z "second called, cannot happen!" + testchannelevent $f removeall + } + } + set z "" + set u toplevel + update + close $f + string compare [string tolower $z] \ + [list {first called} {first called not toplevel} \ + {second called, first time} {second called, second time} \ + {first after update}] +} 0 + +removeFile script +removeFile output +removeFile test1 +removeFile pipe +removeFile my_script +removeFile foo +removeFile bar + +set x "" +unset x diff --git a/contrib/tcl/tests/ioCmd.test b/contrib/tcl/tests/ioCmd.test new file mode 100644 index 0000000..18eb5ec --- /dev/null +++ b/contrib/tcl/tests/ioCmd.test @@ -0,0 +1,394 @@ +# Commands covered: open, close, gets, read, puts, seek, tell, eof, flush, +# fblocked, fconfigure, open, channel +# +# 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) 1991-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. +# +# "@(#) iocmd.test 1.37 96/04/12 11:44:23" + +if {[string compare test [info procs test]] == 1} then {source defs} + +removeFile test1 +removeFile pipe + +set executable [list [info nameofexecutable]] + +#test iocmd-1.0 {copyfile command} { +# list [catch {copyfile a b c d e f} msg] $msg +#} {1 {wrong # args: should be "copyfile inChanId outChanId ?chunkSize?"}} +#test iocmd-1.1 {copyfile command} { +# list [catch {copyfile f1} msg] $msg +#} {1 {wrong # args: should be "copyfile inChanId outChanId ?chunkSize?"}} +#test iocmd-1.2 {copyfile command} { +# list [catch {copyfile f1 f2} msg] $msg +#} {1 {can not find channel named "f1"}} +#test iocmd-1.3 {copyfile command} { +# list [catch {copyfile stdin f2} msg] $msg +#} {1 {can not find channel named "f2"}} +#test iocmd-1.4 {copyfile command} { +# list [catch {copyfile stdin stdout booboo} msg] $msg +#} {1 {expected integer but got "booboo"}} +#test iocmd-1.5 {copyfile command} { +# list [catch {copyfile stdout stdin} msg] $msg +#} {1 {channel "stdout" wasn't opened for reading}} +#test iocmd-1.6 {copyfile command} { +# list [catch {copyfile stdin stdin} msg] $msg +#} {1 {channel "stdin" wasn't opened for writing}} + +test iocmd-2.1 {puts command} { + list [catch {puts} msg] $msg +} {1 {wrong # args: should be "puts ?-nonewline? ?channelId? string"}} +test iocmd-2.2 {puts command} { + list [catch {puts a b c d e f g} msg] $msg +} {1 {wrong # args: should be "puts ?-nonewline? ?channelId? string"}} +test iocmd-2.3 {puts command} { + list [catch {puts froboz -nonewline kablooie} msg] $msg +} {1 {bad argument "kablooie": should be "nonewline"}} +test iocmd-2.4 {puts command} { + list [catch {puts froboz hello} msg] $msg +} {1 {can not find channel named "froboz"}} +test iocmd-2.5 {puts command} { + list [catch {puts stdin hello} msg] $msg +} {1 {channel "stdin" wasn't opened for writing}} + +test iocmd-3.0 {flush command} { + list [catch {flush} msg] $msg +} {1 {wrong # args: should be "flush channelId"}} +test iocmd-3.1 {flush command} { + list [catch {flush a b c d e} msg] $msg +} {1 {wrong # args: should be "flush channelId"}} +test iocmd-3.3 {flush command} { + list [catch {flush foo} msg] $msg +} {1 {can not find channel named "foo"}} +test iocmd-3.4 {flush command} { + list [catch {flush stdin} msg] $msg +} {1 {channel "stdin" wasn't opened for writing}} + +test iocmd-4.0 {gets command} { + list [catch {gets} msg] $msg +} {1 {wrong # args: should be "gets channelId ?varName?"}} +test iocmd-4.1 {gets command} { + list [catch {gets a b c d e f g} msg] $msg +} {1 {wrong # args: should be "gets channelId ?varName?"}} +test iocmd-4.2 {gets command} { + list [catch {gets aaa} msg] $msg +} {1 {can not find channel named "aaa"}} +test iocmd-4.2 {gets command} { + list [catch {gets stdout} msg] $msg +} {1 {channel "stdout" wasn't opened for reading}} + +test iocmd-5.0 {read command} { + list [catch {read} msg] $msg +} {1 {wrong # args: should be "read channelId ?numBytes?" or "read ?-nonewline? channelId"}} +test iocmd-5.1 {read command} { + list [catch {read a b c d e f g h} msg] $msg +} {1 {wrong # args: should be "read channelId ?numBytes?" or "read ?-nonewline? channelId"}} +test iocmd-5.2 {read command} { + list [catch {read aaa} msg] $msg +} {1 {can not find channel named "aaa"}} +test iocmd-5.3 {read command} { + list [catch {read -nonewline} msg] $msg +} {1 {wrong # args: should be "read channelId ?numBytes?" or "read ?-nonewline? channelId"}} +test iocmd-5.4 {read command} { + list [catch {read -nonew file4} msg] $msg $errorCode +} {1 {can not find channel named "-nonew"} NONE} +test iocmd-5.5 {read command} { + list [catch {read stdout} msg] $msg +} {1 {channel "stdout" wasn't opened for reading}} +test iocmd-5.6 {read command} { + list [catch {read -nonewline stdout} msg] $msg +} {1 {channel "stdout" wasn't opened for reading}} +test iocmd-5.23 {read command with incorrect combination of arguments} { + removeFile test1 + set f [open test1 w] + puts $f "Two lines: this one" + puts $f "and this one" + close $f + set f [open test1] + set x [list [catch {read -nonewline $f 20 z} msg] $msg $errorCode] + close $f + set x +} {1 {wrong # args: should be "read channelId ?numBytes?" or "read ?-nonewline? channelId"} NONE} +test iocmd-5.24 {read command} { + list [catch {read stdin foo} msg] $msg $errorCode +} {1 {bad argument "foo": should be "nonewline"} NONE} +test iocmd-5.25 {read command} { + list [catch {read file107} msg] $msg $errorCode +} {1 {can not find channel named "file107"} NONE} +test iocmd-5.26 {read command} { + set f [open 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-5.27 {read command} { + set f [open test1] + set x [list [catch {read $f 12z} msg] $msg $errorCode] + close $f + set x +} {1 {expected integer but got "12z"} NONE} + +test iocmd-6.0 {seek command} { + list [catch {seek} msg] $msg +} {1 {wrong # args: should be "seek channelId offset ?origin?"}} +test iocmd-6.1 {seek command} { + list [catch {seek a b c d e f g} msg] $msg +} {1 {wrong # args: should be "seek channelId offset ?origin?"}} +test iocmd-6.2 {seek command} { + list [catch {seek stdin gugu} msg] $msg +} {1 {expected integer but got "gugu"}} +test iocmd-6.3 {seek command} { + list [catch {seek stdin 100 gugu} msg] $msg +} {1 {bad origin "gugu": should be start, current, or end}} + +test iocmd-7.0 {tell command} { + list [catch {tell} msg] $msg +} {1 {wrong # args: should be "tell channelId"}} +test iocmd-7.1 {tell command} { + list [catch {tell a b c d e} msg] $msg +} {1 {wrong # args: should be "tell channelId"}} +test iocmd-7.2 {tell command} { + list [catch {tell aaa} msg] $msg +} {1 {can not find channel named "aaa"}} + +test iocmd-8.0 {close command} { + list [catch {close} msg] $msg +} {1 {wrong # args: should be "close channelId"}} +test iocmd-8.1 {close command} { + list [catch {close a b c d e} msg] $msg +} {1 {wrong # args: should be "close channelId"}} +test iocmd-8.2 {close command} { + list [catch {close aaa} msg] $msg +} {1 {can not find channel named "aaa"}} + +test iocmd-9.0 {fconfigure command} { + list [catch {fconfigure} msg] $msg +} {1 {wrong # args: should be "fconfigure channelId ?optionName? ?value? ?optionName value?..."}} +test iocmd-9.1 {fconfigure command} { + list [catch {fconfigure a b c d e f} msg] $msg +} {1 {wrong # args: should be "fconfigure channelId ?optionName? ?value? ?optionName value?..."}} +test iocmd-9.2 {fconfigure command} { + list [catch {fconfigure a b} msg] $msg +} {1 {can not find channel named "a"}} +test iocmd-9.3 {fconfigure command} { + removeFile test1 + set f1 [open test1 w] + set x [list [catch {fconfigure $f1 froboz} msg] $msg] + close $f1 + set x +} {1 {bad option "froboz": must be -blocking, -buffering, -buffersize, -eofchar, -translation, or a channel type specific option}} +test iocmd-9.4 {fconfigure command} { + list [catch {fconfigure stdin -buffering froboz} msg] $msg +} {1 {bad value for -buffering: must be one of full, line, or none}} +test iocmd-9.4 {fconfigure command} { + list [catch {fconfigure stdin -translation froboz} msg] $msg +} {1 {bad value for -translation: must be one of auto, binary, cr, lf, crlf, or platform}} +test iocmd-9.5 {fconfigure command} { + removeFile test1 + set f1 [open test1 w] + fconfigure $f1 -translation lf -eofchar {} + set x [fconfigure $f1] + close $f1 + set x +} {-blocking 1 -buffering full -buffersize 4096 -eofchar {} -translation lf} +test iocmd-9.6 {fconfigure command} { + removeFile test1 + set f1 [open test1 w] + fconfigure $f1 -translation lf -buffering line -buffersize 3030 \ + -eofchar {} + set x "" + lappend x [fconfigure $f1 -buffering] + lappend x [fconfigure $f1] + close $f1 + set x +} {line {-blocking 1 -buffering line -buffersize 3030 -eofchar {} -translation lf}} +test iocmd-9.7 {fconfigure command} { + removeFile test1 + set f1 [open test1 w] + fconfigure $f1 -translation binary -buffering none -buffersize 4040 \ + -eofchar {} + set x [fconfigure $f1] + close $f1 + set x +} {-blocking 1 -buffering none -buffersize 4040 -eofchar {} -translation lf} +test iocmd-9.8 {fconfigure command} { + list [catch {fconfigure a b} msg] $msg +} {1 {can not find channel named "a"}} +test iocmd-9.9 {fconfigure command} { + list [catch {fconfigure stdout -froboz blarfo} msg] $msg +} {1 {bad option "-froboz": should be -blocking, -buffering, -buffersize, -eofchar, -translation, or channel type specific option}} +test iocmd-9.10 {fconfigure command} { + list [catch {fconfigure stdout -b blarfo} msg] $msg +} {1 {bad option "-b": should be -blocking, -buffering, -buffersize, -eofchar, -translation, or channel type specific option}} +test iocmd-9.11 {fconfigure command} { + list [catch {fconfigure stdout -buffer blarfo} msg] $msg +} {1 {bad option "-buffer": should be -blocking, -buffering, -buffersize, -eofchar, -translation, or channel type specific option}} +test iocmd-9.12 {fconfigure command} { + fconfigure stdin -buffers +} 4096 + +test iocmd-10.1 {eof command} { + list [catch {eof} msg] $msg $errorCode +} {1 {wrong # args: should be "eof channelId"} NONE} +test iocmd-10.2 {eof command} { + list [catch {eof a b} msg] $msg $errorCode +} {1 {wrong # args: should be "eof channelId"} NONE} +test iocmd-10.3 {eof command} { + catch {close file100} + list [catch {eof file100} msg] $msg $errorCode +} {1 {can not find channel named "file100"} NONE} + +test iocmd-11.0 {fblocked command} { + list [catch {fblocked} msg] $msg +} {1 {wrong # args: should be "fblocked channelId"}} +test iocmd-11.1 {fblocked command} { + list [catch {fblocked a b c d e f g} msg] $msg +} {1 {wrong # args: should be "fblocked channelId"}} +test iocmd-11.2 {fblocked command} { + list [catch {fblocked file1000} msg] $msg +} {1 {can not find channel named "file1000"}} +test iocmd-11.3 {fblocked command} { + list [catch {fblocked stdout} msg] $msg +} {1 {channel "stdout" wasn't opened for reading}} +test iocmd-11.4 {fblocked command} { + fblocked stdin +} 0 + +test iocmd-12.1 {I/O to command pipelines} {unixOrPc unixExecs} { + list [catch {open "| cat < test1 > test3" w} msg] $msg $errorCode +} {1 {can't write input to command: standard input was redirected} NONE} +test iocmd-12.2 {I/O to command pipelines} {unixOrPc unixExecs} { + list [catch {open "| echo > test3" r} msg] $msg $errorCode +} {1 {can't read output from command: standard output was redirected} NONE} +test iocmd-12.3 {I/O to command pipelines} {unixOrPc unixExecs} { + list [catch {open "| echo > test3" r+} msg] $msg $errorCode +} {1 {can't read output from command: standard output was redirected} NONE} + +test iocmd-13.1 {POSIX open access modes: RDONLY} { + removeFile test1 + set f [open test1 w] + puts $f "Two lines: this one" + puts $f "and this one" + close $f + set f [open test1 RDONLY] + set x [list [gets $f] [catch {puts $f Test} msg] $msg] + close $f + string compare $x \ + "{Two lines: this one} 1 [list [format "channel \"%s\" wasn't opened for writing" $f]]" +} 0 +test iocmd-13.2 {POSIX open access modes: RDONLY} { + removeFile test3 + string tolower [list [catch {open test3 RDONLY} msg] $msg] +} {1 {couldn't open "test3": no such file or directory}} +test iocmd-13.3 {POSIX open access modes: WRONLY} { + removeFile test3 + string tolower [list [catch {open test3 WRONLY} msg] $msg] +} {1 {couldn't open "test3": no such file or directory}} +# +# Test 13.4 relies on assigning the same channel name twice. +# +test iocmd-13.4 {POSIX open access modes: WRONLY} {unixOnly} { + removeFile test3 + set f [open test3 w] + fconfigure $f -eofchar {} + puts $f xyzzy + close $f + set f [open 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] + fconfigure $f -eofchar {} + lappend x [gets $f] + close $f + set y [list 1 [format "channel \"%s\" wasn't opened for reading" $f] abzzy] + string compare $x $y +} 0 +test iocmd-13.5 {POSIX open access modes: RDWR} { + removeFile test3 + string tolower [list [catch {open test3 RDWR} msg] $msg] +} {1 {couldn't open "test3": no such file or directory}} +test iocmd-13.15 {POSIX open access modes: errors} { + concat [catch {open 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\"\"" +test iocmd-13.16 {POSIX open access modes: errors} { + list [catch {open 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-13.17 {POSIX open access modes: errors} { + list [catch {open test3 {TRUNC CREAT}} msg] $msg +} {1 {access mode must include either RDONLY, WRONLY, or RDWR}} + +test iocmd-14.1 {errors in open command} { + list [catch {open} msg] $msg +} {1 {wrong # args: should be "open fileName ?access? ?permissions?"}} +test iocmd-14.2 {errors in open command} { + list [catch {open a b c d} msg] $msg +} {1 {wrong # args: should be "open fileName ?access? ?permissions?"}} +test iocmd-14.3 {errors in open command} { + list [catch {open test1 x} msg] $msg +} {1 {illegal access mode "x"}} +test iocmd-14.4 {errors in open command} { + list [catch {open test1 rw} msg] $msg +} {1 {illegal access mode "rw"}} +test iocmd-14.5 {errors in open command} { + list [catch {open test1 r+1} msg] $msg +} {1 {illegal access mode "r+1"}} +test iocmd-14.6 {errors in open command} { + string tolower [list [catch {open _non_existent_} msg] $msg $errorCode] +} {1 {couldn't open "_non_existent_": no such file or directory} {posix enoent {no such file or directory}}} + +test iocmd-15.1 {file id parsing errors} { + list [catch {eof gorp} msg] $msg $errorCode +} {1 {can not find channel named "gorp"} NONE} +test iocmd-15.2 {file id parsing errors} { + list [catch {eof filex} msg] $msg +} {1 {can not find channel named "filex"}} +test iocmd-15.3 {file id parsing errors} { + list [catch {eof file12a} msg] $msg +} {1 {can not find channel named "file12a"}} +test iocmd-15.4 {file id parsing errors} { + list [catch {eof file123} msg] $msg +} {1 {can not find channel named "file123"}} +test iocmd-15.5 {file id parsing errors} { + list [catch {eof stdout} msg] $msg +} {0 0} +test iocmd-15.6 {file id parsing errors} { + list [catch {eof stdin} msg] $msg +} {0 0} +test iocmd-15.7 {file id parsing errors} { + list [catch {eof stdout} msg] $msg +} {0 0} +test iocmd-15.8 {file id parsing errors} { + list [catch {eof stderr} msg] $msg +} {0 0} +test iocmd-15.9 {file id parsing errors} { + list [catch {eof stderr1} msg] $msg +} {1 {can not find channel named "stderr1"}} +set f [open test1] +close $f +set expect "1 {can not find channel named \"$f\"}" +test iocmd-15.10 {file id parsing errors} { + list [catch {eof $f} msg] $msg +} $expect + +removeFile test1 +removeFile test2 +removeFile test3 +removeFile pipe +removeFile output +set x "" +set x diff --git a/contrib/tcl/tests/join.test b/contrib/tcl/tests/join.test new file mode 100644 index 0000000..4023de2 --- /dev/null +++ b/contrib/tcl/tests/join.test @@ -0,0 +1,38 @@ +# Commands covered: join +# +# 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) 1991-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: @(#) join.test 1.6 96/02/16 08:56:02 + +if {[string compare test [info procs test]] == 1} then {source defs} + +test join-1.1 {basic join commands} { + join {a b c} xyz +} axyzbxyzc +test join-1.2 {basic join commands} { + join {a b c} {} +} abc +test join-1.3 {basic join commands} { + join {} xyz +} {} +test join-1.4 {basic join commands} { + join {12 34 56} +} {12 34 56} + +test join-2.1 {join errors} { + list [catch join msg] $msg $errorCode +} {1 {wrong # args: should be "join list ?joinString?"} NONE} +test join-2.2 {join errors} { + list [catch {join a b c} msg] $msg $errorCode +} {1 {wrong # args: should be "join list ?joinString?"} NONE} +test join-2.3 {join errors} { + list [catch {join "a \{ c" 111} msg] $msg $errorCode +} {1 {unmatched open brace in list} NONE} diff --git a/contrib/tcl/tests/license.terms b/contrib/tcl/tests/license.terms new file mode 100644 index 0000000..3dcd816 --- /dev/null +++ b/contrib/tcl/tests/license.terms @@ -0,0 +1,32 @@ +This software is copyrighted by the Regents of the University of +California, Sun Microsystems, Inc., 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. + +RESTRICTED RIGHTS: Use, duplication or disclosure by the government +is subject to the restrictions as set forth in subparagraph (c) (1) (ii) +of the Rights in Technical Data and Computer Software Clause as DFARS +252.227-7013 and FAR 52.227-19. diff --git a/contrib/tcl/tests/lindex.test b/contrib/tcl/tests/lindex.test new file mode 100644 index 0000000..66ff3ac --- /dev/null +++ b/contrib/tcl/tests/lindex.test @@ -0,0 +1,74 @@ +# Commands covered: lindex +# +# 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) 1991-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: @(#) lindex.test 1.5 96/02/16 08:56:03 + +if {[string compare test [info procs test]] == 1} then {source defs} + +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 +} {} +test lindex-1.8 {basic tests} { + lindex {a} e +} a +test lindex-1.9 {basic tests} { + lindex {} end +} {} +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 {expected integer but got "2a2"}} +test lindex-2.4 {error conditions} { + 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 +} {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 +} {1 {list element in quotes followed by "def" instead of space}} + +test lindex-3.1 {quoted elements} { + lindex {a "b c" d} 1 +} {b c} +test lindex-3.2 {quoted elements} { + lindex {"{}" b c} 0 +} {{}} +test lindex-3.3 {quoted elements} { + lindex {ab "c d \" x" y} 1 +} {c d " x} +test lindex-3.4 {quoted elements} { + lindex {a b {c d "e} {f g"}} 2 +} {c d "e} diff --git a/contrib/tcl/tests/link.test b/contrib/tcl/tests/link.test new file mode 100644 index 0000000..570a6ee --- /dev/null +++ b/contrib/tcl/tests/link.test @@ -0,0 +1,230 @@ +# Commands covered: none +# +# This file contains a collection of tests for Tcl_LinkVar and related +# library procedures. Sourcing this file into Tcl runs the tests and +# generates output for errors. No output means no errors were found. +# +# 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: @(#) link.test 1.10 96/02/16 08:56:05 + +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." + return +} + +if {[string compare test [info procs test]] == 1} then {source defs} + +foreach i {int real bool string} { + catch {unset $i} +} +test link-1.1 {reading C variables from Tcl} { + 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 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}} + +test link-2.1 {writing C variables from Tcl} { + testlink delete + testlink set 43 1.23 4 - + testlink create 1 1 1 1 + set int "00721" + set real -8e13 + set bool true + set string abcdef + concat [testlink get] $int $real $bool $string +} {465 -8e+13 1 abcdef 00721 -8e13 true abcdef} +test link-2.2 {writing bad values into variables} { + testlink delete + testlink set 43 1.23 4 - + testlink create 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} { + testlink delete + testlink set 43 1.23 4 - + testlink create 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} { + testlink delete + testlink set 43 1.23 4 - + testlink create 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-3.1 {read-only variables} { + testlink delete + testlink set 43 1.23 4 - + testlink create 0 1 1 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} { + testlink delete + testlink set 43 1.23 4 - + testlink create 1 0 0 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}} + +test link-4.1 {unsetting linked variables} { + testlink delete + testlink set -6 -2.1 0 stringValue + testlink create 1 1 1 1 + unset int real bool string + 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.1 0 0 0 stringValue} +test link-4.2 {unsetting linked variables} { + testlink delete + testlink set -6 -2.1 0 stringValue + testlink create 1 1 1 1 + unset int real bool string + set int 102 + set real 16 + set bool true + set string newValue + testlink get +} {102 16.0 1 newValue} + +test link-5.1 {unlinking variables} { + testlink delete + testlink set -6 -2.1 0 stringValue + testlink delete + set int xx1 + set real qrst + set bool bogus + set string 12345 + testlink get +} {-6 -2.1 0 stringValue} +test link-5.2 {unlinking variables} { + testlink delete + testlink set -6 -2.1 0 stringValue + testlink create 1 1 1 1 + testlink delete + testlink set 25 14.7 7 - + list $int $real $bool $string +} {-6 -2.1 0 stringValue} + +test link-6.1 {errors in setting up link} { + testlink delete + catch {unset int} + set int(44) 1 + list [catch {testlink create 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} { + proc x {} { + upvar int y + unset y + } + testlink delete + testlink create 1 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} { + proc x {} { + upvar int y + return [set y] + } + testlink delete + testlink create 1 0 0 0 + testlink set 0 {} {} {} + set int + testlink set 23 {} {} {} + x + list [x] $int +} {23 23} +test link-7.3 {access to linked variables via upvar} { + proc x {} { + upvar int y + set y 44 + } + testlink delete + testlink create 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} { + proc x {} { + upvar int y + set y abc + } + testlink delete + testlink create 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} { + proc x {} { + upvar real y + set y abc + } + testlink delete + testlink create 1 1 1 1 + testlink set -4 16.3 {} {} + list [catch x msg] $msg $real +} {1 {can't set "y": variable must have real value} 16.3} +test link-7.6 {access to linked variables via upvar} { + proc x {} { + upvar bool y + set y abc + } + testlink delete + testlink create 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-8.1 {Tcl_UpdateLinkedVar procedure} { + proc x args { + global x int real bool string + lappend x $args $int $real $bool $string + } + set x {} + testlink create 1 1 1 1 + testlink set 14 -2.0 0 xyzzy + trace var int w x + testlink update 32 4.0 3 abcd + trace vdelete int w x + set x +} {{int {} w} 32 -2.0 0 xyzzy} +test link-8.2 {Tcl_UpdateLinkedVar procedure} { + proc x args { + global x int real bool string + lappend x $args $int $real $bool $string + } + set x {} + testlink create 1 1 1 1 + testlink set 14 -2.0 0 xyzzy + testlink delete + trace var int w x + testlink update 32 4.0 6 abcd + trace vdelete int w x + set x +} {} + +testlink delete +foreach i {int real bool string} { + catch {unset $i} +} diff --git a/contrib/tcl/tests/linsert.test b/contrib/tcl/tests/linsert.test new file mode 100644 index 0000000..a77a907 --- /dev/null +++ b/contrib/tcl/tests/linsert.test @@ -0,0 +1,86 @@ +# Commands covered: linsert +# +# 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) 1991-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: @(#) linsert.test 1.8 96/02/16 08:56:07 + +if {[string compare test [info procs test]] == 1} then {source defs} + +test linsert-1.1 {linsert command} { + linsert {1 2 3 4 5} 0 a +} {a 1 2 3 4 5} +test linsert-1.2 {linsert command} { + linsert {1 2 3 4 5} 1 a +} {1 a 2 3 4 5} +test linsert-1.3 {linsert command} { + linsert {1 2 3 4 5} 2 a +} {1 2 a 3 4 5} +test linsert-1.4 {linsert command} { + linsert {1 2 3 4 5} 3 a +} {1 2 3 a 4 5} +test linsert-1.5 {linsert command} { + linsert {1 2 3 4 5} 4 a +} {1 2 3 4 a 5} +test linsert-1.6 {linsert command} { + linsert {1 2 3 4 5} 5 a +} {1 2 3 4 5 a} +test linsert-1.7 {linsert command} { + linsert {1 2 3 4 5} 2 one two \{three \$four +} {1 2 one two \{three {$four} 3 4 5} +test linsert-1.8 {linsert command} { + linsert {\{one \$two \{three \ four \ five} 2 a b c +} {\{one \$two a b c \{three \ four \ five} +test linsert-1.9 {linsert command} { + linsert {{1 2} {3 4} {5 6} {7 8}} 2 {x y} {a b} +} {{1 2} {3 4} {x y} {a b} {5 6} {7 8}} +test linsert-1.10 {linsert command} { + linsert {} 2 a b c +} {a b c} +test linsert-1.11 {linsert command} { + linsert {} 2 {} +} {{}} +test linsert-1.12 {linsert command} { + linsert {a b "c c" d e} 3 1 +} {a b "c c" 1 d e} +test linsert-1.13 {linsert command} { + linsert { a b c d} 0 1 2 +} {1 2 a b c d} +test linsert-1.14 {linsert command} { + linsert {a b c {d e f}} 4 1 2 +} {a b c {d e f} 1 2} +test linsert-1.15 {linsert command} { + linsert {a b c \{\ abc} 4 q r +} {a b c \{\ q r abc} +test linsert-1.16 {linsert command} { + linsert {a b c \{ abc} 4 q r +} {a b c \{ q r abc} +test linsert-1.17 {linsert command} { + linsert {a b c} end q r +} {a b c q r} +test linsert-1.18 {linsert command} { + linsert {a} end q r +} {a q r} +test linsert-1.19 {linsert command} { + linsert {} end q r +} {q r} + +test linsert-2.1 {linsert errors} { + list [catch linsert msg] $msg +} {1 {wrong # args: should be "linsert list index element ?element ...?"}} +test linsert-2.2 {linsert errors} { + list [catch {linsert a b} msg] $msg +} {1 {wrong # args: should be "linsert list index element ?element ...?"}} +test linsert-2.3 {linsert errors} { + list [catch {linsert a 12x 2} msg] $msg +} {1 {expected integer but got "12x"}} +test linsert-2.4 {linsert errors} { + list [catch {linsert \{ 12 2} msg] $msg +} {1 {unmatched open brace in list}} diff --git a/contrib/tcl/tests/list.test b/contrib/tcl/tests/list.test new file mode 100644 index 0000000..e901391 --- /dev/null +++ b/contrib/tcl/tests/list.test @@ -0,0 +1,73 @@ +# Commands covered: list +# +# 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) 1991-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: @(#) list.test 1.20 96/02/16 08:56:09 + +if {[string compare test [info procs test]] == 1} then {source defs} + +# First, a bunch of individual tests + +test list-1.1 {basic tests} {list a b c} {a b c} +test list-1.2 {basic tests} {list {a b} c} {{a b} c} +test list-1.3 {basic tests} {list \{a b c} {\{a b c} +test list-1.4 {basic tests} "list a{}} b{} c}" "a\\{\\}\\} b{} c\\}" +test list-1.5 {basic tests} {list a\[ b\] } "{a\[} b\\]" +test list-1.6 {basic tests} {list c\ d\t } "{c } {d\t}" +test list-1.7 {basic tests} {list e\n f\$ } "{e\n} {f\$}" +test list-1.8 {basic tests} {list g\; h\\} {{g;} h\\} +test list-1.9 {basic tests} "list a\\\[} b\\\]} " "a\\\[\\\} b\\\]\\\}" +test list-1.10 {basic tests} "list c\\\} d\\t} " "c\\} d\\t\\}" +test list-1.11 {basic tests} "list e\\n} f\\$} " "e\\n\\} f\\$\\}" +test list-1.12 {basic tests} "list g\\;} h\\\\} " "g\\;\\} {h\\}}" +test list-1.13 {basic tests} {list a {{}} b} {a {{}} b} +test list-1.14 {basic tests} {list a b xy\\} "a b xy\\\\" +test list-1.15 {basic tests} "list a b\} e\\" "a b\\} e\\\\" +test list-1.16 {basic tests} "list a b\}\\\$ e\\\$\\" "a b\\}\\\$ e\\\$\\\\" +test list-1.17 {basic tests} {list a\f \{\f} "{a\f} \\\{\\f" +test list-1.18 {basic tests} {list a\r \{\r} "{a\r} \\\{\\r" +test list-1.19 {basic tests} {list a\v \{\v} "{a\v} \\\{\\v" +test list-1.20 {basic tests} {list \"\}\{} "\\\"\\}\\{" +test list-1.21 {basic tests} {list a b c\\\nd} "a b c\\\\\\nd" +test list-1.22 {basic tests} {list "{ab}\\"} \\{ab\\}\\\\ +test list-1.23 {basic tests} {list \{} "\\{" +test list-1.24 {basic tests} {list} {} + +# For the next round of tests create a list and then pick it apart +# with "index" to make sure that we get back exactly what went in. + +set num 1 +proc lcheck {a b c} { + global num d + set d [list $a $b $c] + test list-2.$num {what goes in must come out} {lindex $d 0} $a + set num [expr $num+1] + test list-2.$num {what goes in must come out} {lindex $d 1} $b + set num [expr $num+1] + test list-2.$num {what goes in must come out} {lindex $d 2} $c + set num [expr $num+1] +} +lcheck a b c +lcheck "a b" c\td e\nf +lcheck {{a b}} {} { } +lcheck \$ \$ab ab\$ +lcheck \; \;ab ab\; +lcheck \[ \[ab ab\[ +lcheck \\ \\ab ab\\ +lcheck {"} {"ab} {ab"} +lcheck {a b} { ab} {ab } +lcheck a{ a{b \{ab +lcheck a} a}b }ab +lcheck a\\} {a \}b} {a \{c} +lcheck xyz \\ 1\\\n2 +lcheck "{ab}\\" "{ab}xy" abc + +concat {} diff --git a/contrib/tcl/tests/llength.test b/contrib/tcl/tests/llength.test new file mode 100644 index 0000000..badfd17 --- /dev/null +++ b/contrib/tcl/tests/llength.test @@ -0,0 +1,35 @@ +# Commands covered: llength +# +# 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) 1991-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: @(#) llength.test 1.4 96/02/16 08:56:11 + +if {[string compare test [info procs test]] == 1} then {source defs} + +test llength-1.1 {length of list} { + llength {a b c d} +} 4 +test llength-1.2 {length of list} { + llength {a b c {a b {c d}} d} +} 5 +test llength-1.3 {length of list} { + llength {} +} 0 + +test llength-2.1 {error conditions} { + list [catch {llength} msg] $msg +} {1 {wrong # args: should be "llength list"}} +test llength-2.2 {error conditions} { + list [catch {llength 123 2} msg] $msg +} {1 {wrong # args: should be "llength list"}} +test llength-2.3 {error conditions} { + list [catch {llength "a b c \{"} msg] $msg +} {1 {unmatched open brace in list}} diff --git a/contrib/tcl/tests/load.test b/contrib/tcl/tests/load.test new file mode 100644 index 0000000..331e3b7 --- /dev/null +++ b/contrib/tcl/tests/load.test @@ -0,0 +1,147 @@ +# Commands covered: load +# +# 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) 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: %Z% %M% %I% %E% %U% + +if {[string compare test [info procs test]] == 1} then {source defs} + +# Figure out what extension is used for shared libraries on this +# platform. + +if {$tcl_platform(platform) == "macintosh"} { + puts "can't run dynamic library tests on macintosh machines" + return +} +set ext [info sharedlibextension] +set testDir [file join [file dirname [info nameofexecutable]] dltest] +if ![file readable [file join $testDir pkga$ext]] { + puts "libraries in $testDir haven't been compiled: skipping tests" + return +} + +if [string match *pkga* [info loaded]] { + puts "load tests have already been run once: skipping (can't rerun)" + return +} + +test load-1.1 {basic errors} { + list [catch {load} msg] $msg +} {1 {wrong # args: should be "load fileName ?packageName? ?interp?"}} +test load-1.2 {basic errors} { + list [catch {load a b c d} msg] $msg +} {1 {wrong # args: should be "load fileName ?packageName? ?interp?"}} +test load-1.3 {basic errors} { + list [catch {load a b foobar} msg] $msg +} {1 {couldn't find slave interpreter named "foobar"}} +test load-1.4 {basic errors} { + list [catch {load {}} msg] $msg +} {1 {must specify either file name or package name}} +test load-1.5 {basic errors} { + list [catch {load {} {}} msg] $msg +} {1 {must specify either file name or package name}} +test load-1.6 {basic errors} { + list [catch {load {} Unknown} msg] $msg +} {1 {package "Unknown" isn't loaded statically}} + +test load-2.1 {basic loading, with guess for package name} { + load [file join $testDir pkga$ext] + list [pkga_eq abc def] [info commands pkga_*] +} {0 {pkga_eq pkga_quote}} +interp create -safe child +test load-2.2 {loading into a safe interpreter, with package name conversion} { + load [file join $testDir pkgb$ext] pKgB child + list [child eval pkgb_sub 44 13] [catch {child eval pkgb_unsafe} msg] $msg \ + [catch {pkgb_sub 12 10} msg2] $msg2 +} {31 1 {invalid command name "pkgb_unsafe"} 1 {invalid command name "pkgb_sub"}} +test load-2.3 {loading with no _Init procedure} { + list [catch {load [file join $testDir pkgc$ext] foo} msg] $msg +} {1 {couldn't find procedure Foo_Init}} +test load-2.4 {loading with no _SafeInit procedure} { + list [catch {load [file join $testDir pkga$ext] {} child} msg] $msg +} {1 {can't use package in a safe interpreter: no Pkga_SafeInit procedure}} + +test load-3.1 {error in _Init procedure, same interpreter} { + list [catch {load [file join $testDir pkge$ext] pkge} msg] $msg $errorInfo $errorCode +} {1 {couldn't open "non_existent": no such file or directory} {couldn't open "non_existent": no such file or directory + while executing +"open non_existent" + invoked from within +"if 44 {open non_existent}" + invoked from within +"load [file join $testDir pkge$ext] pkge"} {POSIX ENOENT {no such file or directory}}} +test load-3.2 {error in _Init procedure, slave interpreter} { + catch {interp delete x} + interp create x + set errorCode foo + set errorInfo bar + set result [list [catch {load [file join $testDir pkge$ext] pkge x} msg] \ + $msg $errorInfo $errorCode] + interp delete x + set result +} {1 {couldn't open "non_existent": no such file or directory} {couldn't open "non_existent": no such file or directory + while executing +"open non_existent" + invoked from within +"if 44 {open non_existent}" + invoked from within +"load [file join $testDir pkge$ext] pkge x"} {POSIX ENOENT {no such file or directory}}} + +test load-4.1 {reloading package into same interpreter} { + list [catch {load [file join $testDir pkga$ext] pkga} msg] $msg +} {0 {}} +test load-4.2 {reloading package into same interpreter} { + list [catch {load [file join $testDir pkga$ext] pkgb} msg] $msg +} "1 {file \"[file join $testDir pkga$ext\"] is already loaded for package \"Pkga\"}" + +# On some platforms, like SunOS 4.1.3, these tests can't be run because +# they cause the process to exit. + +test load-5.1 {errors loading file} {nonPortable} { + catch {load foo foo} +} {1} + +if {[info command teststaticpkg] != ""} { + test load-6.1 {Tcl_StaticPackage procedure, static packages} { + set x "not loaded" + teststaticpkg Test 1 0 + load {} Test + load {} Test child + list [set x] [child eval set x] + } {loaded loaded} + test load-6.2 {Tcl_StaticPackage procedure, static packages} { + set x "not loaded" + teststaticpkg Another 0 0 + load {} Another + child eval {set x "not loaded"} + list [catch {load {} Another child} msg] $msg [child eval set x] [set x] + } {1 {can't use package in a safe interpreter: no Another_SafeInit procedure} {not loaded} loaded} + test load-6.3 {Tcl_StaticPackage procedure, static packages} { + set x "not loaded" + teststaticpkg More 0 1 + load {} More + set x + } {not loaded} + + test load-7.1 {TclGetLoadedPackages procedure} { + info loaded + } "{{} More} {{} Another} {{} Test} {[file join $testDir pkge$ext] Pkge} {[file join $testDir pkgb$ext] Pkgb} {[file join $testDir pkga$ext] Pkga} {{} Tcltest}" + test load-7.2 {TclGetLoadedPackages procedure} { + list [catch {info loaded gorp} msg] $msg + } {1 {couldn't find slave interpreter named "gorp"}} + test load-7.3 {TclGetLoadedPackages procedure} { + list [info loaded {}] [info loaded child] + } "{{{} More} {{} Another} {{} Test} {[file join $testDir pkga$ext] Pkga} {{} Tcltest}} {{{} Test} {[file join $testDir pkgb$ext] Pkgb}}" + test load-7.4 {TclGetLoadedPackages procedure} { + load [file join $testDir pkgb$ext] pkgb + list [info loaded {}] [lsort [info commands pkgb_*]] + } "{{[file join $testDir pkgb$ext] Pkgb} {{} More} {{} Another} {{} Test} {[file join $testDir pkga$ext] Pkga} {{} Tcltest}} {pkgb_sub pkgb_unsafe}" + interp delete child +} diff --git a/contrib/tcl/tests/lrange.test b/contrib/tcl/tests/lrange.test new file mode 100644 index 0000000..43d92e2 --- /dev/null +++ b/contrib/tcl/tests/lrange.test @@ -0,0 +1,77 @@ +# Commands covered: lrange +# +# 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) 1991-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: @(#) lrange.test 1.5 96/02/16 08:56:13 + +if {[string compare test [info procs test]] == 1} then {source defs} + +test lrange-1.1 {range of list elements} { + lrange {a b c d} 1 2 +} {b c} +test lrange-1.2 {range of list elements} { + lrange {a {bcd e {f g {}}} l14 l15 d} 1 1 +} {{bcd e {f g {}}}} +test lrange-1.3 {range of list elements} { + lrange {a {bcd e {f g {}}} l14 l15 d} 3 end +} {l15 d} +test lrange-1.4 {range of list elements} { + lrange {a {bcd e {f g {}}} l14 l15 d} 4 10000 +} {d} +test lrange-1.5 {range of list elements} { + lrange {a {bcd e {f g {}}} l14 l15 d} 4 3 +} {} +test lrange-1.6 {range of list elements} { + lrange {a {bcd e {f g {}}} l14 l15 d} 10 11 +} {} +test lrange-1.7 {range of list elements} { + lrange {a b c d e} -1 2 +} {a b c} +test lrange-1.8 {range of list elements} { + lrange {a b c d e} -2 -1 +} {} +test lrange-1.9 {range of list elements} { + lrange {a b c d e} -2 e +} {a b c d e} +test lrange-1.10 {range of list elements} { + lrange "a b\{c d" 1 2 +} "b\{c d" +test lrange-1.11 {range of list elements} { + lrange "a b c d" end end +} d +test lrange-1.12 {range of list elements} { + lrange "a b c d" end 100000 +} d +test lrange-1.13 {range of list elements} { + lrange "a b c d" e 3 +} d +test lrange-1.14 {range of list elements} { + lrange "a b c d" end 2 +} {} + +test lrange-2.1 {error conditions} { + list [catch {lrange a b} msg] $msg +} {1 {wrong # args: should be "lrange list first last"}} +test lrange-2.2 {error conditions} { + list [catch {lrange a b 6 7} msg] $msg +} {1 {wrong # args: should be "lrange list first last"}} +test lrange-2.3 {error conditions} { + list [catch {lrange a b 6} msg] $msg +} {1 {expected integer but got "b"}} +test lrange-2.4 {error conditions} { + list [catch {lrange a 0 enigma} msg] $msg +} {1 {expected integer or "end" but got "enigma"}} +test lrange-2.5 {error conditions} { + list [catch {lrange "a \{b c" 3 4} msg] $msg +} {1 {unmatched open brace in list}} +test lrange-2.6 {error conditions} { + list [catch {lrange "a b c \{ d e" 1 4} msg] $msg +} {1 {unmatched open brace in list}} diff --git a/contrib/tcl/tests/lreplace.test b/contrib/tcl/tests/lreplace.test new file mode 100644 index 0000000..95c14c0 --- /dev/null +++ b/contrib/tcl/tests/lreplace.test @@ -0,0 +1,111 @@ +# Commands covered: lreplace +# +# 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) 1991-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: @(#) lreplace.test 1.12 96/02/16 08:56:14 + +if {[string compare test [info procs test]] == 1} then {source defs} + +test lreplace-1.1 {lreplace command} { + lreplace {1 2 3 4 5} 0 0 a +} {a 2 3 4 5} +test lreplace-1.2 {lreplace command} { + lreplace {1 2 3 4 5} 1 1 a +} {1 a 3 4 5} +test lreplace-1.3 {lreplace command} { + lreplace {1 2 3 4 5} 2 2 a +} {1 2 a 4 5} +test lreplace-1.4 {lreplace command} { + lreplace {1 2 3 4 5} 3 3 a +} {1 2 3 a 5} +test lreplace-1.5 {lreplace command} { + lreplace {1 2 3 4 5} 4 4 a +} {1 2 3 4 a} +test lreplace-1.6 {lreplace command} { + lreplace {1 2 3 4 5} 4 5 a +} {1 2 3 4 a} +test lreplace-1.7 {lreplace command} { + lreplace {1 2 3 4 5} -1 -1 a +} {a 1 2 3 4 5} +test lreplace-1.8 {lreplace command} { + lreplace {1 2 3 4 5} 2 end a b c d +} {1 2 a b c d} +test lreplace-1.9 {lreplace command} { + lreplace {1 2 3 4 5} 0 3 +} {5} +test lreplace-1.10 {lreplace command} { + lreplace {1 2 3 4 5} 0 4 +} {} +test lreplace-1.11 {lreplace command} { + lreplace {1 2 3 4 5} 0 1 +} {3 4 5} +test lreplace-1.12 {lreplace command} { + lreplace {1 2 3 4 5} 2 3 +} {1 2 5} +test lreplace-1.13 {lreplace command} { + lreplace {1 2 3 4 5} 3 end +} {1 2 3} +test lreplace-1.14 {lreplace command} { + lreplace {1 2 3 4 5} -1 4 a b c +} {a b c} +test lreplace-1.15 {lreplace command} { + lreplace {a b "c c" d e f} 3 3 +} {a b "c c" e f} +test lreplace-1.16 {lreplace command} { + lreplace { 1 2 3 4 5} 0 0 a +} {a 2 3 4 5} +test lreplace-1.17 {lreplace command} { + lreplace {1 2 3 4 "5 6"} 4 4 a +} {1 2 3 4 a} +test lreplace-1.18 {lreplace command} { + lreplace {1 2 3 4 {5 6}} 4 4 a +} {1 2 3 4 a} +test lreplace-1.19 {lreplace command} { + lreplace {1 2 3 4} 2 end x y z +} {1 2 x y z} +test lreplace-1.20 {lreplace command} { + lreplace {1 2 3 4} end end a +} {1 2 3 a} +test lreplace-1.21 {lreplace command} { + lreplace {1 2 3 4} end 3 a +} {1 2 3 a} +test lreplace-1.22 {lreplace command} { + lreplace {1 2 3 4} end end +} {1 2 3} +test lreplace-1.23 {lreplace command} { + lreplace {1 2 3 4} 2 -1 xy +} {1 2 xy 3 4} +test lreplace-1.24 {lreplace command} { + lreplace {1 2 3 4} end -1 z +} {1 2 3 z 4} + + +test lreplace-2.1 {lreplace errors} { + list [catch lreplace msg] $msg +} {1 {wrong # args: should be "lreplace list first last ?element element ...?"}} +test lreplace-2.2 {lreplace errors} { + list [catch {lreplace a b} msg] $msg +} {1 {wrong # args: should be "lreplace list first last ?element element ...?"}} +test lreplace-2.3 {lreplace errors} { + list [catch {lreplace x a 10} msg] $msg +} {1 {bad index "a": must be integer or "end"}} +test lreplace-2.4 {lreplace errors} { + list [catch {lreplace x 10 x} msg] $msg +} {1 {bad index "x": must be integer or "end"}} +test lreplace-2.5 {lreplace errors} { + list [catch {lreplace x 10 1x} msg] $msg +} {1 {bad index "1x": must be integer or "end"}} +test lreplace-2.6 {lreplace errors} { + list [catch {lreplace x 3 2} msg] $msg +} {1 {list doesn't contain element 3}} +test lreplace-2.7 {lreplace errors} { + list [catch {lreplace x 1 1} msg] $msg +} {1 {list doesn't contain element 1}} diff --git a/contrib/tcl/tests/lsearch.test b/contrib/tcl/tests/lsearch.test new file mode 100644 index 0000000..95df872 --- /dev/null +++ b/contrib/tcl/tests/lsearch.test @@ -0,0 +1,67 @@ +# Commands covered: lsearch +# +# 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) 1991-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: @(#) lsearch.test 1.5 96/02/16 08:56:15 + +if {[string compare test [info procs test]] == 1} then {source defs} + +set x {abcd bbcd 123 234 345} +test lsearch-1.1 {lsearch command} { + lsearch $x 123 +} 2 +test lsearch-1.2 {lsearch command} { + lsearch $x 3456 +} -1 +test lsearch-1.3 {lsearch command} { + lsearch $x *5 +} 4 +test lsearch-1.4 {lsearch command} { + lsearch $x *bc* +} 0 + +test lsearch-2.1 {search modes} { + lsearch -exact {xyz bbcc *bc*} *bc* +} 2 +test lsearch-2.2 {search modes} { + lsearch -exact {b.x ^bc xy bcx} ^bc +} 1 +test lsearch-2.3 {search modes} { + list [catch {lsearch -regexp {xyz bbcc *bc*} *bc*} msg] $msg +} {1 {couldn't compile regular expression pattern: ?+* follows nothing}} +test lsearch-2.4 {search modes} { + lsearch -regexp {b.x ^bc xy bcx} ^bc +} 3 +test lsearch-2.5 {search modes} { + lsearch -glob {xyz bbcc *bc*} *bc* +} 1 +test lsearch-2.6 {search modes} { + lsearch -glob {b.x ^bc xy bcx} ^bc +} 1 +test lsearch-2.7 {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}} + +test lsearch-3.1 {lsearch errors} { + list [catch lsearch msg] $msg +} {1 {wrong # args: should be "lsearch ?mode? list pattern"}} +test lsearch-3.2 {lsearch errors} { + list [catch {lsearch a} msg] $msg +} {1 {wrong # args: should be "lsearch ?mode? 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}} +test lsearch-3.4 {lsearch errors} { + list [catch {lsearch a b c d} msg] $msg +} {1 {wrong # args: should be "lsearch ?mode? list pattern"}} +test lsearch-3.5 {lsearch errors} { + list [catch {lsearch "\{" b} msg] $msg +} {1 {unmatched open brace in list}} diff --git a/contrib/tcl/tests/lsort.test b/contrib/tcl/tests/lsort.test new file mode 100644 index 0000000..907dfbf --- /dev/null +++ b/contrib/tcl/tests/lsort.test @@ -0,0 +1,126 @@ +# Commands covered: lsort +# +# 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) 1991-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: @(#) lsort.test 1.8 96/02/16 08:56:17 + +if {[string compare test [info procs test]] == 1} then {source defs} + +test lsort-1.1 {lsort command} { + lsort {abdeq ab 1 ac a} +} {1 a ab abdeq ac} +test lsort-1.2 {lsort command} { + lsort -decreasing {abdeq ab 1 ac a} +} {ac abdeq ab a 1} +test lsort-1.3 {lsort command} { + lsort -increasing {abdeq ab 1 ac a} +} {1 a ab abdeq ac} +test lsort-1.4 {lsort command} { + lsort {{one long element}} +} {{one long element}} +test lsort-1.5 {lsort command} { + lsort {} +} {} +test lsort-1.6 {lsort with characters needing backslashes} { + lsort {$ \\ [] \{} +} {{$} {[]} \\ \{} + +test lsort-2.1 {lsort -integer} { + lsort -integer -inc {1 180 62 040 180 -42 33 0x40} +} {-42 1 040 33 62 0x40 180 180} +test lsort-2.2 {lsort -integer} { + lsort -int -dec {1 180 62 040 180 -42 33 0x40} +} {180 180 0x40 62 33 040 1 -42} +test lsort-2.3 {lsort -integer} { + list [catch {lsort -integer {xxx 180.2 62 040 180 -42 33 0x40}} msg] $msg $errorInfo +} {1 {expected integer but got "xxx"} {expected integer but got "xxx" + (converting list element from string to integer) + invoked from within +"lsort -integer {xxx 180.2 62 040 180 -42 33 0x40}"}} +test lsort-2.4 {lsort -integer} { + list [catch {lsort -integer {1 180.2 62 040 180 -42 33 0x40}} msg] $msg $errorInfo +} {1 {expected integer but got "180.2"} {expected integer but got "180.2" + (converting list element from string to integer) + invoked from within +"lsort -integer {1 180.2 62 040 180 -42 33 0x40}"}} + +test lsort-3.1 {lsort -real} { + lsort -real {1 180.1 62 040 180 -42.7 33} +} {-42.7 1 33 040 62 180 180.1} +test lsort-3.2 {lsort -real} { + lsort -r -d {1 180.1 62 040 180 -42.7 33} +} {180.1 180 62 040 33 1 -42.7} +test lsort-3.3 {lsort -real} { + list [catch {lsort -real -inc {xxx 20 62 180 -42.7 33}} msg] $msg $errorInfo +} {1 {expected floating-point number but got "xxx"} {expected floating-point number but got "xxx" + (converting list element from string to real) + invoked from within +"lsort -real -inc {xxx 20 62 180 -42.7 33}"}} +test lsort-3.4 {lsort -real} { + list [catch {lsort -real -inc {1 0x40 62 180 -42.7 33}} msg] $msg $errorInfo +} {1 {expected floating-point number but got "0x40"} {expected floating-point number but got "0x40" + (converting list element from string to real) + invoked from within +"lsort -real -inc {1 0x40 62 180 -42.7 33}"}} + +proc lsort1 {a b} { + expr {2*([string match x* $a] - [string match x* $b]) + + [string match *y $a] - [string match *y $b]} +} +proc lsort2 {a b} { + error "comparison error" +} +proc lsort3 {a b} { + concat "foobar" +} + +test lsort-4.1 {lsort -command} { + lsort -command lsort1 {xxx yyy abc {xx y}} +} {abc yyy xxx {xx y}} +test lsort-4.2 {lsort -command} { + lsort -command lsort1 -dec {xxx yyy abc {xx y}} +} {{xx y} xxx yyy abc} +test lsort-4.3 {lsort -command} { + list [catch {lsort -command lsort2 -dec {1 1 1 1}} msg] $msg $errorInfo +} {1 {comparison error} {comparison error + while executing +"error "comparison error"" + (procedure "lsort2" line 2) + invoked from within +"lsort2 1 1" + (user-defined comparison command) + invoked from within +"lsort -command lsort2 -dec {1 1 1 1}"}} +test lsort-4.4 {lsort -command} { + list [catch {lsort -command lsort3 -dec {1 2 3 4}} msg] $msg $errorInfo +} {1 {comparison command returned non-numeric result} {comparison command returned non-numeric result + while executing +"lsort -command lsort3 -dec {1 2 3 4}"}} +test lsort-4.5 {lsort -command} { + list [catch {lsort -command {xxx yyy xxy abc}} msg] $msg +} {1 {"-command" must be followed by comparison command}} + +test lsort-5.1 {lsort errors} { + list [catch lsort msg] $msg +} {1 {wrong # args: should be "lsort ?-ascii? ?-integer? ?-real? ?-increasing? ?-decreasing? ?-command string? list"}} +test lsort-5.2 {lsort errors} { + list [catch {lsort a b} msg] $msg +} {1 {bad switch "a": must be -ascii, -integer, -real, -increasing -decreasing, or -command}} +test lsort-5.3 {lsort errors} { + list [catch {lsort "\{"} msg] $msg +} {1 {unmatched open brace in list}} +test lsort-5.4 {lsort errors} { + list [catch {lsort -in {1 180.0 040 62 180 -42.7 33}} msg] $msg +} {1 {bad switch "-in": must be -ascii, -integer, -real, -increasing -decreasing, or -command}} +test lsort-5.5 {lsort errors: disallow recursion} { + proc x args {lsort {a b c}} + list [catch {lsort -command x {3 7}} msg] $msg +} {1 {can't invoke "lsort" recursively}} diff --git a/contrib/tcl/tests/misc.test b/contrib/tcl/tests/misc.test new file mode 100644 index 0000000..b53759d --- /dev/null +++ b/contrib/tcl/tests/misc.test @@ -0,0 +1,70 @@ +# Commands covered: various +# +# This file contains a collection of miscellaneous Tcl tests that +# don't fit naturally in any of the other test files. Many of these +# tests are pathological cases that caused bugs in earlier Tcl +# releases. +# +# Copyright (c) 1992-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: @(#) misc.test 1.5 96/02/16 08:56:18 + +if {[string compare test [info procs test]] == 1} then {source defs} + +test misc-1.1 {error in variable ref. in command in array reference} { + proc tstProc {} { + global a + + set tst $a([winfo name $zz]) + # this is a bogus comment + # this is a bogus comment + # this is a bogus comment + # this is a bogus comment + # this is a bogus comment + # this is a bogus comment + # this is a bogus comment + # this is a bogus comment + } + set msg {} + list [catch tstProc msg] $msg +} {1 {can't read "zz": no such variable}} +test misc-1.2 {error in variable ref. in command in array reference} { + proc tstProc {} " + global a + + set tst \$a(\[winfo name \$\{zz) + # this is a bogus comment + # this is a bogus comment + # this is a bogus comment + # this is a bogus comment + # this is a bogus comment + # this is a bogus comment + # this is a bogus comment + # this is a bogus comment + " + set msg {} + list [catch tstProc msg] $msg $errorInfo +} [list 1 {missing close-brace for variable name} \ +[format {missing close-brace for variable name + while executing +"winfo name $%szz) + # this is a bogus comment + # this is a bogus comment + # this is a bogus comment + # this is a bogus comment + # this is a bogus commen ..." + (parsing index for array "a") + invoked from within +"set tst $a([winfo name $%szz) + # this is a bogus comment + # this is a bogus comment + # this is a bogus comment + # this is a bogus comment + # this is a ..." + (procedure "tstProc" line 4) + invoked from within +"tstProc"} \{ \{]] diff --git a/contrib/tcl/tests/parse.test b/contrib/tcl/tests/parse.test new file mode 100644 index 0000000..fa1c6f5 --- /dev/null +++ b/contrib/tcl/tests/parse.test @@ -0,0 +1,520 @@ +# Commands covered: set (plus basic command syntax). Also tests +# the procedures in the file tclParse.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 +# generates output for errors. No output means no errors were found. +# +# Copyright (c) 1991-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: @(#) parse.test 1.34 96/03/02 14:29:03 + +if {[string compare test [info procs test]] == 1} then {source defs} + +proc fourArgs {a b c d} { + global arg1 arg2 arg3 arg4 + set arg1 $a + set arg2 $b + set arg3 $c + set arg4 $d +} + +proc getArgs args { + global argv + set argv $args +} + +# Basic argument parsing. + +test parse-1.1 {basic argument parsing} { + set arg1 {} + fourArgs a b c d + list $arg1 $arg2 $arg3 $arg4 +} {a b c d} +test parse-1.2 {basic argument parsing} { + set arg1 {} + eval "fourArgs 123\v4\f56\r7890" + list $arg1 $arg2 $arg3 $arg4 +} {123 4 56 7890} + +# Quotes. + +test parse-2.1 {quotes and variable-substitution} { + getArgs "a b c" d + set argv +} {{a b c} d} +test parse-2.2 {quotes and variable-substitution} { + set a 101 + getArgs "a$a b c" + set argv +} {{a101 b c}} +test parse-2.3 {quotes and variable-substitution} { + set argv "xy[format xabc]" + set argv +} {xyxabc} +test parse-2.4 {quotes and variable-substitution} { + set argv "xy\t" + set argv +} xy\t +test parse-2.5 {quotes and variable-substitution} { + set argv "a b c +d e f" + set argv +} a\ b\tc\nd\ e\ f +test parse-2.6 {quotes and variable-substitution} { + set argv a"bcd"e + set argv +} {a"bcd"e} + +# Braces. + +test parse-3.1 {braces} { + getArgs {a b c} d + set argv +} "{a b c} d" +test parse-3.2 {braces} { + set a 101 + set argv {a$a b c} + set b [string index $argv 1] + set b +} {$} +test parse-3.3 {braces} { + set argv {a[format xyz] b} + string length $argv +} 15 +test parse-3.4 {braces} { + set argv {a\nb\}} + string length $argv +} 6 +test parse-3.5 {braces} { + set argv {{{{}}}} + set argv +} "{{{}}}" +test parse-3.6 {braces} { + set argv a{{}}b + set argv +} "a{{}}b" +test parse-3.7 {braces} { + set a [format "last]"] + set a +} {last]} + +# Command substitution. + +test parse-4.1 {command substitution} { + set a [format xyz] + set a +} xyz +test parse-4.2 {command substitution} { + set a a[format xyz]b[format q] + set a +} axyzbq +test parse-4.3 {command substitution} { + set a a[ +set b 22; +format %s $b + +]b + set a +} a22b + +# Variable substitution. + +test parse-5.1 {variable substitution} { + set a 123 + set b $a + set b +} 123 +test parse-5.2 {variable substitution} { + set a 345 + set b x$a.b + set b +} x345.b +test parse-5.3 {variable substitution} { + set _123z xx + set b $_123z^ + set b +} xx^ +test parse-5.4 {variable substitution} { + set a 78 + set b a${a}b + set b +} a78b +test parse-5.5 {variable substitution} {catch {$_non_existent_} msg} 1 +test parse-5.6 {variable substitution} { + catch {$_non_existent_} msg + set msg +} {can't read "_non_existent_": no such variable} +test parse-5.7 {array variable substitution} { + catch {unset a} + set a(xyz) 123 + set b $a(xyz)foo + set b +} 123foo +test parse-5.8 {array variable substitution} { + catch {unset a} + set "a(x y z)" 123 + set b $a(x y z)foo + set b +} 123foo +test parse-5.9 {array variable substitution} { + catch {unset a}; catch {unset qqq} + set "a(x y z)" qqq + set $a([format x]\ y [format z]) foo + set qqq +} foo +test parse-5.10 {array variable substitution} { + catch {unset a} + list [catch {set b $a(22)} msg] $msg +} {1 {can't read "a(22)": no such variable}} +test parse-5.11 {array variable substitution} { + set b a$! + set b +} {a$!} +test parse-5.12 {array variable substitution} { + set b a$() + set b +} {a$()} +catch {unset a} +test parse-5.13 {array variable substitution} { + catch {unset a} + set long {This is a very long variable, long enough to cause storage \ + allocation to occur in Tcl_ParseVar. If that storage isn't getting \ + freed up correctly, then a core leak will occur when this test is \ + run. This text is probably beginning to sound like drivel, but I've \ + run out of things to say and I need more characters still.} + set a($long) 777 + set b $a($long) + list $b [array names a] +} {777 {{This is a very long variable, long enough to cause storage \ + allocation to occur in Tcl_ParseVar. If that storage isn't getting \ + freed up correctly, then a core leak will occur when this test is \ + run. This text is probably beginning to sound like drivel, but I've \ + run out of things to say and I need more characters still.}}} +test parse-5.14 {array variable substitution} { + catch {unset a}; catch {unset b}; catch {unset a1} + set a1(22) foo + set a(foo) bar + set b $a($a1(22)) + set b +} bar +catch {unset a}; catch {unset a1} + +# Backslash substitution. + +set errNum 1 +proc bsCheck {char num} { + global errNum + test parse-6.$errNum {backslash substitution} { + scan $char %c value + set value + } $num + set errNum [expr $errNum+1] +} + +bsCheck \b 8 +bsCheck \e 101 +bsCheck \f 12 +bsCheck \n 10 +bsCheck \r 13 +bsCheck \t 9 +bsCheck \v 11 +bsCheck \{ 123 +bsCheck \} 125 +bsCheck \[ 91 +bsCheck \] 93 +bsCheck \$ 36 +bsCheck \ 32 +bsCheck \; 59 +bsCheck \\ 92 +bsCheck \Ca 67 +bsCheck \Ma 77 +bsCheck \CMa 67 +bsCheck \8a 8 +bsCheck \14 12 +bsCheck \141 97 +bsCheck \340 224 +bsCheck b\0 98 +bsCheck \x 120 +bsCheck \xa 10 +bsCheck \x41 65 +bsCheck \x541 65 + +test parse-6.1 {backslash substitution} { + set a "\a\c\n\]\}" + string length $a +} 5 +test parse-6.2 {backslash substitution} { + set a {\a\c\n\]\}} + string length $a +} 10 +test parse-6.3 {backslash substitution} { + set a "abc\ +def" + set a +} {abc def} +test parse-6.4 {backslash substitution} { + set a {abc\ +def} + set a +} {abc def} +test parse-6.5 {backslash substitution} { + set msg {} + set a xxx + set error [catch {if {24 < \ + 35} {set a 22} {set \ + a 33}} msg] + list $error $msg $a +} {0 22 22} +test parse-6.6 {backslash substitution} { + eval "concat abc\\" +} "abc\\" +test parse-6.7 {backslash substitution} { + eval "concat \\\na" +} "a" +test parse-6.8 {backslash substitution} { + eval "concat x\\\n a" +} "x a" +test parse-6.9 {backslash substitution} { + eval "concat \\x" +} "x" +test parse-6.10 {backslash substitution} { + eval "list a b\\\nc d" +} {a b c d} +test parse-6.11 {backslash substitution} { + eval "list a \"b c\"\\\nd e" +} {a {b c} d e} + +# Semi-colon. + +test parse-7.1 {semi-colons} { + set b 0 + getArgs a;set b 2 + set argv +} a +test parse-7.2 {semi-colons} { + set b 0 + getArgs a;set b 2 + set b +} 2 +test parse-7.3 {semi-colons} { + getArgs a b ; set b 1 + set argv +} {a b} +test parse-7.4 {semi-colons} { + getArgs a b ; set b 1 + set b +} 1 + +# The following checks are to ensure that the interpreter's result +# gets re-initialized by Tcl_Eval in all the right places. + +test parse-8.1 {result initialization} {concat abc} abc +test parse-8.2 {result initialization} {concat abc; proc foo {} {}} {} +test parse-8.3 {result initialization} {concat abc; proc foo {} $a} {} +test parse-8.4 {result initialization} {proc foo {} [concat abc]} {} +test parse-8.5 {result initialization} {concat abc; } abc +test parse-8.6 {result initialization} { + eval { + concat abc +}} abc +test parse-8.7 {result initialization} {} {} +test parse-8.8 {result initialization} {concat abc; ; ;} abc + +# Syntax errors. + +test parse-9.1 {syntax errors} {catch "set a \{bcd" msg} 1 +test parse-9.2 {syntax errors} { + catch "set a \{bcd" msg + set msg +} {missing close-brace} +test parse-9.3 {syntax errors} {catch {set a "bcd} msg} 1 +test parse-9.4 {syntax errors} { + catch {set a "bcd} msg + set msg +} {missing "} +test parse-9.5 {syntax errors} {catch {set a "bcd"xy} msg} 1 +test parse-9.6 {syntax errors} { + catch {set a "bcd"xy} msg + set msg +} {extra characters after close-quote} +test parse-9.7 {syntax errors} {catch "set a {bcd}xy" msg} 1 +test parse-9.8 {syntax errors} { + catch "set a {bcd}xy" msg + set msg +} {extra characters after close-brace} +test parse-9.9 {syntax errors} {catch {set a [format abc} msg} 1 +test parse-9.10 {syntax errors} { + catch {set a [format abc} msg + set msg +} {missing close-bracket} +test parse-9.11 {syntax errors} {catch gorp-a-lot msg} 1 +test parse-9.12 {syntax errors} { + catch gorp-a-lot msg + set msg +} {invalid command name "gorp-a-lot"} +test parse-9.13 {syntax errors} { + set a [concat {a}\ + {b}] + set a +} {a b} +test parse-9.14 {syntax errors} { + list [catch {eval \$x[format "%01000d" 0](} msg] $msg $errorInfo +} {1 {missing )} {missing ) + (parsing index for array "x000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000") + invoked from within +"$x0000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000 ..." + ("eval" body line 1) + invoked from within +"eval \$x[format "%01000d" 0]("}} + +# Long values (stressing storage management) + +set a {1111 2222 3333 4444 5555 6666 7777 8888 9999 aaaa bbbb cccc dddd eeee ffff gggg hhhh iiii jjjj kkkk llll mmmm nnnn oooo pppp qqqq rrrr ssss tttt uuuu vvvv wwww xxxx yyyy zzzz AAAA BBBB CCCC DDDD EEEE FFFF GGGG HHHH} + +test parse-10.1 {long values} { + string length $a +} 214 +test parse-10.2 {long values} { + llength $a +} 43 +test parse-1a1.3 {long values} { + set b "1111 2222 3333 4444 5555 6666 7777 8888 9999 aaaa bbbb cccc dddd eeee ffff gggg hhhh iiii jjjj kkkk llll mmmm nnnn oooo pppp qqqq rrrr ssss tttt uuuu vvvv wwww xxxx yyyy zzzz AAAA BBBB CCCC DDDD EEEE FFFF GGGG HHHH" + set b +} $a +test parse-10.3 {long values} { + set b "$a" + set b +} $a +test parse-10.4 {long values} { + set b [set a] + set b +} $a +test parse-10.5 {long values} { + set b [concat 1111 2222 3333 4444 5555 6666 7777 8888 9999 aaaa bbbb cccc dddd eeee ffff gggg hhhh iiii jjjj kkkk llll mmmm nnnn oooo pppp qqqq rrrr ssss tttt uuuu vvvv wwww xxxx yyyy zzzz AAAA BBBB CCCC DDDD EEEE FFFF GGGG HHHH] + string length $b +} 214 +test parse-10.6 {long values} { + set b [concat 1111 2222 3333 4444 5555 6666 7777 8888 9999 aaaa bbbb cccc dddd eeee ffff gggg hhhh iiii jjjj kkkk llll mmmm nnnn oooo pppp qqqq rrrr ssss tttt uuuu vvvv wwww xxxx yyyy zzzz AAAA BBBB CCCC DDDD EEEE FFFF GGGG HHHH] + llength $b +} 43 +test parse-10.7 {long values} { + set b +} $a +test parse-10.8 {long values} { + set a [concat 0000 1111 2222 3333 4444 5555 6666 7777 8888 9999 aaaa bbbb cccc dddd eeee ffff gggg hhhh iiii jjjj kkkk llll mmmm nnnn oooo pppp qqqq rrrr ssss tttt uuuu vvvv wwww xxxx yyyy zzzz AAAA BBBB CCCC DDDD EEEE FFFF GGGG HHHH IIII JJJJ KKKK LLLL MMMM NNNN OOOO PPPP QQQQ RRRR SSSS TTTT UUUU VVVV WWWW XXXX YYYY ZZZZ] + llength $a +} 62 +set i 0 +foreach j [concat 0000 1111 2222 3333 4444 5555 6666 7777 8888 9999 aaaa bbbb cccc dddd eeee ffff gggg hhhh iiii jjjj kkkk llll mmmm nnnn oooo pppp qqqq rrrr ssss tttt uuuu vvvv wwww xxxx yyyy zzzz AAAA BBBB CCCC DDDD EEEE FFFF GGGG HHHH IIII JJJJ KKKK LLLL MMMM NNNN OOOO PPPP QQQQ RRRR SSSS TTTT UUUU VVVV WWWW XXXX YYYY ZZZZ] { + set test [string index 0123456789abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ $i] + set test $test$test$test$test + set i [expr $i+1] + test parse-10.9 {long values} { + set j + } $test +} +test parse-10.10 {test buffer overflow in backslashes in braces} { + expr {"a" == {xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyy\101\101\101\101\101\101\101\101\101\101\101\101\101\101\101\101\101\101\101\101\101\101\101\101\101\101}} +} 0 + +test parse-11.1 {comments} { + set a old + eval { # set a new} + set a +} {old} +test parse-11.2 {comments} { + set a old + eval " # set a new\nset a new" + set a +} {new} +test parse-11.3 {comments} { + set a old + eval " # set a new\\\nset a new" + set a +} {old} +test parse-11.4 {comments} { + set a old + eval " # set a new\\\\\nset a new" + set a +} {new} + +test parse-12.1 {comments at the end of a bracketed script} { + set x "[ +expr 1+1 +# skip this! +]" +} {2} + +if {[info command testwordend] == "testwordend"} { + test parse-13.1 {TclWordEnd procedure} { + testwordend " \n abc" + } {c} + test parse-13.2 {TclWordEnd procedure} { + testwordend " \\\n" + } {} + test parse-13.3 {TclWordEnd procedure} { + testwordend " \\\n " + } { } + test parse-13.4 {TclWordEnd procedure} { + testwordend {"abc"} + } {"} + test parse-13.5 {TclWordEnd procedure} { + testwordend {{xyz}} + } \} + test parse-13.6 {TclWordEnd procedure} { + testwordend {{a{}b{}\}} xyz} + } "\} xyz" + test parse-13.7 {TclWordEnd procedure} { + testwordend {abc[this is a]def ghi} + } {f ghi} + test parse-13.8 {TclWordEnd procedure} { + testwordend "puts\\\n\n " + } "s\\\n\n " + test parse-13.9 {TclWordEnd procedure} { + testwordend "puts\\\n " + } "s\\\n " + test parse-13.10 {TclWordEnd procedure} { + testwordend "puts\\\n xyz" + } "s\\\n xyz" + test parse-13.11 {TclWordEnd procedure} { + testwordend {a$x.$y(a long index) foo} + } ") foo" + test parse-13.12 {TclWordEnd procedure} { + testwordend {abc; def} + } {; def} + test parse-13.13 {TclWordEnd procedure} { + testwordend {abc def} + } {c def} + test parse-13.14 {TclWordEnd procedure} { + testwordend {abc def} + } {c def} + test parse-13.15 {TclWordEnd procedure} { + testwordend "abc\ndef" + } "c\ndef" + test parse-13.16 {TclWordEnd procedure} { + testwordend "abc" + } {c} +} + +test parse-14.1 {TclScriptEnd procedure} { + info complete {puts [ + expr 1+1 + #this is a comment ]} +} {0} +test parse-14.2 {TclScriptEnd procedure} { + info complete "abc\\\n" +} {0} +test parse-14.3 {TclScriptEnd procedure} { + info complete "abc\\\\\n" +} {1} +test parse-14.4 {TclScriptEnd procedure} { + info complete "xyz \[abc \{abc\]" +} {0} +test parse-14.5 {TclScriptEnd procedure} { + info complete "xyz \[abc" +} {0} diff --git a/contrib/tcl/tests/pid.test b/contrib/tcl/tests/pid.test new file mode 100644 index 0000000..1f6e039 --- /dev/null +++ b/contrib/tcl/tests/pid.test @@ -0,0 +1,52 @@ +# Commands covered: pid +# +# 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) 1991-1993 The Regents of the University of California. +# Copyright (c) 1994-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: @(#) pid.test 1.12 96/04/12 11:14:43 + +# If pid is not defined just return with no error +# Some platforms may not have the pid command implemented +if {[info commands pid] == ""} { + puts "pid is not implemented for this machine" + return +} + +if {[string compare test [info procs test]] == 1} then {source defs} + +catch {removeFile 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 pids [pid $f] + close $f + catch {removeFile test1} + list [llength $pids] [regexp {^[0-9]+$} [lindex $pids 0]] \ + [regexp {^[0-9]+$} [lindex $pids 1]] \ + [expr {[lindex $pids 0] == [lindex $pids 1]}] +} {2 1 1 0} +test pid-1.3 {pid command} { + set f [open test1 w] + set pids [pid $f] + close $f + set pids +} {} +test pid-1.4 {pid command} { + list [catch {pid a b} msg] $msg +} {1 {wrong # args: should be "pid ?channelId?"}} +test pid-1.5 {pid command} { + list [catch {pid gorp} msg] $msg +} {1 {can not find channel named "gorp"}} + +catch {removeFile test1} +concat {} diff --git a/contrib/tcl/tests/pkg.test b/contrib/tcl/tests/pkg.test new file mode 100644 index 0000000..66c1658 --- /dev/null +++ b/contrib/tcl/tests/pkg.test @@ -0,0 +1,549 @@ +# Commands covered: pkg +# +# 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) 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: @(#) pkg.test 1.6 96/03/20 10:50:27 + +if {[string compare test [info procs test]] == 1} then {source defs} + +eval package forget [package names] +package unknown {} +set oldPath auto_path +set auto_path "" + +test pkg-1.1 {Tcl_PkgProvide procedure} { + package forget t + package provide t 2.3 +} {} +test pkg-1.2 {Tcl_PkgProvide procedure} { + package forget t + package provide t 2.3 + list [catch {package provide t 2.2} msg] $msg +} {1 {conflicting versions provided for package "t": 2.3, then 2.2}} +test pkg-1.3 {Tcl_PkgProvide procedure} { + package forget t + package provide t 2.3 + list [catch {package provide t 2.4} msg] $msg +} {1 {conflicting versions provided for package "t": 2.3, then 2.4}} +test pkg-1.4 {Tcl_PkgProvide procedure} { + package forget t + package provide t 2.3 + list [catch {package provide t 3.3} msg] $msg +} {1 {conflicting versions provided for package "t": 2.3, then 3.3}} +test pkg-1.5 {Tcl_PkgProvide procedure} { + package forget t + package provide t 2.3 + package provide t 2.3 +} {} + +test pkg-2.1 {Tcl_PkgRequire procedure, picking best version} { + package forget t + foreach i {1.4 3.4 2.3 2.4 2.2} { + package ifneeded t $i "set x $i; package provide t $i" + } + set x xxx + package require t + set x +} {3.4} +test pkg-2.2 {Tcl_PkgRequire procedure, picking best version} { + package forget t + foreach i {1.4 3.4 2.3 2.4 2.2 3.5 3.2} { + package ifneeded t $i "set x $i; package provide t $i" + } + set x xxx + package require t + set x +} {3.5} +test pkg-2.3 {Tcl_PkgRequire procedure, picking best version} { + package forget t + foreach i {3.5 2.1 2.3} { + package ifneeded t $i "set x $i; package provide t $i" + } + set x xxx + package require t 2.2 + set x +} {2.3} +test pkg-2.4 {Tcl_PkgRequire procedure, picking best version} { + package forget t + foreach i {1.4 3.4 2.3 2.4 2.2} { + package ifneeded t $i "set x $i; package provide t $i" + } + set x xxx + package require -exact t 2.3 + set x +} {2.3} +test pkg-2.5 {Tcl_PkgRequire procedure, picking best version} { + package forget t + foreach i {1.4 3.4 2.3 2.4 2.2} { + package ifneeded t $i "set x $i; package provide t $i" + } + set x xxx + package require t 2.1 + set x +} {2.4} +test pkg-2.6 {Tcl_PkgRequire procedure, can't find suitable version} { + package forget t + package unknown {} + foreach i {1.4 3.4 2.3 2.4 2.2} { + package ifneeded t $i "set x $i" + } + list [catch {package require t 2.5} msg] $msg +} {1 {can't find package t 2.5}} +test pkg-2.7 {Tcl_PkgRequire procedure, can't find suitable version} { + package forget t + package unknown {} + foreach i {1.4 3.4 2.3 2.4 2.2} { + package ifneeded t $i "set x $i" + } + list [catch {package require t 4.1} msg] $msg +} {1 {can't find package t 4.1}} +test pkg-2.8 {Tcl_PkgRequire procedure, can't find suitable version} { + package forget t + package unknown {} + foreach i {1.4 3.4 2.3 2.4 2.2} { + package ifneeded t $i "set x $i" + } + list [catch {package require -exact t 1.3} msg] $msg +} {1 {can't find package t 1.3}} +test pkg-2.9 {Tcl_PkgRequire procedure, can't find suitable version} { + package forget t + package unknown {} + list [catch {package require t} msg] $msg +} {1 {can't find package t}} +test pkg-2.10 {Tcl_PkgRequire procedure, error in ifneeded script} { + package forget t + package ifneeded t 2.1 {package provide t 2.1; error "ifneeded test"} + list [catch {package require t 2.1} msg] $msg $errorInfo +} {1 {ifneeded test} {ifneeded test + while executing +"error "ifneeded test"" + ("package ifneeded" script) + invoked from within +"package require t 2.1"}} +test pkg-2.11 {Tcl_PkgRequire procedure, ifneeded script doesn't provide package} { + package forget t + package ifneeded t 2.1 "set x invoked" + set x xxx + list [catch {package require t 2.1} msg] $msg $x +} {1 {can't find package t 2.1} invoked} +test pkg-2.12 {Tcl_PkgRequire procedure, self-deleting script} { + package forget t + package ifneeded t 1.2 "package forget t; set x 1.2; package provide t 1.2" + set x xxx + package require t 1.2 + set x +} {1.2} +test pkg-2.13 {Tcl_PkgRequire procedure, "package unknown" support} { + proc pkgUnknown args { + global x + set x $args + package provide [lindex $args 0] [lindex $args 1] + } + package forget t + foreach i {1.4 3.4 2.3 2.4 2.2} { + package ifneeded t $i "set x $i" + } + package unknown pkgUnknown + set x xxx + package require -exact t 1.5 + package unknown {} + set x +} {t 1.5 -exact} +test pkg-2.14 {Tcl_PkgRequire procedure, "package unknown" support} { + proc pkgUnknown args { + package ifneeded t 1.2 "set x loaded; package provide t 1.2" + } + package forget t + package unknown pkgUnknown + set x xxx + set result [list [package require t] $x] + package unknown {} + set result +} {1.2 loaded} +test pkg-2.15 {Tcl_PkgRequire procedure, "package unknown" support} { + proc pkgUnknown args { + global x + set x $args + package provide [lindex $args 0] 2.0 + } + package forget {a b} + package unknown pkgUnknown + set x xxx + package require {a b} + package unknown {} + set x +} {{a b} {}} +test pkg-2.16 {Tcl_PkgRequire procedure, "package unknown" error} { + proc pkgUnknown args { + error "testing package unknown" + } + package forget t + package unknown pkgUnknown + set result [list [catch {package require t} msg] $msg $errorInfo] + package unknown {} + set result +} {1 {testing package unknown} {testing package unknown + while executing +"error "testing package unknown"" + (procedure "pkgUnknown" line 2) + invoked from within +"pkgUnknown t {}" + ("package unknown" script) + invoked from within +"package require t"}} +test pkg-2.17 {Tcl_PkgRequire procedure, "package unknown" doesn't load package} { + proc pkgUnknown args { + global x + set x $args + } + package forget t + foreach i {1.4 3.4 2.3 2.4 2.2} { + package ifneeded t $i "set x $i" + } + package unknown pkgUnknown + set x xxx + set result [list [catch {package require -exact t 1.5} msg] $msg $x] + package unknown {} + set result +} {1 {can't find package t 1.5} {t 1.5 -exact}} +test pkg-2.18 {Tcl_PkgRequire procedure, version checks} { + package forget t + package provide t 2.3 + package require t +} {2.3} +test pkg-2.19 {Tcl_PkgRequire procedure, version checks} { + package forget t + package provide t 2.3 + package require t 2.1 +} {2.3} +test pkg-2.20 {Tcl_PkgRequire procedure, version checks} { + package forget t + package provide t 2.3 + package require t 2.3 +} {2.3} +test pkg-2.21 {Tcl_PkgRequire procedure, version checks} { + package forget t + package provide t 2.3 + list [catch {package require t 2.4} msg] $msg +} {1 {version conflict for package "t": have 2.3, need 2.4}} +test pkg-2.22 {Tcl_PkgRequire procedure, version checks} { + package forget t + package provide t 2.3 + list [catch {package require t 1.2} msg] $msg +} {1 {version conflict for package "t": have 2.3, need 1.2}} +test pkg-2.23 {Tcl_PkgRequire procedure, version checks} { + package forget t + package provide t 2.3 + package require -exact t 2.3 +} {2.3} +test pkg-2.24 {Tcl_PkgRequire procedure, version checks} { + package forget t + package provide t 2.3 + list [catch {package require -exact t 2.2} msg] $msg +} {1 {version conflict for package "t": have 2.3, need 2.2}} + +test pkg-3.1 {Tcl_PackageCmd procedure} { + list [catch {package} msg] $msg +} {1 {wrong # args: should be "package option ?arg arg ...?"}} +test pkg-3.2 {Tcl_PackageCmd procedure, "forget" option} { + foreach i [package names] { + package forget $i + } + package names +} {} +test pkg-3.3 {Tcl_PackageCmd procedure, "forget" option} { + foreach i [package names] { + package forget $i + } + package forget foo +} {} +test pkg-3.4 {Tcl_PackageCmd procedure, "forget" option} { + foreach i [package names] { + package forget $i + } + package ifneeded t 1.1 {first script} + package ifneeded t 2.3 {second script} + package ifneeded x 1.4 {x's script} + set result {} + lappend result [lsort [package names]] [package versions t] + package forget t + lappend result [lsort [package names]] [package versions t] +} {{t x} {1.1 2.3} x {}} +test pkg-3.5 {Tcl_PackageCmd procedure, "forget" option} { + foreach i [package names] { + package forget $i + } + package ifneeded a 1.1 {first script} + package ifneeded b 2.3 {second script} + package ifneeded c 1.4 {third script} + package forget + set result [list [lsort [package names]]] + package forget a c + lappend result [lsort [package names]] +} {{a b c} b} +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?"}} +test pkg-3.7 {Tcl_PackageCmd procedure, "ifneeded" option} { + list [catch {package ifneeded a b c d} msg] $msg +} {1 {wrong # args: should be "package ifneeded package version ?script?"}} +test pkg-3.8 {Tcl_PackageCmd procedure, "ifneeded" option} { + list [catch {package ifneeded t xyz} msg] $msg +} {1 {expected version number but got "xyz"}} +test pkg-3.9 {Tcl_PackageCmd procedure, "ifneeded" option} { + foreach i [package names] { + package forget $i + } + list [package ifneeded foo 1.1] [package names] +} {{} {}} +test pkg-3.10 {Tcl_PackageCmd procedure, "ifneeded" option} { + package forget t + package ifneeded t 1.4 "script for t 1.4" + list [package names] [package ifneeded t 1.4] [package versions t] +} {t {script for t 1.4} 1.4} +test pkg-3.11 {Tcl_PackageCmd procedure, "ifneeded" option} { + package forget t + package ifneeded t 1.4 "script for t 1.4" + list [package ifneeded t 1.5] [package names] [package versions t] +} {{} t 1.4} +test pkg-3.12 {Tcl_PackageCmd procedure, "ifneeded" option} { + package forget t + package ifneeded t 1.4 "script for t 1.4" + package ifneeded t 1.4 "second script for t 1.4" + list [package ifneeded t 1.4] [package names] [package versions t] +} {{second script for t 1.4} t 1.4} +test pkg-3.13 {Tcl_PackageCmd procedure, "ifneeded" option} { + package forget t + package ifneeded t 1.4 "script for t 1.4" + package ifneeded t 1.2 "second script" + package ifneeded t 3.1 "last script" + list [package ifneeded t 1.2] [package versions t] +} {{second script} {1.4 1.2 3.1}} +test pkg-3.14 {Tcl_PackageCmd procedure, "names" option} { + list [catch {package names a} msg] $msg +} {1 {wrong # args: should be "package names"}} +test pkg-3.15 {Tcl_PackageCmd procedure, "names" option} { + foreach i [package names] { + package forget $i + } + package names +} {} +test pkg-3.16 {Tcl_PackageCmd procedure, "names" option} { + foreach i [package names] { + package forget $i + } + package ifneeded x 1.2 {dummy} + package provide x 1.3 + package provide y 2.4 + catch {package require z 47.16} + lsort [package names] +} {x y} +test pkg-3.17 {Tcl_PackageCmd procedure, "provide" option} { + list [catch {package provide} msg] $msg +} {1 {wrong # args: should be "package provide package ?version?"}} +test pkg-3.18 {Tcl_PackageCmd procedure, "provide" option} { + list [catch {package provide a b c} msg] $msg +} {1 {wrong # args: should be "package provide package ?version?"}} +test pkg-3.19 {Tcl_PackageCmd procedure, "provide" option} { + package forget t + package provide t +} {} +test pkg-3.20 {Tcl_PackageCmd procedure, "provide" option} { + package forget t + package provide t 2.3 + package provide t +} {2.3} +test pkg-3.21 {Tcl_PackageCmd procedure, "provide" option} { + package forget t + list [catch {package provide t a.b} msg] $msg +} {1 {expected version number but got "a.b"}} +test pkg-3.22 {Tcl_PackageCmd procedure, "require" option} { + list [catch {package require} msg] $msg +} {1 {wrong # args: should be "package require ?-exact? package ?version?"}} +test pkg-3.23 {Tcl_PackageCmd procedure, "require" option} { + list [catch {package require a b c} msg] $msg +} {1 {wrong # args: should be "package require ?-exact? package ?version?"}} +test pkg-3.24 {Tcl_PackageCmd procedure, "require" option} { + list [catch {package require -exact a b c} msg] $msg +} {1 {wrong # args: should be "package require ?-exact? package ?version?"}} +test pkg-3.25 {Tcl_PackageCmd procedure, "require" option} { + list [catch {package require -bs a b} msg] $msg +} {1 {wrong # args: should be "package require ?-exact? package ?version?"}} +test pkg-3.26 {Tcl_PackageCmd procedure, "require" option} { + list [catch {package require x a.b} msg] $msg +} {1 {expected version number but got "a.b"}} +test pkg-3.27 {Tcl_PackageCmd procedure, "require" option} { + list [catch {package require -exact x a.b} msg] $msg +} {1 {expected version number but got "a.b"}} +test pkg-3.28 {Tcl_PackageCmd procedure, "require" option} { + list [catch {package require -exact x} msg] $msg +} {1 {wrong # args: should be "package require ?-exact? package ?version?"}} +test pkg-3.29 {Tcl_PackageCmd procedure, "require" option} { + list [catch {package require -exact} msg] $msg +} {1 {wrong # args: should be "package require ?-exact? package ?version?"}} +test pkg-3.30 {Tcl_PackageCmd procedure, "require" option} { + package forget t + package provide t 2.3 + package require t 2.1 +} {2.3} +test pkg-3.31 {Tcl_PackageCmd procedure, "require" option} { + package forget t + list [catch {package require t} msg] $msg +} {1 {can't find package t}} +test pkg-3.32 {Tcl_PackageCmd procedure, "require" option} { + package forget t + package ifneeded t 2.3 "error {synthetic error}" + list [catch {package require t 2.3} msg] $msg +} {1 {synthetic error}} +test pkg-3.33 {Tcl_PackageCmd procedure, "unknown" option} { + list [catch {package unknown a b} msg] $msg +} {1 {wrong # args: should be "package unknown ?command?"}} +test pkg-3.34 {Tcl_PackageCmd procedure, "unknown" option} { + package unknown "test script" + package unknown +} {test script} +test pkg-3.35 {Tcl_PackageCmd procedure, "unknown" option} { + package unknown "test script" + package unknown {} + package unknown +} {} +test pkg-3.36 {Tcl_PackageCmd procedure, "vcompare" option} { + list [catch {package vcompare a} msg] $msg +} {1 {wrong # args: should be "package vcompare version1 version2"}} +test pkg-3.37 {Tcl_PackageCmd procedure, "vcompare" option} { + list [catch {package vcompare a b c} msg] $msg +} {1 {wrong # args: should be "package vcompare version1 version2"}} +test pkg-3.38 {Tcl_PackageCmd procedure, "vcompare" option} { + list [catch {package vcompare x.y 3.4} msg] $msg +} {1 {expected version number but got "x.y"}} +test pkg-3.39 {Tcl_PackageCmd procedure, "vcompare" option} { + list [catch {package vcompare 2.1 a.b} msg] $msg +} {1 {expected version number but got "a.b"}} +test pkg-3.40 {Tcl_PackageCmd procedure, "vcompare" option} { + package vc 2.1 2.3 +} {-1} +test pkg-3.41 {Tcl_PackageCmd procedure, "vcompare" option} { + package vc 2.2.4 2.2.4 +} {0} +test pkg-3.42 {Tcl_PackageCmd procedure, "versions" option} { + list [catch {package versions} msg] $msg +} {1 {wrong # args: should be "package versions package"}} +test pkg-3.43 {Tcl_PackageCmd procedure, "versions" option} { + list [catch {package versions a b} msg] $msg +} {1 {wrong # args: should be "package versions package"}} +test pkg-3.44 {Tcl_PackageCmd procedure, "versions" option} { + package forget t + package versions t +} {} +test pkg-3.45 {Tcl_PackageCmd procedure, "versions" option} { + package forget t + package provide t 2.3 + package versions t +} {} +test pkg-3.46 {Tcl_PackageCmd procedure, "versions" option} { + package forget t + package ifneeded t 2.3 x + package ifneeded t 2.4 y + package versions t +} {2.3 2.4} +test pkg-3.47 {Tcl_PackageCmd procedure, "vsatisfies" option} { + list [catch {package vsatisfies a} msg] $msg +} {1 {wrong # args: should be "package vsatisfies version1 version2"}} +test pkg-3.48 {Tcl_PackageCmd procedure, "vsatisfies" option} { + list [catch {package vsatisfies a b c} msg] $msg +} {1 {wrong # args: should be "package vsatisfies version1 version2"}} +test pkg-3.49 {Tcl_PackageCmd procedure, "vsatisfies" option} { + list [catch {package vsatisfies x.y 3.4} msg] $msg +} {1 {expected version number but got "x.y"}} +test pkg-3.50 {Tcl_PackageCmd procedure, "vsatisfies" option} { + list [catch {package vcompare 2.1 a.b} msg] $msg +} {1 {expected version number but got "a.b"}} +test pkg-3.51 {Tcl_PackageCmd procedure, "vsatisfies" option} { + package vs 2.3 2.1 +} {1} +test pkg-3.52 {Tcl_PackageCmd procedure, "vsatisfies" option} { + package vs 2.3 1.2 +} {0} +test pkg-3.53 {Tcl_PackageCmd procedure, "versions" option} { + list [catch {package foo} msg] $msg +} {1 {bad option "foo": should be forget, ifneeded, names, provide, require, unknown, vcompare, versions, or vsatisfies}} + +# No tests for FindPackage; can't think up anything detectable +# errors. + +test pkg-4.1 {TclFreePackageInfo procedure} { + interp create foo + foo eval { + package ifneeded t 2.3 x + package ifneeded t 2.4 y + package ifneeded x 3.1 z + package provide q 4.3 + package unknown "will this get freed?" + } + interp delete foo +} {} +test pkg-4.2 {TclFreePackageInfo procedure} { + interp create foo + foo eval { + package ifneeded t 2.3 x + package ifneeded t 2.4 y + package ifneeded x 3.1 z + package provide q 4.3 + } + foo alias z kill + proc kill {} { + interp delete foo + } + list [catch {foo eval package require x 3.1} msg] $msg +} {1 {can't find package x 3.1}} + +test pkg-5.1 {CheckVersion procedure} { + list [catch {package vcompare 1 2.1} msg] $msg +} {0 -1} +test pkg-5.2 {CheckVersion procedure} { + list [catch {package vcompare .1 2.1} msg] $msg +} {1 {expected version number but got ".1"}} +test pkg-5.3 {CheckVersion procedure} { + list [catch {package vcompare 111.2a.3 2.1} msg] $msg +} {1 {expected version number but got "111.2a.3"}} +test pkg-5.4 {CheckVersion procedure} { + list [catch {package vcompare 1.2.3. 2.1} msg] $msg +} {1 {expected version number but got "1.2.3."}} + +test pkg-6.1 {ComparePkgVersions procedure} { + package vcompare 1.23 1.22 +} {1} +test pkg-6.2 {ComparePkgVersions procedure} { + package vcompare 1.22.1.2.3 1.22.1.2.3 +} {0} +test pkg-6.3 {ComparePkgVersions procedure} { + package vcompare 1.21 1.22 +} {-1} +test pkg-6.4 {ComparePkgVersions procedure} { + package vcompare 1.21 1.21.2 +} {-1} +test pkg-6.5 {ComparePkgVersions procedure} { + package vcompare 1.21.1 1.21 +} {1} +test pkg-6.6 {ComparePkgVersions procedure} { + package vsatisfies 1.21.1 1.21 +} {1} +test pkg-6.7 {ComparePkgVersions procedure} { + package vsatisfies 2.22.3 1.21 +} {0} +test pkg-6.8 {ComparePkgVersions procedure} { + package vsatisfies 1 1 +} {1} +test pkg-6.9 {ComparePkgVersions procedure} { + package vsatisfies 2 1 +} {0} + +set auto_path oldPath +concat diff --git a/contrib/tcl/tests/proc.test b/contrib/tcl/tests/proc.test new file mode 100644 index 0000000..6eef73c --- /dev/null +++ b/contrib/tcl/tests/proc.test @@ -0,0 +1,461 @@ +# Commands covered: proc, return, global +# +# 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) 1991-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: @(#) proc.test 1.21 96/02/16 08:56:21 + +if {[string compare test [info procs test]] == 1} then {source defs} + +proc tproc {} {return a; return b} +test proc-1.1 {simple procedure call and return} {tproc} a +proc tproc x { + set x [expr $x+1] + return $x +} +test proc-1.2 {simple procedure call and return} {tproc 2} 3 +test proc-1.3 {simple procedure call and return} { + proc tproc {} {return foo} +} {} +test proc-1.4 {simple procedure call and return} { + proc tproc {} {return} + tproc +} {} + +test proc-2.1 {local and global variables} { + proc tproc x { + set x [expr $x+1] + return $x + } + set x 42 + list [tproc 6] $x +} {7 42} +test proc-2.2 {local and global variables} { + proc tproc x { + set y [expr $x+1] + return $y + } + set y 18 + list [tproc 6] $y +} {7 18} +test proc-2.3 {local and global variables} { + proc tproc x { + global y + set y [expr $x+1] + return $y + } + set y 189 + list [tproc 6] $y +} {7 7} +test proc-2.4 {local and global variables} { + proc tproc x { + global y + return [expr $x+$y] + } + set y 189 + list [tproc 6] $y +} {195 189} +catch {unset _undefined_} +test proc-2.5 {local and global variables} { + proc tproc x { + global _undefined_ + return $_undefined_ + } + list [catch {tproc xxx} msg] $msg +} {1 {can't read "_undefined_": no such variable}} +test proc-2.6 {local and global variables} { + set a 114 + set b 115 + global a b + list $a $b +} {114 115} + +proc do {cmd} {eval $cmd} +test proc-3.1 {local and global arrays} { + catch {unset a} + set a(0) 22 + list [catch {do {global a; set a(0)}} msg] $msg +} {0 22} +test proc-3.2 {local and global arrays} { + catch {unset a} + set a(x) 22 + list [catch {do {global a; set a(x) newValue}} msg] $msg $a(x) +} {0 newValue newValue} +test proc-3.3 {local and global arrays} { + catch {unset a} + set a(x) 22 + set a(y) 33 + list [catch {do {global a; unset a(y)}; array names a} msg] $msg +} {0 x} +test proc-3.4 {local and global arrays} { + catch {unset a} + set a(x) 22 + set a(y) 33 + list [catch {do {global a; unset a; info exists a}} msg] $msg \ + [info exists a] +} {0 0 0} +test proc-3.5 {local and global arrays} { + catch {unset a} + set a(x) 22 + set a(y) 33 + list [catch {do {global a; unset a(y); array names a}} msg] $msg +} {0 x} +catch {unset a} +test proc-3.6 {local and global arrays} { + catch {unset a} + set a(x) 22 + set a(y) 33 + do {global a; do {global a; unset a}; set a(z) 22} + list [catch {array names a} msg] $msg +} {0 z} +test proc-3.7 {local and global arrays} { + proc t1 {args} {global info; set info 1} + catch {unset a} + set info {} + do {global a; trace var a(1) w t1} + set a(1) 44 + set info +} 1 +test proc-3.8 {local and global arrays} { + proc t1 {args} {global info; set info 1} + catch {unset a} + trace var a(1) w t1 + set info {} + do {global a; trace vdelete a(1) w t1} + set a(1) 44 + set info +} {} +test proc-3.9 {local and global arrays} { + proc t1 {args} {global info; set info 1} + catch {unset a} + trace var a(1) w t1 + do {global a; trace vinfo a(1)} +} {{w t1}} +catch {unset a} + +test proc-3.1 {arguments and defaults} { + proc tproc {x y z} { + return [list $x $y $z] + } + tproc 11 12 13 +} {11 12 13} +test proc-3.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-3.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-3.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-3.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-3.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-3.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-3.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-3.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-3.10 {arguments and defaults} { + proc tproc {x {y y-default} args} { + return [list $x $y $args] + } + tproc 2 3 +} {2 3 {}} +test proc-3.11 {arguments and defaults} { + proc tproc {x {y y-default} args} { + return [list $x $y $args] + } + tproc 2 +} {2 y-default {}} +test proc-3.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"}} + +test proc-4.1 {variable numbers of arguments} { + proc tproc args {return $args} + tproc +} {} +test proc-4.2 {variable numbers of arguments} { + proc tproc args {return $args} + tproc 1 2 3 4 5 6 7 8 +} {1 2 3 4 5 6 7 8} +test proc-4.3 {variable numbers of arguments} { + proc tproc args {return $args} + tproc 1 {2 3} {4 {5 6} {{{7}}}} 8 +} {1 {2 3} {4 {5 6} {{{7}}}} 8} +test proc-4.4 {variable numbers of arguments} { + proc tproc {x y args} {return $args} + tproc 1 2 3 4 5 6 7 +} {3 4 5 6 7} +test proc-4.5 {variable numbers of arguments} { + proc tproc {x y args} {return $args} + tproc 1 2 +} {} +test proc-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"}} + +test proc-5.1 {error conditions} { + list [catch {proc} msg] $msg +} {1 {wrong # args: should be "proc name args body"}} +test proc-5.2 {error conditions} { + list [catch {proc tproc b} msg] $msg +} {1 {wrong # args: should be "proc name args body"}} +test proc-5.3 {error conditions} { + list [catch {proc tproc b c d e} msg] $msg +} {1 {wrong # args: should be "proc name args body"}} +test proc-5.4 {error conditions} { + list [catch {proc tproc \{xyz {return foo}} msg] $msg +} {1 {unmatched open brace in list}} +test proc-5.5 {error conditions} { + list [catch {proc tproc {{} y} {return foo}} msg] $msg +} {1 {procedure "tproc" has argument with no name}} +test proc-5.6 {error conditions} { + list [catch {proc tproc {{} y} {return foo}} msg] $msg +} {1 {procedure "tproc" has argument with no name}} +test proc-5.7 {error conditions} { + list [catch {proc tproc {{x 1 2} y} {return foo}} msg] $msg +} {1 {too many fields in argument specifier "x 1 2"}} +test proc-5.8 {error conditions} { + catch {return} +} 2 +test proc-5.9 {error conditions} { + list [catch {global} msg] $msg +} {1 {wrong # args: should be "global varName ?varName ...?"}} +proc tproc {} { + set a 22 + global a +} +test proc-5.10 {error conditions} { + list [catch {tproc} msg] $msg +} {1 {variable "a" already exists}} +test proc-5.11 {error conditions} { + catch {rename tproc {}} + catch { + proc tproc {x {} z} {return foo} + } + list [catch {tproc 1} msg] $msg +} {1 {invalid command name "tproc"}} +test proc-5.12 {error conditions} { + proc tproc {} { + set a 22 + error "error in procedure" + return + } + list [catch tproc msg] $msg +} {1 {error in procedure}} +test proc-5.13 {error conditions} { + proc tproc {} { + set a 22 + error "error in procedure" + return + } + catch tproc msg + set errorInfo +} {error in procedure + while executing +"error "error in procedure"" + (procedure "tproc" line 3) + invoked from within +"tproc"} +test proc-5.14 {error conditions} { + proc tproc {} { + set a 22 + break + return + } + catch tproc msg + set errorInfo +} {invoked "break" outside of a loop + while executing +"tproc"} +test proc-5.15 {error conditions} { + proc tproc {} { + set a 22 + continue + return + } + catch tproc msg + set errorInfo +} {invoked "continue" outside of a loop + while executing +"tproc"} +test proc-5.16 {error conditions} { + proc foo args { + global fooMsg + set fooMsg "foo was called: $args" + } + proc tproc {} { + set x 44 + trace var x u foo + while {$x < 100} { + error "Nested error" + } + } + set fooMsg "foo not called" + list [catch tproc msg] $msg $errorInfo $fooMsg +} {1 {Nested error} {Nested error + while executing +"error "Nested error"" + ("while" body line 2) + invoked from within +"while {$x < 100} { + error "Nested error" + }" + (procedure "tproc" line 4) + invoked from within +"tproc"} {foo was called: x {} u}} + +# The tests below will really only be useful when run under Purify or +# some other system that can detect accesses to freed memory... + +test proc-6.1 {procedure that redefines itself} { + proc tproc {} { + proc tproc {} { + return 44 + } + return 45 + } + tproc +} 45 +test proc-6.2 {procedure that deletes itself} { + proc tproc {} { + rename tproc {} + return 45 + } + tproc +} 45 + +proc tproc code { + return -code $code abc +} +test proc-7.1 {return with special completion code} { + list [catch {tproc ok} msg] $msg +} {0 abc} +test proc-7.2 {return with special completion code} { + list [catch {tproc error} msg] $msg $errorInfo $errorCode +} {1 abc {abc + while executing +"tproc error"} NONE} +test proc-7.3 {return with special completion code} { + list [catch {tproc return} msg] $msg +} {2 abc} +test proc-7.4 {return with special completion code} { + list [catch {tproc break} msg] $msg +} {3 abc} +test proc-7.5 {return with special completion code} { + list [catch {tproc continue} msg] $msg +} {4 abc} +test proc-7.6 {return with special completion code} { + list [catch {tproc -14} msg] $msg +} {-14 abc} +test proc-7.7 {return with special completion code} { + list [catch {tproc gorp} msg] $msg +} {1 {bad completion code "gorp": must be ok, error, return, break, continue, or an integer}} +test proc-7.8 {return with special completion code} { + list [catch {tproc 10b} msg] $msg +} {1 {bad completion code "10b": must be ok, error, return, break, continue, or an integer}} +test proc-7.9 {return with special completion code} { + proc tproc2 {} { + tproc return + } + list [catch tproc2 msg] $msg +} {0 abc} +test proc-7.10 {return with special completion code} { + proc tproc2 {} { + return -code error + } + list [catch tproc2 msg] $msg +} {1 {}} +test proc-7.11 {return with special completion code} { + proc tproc2 {} { + global errorCode errorInfo + catch {open _bad_file_name r} msg + return -code error -errorinfo $errorInfo -errorcode $errorCode $msg + } + normalizeMsg [list [catch tproc2 msg] $msg $errorInfo $errorCode] +} {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" + invoked from within +"tproc2"} {posix enoent {no such file or directory}}} +test proc-7.12 {return with special completion code} { + proc tproc2 {} { + global errorCode errorInfo + catch {open _bad_file_name r} msg + return -code error -errorcode $errorCode $msg + } + normalizeMsg [list [catch tproc2 msg] $msg $errorInfo $errorCode] +} {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}}} +test proc-7.13 {return with special completion code} { + proc tproc2 {} { + global errorCode errorInfo + catch {open _bad_file_name r} msg + return -code error -errorinfo $errorInfo $msg + } + normalizeMsg [list [catch tproc2 msg] $msg $errorInfo $errorCode] +} {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" + invoked from within +"tproc2"} none} +test proc-7.14 {return with special completion code} { + proc tproc2 {} { + global errorCode errorInfo + catch {open _bad_file_name r} msg + return -code error $msg + } + normalizeMsg [list [catch tproc2 msg] $msg $errorInfo $errorCode] +} {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} +test proc-7.14 {return with special completion code} { + list [catch {return -badOption foo message} msg] $msg +} {1 {bad option "-badOption: must be -code, -errorcode, or -errorinfo}} diff --git a/contrib/tcl/tests/regexp.test b/contrib/tcl/tests/regexp.test new file mode 100644 index 0000000..1f1aecf --- /dev/null +++ b/contrib/tcl/tests/regexp.test @@ -0,0 +1,315 @@ +# Commands covered: regexp, regsub +# +# 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) 1991-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: @(#) regexp.test 1.20 96/04/02 15:03:53 + +if {[string compare test [info procs test]] == 1} then {source defs} + +catch {unset foo} +test regexp-1.1 {basic regexp operation} { + regexp ab*c abbbc +} 1 +test regexp-1.2 {basic regexp operation} { + regexp ab*c ac +} 1 +test regexp-1.3 {basic regexp operation} { + regexp ab*c ab +} 0 +test regexp-1.4 {basic regexp operation} { + regexp -- -gorp abc-gorpxxx +} 1 + +test regexp-2.1 {getting substrings back from regexp} { + set foo {} + list [regexp ab*c abbbbc foo] $foo +} {1 abbbbc} +test regexp-2.2 {getting substrings back from regexp} { + set foo {} + set f2 {} + list [regexp a(b*)c abbbbc foo f2] $foo $f2 +} {1 abbbbc bbbb} +test regexp-2.3 {getting substrings back from regexp} { + set foo {} + set f2 {} + list [regexp a(b*)(c) abbbbc foo f2] $foo $f2 +} {1 abbbbc bbbb} +test regexp-2.4 {getting substrings back from regexp} { + set foo {} + set f2 {} + set f3 {} + list [regexp a(b*)(c) abbbbc foo f2 f3] $foo $f2 $f3 +} {1 abbbbc bbbb c} +test regexp-2.5 {getting substrings back from regexp} { + set foo {}; set f1 {}; set f2 {}; set f3 {}; set f4 {}; set f5 {}; + set f6 {}; set f7 {}; set f8 {}; set f9 {}; set fa {}; set fb {}; + list [regexp (1*)(2*)(3*)(4*)(5*)(6*)(7*)(8*)(9*)(a*)(b*) \ + 12223345556789999aabbb \ + foo f1 f2 f3 f4 f5 f6 f7 f8 f9 fa fb] $foo $f1 $f2 $f3 $f4 $f5 \ + $f6 $f7 $f8 $f9 $fa $fb +} {1 12223345556789999aabbb 1 222 33 4 555 6 7 8 9999 aa bbb} +test regexp-2.6 {getting substrings back from regexp} { + set foo 2; set f2 2; set f3 2; set f4 2 + list [regexp (a)(b)? xay foo f2 f3 f4] $foo $f2 $f3 $f4 +} {1 a a {} {}} +test regexp-2.7 {getting substrings back from regexp} { + set foo 1; set f2 1; set f3 1; set f4 1 + list [regexp (a)(b)?(c) xacy foo f2 f3 f4] $foo $f2 $f3 $f4 +} {1 ac a {} c} + + +test regexp-3.1 {-indices option to regexp} { + set foo {} + list [regexp -indices ab*c abbbbc foo] $foo +} {1 {0 5}} +test regexp-3.2 {-indices option to regexp} { + set foo {} + set f2 {} + list [regexp -indices a(b*)c abbbbc foo f2] $foo $f2 +} {1 {0 5} {1 4}} +test regexp-3.3 {-indices option to regexp} { + set foo {} + set f2 {} + list [regexp -indices a(b*)(c) abbbbc foo f2] $foo $f2 +} {1 {0 5} {1 4}} +test regexp-3.4 {-indices option to regexp} { + set foo {} + set f2 {} + set f3 {} + list [regexp -indices a(b*)(c) abbbbc foo f2 f3] $foo $f2 $f3 +} {1 {0 5} {1 4} {5 5}} +test regexp-3.5 {-indices option to regexp} { + set foo {}; set f1 {}; set f2 {}; set f3 {}; set f4 {}; set f5 {}; + set f6 {}; set f7 {}; set f8 {}; set f9 {} + list [regexp -indices (1*)(2*)(3*)(4*)(5*)(6*)(7*)(8*)(9*) \ + 12223345556789999 \ + foo f1 f2 f3 f4 f5 f6 f7 f8 f9] $foo $f1 $f2 $f3 $f4 $f5 \ + $f6 $f7 $f8 $f9 +} {1 {0 16} {0 0} {1 3} {4 5} {6 6} {7 9} {10 10} {11 11} {12 12} {13 16}} +test regexp-3.6 {getting substrings back from regexp} { + set foo 2; set f2 2; set f3 2; set f4 2 + list [regexp -indices (a)(b)? xay foo f2 f3 f4] $foo $f2 $f3 $f4 +} {1 {1 1} {1 1} {-1 -1} {-1 -1}} +test regexp-3.7 {getting substrings back from regexp} { + set foo 1; set f2 1; set f3 1; set f4 1 + list [regexp -indices (a)(b)?(c) xacy foo f2 f3 f4] $foo $f2 $f3 $f4 +} {1 {1 2} {1 1} {-1 -1} {2 2}} + +test regexp-4.1 {-nocase option to regexp} { + regexp -nocase foo abcFOo +} 1 +test regexp-4.2 {-nocase option to regexp} { + set f1 22 + set f2 33 + set f3 44 + list [regexp -nocase {a(b*)([xy]*)z} aBbbxYXxxZ22 f1 f2 f3] $f1 $f2 $f3 +} {1 aBbbxYXxxZ Bbb xYXxx} +test regexp-4.3 {-nocase option to regexp} { + regexp -nocase FOo abcFOo +} 1 +set x abcdefghijklmnopqrstuvwxyz1234567890 +set x $x$x$x$x$x$x$x$x$x$x$x$x +test regexp-4.4 {case conversion in regsub} { + list [regexp -nocase $x $x foo] $foo +} "1 $x" +unset x + +test regexp-5.1 {exercise cache of compiled expressions} { + regexp .*a b + regexp .*b c + regexp .*c d + regexp .*d e + regexp .*e f + regexp .*a bbba +} 1 +test regexp-5.2 {exercise cache of compiled expressions} { + regexp .*a b + regexp .*b c + regexp .*c d + regexp .*d e + regexp .*e f + regexp .*b xxxb +} 1 +test regexp-5.3 {exercise cache of compiled expressions} { + regexp .*a b + regexp .*b c + regexp .*c d + regexp .*d e + regexp .*e f + regexp .*c yyyc +} 1 +test regexp-5.4 {exercise cache of compiled expressions} { + regexp .*a b + regexp .*b c + regexp .*c d + regexp .*d e + regexp .*e f + regexp .*d 1d +} 1 +test regexp-5.5 {exercise cache of compiled expressions} { + regexp .*a b + regexp .*b c + regexp .*c d + regexp .*d e + regexp .*e f + regexp .*e xe +} 1 + +test regexp-6.1 {regexp errors} { + list [catch {regexp a} msg] $msg +} {1 {wrong # args: should be "regexp ?switches? exp string ?matchVar? ?subMatchVar subMatchVar ...?"}} +test regexp-6.2 {regexp errors} { + list [catch {regexp -nocase a} msg] $msg +} {1 {wrong # args: should be "regexp ?switches? exp string ?matchVar? ?subMatchVar subMatchVar ...?"}} +test regexp-6.3 {regexp errors} { + list [catch {regexp -gorp a} msg] $msg +} {1 {bad switch "-gorp": must be -indices, -nocase, or --}} +test regexp-6.4 {regexp errors} { + list [catch {regexp a( b} msg] $msg +} {1 {couldn't compile regular expression pattern: unmatched ()}} +test regexp-6.5 {regexp errors} { + list [catch {regexp a( b} msg] $msg +} {1 {couldn't compile regular expression pattern: unmatched ()}} +test regexp-6.6 {regexp errors} { + list [catch {regexp a a f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1} msg] $msg +} {0 1} +test regexp-6.7 {regexp errors} { + list [catch {regexp (x)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.) xyzzy} msg] $msg +} {1 {couldn't compile regular expression pattern: too many ()}} +test regexp-6.8 {regexp errors} { + set f1 44 + list [catch {regexp abc abc f1(f2)} msg] $msg +} {1 {couldn't set variable "f1(f2)"}} + +test regexp-7.1 {basic regsub operation} { + list [regsub aa+ xaxaaaxaa 111&222 foo] $foo +} {1 xax111aaa222xaa} +test regexp-7.2 {basic regsub operation} { + list [regsub aa+ aaaxaa &111 foo] $foo +} {1 aaa111xaa} +test regexp-7.3 {basic regsub operation} { + list [regsub aa+ xaxaaa 111& foo] $foo +} {1 xax111aaa} +test regexp-7.4 {basic regsub operation} { + list [regsub aa+ aaa 11&2&333 foo] $foo +} {1 11aaa2aaa333} +test regexp-7.5 {basic regsub operation} { + list [regsub aa+ xaxaaaxaa &2&333 foo] $foo +} {1 xaxaaa2aaa333xaa} +test regexp-7.6 {basic regsub operation} { + list [regsub aa+ xaxaaaxaa 1&22& foo] $foo +} {1 xax1aaa22aaaxaa} +test regexp-7.7 {basic regsub operation} { + list [regsub a(a+) xaxaaaxaa {1\122\1} foo] $foo +} {1 xax1aa22aaxaa} +test regexp-7.8 {basic regsub operation} { + list [regsub a(a+) xaxaaaxaa {1\\\122\1} foo] $foo +} "1 {xax1\\aa22aaxaa}" +test regexp-7.9 {basic regsub operation} { + list [regsub a(a+) xaxaaaxaa {1\\122\1} foo] $foo +} "1 {xax1\\122aaxaa}" +test regexp-7.10 {basic regsub operation} { + list [regsub a(a+) xaxaaaxaa {1\\&\1} foo] $foo +} "1 {xax1\\aaaaaxaa}" +test regexp-7.11 {basic regsub operation} { + list [regsub a(a+) xaxaaaxaa {1\&\1} foo] $foo +} {1 xax1&aaxaa} +test regexp-7.12 {basic regsub operation} { + list [regsub a(a+) xaxaaaxaa {\1\1\1\1&&} foo] $foo +} {1 xaxaaaaaaaaaaaaaaxaa} +test regexp-7.13 {basic regsub operation} { + set foo xxx + list [regsub abc xyz 111 foo] $foo +} {0 xyz} +test regexp-7.14 {basic regsub operation} { + set foo xxx + list [regsub ^ xyz "111 " foo] $foo +} {1 {111 xyz}} +test regexp-7.15 {basic regsub operation} { + set foo xxx + list [regsub -- -foo abc-foodef "111 " foo] $foo +} {1 {abc111 def}} +test regexp-7.16 {basic regsub operation} { + set foo xxx + list [regsub x "" y foo] $foo +} {0 {}} + +test regexp-8.1 {case conversion in regsub} { + list [regsub -nocase a(a+) xaAAaAAay & foo] $foo +} {1 xaAAaAAay} +test regexp-8.2 {case conversion in regsub} { + list [regsub -nocase a(a+) xaAAaAAay & foo] $foo +} {1 xaAAaAAay} +test regexp-8.3 {case conversion in regsub} { + set foo 123 + list [regsub a(a+) xaAAaAAay & foo] $foo +} {0 xaAAaAAay} +test regexp-8.4 {case conversion in regsub} { + set foo 123 + list [regsub -nocase a CaDE b foo] $foo +} {1 CbDE} +test regexp-8.5 {case conversion in regsub} { + set foo 123 + list [regsub -nocase XYZ CxYzD b foo] $foo +} {1 CbD} +test regexp-8.6 {case conversion in regsub} { + set x abcdefghijklmnopqrstuvwxyz1234567890 + set x $x$x$x$x$x$x$x$x$x$x$x$x + set foo 123 + list [regsub -nocase $x $x b foo] $foo +} {1 b} + +test regexp-9.1 {-all option to regsub} { + set foo 86 + list [regsub -all x+ axxxbxxcxdx |&| foo] $foo +} {4 a|xxx|b|xx|c|x|d|x|} +test regexp-9.2 {-all option to regsub} { + set foo 86 + list [regsub -nocase -all x+ aXxXbxxcXdx |&| foo] $foo +} {4 a|XxX|b|xx|c|X|d|x|} +test regexp-9.3 {-all option to regsub} { + set foo 86 + list [regsub x+ axxxbxxcxdx |&| foo] $foo +} {1 a|xxx|bxxcxdx} +test regexp-9.4 {-all option to regsub} { + set foo 86 + list [regsub -all bc axxxbxxcxdx |&| foo] $foo +} {0 axxxbxxcxdx} +test regexp-9.5 {-all option to regsub} { + set foo xxx + list [regsub -all node "node node more" yy foo] $foo +} {2 {yy yy more}} +test regexp-9.6 {-all option to regsub} { + set foo xxx + list [regsub -all ^ xxx 123 foo] $foo +} {1 123xxx} + +test regexp-10.1 {regsub errors} { + list [catch {regsub a b c} msg] $msg +} {1 {wrong # args: should be "regsub ?switches? exp string subSpec varName"}} +test regexp-10.2 {regsub errors} { + list [catch {regsub -nocase a b c} msg] $msg +} {1 {wrong # args: should be "regsub ?switches? exp string subSpec varName"}} +test regexp-10.3 {regsub errors} { + list [catch {regsub -nocase -all a b c} msg] $msg +} {1 {wrong # args: should be "regsub ?switches? exp string subSpec varName"}} +test regexp-10.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"}} +test regexp-10.5 {regsub errors} { + list [catch {regsub -gorp a b c} msg] $msg +} {1 {bad switch "-gorp": must be -all, -nocase, or --}} +test regexp-10.6 {regsub errors} { + list [catch {regsub -nocase a( b c d} msg] $msg +} {1 {couldn't compile regular expression pattern: unmatched ()}} +test regexp-10.7 {regsub errors} { + list [catch {regsub -nocase aaa aaa xxx f1(f2)} msg] $msg +} {1 {couldn't set variable "f1(f2)"}} diff --git a/contrib/tcl/tests/remote.tcl b/contrib/tcl/tests/remote.tcl new file mode 100644 index 0000000..3ede61a --- /dev/null +++ b/contrib/tcl/tests/remote.tcl @@ -0,0 +1,161 @@ +# This file contains Tcl code to implement a remote server that can be +# used during testing of Tcl socket code. This server is used by some +# of the tests in socket.test. +# +# Source this file in the remote server you are using to test Tcl against. +# +# Copyright (c) 1995-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. +# +# @(#) remote.tcl 1.5 96/04/17 08:21:19" + +# Initialize message delimitor + +# Initialize command array +catch {unset command} +set command(0) "" +set callerSocket "" + +# Detect whether we should print out connection messages etc. +if {![info exists VERBOSE]} { + set VERBOSE 0 +} + +proc __doCommands__ {l s} { + global callerSocket VERBOSE + + if {$VERBOSE} { + puts "--- Server executing the following for socket $s:" + puts $l + puts "---" + } + set callerSocket $s + if {[catch {uplevel #0 $l} msg]} { + list error $msg + } else { + list success $msg + } +} + +proc __readAndExecute__ {s} { + global command VERBOSE + + set l [gets $s] + if {[string compare $l "--Marker--Marker--Marker--"] == 0} { + if {[info exists command($s)]} { + puts $s [list error incomplete_command] + } + puts $s "--Marker--Marker--Marker--" + return + } + if {[string compare $l ""] == 0} { + if {[eof $s]} { + if {$VERBOSE} { + puts "Server closing $s, eof from client" + } + close $s + } + return + } + append command($s) $l "\n" + if {[info complete $command($s)]} { + set cmds $command($s) + unset command($s) + puts $s [__doCommands__ $cmds $s] + } + if {[eof $s]} { + if {$VERBOSE} { + puts "Server closing $s, eof from client" + } + close $s + } +} + +proc __accept__ {s a p} { + global VERBOSE + + if {$VERBOSE} { + puts "Server accepts new connection from $a:$p on $s" + } + fileevent $s readable [list __readAndExecute__ $s] + fconfigure $s -buffering line -translation crlf +} + +set serverIsSilent 0 +for {set i 0} {$i < $argc} {incr i} { + if {[string compare -serverIsSilent [lindex $argv $i]] == 0} { + set serverIsSilent 1 + break + } +} +if {![info exists serverPort]} { + if {[info exists env(serverPort)]} { + set serverPort $env(serverPort) + } +} +if {![info exists serverPort]} { + for {set i 0} {$i < $argc} {incr i} { + if {[string compare -port [lindex $argv $i]] == 0} { + if {$i < [expr $argc - 1]} { + set serverPort [lindex $argv [expr $i + 1]] + } + break + } + } +} +if {![info exists serverPort]} { + set serverPort 2048 +} + +if {![info exists serverAddress]} { + if {[info exists env(serverAddress)]} { + set serverAddress $env(serverAddress) + } +} +if {![info exists serverAddress]} { + for {set i 0} {$i < $argc} {incr i} { + if {[string compare -address [lindex $argv $i]] == 0} { + if {$i < [expr $argc - 1]} { + set serverAddress [lindex $argv [expr $i + 1]] + } + break + } + } +} +if {![info exists serverAddress]} { + set serverAddress 0.0.0.0 +} + +if {$serverIsSilent == 0} { + set l "Remote server listening on port $serverPort, IP $serverAddress." + puts "" + puts $l + for {set c [string length $l]} {$c > 0} {incr c -1} {puts -nonewline "-"} + puts "" + puts "" + puts "You have set the Tcl variables serverAddress to $serverAddress and" + puts "serverPort to $serverPort. You can set these with the -address and" + puts "-port command line options, or as environment variables in your" + puts "shell." + puts "" + puts "NOTE: The tests will not work properly if serverAddress is set to" + puts "\"localhost\" or 127.0.0.1." + puts "" + puts "When you invoke tcltest to run the tests, set the variables" + puts "remoteServerPort to $serverPort and remoteServerIP to" + puts "[info hostname]. You can set these as environment variables" + puts "from the shell. The tests will not work properly if you set" + puts "remoteServerIP to \"localhost\" or 127.0.0.1." + puts "" + puts -nonewline "Type Ctrl-C to terminate--> " + flush stdout +} + +if {[catch {set serverSocket \ + [socket -myaddr $serverAddress -server __accept__ $serverPort]} msg]} { + puts "Server on $serverAddress:$serverPort cannot start: $msg" +} else { + vwait __server_wait_variable__ +} diff --git a/contrib/tcl/tests/rename.test b/contrib/tcl/tests/rename.test new file mode 100644 index 0000000..1613445 --- /dev/null +++ b/contrib/tcl/tests/rename.test @@ -0,0 +1,131 @@ +# Commands covered: rename +# +# 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) 1991-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: @(#) rename.test 1.13 96/03/20 10:49:22 + +if {[string compare test [info procs test]] == 1} then {source defs} + +# Must eliminate the "unknown" command while the test is running, +# especially if the test is being run in a program with its +# own special-purpose unknown command. + +catch {rename unknown unknown.old} + +catch {rename r2 {}} +proc r1 {} {return "procedure r1"} +rename r1 r2 +test rename-1.1 {simple renaming} { + r2 +} {procedure r1} +test rename-1.2 {simple renaming} { + list [catch r1 msg] $msg +} {1 {invalid command name "r1"}} +rename r2 {} +test rename-1.3 {simple renaming} { + list [catch r2 msg] $msg +} {1 {invalid command name "r2"}} + +# The test below is tricky because it renames a built-in command. +# It's possible that the test procedure uses this command, so must +# restore the command before calling test again. + +rename list l.new +set a [catch list msg1] +set b [l.new a b c] +rename l.new list +set c [catch l.new msg2] +set d [list 111 222] +test 2.1 {renaming built-in command} { + list $a $msg1 $b $c $msg2 $d +} {1 {invalid command name "list"} {a b c} 1 {invalid command name "l.new"} {111 222}} + +test rename-3.1 {error conditions} { + list [catch {rename r1} msg] $msg $errorCode +} {1 {wrong # args: should be "rename oldName newName"} NONE} +test rename-3.2 {error conditions} { + list [catch {rename r1 r2 r3} msg] $msg $errorCode +} {1 {wrong # args: should be "rename oldName newName"} NONE} +test rename-3.3 {error conditions} { + proc r1 {} {} + proc r2 {} {} + list [catch {rename r1 r2} msg] $msg +} {1 {can't rename to "r2": command already exists}} +test rename-3.4 {error conditions} { + catch {rename r1 {}} + catch {rename r2 {}} + list [catch {rename r1 r2} msg] $msg +} {1 {can't rename "r1": command doesn't exist}} +test rename-3.5 {error conditions} { + catch {rename _non_existent_command {}} + list [catch {rename _non_existent_command {}} msg] $msg +} {1 {can't delete "_non_existent_command": command doesn't exist}} + +catch {rename unknown {}} +catch {rename unknown.old unknown} + +if {[info command testdel] == "testdel"} { + test rename-4.1 {reentrancy issues with command deletion and renaming} { + set x {} + testdel {} foo {lappend x deleted; rename bar {}; lappend x [info command bar]} + rename foo bar + lappend x | + rename bar {} + set x + } {| deleted {}} + test rename-4.2 {reentrancy issues with command deletion and renaming} { + set x {} + testdel {} foo {lappend x deleted; rename foo bar} + rename foo {} + set x + } {deleted} + test rename-4.3 {reentrancy issues with command deletion and renaming} { + set x {} + testdel {} foo {lappend x deleted; testdel {} foo {lappend x deleted2}} + rename foo {} + lappend x | + rename foo {} + set x + } {deleted | deleted2} + test rename-4.4 {reentrancy issues with command deletion and renaming} { + set x {} + testdel {} foo {lappend x deleted; rename foo bar} + rename foo {} + lappend x | [info command bar] + } {deleted | {}} + test rename-4.5 {reentrancy issues with command deletion and renaming} { + set env(value) before + interp create foo + testdel foo cmd {set env(value) deleted} + interp delete foo + set env(value) + } {deleted} + test rename-4.6 {reentrancy issues with command deletion and renaming} { + proc kill args { + interp delete foo + } + set env(value) before + interp create foo + foo alias kill kill + testdel foo cmd {set env(value) deleted; kill} + list [catch {foo eval {rename cmd {}}} msg] $msg $env(value) + } {0 {} deleted} + test rename-4.7 {reentrancy issues with command deletion and renaming} { + proc kill args { + interp delete foo + } + set env(value) before + interp create foo + foo alias kill kill + testdel foo cmd {set env(value) deleted; kill} + list [catch {interp delete foo} msg] $msg $env(value) + } {0 {} deleted} +} diff --git a/contrib/tcl/tests/scan.test b/contrib/tcl/tests/scan.test new file mode 100644 index 0000000..0b2da90 --- /dev/null +++ b/contrib/tcl/tests/scan.test @@ -0,0 +1,257 @@ +# Commands covered: scan +# +# 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) 1991-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: @(#) scan.test 1.23 96/02/16 08:56:24 + +if {[string compare test [info procs test]] == 1} then {source defs} + +test scan-1.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 +} {4 -20 1476 33 0} +test scan-1.2 {integer scanning} { + set a {}; set b {}; set c {} + list [scan "-45 16 7890 +10" "%2d %*d %10d %d" a b c] $a $b $c +} {3 -4 16 7890} +test scan-1.3 {integer scanning} { + set a {}; set b {}; set c {}; set d {} + list [scan "-45 16 +10 987" "%ld %d %ld %d" a b c d] $a $b $c $d +} {4 -45 16 10 987} +test scan-1.4 {integer scanning} { + set a {}; set b {}; set c {}; set d {} + list [scan "14 1ab 62 10" "%d %x %lo %x" a b c d] $a $b $c $d +} {4 14 427 50 16} +test scan-1.5 {integer scanning} { + set a {}; set b {}; set c {}; set d {} + list [scan "12345670 1234567890ab cdefg" "%o %o %x %lx" a b c d] \ + $a $b $c $d +} {4 2739128 342391 561323 52719} +test scan-1.6 {integer scanning} { + set a {}; set b {}; set c {}; set d {} + list [scan "ab123-24642" "%2x %3x %3o %2o" a b c d] $a $b $c $d +} {4 171 291 -20 52} +test scan-1.7 {integer scanning} { + set a {}; set b {} + list [scan "1234567 234 567 " "%*3x %x %*o %4o" a b] $a $b +} {2 17767 375} +test scan-1.8 {integer scanning} { + set a {}; set b {} + list [scan "a 1234" "%d %d" a b] $a $b +} {0 {} {}} +test scan-1.9 {integer scanning} { + set a {}; set b {}; set c {}; set d {}; + list [scan "12345678" "%2d %2d %2ld %2d" a b c d] $a $b $c $d +} {4 12 34 56 78} +test scan-1.10 {integer scanning} { + set a {}; set b {}; set c {}; set d {} + list [scan "1 2 " "%hd %d %d %d" a b c d] $a $b $c $d +} {2 1 2 {} {}} +test scan-1.11 {integer scanning} {nonPortable} { + set a {}; set b {}; + list [scan "4294967280 4294967280" "%u %d" a b] $a $b +} {2 4294967280 -16} + +test scan-2.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 +} {3 2.1 -3e+08 0.99962 {}} +test scan-2.2 {floating-point scanning} { + set a {}; set b {}; set c {}; set d {} + list [scan "-1.2345 +8.2 9" "%3e %3lf %f %f" a b c d] $a $b $c $d +} {4 -1.0 234.0 5.0 8.2} +test scan-2.3 {floating-point scanning} { + set a {}; set b {}; set c {} + list [scan "1e00004 332E-4 3e+4" "%Lf %*2e %f %f" a b c] $a $c +} {3 10000.0 30000.0} +test scan-2.4 {floating-point scanning} {nonPortable} { + set a {}; set b {}; set c {} + list [scan "1. 47.6 2.e2 3.e-" "%f %*f %f %f" a b c] $a $b $c +} {3 1.0 200.0 3.0} +test scan-2.5 {floating-point scanning} { + set a {}; set b {}; set c {}; set d {} + list [scan "4.6 99999.7 876.43e-1 118" "%f %f %f %e" a b c d] $a $b $c $d +} {4 4.6 99999.7 87.643 118.0} +test scan-2.6 {floating-point scanning} { + set a {}; set b {}; set c {}; set d {} + list [scan "1.2345 697.0e-3 124 .00005" "%f %e %f %e" a b c d] $a $b $c $d +} {4 1.2345 0.697 124.0 5e-05} +test scan-2.7 {floating-point scanning} { + set a {}; set b {}; set c {}; set d {} + list [scan "4.6abc" "%f %f %f %f" a b c d] $a $b $c $d +} {1 4.6 {} {} {}} +test scan-2.8 {floating-point scanning} { + set a {}; set b {}; set c {}; set d {} + list [scan "4.6 5.2" "%f %f %f %f" a b c d] $a $b $c $d +} {2 4.6 5.2 {} {}} + +test scan-3.1 {string and character scanning} { + set a {}; set b {}; set c {}; set d {} + list [scan "abc defghijk dum " "%s %3s %20s %s" a b c d] $a $b $c $d +} {4 abc def ghijk dum} +test scan-3.2 {string and character scanning} { + set a {}; set b {}; set c {}; set d {} + list [scan "a bcdef" "%c%c%1s %s" a b c d] $a $b $c $d +} {4 97 32 b cdef} +test scan-3.3 {string and character scanning} { + set a {}; set b {}; set c {} + list [scan "123456 test " "%*c%*s %s %s %s" a b c] $a $b $c +} {1 test {} {}} +test scan-3.4 {string and character scanning} { + set a {}; set b {}; set c {}; set d + list [scan "ababcd01234 f 123450" {%4[abcd] %4[abcd] %[^abcdef] %[^0]} a b c d] $a $b $c $d +} {4 abab cd {01234 } {f 12345}} +test scan-3.5 {string and character scanning} { + set a {}; set b {}; set c {} + list [scan "aaaaaabc aaabcdefg + + XYZQR" {%*4[a] %s %*4[a]%s%*4[ +]%c} a b c] $a $b $c +} {3 aabc bcdefg 43} + +test scan-4.1 {error conditions} { + catch {scan a} +} 1 +test scan-4.2 {error conditions} { + catch {scan a} msg + set msg +} {wrong # args: should be "scan string format ?varName varName ...?"} +test scan-4.3 {error conditions} { + catch {scan "1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21" "%d %d %d %d %d %d %d %d %d %d %d %d %d %d %d %d %d %d %d %d %d" a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11 a12 a13 a14 a15 a16 a17 a18 a19 a20 a21} +} 1 +test scan-4.4 {error conditions} { + catch {scan "1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21" "%d %d %d %d %d %d %d %d %d %d %d %d %d %d %d %d %d %d %d %d %d" a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11 a12 a13 a14 a15 a16 a17 a18 a19 a20 a21} msg + set msg +} {too many fields to scan} +test scan-4.5 {error conditions} { + list [catch {scan a %D} msg] $msg +} {1 {bad scan conversion character "D"}} +test scan-4.6 {error conditions} { + list [catch {scan a %O} msg] $msg +} {1 {bad scan conversion character "O"}} +test scan-4.7 {error conditions} { + list [catch {scan a %X} msg] $msg +} {1 {bad scan conversion character "X"}} +test scan-4.8 {error conditions} { + list [catch {scan a %F} msg] $msg +} {1 {bad scan conversion character "F"}} +test scan-4.9 {error conditions} { + list [catch {scan a %E} msg] $msg +} {1 {bad scan conversion character "E"}} +test scan-4.10 {error conditions} { + list [catch {scan a "%d %d" a} msg] $msg +} {1 {different numbers of variable names and field specifiers}} +test scan-4.11 {error conditions} { + list [catch {scan a "%d %d" a b c} msg] $msg +} {1 {different numbers of variable names and field specifiers}} +test scan-4.12 {error conditions} { + set a {}; set b {}; set c {}; set d {} + list [expr {[scan " a" " a %d %d %d %d" a b c d] <= 0}] $a $b $c $d +} {1 {} {} {} {}} +test scan-4.13 {error conditions} { + set a {}; set b {}; set c {}; set d {} + list [scan "1 2" "%d %d %d %d" a b c d] $a $b $c $d +} {2 1 2 {} {}} +test scan-4.14 {error conditions} { + catch {unset a} + set a(0) 44 + list [catch {scan 44 %d a} msg] $msg +} {1 {couldn't set variable "a"}} +test scan-4.15 {error conditions} { + catch {unset a} + set a(0) 44 + list [catch {scan 44 %c a} msg] $msg +} {1 {couldn't set variable "a"}} +test scan-4.16 {error conditions} { + catch {unset a} + set a(0) 44 + list [catch {scan 44 %s a} msg] $msg +} {1 {couldn't set variable "a"}} +test scan-4.17 {error conditions} { + catch {unset a} + set a(0) 44 + list [catch {scan 44 %f a} msg] $msg +} {1 {couldn't set variable "a"}} +test scan-4.18 {error conditions} { + catch {unset a} + set a(0) 44 + list [catch {scan 44 %f a} msg] $msg +} {1 {couldn't set variable "a"}} +catch {unset a} +test scan-4.19 {error conditions} { + list [catch {scan 44 %2c a} msg] $msg +} {1 {field width may not be specified in %c conversion}} +test scan-4.20 {error conditions} { + list [catch {scan abc {%[}} msg] $msg +} {1 {unmatched [ in format string}} + +test scan-5.1 {lots of arguments} { + scan "10 20 30 40 50 60 70 80 90 100 110 120 130 140 150 160 170 180 190 200" "%d %d %d %d %d %d %d %d %d %d %d %d %d %d %d %d %d %d %d %d" a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11 a12 a13 a14 a15 a16 a17 a18 a19 a20 +} 20 +test scan-5.2 {lots of arguments} { + scan "10 20 30 40 50 60 70 80 90 100 110 120 130 140 150 160 170 180 190 200" "%d %d %d %d %d %d %d %d %d %d %d %d %d %d %d %d %d %d %d %d" a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11 a12 a13 a14 a15 a16 a17 a18 a19 a20 + set a20 +} 200 + +test scan-6.1 {miscellaneous tests} { + set a {} + list [scan ab16c ab%dc a] $a +} {1 16} +test scan-6.2 {miscellaneous tests} { + set a {} + list [scan ax16c ab%dc a] $a +} {0 {}} +test scan-6.3 {miscellaneous tests} { + set a {} + list [catch {scan ab%c114 ab%%c%d a} msg] $msg $a +} {0 1 114} +test scan-6.4 {miscellaneous tests} { + set a {} + list [catch {scan ab%c14 ab%%c%d a} msg] $msg $a +} {0 1 14} +test scan-6.5 {miscellaneous tests} { + catch {unset tcl_precision} + set a {} + scan 1.111122223333 %f a + set a +} {1.11112} +test scan-6.6 {miscellaneous tests} { + set tcl_precision 10 + set a {} + scan 1.111122223333 %lf a + unset tcl_precision + set a +} {1.111122223} +test scan-6.7 {miscellaneous tests} { + set tcl_precision 10 + set a {} + scan 1.111122223333 %f a + unset tcl_precision + set a +} {1.111122223} + +test scan-7.1 {alignment in results array (TCL_ALIGN)} { + scan "123 13.6" "%s %f" a b + set b +} 13.6 +test scan-7.2 {alignment in results array (TCL_ALIGN)} { + scan "1234567 13.6" "%s %f" a b + set b +} 13.6 +test scan-7.3 {alignment in results array (TCL_ALIGN)} { + scan "12345678901 13.6" "%s %f" a b + set b +} 13.6 +test scan-7.4 {alignment in results array (TCL_ALIGN)} { + scan "123456789012345 13.6" "%s %f" a b + set b +} 13.6 +test scan-7.5 {alignment in results array (TCL_ALIGN)} { + scan "1234567890123456789 13.6" "%s %f" a b + set b +} 13.6 diff --git a/contrib/tcl/tests/set.test b/contrib/tcl/tests/set.test new file mode 100644 index 0000000..8a8d887 --- /dev/null +++ b/contrib/tcl/tests/set.test @@ -0,0 +1,677 @@ +# Commands covered: set, unset, array +# +# 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) 1991-1993 The Regents of the University of California. +# Copyright (c) 1994-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: @(#) set.test 1.18 96/02/16 08:56:25 + +if {[string compare test [info procs test]] == 1} then {source defs} + +proc ignore args {} + +# Simple variable operations. + +catch {unset a} +test set-1.1 {basic variable setting and unsetting} { + set a 22 +} 22 +test set-1.2 {basic variable setting and unsetting} { + set a 123 + set a +} 123 +test set-1.3 {basic variable setting and unsetting} { + set a xxx + format %s $a +} xxx +test set-1.4 {basic variable setting and unsetting} { + set a 44 + unset a + list [catch {set a} msg] $msg +} {1 {can't read "a": no such variable}} + +# Basic array operations. + +catch {unset a} +set a(xyz) 2 +set a(44) 3 +set {a(a long name)} test +test set-2.1 {basic array operations} { + lsort [array names a] +} {44 {a long name} xyz} +test set-2.2 {basic array operations} { + set a(44) +} 3 +test set-2.3 {basic array operations} { + set a(xyz) +} 2 +test set-2.4 {basic array operations} { + set "a(a long name)" +} test +test set-2.5 {basic array operations} { + list [catch {set a(other)} msg] $msg +} {1 {can't read "a(other)": no such element in array}} +test set-2.6 {basic array operations} { + list [catch {set a} msg] $msg +} {1 {can't read "a": variable is array}} +test set-2.7 {basic array operations} { + format %s $a(44) +} 3 +test set-2.8 {basic array operations} { + format %s $a(a long name) +} test +unset a(44) +test set-2.9 {basic array operations} { + lsort [array names a] +} {{a long name} xyz} +test set-2.10 {basic array operations} { + catch {unset b} + list [catch {set b(123)} msg] $msg +} {1 {can't read "b(123)": no such variable}} +test set-2.11 {basic array operations} { + catch {unset b} + set b 44 + list [catch {set b(123)} msg] $msg +} {1 {can't read "b(123)": variable isn't array}} +test set-2.12 {basic array operations} { + list [catch {set a 14} msg] $msg +} {1 {can't set "a": variable is array}} +unset a +test set-2.13 {basic array operations} { + list [catch {set a(xyz)} msg] $msg +} {1 {can't read "a(xyz)": no such variable}} + +# Test the set commands, and exercise the corner cases of the code +# that parses array references into two parts. + +test set-3.1 {set command} { + list [catch {set} msg] $msg +} {1 {wrong # args: should be "set varName ?newValue?"}} +test set-3.2 {set command} { + list [catch {set x y z} msg] $msg +} {1 {wrong # args: should be "set varName ?newValue?"}} +test set-3.3 {set command} { + catch {unset a} + list [catch {set a} msg] $msg +} {1 {can't read "a": no such variable}} +test set-3.4 {set command} { + catch {unset a} + set a(14) 83 + list [catch {set a 22} msg] $msg +} {1 {can't set "a": variable is array}} + +# Test the corner-cases of parsing array names, using set and unset. + +test set-4.1 {parsing array names} { + catch {unset a} + set a(()) 44 + list [catch {array names a} msg] $msg +} {0 ()} +test set-4.2 {parsing array names} { + catch {unset a a(abcd} + set a(abcd 33 + info exists a(abcd +} 1 +test set-4.3 {parsing array names} { + catch {unset a a(abcd} + set a(abcd 33 + list [catch {array names a} msg] $msg +} {0 {}} +test set-4.4 {parsing array names} { + catch {unset a abcd)} + set abcd) 33 + info exists abcd) +} 1 +test set-4.5 {parsing array names} { + set a(bcd yyy + catch {unset a} + list [catch {set a(bcd} msg] $msg +} {0 yyy} +test set-4.6 {parsing array names} { + catch {unset a} + set a 44 + list [catch {set a(bcd test} msg] $msg +} {0 test} + +# Errors in reading variables + +test set-5.1 {errors in reading variables} { + catch {unset a} + list [catch {set a} msg] $msg +} {1 {can't read "a": no such variable}} +test set-5.2 {errors in reading variables} { + catch {unset a} + set a 44 + list [catch {set a(18)} msg] $msg +} {1 {can't read "a(18)": variable isn't array}} +test set-5.3 {errors in reading variables} { + catch {unset a} + set a(6) 44 + list [catch {set a(18)} msg] $msg +} {1 {can't read "a(18)": no such element in array}} +test set-5.4 {errors in reading variables} { + catch {unset a} + set a(6) 44 + list [catch {set a} msg] $msg +} {1 {can't read "a": variable is array}} + +# Errors and other special cases in writing variables + +test set-6.1 {creating array during write} { + catch {unset a} + trace var a rwu ignore + list [catch {set a(14) 186} msg] $msg [array names a] +} {0 186 14} +test set-6.2 {errors in writing variables} { + catch {unset a} + set a xxx + list [catch {set a(14) 186} msg] $msg +} {1 {can't set "a(14)": variable isn't array}} +test set-6.3 {errors in writing variables} { + catch {unset a} + set a(100) yyy + list [catch {set a 2} msg] $msg +} {1 {can't set "a": variable is array}} +test set-6.4 {expanding variable size} { + catch {unset a} + list [set a short] [set a "longer name"] [set a "even longer name"] \ + [set a "a much much truly longer name"] +} {short {longer name} {even longer name} {a much much truly longer name}} + +# Unset command, Tcl_UnsetVar procedures + +test set-7.1 {unset command} { + catch {unset a}; catch {unset b}; catch {unset c}; catch {unset d} + set a 44 + set b 55 + set c 66 + set d 77 + unset a b c + list [catch {set a(0) 0}] [catch {set b(0) 0}] [catch {set c(0) 0}] \ + [catch {set d(0) 0}] +} {0 0 0 1} +test set-7.2 {unset command} { + list [catch {unset} msg] $msg +} {1 {wrong # args: should be "unset varName ?varName ...?"}} +test set-7.3 {unset command} { + catch {unset a} + list [catch {unset a} msg] $msg +} {1 {can't unset "a": no such variable}} +test set-7.4 {unset command} { + catch {unset a} + set a 44 + list [catch {unset a(14)} msg] $msg +} {1 {can't unset "a(14)": variable isn't array}} +test set-7.5 {unset command} { + catch {unset a} + set a(0) xx + list [catch {unset a(14)} msg] $msg +} {1 {can't unset "a(14)": no such element in array}} +test set-7.6 {unset command} { + catch {unset a}; catch {unset b}; catch {unset c} + set a foo + set c gorp + list [catch {unset a a a(14)} msg] $msg [info exists c] +} {1 {can't unset "a": no such variable} 1} +test set-7.7 {unsetting globals from within procedures} { + set y 0 + proc p1 {} { + global y + set z [p2] + return [list $z [catch {set y} msg] $msg] + } + proc p2 {} {global y; unset y; list [catch {set y} msg] $msg} + p1 +} {{1 {can't read "y": no such variable}} 1 {can't read "y": no such variable}} +test set-7.8 {unsetting globals from within procedures} { + set y 0 + proc p1 {} { + global y + p2 + return [list [catch {set y 44} msg] $msg] + } + proc p2 {} {global y; unset y} + concat [p1] [list [catch {set y} msg] $msg] +} {0 44 0 44} +test set-7.9 {unsetting globals from within procedures} { + set y 0 + proc p1 {} { + global y + unset y + return [list [catch {set y 55} msg] $msg] + } + concat [p1] [list [catch {set y} msg] $msg] +} {0 55 0 55} +test set-7.10 {unset command} { + catch {unset a} + set a(14) 22 + unset a(14) + list [catch {set a(14)} msg] $msg [catch {array names a} msg2] $msg2 +} {1 {can't read "a(14)": no such element in array} 0 {}} +test set-7.11 {unset command} { + catch {unset a} + set a(14) 22 + 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 {}} + +# Array command. + +test set-8.1 {array command} { + list [catch {array} msg] $msg +} {1 {wrong # args: should be "array option arrayName ?arg ...?"}} +test set-8.2 {array command} { + list [catch {array a} msg] $msg +} {1 {wrong # args: should be "array option arrayName ?arg ...?"}} +test set-8.3 {array command} { + catch {unset a} + list [catch {array anymore a b} msg] $msg +} {1 {"a" isn't an array}} +test set-8.4 {array command} { + catch {unset a} + set a 44 + list [catch {array anymore a b} msg] $msg +} {1 {"a" isn't an array}} +test set-8.5 {array command} { + proc foo {} { + set a 44 + upvar 0 a x + list [catch {array anymore x b} msg] $msg + } + foo +} {1 {"x" isn't an array}} +test set-8.6 {array command} { + catch {unset a} + set a(22) 3 + list [catch {array gorp a} msg] $msg +} {1 {bad option "gorp": should be anymore, donesearch, exists, get, names, nextelement, set, size, or startsearch}} +test set-8.7 {array command, anymore option} { + catch {unset a} + list [catch {array anymore a x} msg] $msg +} {1 {"a" isn't an array}} +test set-8.8 {array command, donesearch option} { + catch {unset a} + list [catch {array donesearch a x} msg] $msg +} {1 {"a" isn't an array}} +test set-8.9 {array command, exists option} { + list [catch {array exists a b} msg] $msg +} {1 {wrong # args: should be "array exists arrayName"}} +test set-8.10 {array command, exists option} { + catch {unset a} + array exists a +} {0} +test set-8.11 {array command, exists option} { + catch {unset a} + set a(0) 1 + array exists a +} {1} +test set-8.12 {array command, get option} { + list [catch {array get} msg] $msg +} {1 {wrong # args: should be "array option arrayName ?arg ...?"}} +test set-8.13 {array command, get option} { + list [catch {array get a b c} msg] $msg +} {1 {wrong # args: should be "array get arrayName ?pattern?"}} +test set-8.14 {array command, get option} { + catch {unset a} + array get a +} {} +test set-8.15 {array command, get option} { + catch {unset a} + set a(22) 3 + set {a(long name)} {} + array get a +} {22 3 {long name} {}} +test set-8.16 {array command, get option (unset variable)} { + catch {unset a} + set a(x) 3 + trace var a(y) w ignore + array get a +} {x 3} +test set-8.17 {array command, get option, with pattern} { + catch {unset a} + set a(x1) 3 + set a(x2) 4 + set a(x3) 5 + set a(b1) 24 + set a(b2) 25 + array get a x* +} {x1 3 x2 4 x3 5} +test set-8.18 {array command, names option} { + 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?"}} +test set-8.19 {array command, names option} { + catch {unset a} + array names a +} {} +test set-8.20 {array command, names option} { + catch {unset a} + set a(22) 3; set a(Textual_name) 44; set "a(name with spaces)" xxx + list [catch {lsort [array names a]} msg] $msg +} {0 {22 Textual_name {name with spaces}}} +test set-8.21 {array command, names option} { + catch {unset a} + set a(22) 3; set a(33) 44; + trace var a(xxx) w ignore + list [catch {lsort [array names a]} msg] $msg +} {0 {22 33}} +test set-8.22 {array command, names option} { + catch {unset a} + set a(22) 3; set a(33) 44; + trace var a(xxx) w ignore + set a(xxx) value + list [catch {lsort [array names a]} msg] $msg +} {0 {22 33 xxx}} +test set-8.23 {array command, names option} { + catch {unset a} + set a(axy) 3 + set a(bxy) 44 + set a(no) yes + set a(xxx) value + list [lsort [array names a *xy]] [lsort [array names a]] +} {{axy bxy} {axy bxy no xxx}} +test set-8.24 {array command, nextelement option} { + list [catch {array nextelement a} msg] $msg +} {1 {wrong # args: should be "array nextelement arrayName searchId"}} +test set-8.25 {array command, nextelement option} { + catch {unset a} + list [catch {array nextelement a b} msg] $msg +} {1 {"a" isn't an array}} +test set-8.26 {array command, set option} { + list [catch {array set a} msg] $msg +} {1 {wrong # args: should be "array set arrayName list"}} +test set-8.27 {array command, set option} { + list [catch {array set a 1 2} msg] $msg +} {1 {wrong # args: should be "array set arrayName list"}} +test set-8.28 {array command, set option} { + list [catch {array set a "a \{ c"} msg] $msg +} {1 {unmatched open brace in list}} +test set-8.29 {array command, set option} { + catch {unset a} + set a 44 + list [catch {array set a {a b c d}} msg] $msg +} {1 {can't set "a(a)": variable isn't array}} +test set-8.30 {array command, set option} { + catch {unset a} + set a(xx) yy + array set a {b c d e} + array get a +} {d e xx yy b c} +test set-8.31 {array command, size option} { + list [catch {array size a 4} msg] $msg +} {1 {wrong # args: should be "array size arrayName"}} +test set-8.32 {array command, size option} { + catch {unset a} + array size a +} {0} +test set-8.33 {array command, size option} { + catch {unset a} + set a(22) 3; set a(Textual_name) 44; set "a(name with spaces)" xxx + list [catch {array size a} msg] $msg +} {0 3} +test set-8.34 {array command, size option} { + catch {unset a} + set a(22) 3; set a(xx) 44; set a(y) xxx + unset a(22) a(y) a(xx) + list [catch {array size a} msg] $msg +} {0 0} +test set-8.35 {array command, size option} { + catch {unset a} + set a(22) 3; + trace var a(33) rwu ignore + list [catch {array size a} msg] $msg +} {0 1} +test set-8.36 {array command, startsearch option} { + list [catch {array startsearch a b} msg] $msg +} {1 {wrong # args: should be "array startsearch arrayName"}} +test set-8.37 {array command, startsearch option} { + catch {unset a} + list [catch {array startsearch a} msg] $msg +} {1 {"a" isn't an array}} + +test set-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] \ + [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-9.2 {array enumeration} { + catch {unset a} + set a(a) 1 + set a(b) 1 + set a(c) 1 + set x [array startsearch a] + list [array nextelement a $x] [array ne a $x] [array next a $x] \ + [array next a $x] [array next a $x] +} {a b c {} {}} +test set-9.3 {array enumeration} { + catch {unset a} + set a(a) 1 + set a(b) 1 + set a(c) 1 + set x [array startsearch a] + set y [array startsearch a] + set z [array startsearch a] + list [array nextelement a $x] [array ne a $x] \ + [array next a $y] [array next a $z] [array next a $y] \ + [array next a $z] [array next a $y] [array next a $z] \ + [array next a $y] [array next a $z] [array next a $x] \ + [array next a $x] +} {a b a a b b c c {} {} c {}} +test set-9.4 {array enumeration: stopping searches} { + catch {unset a} + set a(a) 1 + set a(b) 1 + set a(c) 1 + set x [array startsearch a] + set y [array startsearch a] + set z [array startsearch a] + list [array next a $x] [array next a $x] [array next a $y] \ + [array done a $z; array next a $x] \ + [array done a $x; array next a $y] [array next a $y] +} {a b a c b c} +test set-9.5 {array enumeration: stopping searches} { + catch {unset a} + set a(a) 1 + set x [array startsearch a] + array done a $x + list [catch {array next a $x} msg] $msg +} {1 {couldn't find search "s-1-a"}} +test set-9.6 {array enumeration: searches automatically stopped} { + catch {unset a} + set a(a) 1 + set x [array startsearch a] + set y [array startsearch a] + set a(b) 1 + list [catch {array next a $x} msg] $msg \ + [catch {array next a $y} msg2] $msg2 +} {1 {couldn't find search "s-1-a"} 1 {couldn't find search "s-2-a"}} +test set-9.7 {array enumeration: searches automatically stopped} { + catch {unset a} + set a(a) 1 + set x [array startsearch a] + set y [array startsearch a] + set a(a) 2 + list [catch {array next a $x} msg] $msg \ + [catch {array next a $y} msg2] $msg2 +} {0 a 0 a} +test set-9.8 {array enumeration: searches automatically stopped} { + catch {unset a} + set a(a) 1 + set a(c) 2 + set x [array startsearch a] + set y [array startsearch a] + catch {unset a(c)} + list [catch {array next a $x} msg] $msg \ + [catch {array next a $y} msg2] $msg2 +} {1 {couldn't find search "s-1-a"} 1 {couldn't find search "s-2-a"}} +test set-9.9 {array enumeration: searches automatically stopped} { + catch {unset a} + set a(a) 1 + set x [array startsearch a] + set y [array startsearch a] + catch {unset a(c)} + list [catch {array next a $x} msg] $msg \ + [catch {array next a $y} msg2] $msg2 +} {0 a 0 a} +test set-9.10 {array enumeration: searches automatically stopped} { + catch {unset a} + set a(a) 1 + set x [array startsearch a] + set y [array startsearch a] + trace var a(b) r {} + list [catch {array next a $x} msg] $msg \ + [catch {array next a $y} msg2] $msg2 +} {1 {couldn't find search "s-1-a"} 1 {couldn't find search "s-2-a"}} +test set-9.11 {array enumeration: searches automatically stopped} { + catch {unset a} + set a(a) 1 + set x [array startsearch a] + set y [array startsearch a] + trace var a(a) r {} + list [catch {array next a $x} msg] $msg \ + [catch {array next a $y} msg2] $msg2 +} {0 a 0 a} +test set-9.12 {array enumeration with traced undefined elements} { + catch {unset a} + set a(a) 1 + trace var a(b) r {} + set x [array startsearch a] + list [array next a $x] [array next a $x] +} {a {}} + +test set-10.1 {array enumeration errors} { + list [catch {array start} msg] $msg +} {1 {wrong # args: should be "array option arrayName ?arg ...?"}} +test set-10.2 {array enumeration errors} { + list [catch {array start a b} msg] $msg +} {1 {wrong # args: should be "array startsearch arrayName"}} +test set-10.3 {array enumeration errors} { + catch {unset a} + list [catch {array start a} msg] $msg +} {1 {"a" isn't an array}} +test set-10.4 {array enumeration errors} { + catch {unset a} + set a(a) 1 + set x [array startsearch a] + list [catch {array next a} msg] $msg +} {1 {wrong # args: should be "array nextelement arrayName searchId"}} +test set-10.5 {array enumeration errors} { + catch {unset a} + set a(a) 1 + set x [array startsearch a] + list [catch {array next a b c} msg] $msg +} {1 {wrong # args: should be "array nextelement arrayName searchId"}} +test set-10.6 {array enumeration errors} { + catch {unset a} + set a(a) 1 + set x [array startsearch a] + list [catch {array next a a-1-a} msg] $msg +} {1 {illegal search identifier "a-1-a"}} +test set-10.7 {array enumeration errors} { + catch {unset a} + set a(a) 1 + set x [array startsearch a] + list [catch {array next a sx1-a} msg] $msg +} {1 {illegal search identifier "sx1-a"}} +test set-10.8 {array enumeration errors} { + catch {unset a} + set a(a) 1 + set x [array startsearch a] + list [catch {array next a s--a} msg] $msg +} {1 {illegal search identifier "s--a"}} +test set-10.9 {array enumeration errors} { + catch {unset a} + set a(a) 1 + set x [array startsearch a] + list [catch {array next a s-1-b} msg] $msg +} {1 {search identifier "s-1-b" isn't for variable "a"}} +test set-10.10 {array enumeration errors} { + catch {unset a} + set a(a) 1 + set x [array startsearch a] + list [catch {array next a s-1ba} msg] $msg +} {1 {illegal search identifier "s-1ba"}} +test set-10.11 {array enumeration errors} { + catch {unset a} + set a(a) 1 + set x [array startsearch a] + list [catch {array next a s-2-a} msg] $msg +} {1 {couldn't find search "s-2-a"}} +test set-10.12 {array enumeration errors} { + list [catch {array done a} msg] $msg +} {1 {wrong # args: should be "array donesearch arrayName searchId"}} +test set-10.13 {array enumeration errors} { + list [catch {array done a b c} msg] $msg +} {1 {wrong # args: should be "array donesearch arrayName searchId"}} +test set-10.14 {array enumeration errors} { + list [catch {array done a b} msg] $msg +} {1 {illegal search identifier "b"}} +test set-10.15 {array enumeration errors} { + list [catch {array anymore a} msg] $msg +} {1 {wrong # args: should be "array anymore arrayName searchId"}} +test set-10.16 {array enumeration errors} { + list [catch {array any a b c} msg] $msg +} {1 {wrong # args: should be "array anymore arrayName searchId"}} +test set-10.17 {array enumeration errors} { + catch {unset a} + set a(0) 44 + list [catch {array any a bogus} msg] $msg +} {1 {illegal search identifier "bogus"}} + +# Array enumeration with "anymore" option + +test set-11.1 {array anymore option} { + catch {unset a} + set a(a) 1 + set a(b) 2 + set a(c) 3 + array startsearch a + list [array anymore a s-1-a] [array next a s-1-a] \ + [array anymore a s-1-a] [array next a s-1-a] \ + [array anymore a s-1-a] [array next a s-1-a] \ + [array anymore a s-1-a] [array next a s-1-a] +} {1 a 1 b 1 c 0 {}} +test set-11.2 {array anymore option} { + catch {unset a} + set a(a) 1 + set a(b) 2 + set a(c) 3 + array startsearch a + list [array next a s-1-a] [array next a s-1-a] \ + [array anymore a s-1-a] [array next a s-1-a] \ + [array next a s-1-a] [array anymore a s-1-a] +} {a b 1 c {} 0} + +# Special check to see that the value of a variable is handled correctly +# if it is returned as the result of a procedure (must not free the variable +# string while deleting the call frame). Errors will only be detected if +# a memory consistency checker such as Purify is being used. + +test set-12.1 {cleanup on procedure return} { + proc foo {} { + set x 12345 + } + foo +} 12345 +test set-12.2 {cleanup on procedure return} { + proc foo {} { + set x(1) 23456 + } + foo +} 23456 + +# Must delete variables when done, since these arrays get used as +# scalars by other tests. + +catch {unset a} +catch {unset b} +catch {unset c} +return "" diff --git a/contrib/tcl/tests/socket.test b/contrib/tcl/tests/socket.test new file mode 100644 index 0000000..a6c6642 --- /dev/null +++ b/contrib/tcl/tests/socket.test @@ -0,0 +1,1009 @@ +# Commands tested in this file: socket. +# +# 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) 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. +# +# Running socket tests with a remote server: +# ------------------------------------------ +# +# Some tests in socket.test depend on the existence of a remote server to +# which they connect. The remote server must be an instance of tcltest and it +# must run the script found in the file "remote.tcl" in this directory. You +# can start the remote server on any machine reachable from the machine on +# which you want to run the socket tests, by issuing: +# +# tcltest remote.tcl -port 2048 # Or choose another port number. +# +# If the machine you are running the remote server on has several IP +# interfaces, you can choose which interface the server listens on for +# connections by specifying the -address command line flag, so: +# +# tcltest remote.tcl -address your.machine.com +# +# These options can also be set by environment variables. On Unix, you can +# type these commands to the shell from which the remote server is started: +# +# shell% setenv serverPort 2048 +# shell% setenv serverAddress your.machine.com +# +# and subsequently you can start the remote server with: +# +# tcltest remote.tcl +# +# to have it listen on port 2048 on the interface your.machine.com. +# +# When the server starts, it prints out a detailed message containing its +# configuration information, and it will block until killed with a Ctrl-C. +# Once the remote server exists, you can run the tests in socket.test with +# the server by setting two Tcl variables: +# +# % set remoteServerIP <name or address of machine on which server runs> +# % set remoteServerPort 2048 +# +# These variables are also settable from the environment. On Unix, you can: +# +# shell% setenv remoteServerIP machine.where.server.runs +# shell% senetv remoteServerPort 2048 +# +# The preamble of the socket.test file checks to see if the variables are set +# either in Tcl or in the environment; if they are, it attempts to connect to +# the server. If the connection is successful, the tests using the remote +# server will be performed; otherwise, it will attempt to start the remote +# server (via exec) on platforms that support this, on the local host, +# listening at port 2048. If all fails, a message is printed and the tests +# using the remote server are not performed. +# +# "@(#) socket.test 1.56 96/04/20 13:29:26" + +if {[string compare test [info procs test]] == 1} then {source defs} + +# +# If remoteServerIP or remoteServerPort are not set, check in the +# environment variables for externally set values. +# + +if {![info exists remoteServerIP]} { + if {[info exists env(remoteServerIP)]} { + set remoteServerIP $env(remoteServerIP) + } +} +if {![info exists remoteServerPort]} { + if {[info exists env(remoteServerIP)]} { + set remoteServerPort $env(remoteServerPort) + } else { + if {[info exists remoteServerIP]} { + set remoteServerPort 2048 + } + } +} + +# +# Check if we're supposed to do tests against the remote server +# + +set doTestsWithRemoteServer 1 +if {![info exists remoteServerIP] && ($tcl_platform(platform) != "macintosh")} { + set remoteServerIP localhost +} +if {($doTestsWithRemoteServer == 1) && (![info exists remoteServerPort])} { + set remoteServerPort 2048 +} + +# Attempt to connect to a remote server if one is already running. If it +# is not running or for some other reason the connect fails, attempt to +# start the remote server on the local host listening on port 2048. This +# is only done on platforms that support exec (i.e. not on the Mac). On +# platforms that do not support exec, the remote server must be started +# by the user before running the tests. + +set remotePid -1 +if {$doTestsWithRemoteServer == 1} { + catch {close $commandSocket} + if {[catch {set commandSocket [socket $remoteServerIP \ + $remoteServerPort]}] != 0} { + if {[info commands exec] == ""} { + set doTestsWithRemoteServer 0 + } else { + set remoteServerIP localhost + if {[catch {set remotePid [exec $tcltest remote.tcl \ + -serverIsSilent \ + -port $remoteServerPort \ + -address $remoteServerIP &]} \ + msg] == 0} { + after 1000 + if {[catch {set commandSocket [socket $remoteServerIP \ + $remoteServerPort]}] == 0} { + fconfigure $commandSocket -translation crlf -buffering line + } else { + set doTestsWithRemoteServer 0 + } + } else { + set doTestsWithRemoteServer 0 + } + } + } else { + fconfigure $commandSocket -translation crlf -buffering line + } +} + +if {$doTestsWithRemoteServer == 0} { + puts "Skipping tests with remote server. See tests/socket.test for" + puts "information on how to run remote server." +} + +# +# If we do the tests, define a command to send a command to the +# remote server. +# + +if {$doTestsWithRemoteServer == 1} { + proc sendCommand {c} { + global commandSocket + + if {[eof $commandSocket]} { + error "remote server disappeared" + } + + if {[catch {puts $commandSocket $c} msg]} { + error "remote server disappaered: $msg" + } + if {[catch {puts $commandSocket "--Marker--Marker--Marker--"} msg]} { + error "remote server disappeared: $msg" + } + + set resp "" + while {1} { + set line [gets $commandSocket] + if {[eof $commandSocket]} { + error "remote server disappaered" + } + if {[string compare $line "--Marker--Marker--Marker--"] == 0} { + if {[string compare [lindex $resp 0] error] == 0} { + error [lindex $resp 1] + } else { + return [lindex $resp 1] + } + } else { + append resp $line "\n" + } + } + } +} + +test socket-1.1 {arg parsing for socket command} { + list [catch {socket -server} msg] $msg +} {1 {no argument given for -server option}} +test socket-1.2 {arg parsing for socket command} { + list [catch {socket -server foo} msg] $msg +} {1 {wrong # args: should be either: +socket ?-myaddr addr? ?-myport myport? ?-async? host port +socket -server command ?-myaddr addr? port}} +test socket-1.3 {arg parsing for socket command} { + list [catch {socket -myaddr} msg] $msg +} {1 {no argument given for -myaddr option}} +test socket-1.4 {arg parsing for socket command} { + list [catch {socket -myaddr 127.0.0.1} msg] $msg +} {1 {wrong # args: should be either: +socket ?-myaddr addr? ?-myport myport? ?-async? host port +socket -server command ?-myaddr addr? port}} +test socket-1.5 {arg parsing for socket command} { + list [catch {socket -myport} msg] $msg +} {1 {no argument given for -myport option}} +test socket-1.6 {arg parsing for socket command} { + list [catch {socket -myport xxxx} msg] $msg +} {1 {expected integer but got "xxxx"}} +test socket-1.7 {arg parsing for socket command} { + list [catch {socket -myport 2522} msg] $msg +} {1 {wrong # args: should be either: +socket ?-myaddr addr? ?-myport myport? ?-async? host port +socket -server command ?-myaddr addr? port}} +test socket-1.8 {arg parsing for socket command} { + list [catch {socket -froboz} msg] $msg +} {1 {bad option "-froboz", must be -async, -myaddr, -myport, or -server}} +test socket-1.9 {arg parsing for socket command} { + list [catch {socket -server foo -myport 2521 3333} msg] $msg +} {1 {Option -myport is not valid for servers}} +test socket-1.10 {arg parsing for socket command} { + list [catch {socket host 2528 -junk} msg] $msg +} {1 {wrong # args: should be either: +socket ?-myaddr addr? ?-myport myport? ?-async? host port +socket -server command ?-myaddr addr? port}} +test socket-1.11 {arg parsing for socket command} { + list [catch {socket -server callback 2520 --} msg] $msg +} {1 {wrong # args: should be either: +socket ?-myaddr addr? ?-myport myport? ?-async? host port +socket -server command ?-myaddr addr? port}} +test socket-1.12 {arg parsing for socket command} { + list [catch {socket foo badport} msg] $msg +} {1 {expected integer but got "badport"}} + +test socket-2.1 {tcp connection} {unixOrPc} { + removeFile script + set f [open script w] + puts $f { + set f [socket -server accept 2828] + proc accept {file addr port} { + global x + set x done + close $file + } + puts ready + vwait x + close $f + puts done + } + close $f + set f [open "|$tcltest script" r] + gets $f x + if {[catch {socket localhost 2828} msg]} { + set x $msg + } else { + lappend x [gets $f] + close $msg + } + lappend x [gets $f] + close $f + set x +} {ready done {}} + +if [info exists port] { + incr port +} else { + set port [expr 2048 + [pid]%1024] +} +test socket-2.2 {tcp connection with client port specified} {unixOrPc} { + removeFile script + set f [open script w] + puts $f { + set f [socket -server accept 2828] + proc accept {file addr port} { + global x + puts "[gets $file] $port" + close $file + set x done + } + puts ready + vwait x + close $f + } + close $f + set f [open "|$tcltest script" r] + gets $f x + global port + if {[catch {socket -myport $port localhost 2828} sock]} { + set x $sock + close [socket localhost 2828] + puts stderr $sock + } else { + puts $sock hello + flush $sock + lappend x [gets $f] + close $sock + } + close $f + set x +} [list ready "hello $port"] +test socket-2.3 {tcp connection with client interface specified} {unixOrPc} { + removeFile script + set f [open script w] + puts $f { + set f [socket -server accept 2828] + proc accept {file addr port} { + global x + puts "[gets $file] $addr" + close $file + set x done + } + puts ready + vwait x + close $f + } + close $f + set f [open "|$tcltest script" r] + gets $f x + if {[catch {socket -myaddr localhost localhost 2828} sock]} { + set x $sock + } else { + puts $sock hello + flush $sock + lappend x [gets $f] + close $sock + } + close $f + set x +} {ready {hello 127.0.0.1}} +test socket-2.4 {tcp connection with server interface specified} {unixOrPc} { + removeFile script + set f [open script w] + puts $f { + set f [socket -server accept -myaddr [info hostname] 2828] + proc accept {file addr port} { + global x + puts "[gets $file]" + close $file + set x done + } + puts ready + vwait x + close $f + } + close $f + set f [open "|$tcltest script" r] + gets $f x + if {[catch {socket [info hostname] 2828} sock]} { + set x $sock + } else { + puts $sock hello + flush $sock + lappend x [gets $f] + close $sock + } + close $f + set x +} {ready hello} +test socket-2.5 {tcp connection with redundant server port} {unixOrPc} { + removeFile script + set f [open script w] + puts $f { + set f [socket -server accept 2828] + proc accept {file addr port} { + global x + puts "[gets $file]" + close $file + set x done + } + puts ready + vwait x + close $f + } + close $f + set f [open "|$tcltest script" r] + gets $f x + if {[catch {socket localhost 2828} sock]} { + set x $sock + } else { + puts $sock hello + flush $sock + lappend x [gets $f] + close $sock + } + close $f + set x +} {ready hello} +test socket-2.6 {tcp connection} {unixOrPc} { + set status ok + if {![catch {set sock [socket localhost 2828]}]} { + if {![catch {gets $sock}]} { + set status broken + } + close $sock + } + set status +} ok +test socket-2.7 {echo server, one line} {unixOrPc} { + removeFile script + set f [open script w] + puts $f { + set f [socket -server accept 2828] + proc accept {s a p} { + fileevent $s readable [list echo $s] + fconfigure $s -translation lf -buffering line + } + proc echo {s} { + set l [gets $s] + if {[eof $s]} { + global x + close $s + set x done + } else { + puts $s $l + } + } + puts ready + vwait x + close $f + puts done + } + close $f + set f [open "|$tcltest script" r] + gets $f + set s [socket localhost 2828] + fconfigure $s -buffering line -translation lf + puts $s "hello abcdefghijklmnop" + set x [gets $s] + close $s + set y [gets $f] + close $f + list $x $y +} {{hello abcdefghijklmnop} done} +test socket-2.8 {echo server, loop 50 times, single connection} {unixOrPc} { + removeFile script + set f [open script w] + puts $f { + set f [socket -server accept 2828] + proc accept {s a p} { + fileevent $s readable [list echo $s] + fconfigure $s -buffering line + } + proc echo {s} { + global i + set l [gets $s] + if {[eof $s]} { + global x + close $s + set x done + } else { + incr i + puts $s $l + } + } + set i 0 + puts ready + vwait x + close $f + puts "done $i" + } + close $f + set f [open "|$tcltest script" r] + gets $f + set s [socket localhost 2828] + fconfigure $s -buffering line + for {set x 0} {$x < 50} {incr x} { + puts $s "hello abcdefghijklmnop" + gets $s + } + close $s + set x [gets $f] + close $f + set x +} {done 50} +test socket-2.9 {socket conflict} {unixOrPc} { + set s [socket -server accept 2828] + removeFile script + set f [open script w] + puts $f {set f [socket -server accept 2828]} + close $f + set f [open "|$tcltest script" r] + gets $f + after 100 + set x [list [catch {close $f} msg] $msg] + close $s + set x +} {1 {couldn't open socket: address already in use + while executing +"socket -server accept 2828" + invoked from within +"set f [socket -server accept 2828]..." + (file "script" line 1)}} + +test socket-3.1 {socket conflict} {unixOrPc} { + removeFile script + set f [open script w] + puts $f { + set f [socket -server accept 2828] + puts ready + gets stdin + close $f + } + close $f + set f [open "|$tcltest script" r+] + gets $f + set x [list [catch {socket -server accept 2828} msg] \ + $msg] + puts $f bye + close $f + set x +} {1 {couldn't open socket: address already in use}} +test socket-3.2 {server with several clients} {unixOrPc} { + removeFile script + set f [open script w] + puts $f { + set counter 0 + set s [socket -server accept 2828] + proc accept {s a p} { + fileevent $s readable [list echo $s] + fconfigure $s -buffering line + } + proc echo {s} { + global x + set l [gets $s] + if {[eof $s]} { + close $s + set x done + } else { + puts $s $l + } + } + puts ready + vwait x + vwait x + vwait x + close $s + puts done + } + close $f + set f [open "|$tcltest script" r+] + set x [gets $f] + set s1 [socket localhost 2828] + fconfigure $s1 -buffering line + set s2 [socket localhost 2828] + fconfigure $s2 -buffering line + set s3 [socket localhost 2828] + fconfigure $s3 -buffering line + for {set i 0} {$i < 100} {incr i} { + puts $s1 hello,s1 + gets $s1 + puts $s2 hello,s2 + gets $s2 + puts $s3 hello,s3 + gets $s3 + } + close $s1 + close $s2 + close $s3 + lappend x [gets $f] + close $f + set x +} {ready done} + +test socket-4.1 {server with several clients} {unixOrPc} { + removeFile script + set f [open script w] + puts $f { + gets stdin + set s [socket localhost 2828] + fconfigure $s -buffering line + for {set i 0} {$i < 100} {incr i} { + puts $s hello + gets $s + } + close $s + puts bye + gets stdin + } + close $f + set p1 [open "|$tcltest script" r+] + fconfigure $p1 -buffering line + set p2 [open "|$tcltest script" r+] + fconfigure $p2 -buffering line + set p3 [open "|$tcltest script" r+] + fconfigure $p3 -buffering line + proc accept {s a p} { + fconfigure $s -buffering line + fileevent $s readable [list echo $s] + } + proc echo {s} { + global x + set l [gets $s] + if {[eof $s]} { + close $s + set x done + } else { + puts $s $l + } + } + set s [socket -server accept 2828] + puts $p1 open + puts $p2 open + puts $p3 open + vwait x + vwait x + vwait x + close $s + set l "" + lappend l [list p1 [gets $p1]] + lappend l [list p2 [gets $p2]] + lappend l [list p3 [gets $p3]] + puts $p1 bye + puts $p2 bye + puts $p3 bye + close $p1 + close $p2 + close $p3 + set l +} {{p1 bye} {p2 bye} {p3 bye}} +test socket-4.2 {byte order problems, socket numbers, htons} { + set x ok + if {[catch {socket -server dodo 0x3000} msg]} { + set x $msg + } else { + close $msg + } + set x +} ok + +test socket-5.1 {byte order problems, socket numbers, htons} {unixOnly} { + # + # THIS TEST WILL FAIL if you are running as superuser. + # + set x {couldn't open socket: not owner} + if {![catch {socket -server dodo 0x1} msg]} { + set x {htons problem, should be disallowed, are you running as SU?} + close $msg + } + set x +} {couldn't open socket: not owner} +test socket-5.2 {byte order problems, socket numbers, htons} { + set x {couldn't open socket: port number too high} + if {![catch {socket -server dodo 0x10000} msg]} { + set x {port resolution problem, should be disallowed} + close $msg + } + set x +} {couldn't open socket: port number too high} +test socket-5.3 {byte order problems, socket numbers, htons} {unixOnly} { + # + # THIS TEST WILL FAIL if you are running as superuser. + # + set x {couldn't open socket: not owner} + if {![catch {socket -server dodo 21} msg]} { + set x {htons problem, should be disallowed, are you running as SU?} + close $msg + } + set x +} {couldn't open socket: not owner} + +test socket-6.1 {accept callback error} {unixOrPc} { + removeFile script + set f [open script w] + puts $f { + gets stdin + socket localhost 2848 + } + close $f + set f [open "|$tcltest 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 + close $f + vwait x + close $s + rename bgerror {} + set x +} {{divide by zero}} + +test socket-7.1 {testing socket specific options} {unixOrPc} { + removeFile script + set f [open script w] + puts $f { + socket -server accept 2828 + proc accept args { + global x + set x done + } + puts ready + vwait x + } + close $f + set f [open "|$tcltest script" r] + gets $f + set s [socket localhost 2828] + 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] 2828] + lappend l [llength $p] +} {0 0 3} +test socket-7.2 {testing socket specific options} {unixOrPc} { + removeFile script + set f [open script w] + puts $f { + socket -server accept 2828 + proc accept args { + global x + set x done + } + puts ready + vwait x + } + close $f + set f [open "|$tcltest script" r] + gets $f + set s [socket localhost 2828] + 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] == 2828] +} {3 127.0.0.1 0} +test socket-7.3 {testing socket specific options} { + set s [socket -server accept 2828] + set l [fconfigure $s] + close $s + llength $l +} 10 +test socket-7.4 {testing socket specific options} { + set s [socket -server accept 2828] + proc accept {s a p} { + global x + set x [fconfigure $s -sockname] + close $s + } + set s1 [socket localhost 2828] + vwait x + close $s + close $s1 + set l "" + lappend l [lindex $x 0] [lindex $x 2] [llength $x] +} {127.0.0.1 2828 3} + +test socket-8.1 {testing -async flag on sockets} { + # NOTE: This test may fail on some Solaris 2.4 systems. If it does, + # check that you have these patches installed (using showrev -p): + # + # 101907-05, 101925-02, 101945-14, 101959-03, 101969-05, 101973-03, + # 101977-03, 101981-02, 101985-01, 102001-03, 102003-01, 102007-01, + # 102011-02, 102024-01, 102039-01, 102044-01, 102048-01, 102062-03, + # 102066-04, 102070-01, 102105-01, 102153-03, 102216-01, 102232-01, + # 101878-03, 101879-01, 101880-03, 101933-01, 101950-01, 102030-01, + # 102057-08, 102140-01, 101920-02, 101921-09, 101922-07, 101923-03 + # + # If after installing these patches you are still experiencing a + # 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 2828] + proc accept {s a p} { + global x + puts $s bye + close $s + set x done + } + set s1 [socket -async localhost 2828] + vwait x + set z [gets $s1] + close $s + close $s1 + set z +} bye + +removeFile script + +# +# The rest of the tests are run only if we are doing testing against +# a remote server. +# + +if {$doTestsWithRemoteServer == 0} { + return +} + +test socket-9.1 {tcp connection} { + sendCommand { + set socket9_1_test_server [socket -server accept 2828] + proc accept {s a p} { + puts $s done + close $s + } + } + set s [socket $remoteServerIP 2828] + set r [gets $s] + close $s + sendCommand {close $socket9_1_test_server} + set r +} done +test socket-9.2 {client specifies its port} { + if {[info exists port]} { + incr port + } else { + set port [expr 2048 + [pid]%1024] + } + sendCommand { + set socket9_2_test_server [socket -server accept 2828] + proc accept {s a p} { + puts $s $p + close $s + } + } + set s [socket -myport $port $remoteServerIP 2828] + set r [gets $s] + close $s + sendCommand {close $socket9_2_test_server} + if {$r == $port} { + set result ok + } else { + set result broken + } + set result +} ok +# +# Tests io-9.3, io-9.4 have been removed. +# +test socket-9.5 {trying to connect, no server} { + set status ok + if {![catch {set s [socket $remoteServerIp 2828]}]} { + if {![catch {gets $s}]} { + set status broken + } + close $s + } + set status +} ok +test socket-9.6 {remote echo, one line} { + sendCommand { + set socket9_6_test_server [socket -server accept 2828] + proc accept {s a p} { + fileevent $s readable [list echo $s] + fconfigure $s -buffering line -translation crlf + } + proc echo {s} { + set l [gets $s] + if {[eof $s]} { + close $s + } else { + puts $s $l + } + } + } + set f [socket $remoteServerIP 2828] + fconfigure $f -translation crlf -buffering line + puts $f hello + set r [gets $f] + close $f + sendCommand {close $socket9_6_test_server} + set r +} hello +test socket-9.7 {remote echo, 50 lines} { + sendCommand { + set socket9_7_test_server [socket -server accept 2828] + proc accept {s a p} { + fileevent $s readable [list echo $s] + fconfigure $s -buffering line -translation crlf + } + proc echo {s} { + set l [gets $s] + if {[eof $s]} { + close $s + } else { + puts $s $l + } + } + } + set f [socket $remoteServerIP 2828] + fconfigure $f -translation crlf -buffering line + for {set cnt 0} {$cnt < 50} {incr cnt} { + puts $f "hello, $cnt" + if {[string compare [gets $f] "hello, $cnt"] != 0} { + break + } + } + close $f + sendCommand {close $socket9_7_test_server} + set cnt +} 50 +# Macintosh sockets can have more than one server per port +if {$tcl_platform(platform) == "macintosh"} { + set conflictResult {0 2828} +} else { + set conflictResult {1 {couldn't open socket: address already in use}} +} +test socket-9.8 {socket conflict} { + set s1 [socket -server accept 2828] + if {[catch {set s2 [socket -server accept 2828]} msg]} { + set result [list 1 $msg] + } else { + set result [list 0 [lindex [fconfigure $s2 -sockname] 2]] + close $s2 + } + close $s1 + set result +} $conflictResult +test socket-9.9 {server with several clients} { + sendCommand { + set socket9_9_test_server [socket -server accept 2828] + proc accept {s a p} { + fconfigure $s -buffering line + fileevent $s readable [list echo $s] + } + proc echo {s} { + set l [gets $s] + if {[eof $s]} { + close $s + } else { + puts $s $l + } + } + } + set s1 [socket $remoteServerIP 2828] + fconfigure $s1 -buffering line + set s2 [socket $remoteServerIP 2828] + fconfigure $s2 -buffering line + set s3 [socket $remoteServerIP 2828] + fconfigure $s3 -buffering line + for {set i 0} {$i < 100} {incr i} { + puts $s1 hello,s1 + gets $s1 + puts $s2 hello,s2 + gets $s2 + puts $s3 hello,s3 + gets $s3 + } + close $s1 + close $s2 + close $s3 + sendCommand {close $socket9_9_test_server} + set i +} 100 +test socket-9.10 {client with several servers} { + sendCommand { + set s1 [socket -server "accept 3000" 3000] + set s2 [socket -server "accept 3001" 3001] + set s3 [socket -server "accept 3002" 3002] + proc accept {mp s a p} { + puts $s $mp + close $s + } + } + set s1 [socket $remoteServerIP 3000] + set s2 [socket $remoteServerIP 3001] + set s3 [socket $remoteServerIP 3002] + set l "" + lappend l [gets $s1] [gets $s1] [eof $s1] [gets $s2] [gets $s2] [eof $s2] \ + [gets $s3] [gets $s3] [eof $s3] + close $s1 + close $s2 + close $s3 + sendCommand { + close $s1 + close $s2 + close $s3 + } + set l +} {3000 {} 1 3001 {} 1 3002 {} 1} +test socket-9.11 {accept callback error} { + set s [socket -server accept 2828] + proc accept {s a p} {expr 10 / 0} + proc bgerror args { + global x + set x $args + } + if {[catch {sendCommand { + set peername [fconfigure $callerSocket -peername] + set s [socket [lindex $peername 0] 2828] + close $s + }} msg]} { + close $s + error $msg + } + vwait x + close $s + rename bgerror {} + set x +} {{divide by zero}} +test socket-9.12 {testing socket specific options} { + sendCommand { + set socket9_12_test_server [socket -server accept 2828] + proc accept {s a p} {close $s} + } + set s [socket $remoteServerIP 2828] + set p [fconfigure $s -peername] + set n [fconfigure $s -sockname] + set l "" + lappend l [lindex $p 2] [llength $p] [llength $p] + close $s + sendCommand {close $socket9_12_test_server} + set l +} {2828 3 3} + +if {$remotePid != -1} { + puts $commandSocket exit + flush $commandSocket +} +catch {close $commandSocket} + +set x "" +unset x diff --git a/contrib/tcl/tests/source.test b/contrib/tcl/tests/source.test new file mode 100644 index 0000000..f335c0e --- /dev/null +++ b/contrib/tcl/tests/source.test @@ -0,0 +1,180 @@ +# Commands covered: source +# +# 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) 1991-1993 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: @(#) source.test 1.22 96/04/05 15:27:13 + +if {[string compare test [info procs test]] == 1} then {source defs} + +test source-1.1 {source command} { + set x "old x value" + set y "old y value" + set z "old z value" + makeFile { + set x 22 + set y 33 + set z 44 + } source.file + source source.file + list $x $y $z +} {22 33 44} +test source-1.2 {source command} { + makeFile {list result} source.file + source source.file +} result + +# The mac version of source returns a differnt result for +# the next two tests. + +if {$tcl_platform(platform) == "macintosh"} { + set retMsg1 {1 {wrong # args: should be "source fileName" or "source -rsrc name ?fileName?" or "source -rsrcid id ?fileName?"}} + set retMsg2 {1 {bad argument: should be "source fileName" or "source -rsrc name ?fileName?" or "source -rsrcid id ?fileName?"}} +} else { + set retMsg1 {1 {wrong # args: should be "source fileName"}} + set retMsg2 {1 {wrong # args: should be "source fileName"}} +} +test source-2.1 {source error conditions} { + list [catch {source} msg] $msg +} $retMsg1 +test source-2.2 {source error conditions} { + list [catch {source a b} msg] $msg +} $retMsg2 +test source-2.3 {source error conditions} { + 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 + while executing +"error "error in sourced file"" + (file "source.file" line 3) + invoked from within +"source source.file"}} +test source-2.4 {source error conditions} { + makeFile {break} source.file + catch {source source.file} +} 3 +test source-2.5 {source error conditions} { + makeFile {continue} source.file + catch {source source.file} +} 4 +test source-2.6 {source error conditions} { + normalizeMsg [list [catch {source _non_existent_} msg] $msg $errorCode] +} {1 {couldn't read file "_non_existent_": no such file or directory} {posix enoent {no such file or directory}}} + +test source-3.1 {return in middle of source file} { + makeFile { + set x new-x + return allDone + set y new-y + } source.file + set x old-x + set y old-y + set z [source source.file] + list $x $y $z +} {new-x old-y allDone} +test source-3.2 {return with special code etc.} { + makeFile { + set x new-x + return -code break "Silly result" + set y new-y + } source.file + list [catch {source source.file} msg] $msg +} {3 {Silly result}} +test source-3.3 {return with special code etc.} { + makeFile { + set x new-x + return -code error "Simulated error" + set y new-y + } source.file + list [catch {source source.file} msg] $msg $errorInfo $errorCode +} {1 {Simulated error} {Simulated error + while executing +"source source.file"} 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 +} {1 {} {Simulated errorInfo stuff + invoked from within +"source source.file"} NONE} +test source-3.5 {return with special code etc.} { + makeFile { + set x new-x + return -code error -errorinfo "Simulated errorInfo stuff" \ + -errorcode {a b c} + set y new-y + } source.file + list [catch {source source.file} msg] $msg $errorInfo $errorCode +} {1 {} {Simulated errorInfo stuff + invoked from within +"source source.file"} {a b c}} + +# Test for the Macintosh specfic features of the source command +test source-4.1 {source error conditions} {macOnly} { + list [catch {source -rsrc _no_exist_} msg] $msg +} [list 1 "The resource \"_no_exist_\" could not be loaded from application."] +test source-4.2 {source error conditions} {macOnly} { + list [catch {source -rsrcid bad_id} msg] $msg +} [list 1 "expected integer but got \"bad_id\""] +test source-4.3 {source error conditions} {macOnly} { + list [catch {source -rsrc rsrcName fileName extra} msg] $msg +} $retMsg1 +test source-4.4 {source error conditions} {macOnly} { + list [catch {source non_switch rsrcName} msg] $msg +} $retMsg2 +test source-4.5 {source error conditions} {macOnly} { + list [catch {source -bad_switch argument} msg] $msg +} $retMsg2 +test source-5.1 {source resource files} {macOnly} { + list [catch {source -rsrc rsrcName bad_file} msg] $msg +} [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\"."] +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] + rm rsrc.file + list $msg2 $result $msg +} [list ok 0 {}] +test source-5.4 {source resource files} {macOnly} { + catch {unset msg2} + testWriteTextResource -rsrc fileRsrcName -file rsrc.file {set msg2 ok; return} + source -rsrc fileRsrcName rsrc.file + set result [catch {source -rsrc fileRsrcName} msg] + rm rsrc.file + list $msg2 $result $msg +} [list ok 1 {The resource "fileRsrcName" could not be loaded from application.}] +test source-5.5 {source resource files} {macOnly} { + testWriteTextResource -rsrcid 200 -file rsrc.file {set msg2 hello; set msg3 bye} + set result [catch {source -rsrcid 200 rsrc.file} msg] + rm rsrc.file + list $msg2 $result $msg +} [list hello 0 bye] +test source-5.6 {source resource files} {macOnly} { + testWriteTextResource -rsrcid 200 -file rsrc.file {set msg2 hello; error bad; set msg3 bye} + set result [catch {source -rsrcid 200 rsrc.file} msg] + rm rsrc.file + list $msg2 $result $msg +} [list hello 1 bad] + +catch {exec rm source.file} + +# Generate null final value + +concat {} diff --git a/contrib/tcl/tests/split.test b/contrib/tcl/tests/split.test new file mode 100644 index 0000000..e87fcd4 --- /dev/null +++ b/contrib/tcl/tests/split.test @@ -0,0 +1,44 @@ +# Commands covered: split +# +# 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) 1991-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: @(#) split.test 1.8 96/02/16 08:56:28 + +if {[string compare test [info procs test]] == 1} then {source defs} + +test split-1.1 {basic split commands} { + split "a\n b\t\r c\n " +} {a {} b {} {} c {} {}} +test split-1.2 {basic split commands} { + split "word 1xyzword 2zword 3" xyz +} {{word 1} {} {} {word 2} {word 3}} +test split-1.3 {basic split commands} { + split "12345" {} +} {1 2 3 4 5} +test split-1.4 {basic split commands} { + split "a\}b\[c\{\]\$" +} "a\\}b\\\[c\\{\\\]\\\$" +test split-1.5 {basic split commands} { + split {} {} +} {} +test split-1.6 {basic split commands} { + split {} +} {} +test split-1.7 {basic split commands} { + split { } +} {{} {} {} {}} + +test split-2.1 {split errors} { + list [catch split msg] $msg $errorCode +} {1 {wrong # args: should be "split string ?splitChars?"} NONE} +test split-2.2 {split errors} { + list [catch {split a b c} msg] $msg $errorCode +} {1 {wrong # args: should be "split string ?splitChars?"} NONE} diff --git a/contrib/tcl/tests/string.test b/contrib/tcl/tests/string.test new file mode 100644 index 0000000..77e1bc7 --- /dev/null +++ b/contrib/tcl/tests/string.test @@ -0,0 +1,375 @@ +# Commands covered: string +# +# 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) 1991-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: @(#) string.test 1.12 96/02/16 08:56:29 + +if {[string compare test [info procs test]] == 1} then {source defs} + +test string-1.1 {string compare} { + string compare abcde abdef +} -1 +test string-1.2 {string compare} { + string c abcde ABCDE +} 1 +test string-1.3 {string compare} { + string compare abcde abcde +} 0 +test string-1.4 {string compare} { + list [catch {string compare a} msg] $msg +} {1 {wrong # args: should be "string compare string1 string2"}} +test string-1.5 {string compare} { + list [catch {string compare a b c} msg] $msg +} {1 {wrong # args: should be "string compare string1 string2"}} + +test string-2.1 {string first} { + string first bq abcdefgbcefgbqrs +} 12 +test string-2.2 {string first} { + string fir bcd abcdefgbcefgbqrs +} 1 +test string-2.3 {string first} { + string f b abcdefgbcefgbqrs +} 1 +test string-2.4 {string first} { + string first xxx x123xx345xxx789xxx012 +} 9 +test string-2.5 {string first} { + list [catch {string first a} msg] $msg +} {1 {wrong # args: should be "string first string1 string2"}} +test string-2.6 {string first} { + list [catch {string first a b c} msg] $msg +} {1 {wrong # args: should be "string first string1 string2"}} + +test string-3.1 {string index} { + string index abcde 0 +} a +test string-3.2 {string index} { + string i abcde 4 +} e +test string-3.3 {string index} { + string index abcde 5 +} {} +test string-3.4 {string index} { + list [catch {string index abcde -10} msg] $msg +} {0 {}} +test string-3.5 {string index} { + list [catch {string index} msg] $msg +} {1 {wrong # args: should be "string index string charIndex"}} +test string-3.6 {string index} { + list [catch {string index a b c} msg] $msg +} {1 {wrong # args: should be "string index string charIndex"}} +test string-3.7 {string index} { + list [catch {string index a xyz} msg] $msg +} {1 {expected integer but got "xyz"}} + +test string-4.1 {string last} { + string la xxx xxxx123xx345x678 +} 1 +test string-4.2 {string last} { + string last xx xxxx123xx345x678 +} 7 +test string-4.3 {string last} { + string las x xxxx123xx345x678 +} 12 +test string-4.4 {string last} { + list [catch {string last a} msg] $msg +} {1 {wrong # args: should be "string last string1 string2"}} +test string-4.5 {string last} { + list [catch {string last a b c} msg] $msg +} {1 {wrong # args: should be "string last string1 string2"}} + +test string-5.1 {string length} { + string length "a little string" +} 15 +test string-5.2 {string length} { + string le "" +} 0 +test string-5.3 {string length} { + list [catch {string length} msg] $msg +} {1 {wrong # args: should be "string length string"}} +test string-5.4 {string length} { + list [catch {string length a b} msg] $msg +} {1 {wrong # args: should be "string length string"}} + +test string-6.1 {string match} { + string match abc abc +} 1 +test string-6.2 {string match} { + string m abc abd +} 0 +test string-6.3 {string match} { + string match ab*c abc +} 1 +test string-6.4 {string match} { + string match ab**c abc +} 1 +test string-6.5 {string match} { + string match ab* abcdef +} 1 +test string-6.6 {string match} { + string match *c abc +} 1 +test string-6.7 {string match} { + string match *3*6*9 0123456789 +} 1 +test string-6.8 {string match} { + string match *3*6*9 01234567890 +} 0 +test string-6.9 {string match} { + string match a?c abc +} 1 +test string-6.10 {string match} { + string match a??c abc +} 0 +test string-6.11 {string match} { + string match ?1??4???8? 0123456789 +} 1 +test string-6.12 {string match} { + string match {[abc]bc} abc +} 1 +test string-6.13 {string match} { + string match {a[abc]c} abc +} 1 +test string-6.14 {string match} { + string match {a[xyz]c} abc +} 0 +test string-6.15 {string match} { + string match {12[2-7]45} 12345 +} 1 +test string-6.16 {string match} { + string match {12[ab2-4cd]45} 12345 +} 1 +test string-6.17 {string match} { + string match {12[ab2-4cd]45} 12b45 +} 1 +test string-6.18 {string match} { + string match {12[ab2-4cd]45} 12d45 +} 1 +test string-6.19 {string match} { + string match {12[ab2-4cd]45} 12145 +} 0 +test string-6.20 {string match} { + string match {12[ab2-4cd]45} 12545 +} 0 +test string-6.21 {string match} { + string match {a\*b} a*b +} 1 +test string-6.22 {string match} { + string match {a\*b} ab +} 0 +test string-6.23 {string match} { + string match {a\*\?\[\]\\\x} "a*?\[\]\\x" +} 1 +test string-6.24 {string match} { + string match ** "" +} 1 +test string-6.25 {string match} { + string match *. "" +} 0 +test string-6.26 {string match} { + string match "" "" +} 1 +test string-6.27 {string match} { + string match \[a a +} 1 +test string-6.28 {string match} { + list [catch {string match a} msg] $msg +} {1 {wrong # args: should be "string match pattern string"}} +test string-6.29 {string match} { + list [catch {string match a b c} msg] $msg +} {1 {wrong # args: should be "string match pattern string"}} + +test string-7.1 {string range} { + string range abcdefghijklmnop 2 14 +} {cdefghijklmno} +test string-7.2 {string range} { + string range abcdefghijklmnop 7 1000 +} {hijklmnop} +test string-7.3 {string range} { + string range abcdefghijklmnop 10 e +} {klmnop} +test string-7.4 {string range} { + string range abcdefghijklmnop 10 9 +} {} +test string-7.5 {string range} { + string range abcdefghijklmnop -3 2 +} {abc} +test string-7.6 {string range} { + string range abcdefghijklmnop -3 -2 +} {} +test string-7.7 {string range} { + string range abcdefghijklmnop 1000 1010 +} {} +test string-7.8 {string range} { + string range abcdefghijklmnop -100 end +} {abcdefghijklmnop} +test string-7.9 {string range} { + list [catch {string range} msg] $msg +} {1 {wrong # args: should be "string range string first last"}} +test string-7.10 {string range} { + list [catch {string range a 1} msg] $msg +} {1 {wrong # args: should be "string range string first last"}} +test string-7.11 {string range} { + list [catch {string range a 1 2 3} msg] $msg +} {1 {wrong # args: should be "string range string first last"}} +test string-7.12 {string range} { + list [catch {string range abc abc 1} msg] $msg +} {1 {expected integer but got "abc"}} +test string-7.13 {string range} { + list [catch {string range abc 1 eof} msg] $msg +} {1 {expected integer or "end" but got "eof"}} + +test string-8.1 {string trim} { + string trim " XYZ " +} {XYZ} +test string-8.2 {string trim} { + string trim "\t\nXYZ\t\n\r\n" +} {XYZ} +test string-8.3 {string trim} { + string trim " A XYZ A " +} {A XYZ A} +test string-8.4 {string trim} { + string trim "XXYYZZABC XXYYZZ" ZYX +} {ABC } +test string-8.5 {string trim} { + string trim " \t\r " +} {} +test string-8.6 {string trim} { + string trim {abcdefg} {} +} {abcdefg} +test string-8.7 {string trim} { + string trim {} +} {} +test string-8.8 {string trim} { + string trim ABC DEF +} {ABC} +test string-8.9 {string trim} { + list [catch {string trim} msg] $msg +} {1 {wrong # args: should be "string trim string ?chars?"}} +test string-8.10 {string trim} { + list [catch {string trim a b c} msg] $msg +} {1 {wrong # args: should be "string trim string ?chars?"}} + +test string-9.1 {string trimleft} { + string trimleft " XYZ " +} {XYZ } +test string-9.2 {string trimleft} { + list [catch {string triml} msg] $msg +} {1 {wrong # args: should be "string trimleft string ?chars?"}} + +test string-10.1 {string trimright} { + string trimright " XYZ " +} { XYZ} +test string-10.2 {string trimright} { + string trimright " " +} {} +test string-10.3 {string trimright} { + string trimright "" +} {} +test string-10.4 {string trimright errors} { + list [catch {string trimr} msg] $msg +} {1 {wrong # args: should be "string trimright string ?chars?"}} +test string-10.5 {string trimright errors} { + list [catch {string trimg a} msg] $msg +} {1 {bad option "trimg": should be compare, first, index, last, length, match, range, tolower, toupper, trim, trimleft, trimright, wordend, or wordstart}} + +test string-11.1 {string tolower} { + string tolower ABCDeF +} {abcdef} +test string-11.2 {string tolower} { + string tolower "ABC XyZ" +} {abc xyz} +test string-11.3 {string tolower} { + string tolower {123#$&*()} +} {123#$&*()} +test string-11.4 {string tolower} { + list [catch {string tolower} msg] $msg +} {1 {wrong # args: should be "string tolower string"}} +test string-11.5 {string tolower} { + list [catch {string tolower a b} msg] $msg +} {1 {wrong # args: should be "string tolower string"}} + +test string-12.1 {string toupper} { + string toupper abCDEf +} {ABCDEF} +test string-12.2 {string toupper} { + string toupper "abc xYz" +} {ABC XYZ} +test string-12.3 {string toupper} { + string toupper {123#$&*()} +} {123#$&*()} +test string-12.4 {string toupper} { + list [catch {string toupper} msg] $msg +} {1 {wrong # args: should be "string toupper string"}} +test string-12.5 {string toupper} { + list [catch {string toupper a b} msg] $msg +} {1 {wrong # args: should be "string toupper string"}} + +test string-13.1 {string wordend} { + list [catch {string wordend a} msg] $msg +} {1 {wrong # args: should be "string wordend string index"}} +test string-13.2 {string wordend} { + list [catch {string wordend a b c} msg] $msg +} {1 {wrong # args: should be "string wordend string index"}} +test string-13.3 {string wordend} { + list [catch {string wordend a gorp} msg] $msg +} {1 {expected integer but got "gorp"}} +test string-13.4 {string wordend} { + string wordend abc. -1 +} 3 +test string-13.5 {string wordend} { + string wordend abc. 100 +} 4 +test string-13.6 {string wordend} { + string wordend "word_one two three" 2 +} 8 +test string-13.7 {string wordend} { + string wordend "one .&# three" 5 +} 6 +test string-13.8 {string wordend} { + string worde "x.y" 0 +} 1 + +test string-14.1 {string wordstart} { + list [catch {string word a} msg] $msg +} {1 {bad option "word": should be compare, first, index, last, length, match, range, tolower, toupper, trim, trimleft, trimright, wordend, or wordstart}} +test string-14.2 {string wordstart} { + list [catch {string wordstart a} msg] $msg +} {1 {wrong # args: should be "string wordstart string index"}} +test string-14.3 {string wordstart} { + list [catch {string wordstart a b c} msg] $msg +} {1 {wrong # args: should be "string wordstart string index"}} +test string-14.4 {string wordstart} { + list [catch {string wordstart a gorp} msg] $msg +} {1 {expected integer but got "gorp"}} +test string-14.5 {string wordstart} { + string wordstart "one two three_words" 400 +} 8 +test string-14.6 {string wordstart} { + string wordstart "one two three_words" 2 +} 0 +test string-14.7 {string wordend} { + string wordstart "one two three_words" -2 +} 0 +test string-14.8 {string wordend} { + string wordstart "one .*&^ three" 6 +} 6 +test string-14.9 {string wordend} { + string wordstart "one two three" 4 +} 4 + +test string-15.1 {error conditions} { + list [catch {string gorp a b} msg] $msg +} {1 {bad option "gorp": should be compare, first, index, last, length, match, range, tolower, toupper, trim, trimleft, trimright, wordend, or wordstart}} +test string-15.2 {error conditions} { + list [catch {string} msg] $msg +} {1 {wrong # args: should be "string option arg ?arg ...?"}} diff --git a/contrib/tcl/tests/subst.test b/contrib/tcl/tests/subst.test new file mode 100644 index 0000000..5c7f556 --- /dev/null +++ b/contrib/tcl/tests/subst.test @@ -0,0 +1,106 @@ +# Commands covered: subst +# +# 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) 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: @(#) subst.test 1.7 96/02/16 08:56:30 + +if {[string compare test [info procs test]] == 1} then {source defs} + +test subst-1.1 {basics} { + list [catch {subst} msg] $msg +} {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"}} + +test subst-2.1 {simple strings} { + subst {} +} {} +test subst-2.2 {simple strings} { + subst a +} a +test subst-2.3 {simple strings} { + subst abcdefg +} abcdefg + +test subst-3.1 {backslash substitutions} { + subst {\x\$x\[foo bar]\\} +} "x\$x\[foo bar]\\" + +test subst-4.1 {variable substitutions} { + set a 44 + subst {$a} +} {44} +test subst-4.2 {variable substitutions} { + set a 44 + subst {x$a.y{$a}.z} +} {x44.y{44}.z} +test subst-4.3 {variable substitutions} { + catch {unset a} + set a(13) 82 + set i 13 + subst {x.$a($i)} +} {x.82} +catch {unset a} +set long {This is a very long string, intentionally made so long that it + will overflow the static character size for dstrings, so that + additional memory will have to be allocated by subst. That way, + if the subst procedure forgets to free up memory while returning + an error, there will be memory that isn't freed (this will be + detected when the tests are run under a checking memory allocator + such as Purify).} +test subst-4.4 {variable substitutions} { + list [catch {subst {$long $a}} msg] $msg +} {1 {can't read "a": no such variable}} + +test subst-5.1 {command substitutions} { + subst {[concat {}]} +} {} +test subst-5.2 {command substitutions} { + subst {[concat A test string]} +} {A test string} +test subst-5.3 {command substitutions} { + subst {x.[concat foo].y.[concat bar].z} +} {x.foo.y.bar.z} +test subst-5.3 {command substitutions} { + list [catch {subst {$long [set long] [bogus_command]}} msg] $msg +} {1 {invalid command name "bogus_command"}} + +test subst-6.1 {clear the result after command substitution} { + catch {unset a} + list [catch {subst {[concat foo] $a}} msg] $msg +} {1 {can't read "a": no such variable}} + +test subst-7.1 {switches} { + list [catch {subst foo bar} msg] $msg +} {1 {wrong # args: should be "subst ?-nobackslashes? ?-nocommands? ?-novariables? string"}} +test subst-7.2 {switches} { + list [catch {subst -no bar} msg] $msg +} {1 {bad switch "-no": must be -nobackslashes, -nocommands, or -novariables}} +test subst-7.3 {switches} { + list [catch {subst -bogus bar} msg] $msg +} {1 {bad switch "-bogus": must be -nobackslashes, -nocommands, or -novariables}} +test subst-7.4 {switches} { + set x 123 + subst -nobackslashes {abc $x [expr 1+2] \\\x41} +} {abc 123 3 \\\x41} +test subst-7.5 {switches} { + set x 123 + subst -nocommands {abc $x [expr 1+2] \\\x41} +} {abc 123 [expr 1+2] \A} +test subst-7.6 {switches} { + set x 123 + subst -novariables {abc $x [expr 1+2] \\\x41} +} {abc $x 3 \A} +test subst-7.7 {switches} { + set x 123 + subst -nov -nob -noc {abc $x [expr 1+2] \\\x41} +} {abc $x [expr 1+2] \\\x41} diff --git a/contrib/tcl/tests/switch.test b/contrib/tcl/tests/switch.test new file mode 100644 index 0000000..740ecb1 --- /dev/null +++ b/contrib/tcl/tests/switch.test @@ -0,0 +1,170 @@ +# Commands covered: switch +# +# 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) 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: @(#) switch.test 1.5 96/02/16 08:56:31 + +if {[string compare test [info procs test]] == 1} then {source defs} + +test switch-1.1 {simple patterns} { + switch a a {format 1} b {format 2} c {format 3} default {format 4} +} 1 +test switch-1.2 {simple patterns} { + switch b a {format 1} b {format 2} c {format 3} default {format 4} +} 2 +test switch-1.3 {simple patterns} { + switch x a {format 1} b {format 2} c {format 3} default {format 4} +} 4 +test switch-1.4 {simple patterns} { + switch x a {format 1} b {format 2} c {format 3} +} {} +test switch-1.5 {simple pattern matches many times} { + switch b a {format 1} b {format 2} b {format 3} b {format 4} +} 2 +test switch-1.6 {simple patterns} { + switch default a {format 1} default {format 2} c {format 3} default {format 4} +} 2 +test switch-1.7 {simple patterns} { + switch x a {format 1} default {format 2} c {format 3} default {format 4} +} 4 + +test switch-2.1 {single-argument form for pattern/command pairs} { + switch b { + a {format 1} + b {format 2} + default {format 6} + } +} {2} +test switch-2.2 {single-argument form for pattern/command pairs} { + list [catch {switch z {a 2 b}} msg] $msg +} {1 {extra switch pattern with no body}} + +test switch-3.1 {-exact vs. -glob vs. -regexp} { + switch -exact aaaab { + ^a*b$ {concat regexp} + *b {concat glob} + aaaab {concat exact} + default {concat none} + } +} exact +test switch-3.2 {-exact vs. -glob vs. -regexp} { + switch -exact -regexp aaaab { + ^a*b$ {concat regexp} + *b {concat glob} + aaaab {concat exact} + default {concat none} + } +} regexp +test switch-3.3 {-exact vs. -glob vs. -regexp} { + switch -glob aaaab { + ^a*b$ {concat regexp} + *b {concat glob} + aaaab {concat exact} + default {concat none} + } +} glob +test switch-3.4 {-exact vs. -glob vs. -regexp} { + switch aaaab {^a*b$} {concat regexp} *b {concat glob} \ + aaaab {concat exact} default {concat none} +} exact +test switch-3.5 {-exact vs. -glob vs. -regexp} { + switch -- -glob { + ^g.*b$ {concat regexp} + -* {concat glob} + -glob {concat exact} + default {concat none} + } +} exact +test switch-3.6 {-exact vs. -glob vs. -regexp} { + list [catch {switch -foo a b c} msg] $msg +} {1 {bad option "-foo": should be -exact, -glob, -regexp, or --}} + +test switch-4.1 {error in executed command} { + list [catch {switch a a {error "Just a test"} default {format 1}} msg] \ + $msg $errorInfo +} {1 {Just a test} {Just a test + while executing +"error "Just a test"" + ("a" arm line 1) + invoked from within +"switch a a {error "Just a test"} default {format 1}"}} +test switch-4.2 {error: not enough args} { + list [catch {switch} msg] $msg +} {1 {wrong # args: should be "switch ?switches? string pattern body ... ?default body?"}} +test switch-4.3 {error: pattern with no body} { + list [catch {switch a b} msg] $msg +} {1 {extra switch pattern with no body}} +test switch-4.4 {error: pattern with no body} { + list [catch {switch a b {format 1} c} msg] $msg +} {1 {extra switch pattern with no body}} +test switch-4.5 {error in default command} { + list [catch {switch foo a {error switch1} b {error switch 3} \ + default {error switch2}} msg] $msg $errorInfo +} {1 switch2 {switch2 + while executing +"error switch2" + ("default" arm line 1) + invoked from within +"switch foo a {error switch1} b {error switch 3} default {error switch2}"}} + +test switch-5.1 {errors in -regexp matching} { + list [catch {switch -regexp aaaab { + *b {concat glob} + aaaab {concat exact} + default {concat none} + }} msg] $msg +} {1 {couldn't compile regular expression pattern: ?+* follows nothing}} + +test switch-6.1 {backslashes in patterns} { + switch -exact {\a\$\.\[} { + \a\$\.\[ {concat first} + \a\\$\.\\[ {concat second} + \\a\\$\\.\\[ {concat third} + {\a\\$\.\\[} {concat fourth} + {\\a\\$\\.\\[} {concat fifth} + default {concat none} + } +} third +test switch-6.2 {backslashes in patterns} { + switch -exact {\a\$\.\[} { + \a\$\.\[ {concat first} + {\a\$\.\[} {concat second} + {{\a\$\.\[}} {concat third} + default {concat none} + } +} second + +test switch-7.1 {"-" bodies} { + switch a { + a - + b - + c {concat 1} + default {concat 2} + } +} 1 +test switch-7.2 {"-" bodies} { + list [catch { + switch a { + a - + b - + c - + } + } msg] $msg +} {1 {no body specified for pattern "a"}} +test switch-7.3 {"-" bodies} { + list [catch { + switch a { + a - + b -foo + c - + } + } msg] $msg +} {1 {invalid command name "-foo"}} diff --git a/contrib/tcl/tests/trace.test b/contrib/tcl/tests/trace.test new file mode 100644 index 0000000..9077906 --- /dev/null +++ b/contrib/tcl/tests/trace.test @@ -0,0 +1,930 @@ +# Commands covered: trace +# +# 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) 1991-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: @(#) trace.test 1.24 96/02/16 08:56:32 + +if {[string compare test [info procs test]] == 1} then {source defs} + +proc traceScalar {name1 name2 op} { + global info + set info [list $name1 $name2 $op [catch {uplevel set $name1} msg] $msg] +} +proc traceScalarAppend {name1 name2 op} { + global info + lappend info $name1 $name2 $op [catch {uplevel set $name1} msg] $msg +} +proc traceArray {name1 name2 op} { + global info + set info [list $name1 $name2 $op [catch {uplevel set [set name1]($name2)} msg] $msg] +} +proc traceProc {name1 name2 op} { + global info + set info [concat $info [list $name1 $name2 $op]] +} +proc traceTag {tag args} { + global info + set info [concat $info $tag] +} +proc traceError {args} { + error "trace returned error" +} +proc traceCheck {cmd args} { + global info + set info [list [catch $cmd msg] $msg] +} +proc traceCrtElement {value name1 name2 op} { + uplevel set ${name1}($name2) $value +} + +# Read-tracing on variables + +test trace-1.1 {trace variable reads} { + catch {unset x} + set info {} + trace var x r 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}}} +test trace-1.2 {trace variable reads} { + catch {unset x} + set x 123 + set info {} + trace var x r traceScalar + list [catch {set x} msg] $msg $info +} {0 123 {x {} r 0 123}} +test trace-1.3 {trace variable reads} { + catch {unset x} + set info {} + trace var x r 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 + 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}}} +test trace-1.5 {trace array element reads} { + catch {unset x} + set x(2) zzz + set info {} + trace var x(2) r traceArray + list [catch {set x(2)} msg] $msg $info +} {0 zzz {x 2 r 0 zzz}} +test trace-1.6 {trace reads on whole arrays} { + catch {unset x} + set info {} + trace var x r traceArray + list [catch {set x(2)} msg] $msg $info +} {1 {can't read "x(2)": no such variable} {}} +test trace-1.7 {trace reads on whole arrays} { + catch {unset x} + set x(2) zzz + set info {} + trace var x r traceArray + list [catch {set x(2)} msg] $msg $info +} {0 zzz {x 2 r 0 zzz}} +test trace-1.8 {trace variable reads} { + catch {unset x} + set x 444 + set info {} + trace var x r traceScalar + unset x + set info +} {} + +# Basic write-tracing on variables + +test trace-2.1 {trace variable writes} { + catch {unset x} + set info {} + trace var x w traceScalar + set x 123 + set info +} {x {} w 0 123} +test trace-2.2 {trace writes to array elements} { + catch {unset x} + set info {} + trace var x(33) w traceArray + set x(33) 444 + set info +} {x 33 w 0 444} +test trace-2.3 {trace writes on whole arrays} { + catch {unset x} + set info {} + trace var x w traceArray + set x(abc) qq + set info +} {x abc w 0 qq} +test trace-2.4 {trace variable writes} { + catch {unset x} + set x 1234 + set info {} + trace var x w traceScalar + set x + set info +} {} +test trace-2.5 {trace variable writes} { + catch {unset x} + set x 1234 + set info {} + trace var x w traceScalar + unset x + set info +} {} + +test trace-3.1 {trace variable read-modify-writes} { + catch {unset x} + set info {} + trace var x r traceScalarAppend + append x 123 + append x 456 + lappend x 789 + set info +} {x {} r 1 {can't read "x": no such variable} x {} r 0 123 x {} r 0 123456} +test trace-3.2 {trace variable read-modify-writes} { + catch {unset x} + set info {} + trace var x rw traceScalarAppend + append x 123 + lappend x 456 + set info +} {x {} r 1 {can't read "x": no such variable} x {} w 0 123 x {} r 0 123 x {} w 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 + catch {unset x} + set info +} {x {} u 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 + unset x + set info +} {x {} u 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 + set x 44 + set x + set info +} {} +test trace-4.4 {trace unsets on array elements} { + catch {unset x} + set x(0) 18 + set info {} + trace var x(1) u traceArray + catch {unset x(1)} + set info +} {x 1 u 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 + unset x(1) + set info +} {x 1 u 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 + unset x + set info +} {x 1 u 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 + catch {unset x(0)} + set info +} {} +test trace-4.8 {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 + unset x(1) + set info +} {x 1 u} +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 + unset x + set info +} {x {} u} + +# Trace multiple trace types at once. + +test trace-5.1 {multiple ops traced at once} { + catch {unset x} + set info {} + trace var x rwu 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} { + catch {unset x} + set info {} + trace var x(0) rwu traceProc + catch {set x(0)} + set x(0) 22 + set x(0) + set x(0) 33 + 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} { + catch {unset x} + set info {} + trace var x rwu traceProc + catch {set x(0)} + set x(0) 22 + set x(0) + set x(0) 33 + unset x(0) + unset x + set info +} {x 0 w x 0 r x 0 w x 0 u x {} u} + +# Check order of invocation of traces + +test trace-6.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" + 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} { + 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" + set x(0) + set info +} {3 2 1} +test trace-6.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" + 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} { + catch {unset x} + set x 123 + set info {} + trace var x r "traceTag 1" + trace var x r traceError + list [catch {set x} msg] $msg $info +} {1 {can't read "x": trace returned error} {}} +test trace-7.2 {error returns from traces} { + catch {unset x} + set x 123 + set info {} + trace var x w "traceTag 1" + trace var x w 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} { + catch {unset x} + set x 123 + set info {} + trace var x r traceError + trace var x w traceScalar + list [catch {append x 44} msg] $msg $info +} {1 {can't read "x": trace returned error} {}} +test trace-7.4 {error returns from traces} { + catch {unset x} + set x 123 + set info {} + trace var x u "traceTag 1" + trace var x u traceError + list [catch {unset x} msg] $msg $info +} {0 {} 1} +test trace-7.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" + 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} { + catch {unset x} + set x 123 + trace var x u traceError + list [catch {unset x} msg] $msg +} {0 {}} +test trace-7.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 + catch {set x} + catch {set x} + trace vdelete x r traceError +} {} + +# 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} { + catch {unset x} + set x 33 + set info {} + trace var x u {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} { + catch {unset x} + set x 33 + set info {} + trace var x u {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} { + catch {unset x} + set x 33 + set info {} + trace var x u {traceCheck {uplevel trace vinfo x}} + unset x + set info +} {0 {}} +test trace-8.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}} + unset x + concat $info [trace vinfo x] +} {0 {} {u traceProc}} + +test trace-9.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)}} + 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} { + catch {unset x} + set x(0) 33 + set info {} + trace var x(0) u {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} { + catch {unset x} + set x(0) 33 + set info {} + trace var x(0) u {traceCheck {global x; trace vinfo x(0)}} + unset x(0) + set info +} {0 {}} +test trace-9.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 {}}}} + catch {unset x(0)} + concat $info [trace vinfo x(0)] +} {0 {} {r {}}} + +test trace-10.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)}} + 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} { + catch {unset x} + set x(y) 33 + set info {} + trace var x u {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} { + catch {unset x} + set x(y) 33 + set info {} + trace var x u {traceCheck {uplevel array exists x}} + unset x + set info +} {0 0} +test trace-10.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 + unset x + set info +} {0 {}} +test trace-10.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 {}}} + unset x + concat $info [trace vinfo x] +} {0 {} {r {}}} +test trace-10.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}} + 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} { + catch {unset x} + set info {} + trace var x(0) w 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} { + catch {unset x} + set info {} + trace var x(0) w 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} { + catch {unset x} + set info {} + trace var x(0) w traceProc + set x(0) 22 + set info +} {x 0 w} +test trace-11.4 {creating variable when setting variable traces} { + catch {unset x} + set info {} + trace var x w 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} { + catch {unset x} + set info {} + trace var x w traceProc + set x 22 + set info +} {x {} w} +test trace-11.6 {creating variable when setting variable traces} { + catch {unset x} + set info {} + trace var x w traceProc + set x(0) 22 + set info +} {x 0 w} +test trace-11.7 {create array element during read trace} { + catch {unset x} + set x(2) zzz + trace var x r {traceCrtElement xyzzy} + list [catch {set x(3)} msg] $msg +} {0 xyzzy} +test trace-11.8 {errors when setting variable traces} { + catch {unset x} + set x 44 + list [catch {trace var x(0) w 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} { + proc delTraces {args} { + global x + trace vdel x r {traceTag 2} + trace vdel x r {traceTag 3} + trace vdel x r {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} + set x + set info +} {5 1} + +# Check operation and syntax of "trace" command. + +test trace-13.1 {trace command (overall)} { + list [catch {trace} msg] $msg +} {1 {too few args: should be "trace option [arg arg ...]"}} +test trace-13.2 {trace command (overall)} { + list [catch {trace gorp} msg] $msg +} {1 {bad option "gorp": should be variable, vdelete, or vinfo}} +test trace-13.3 {trace command ("variable" option)} { + 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 +} {} +test trace-13.10 {trace command ("vdelete" option)} { + catch {unset x} + set info {} + trace var x w traceProc + trace vdelete x w traceProc + set x 12345 + set info +} {} +test trace-13.11 {trace command ("vdelete" option)} { + catch {unset x} + set info {} + trace var x w {traceTag 1} + trace var x w traceProc + trace var x w {traceTag 2} + set x yy + trace vdelete x w traceProc + set x 12345 + trace vdelete x w {traceTag 1} + set x foo + trace vdelete x w {traceTag 2} + set x gorp + set info +} {2 x {} w 1 2 1 2} +test trace-13.12 {trace command ("vdelete" option)} { + catch {unset x} + set info {} + trace var x w {traceTag 1} + trace vdelete x w 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-13.17 {trace command ("vinfo" option)} { + catch {unset x} + trace vinfo x(0) +} {} +test trace-13.18 {trace command ("vinfo" option)} { + catch {unset x} + set x 44 + trace vinfo x(0) +} {} +test trace-13.19 {trace command ("vinfo" option)} { + catch {unset x} + set x 44 + trace var x w {traceTag 1} + proc check {} {global x; trace vinfo x} + check +} {{w {traceTag 1}}} + +# Check fancy trace commands (long ones, weird arguments, etc.) + +test trace-14.1 {long trace command} { + catch {unset x} + set info {} + trace var x w {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 \ + invoking this test over and over again will eventually leak memory.}} + set x 44 + set info +} {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 \ + invoking this test over and over again will eventually leak memory.} +test trace-14.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 + set x 44 + set x 5 + set x abcde +} abcde +test trace-14.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 + set "x y z(a\n\{)" 33 + set info +} "{x y z} a\\n\\{ w" + +# Check for proper handling of unsets during traces. + +proc traceUnset {unsetName args} { + global info + upvar $unsetName x + lappend info [catch {unset x} msg] $msg [catch {set x} msg] $msg +} +proc traceReset {unsetName resetName args} { + global info + upvar $unsetName x $resetName y + lappend info [catch {unset x} msg] $msg [catch {set y xyzzy} msg] $msg +} +proc traceReset2 {unsetName resetName args} { + global info + lappend info [catch {uplevel unset $unsetName} msg] $msg \ + [catch {uplevel set $resetName xyzzy} msg] $msg +} +proc traceAppend {string name1 name2 op} { + global info + lappend info $string +} + +test trace-15.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} + 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} { + catch {unset y} + set y(0) 1234 + set info {} + trace var y(0) r {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} { + catch {unset y} + set y(0) 1234 + set info {} + trace var y(0) r {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} { + catch {unset y} + set y 1234 + set info {} + trace var y r {traceReset y y} + lappend info [catch {set y} msg] $msg +} {0 {} 0 xyzzy 0 xyzzy} +test trace-15.5 {unsets during read traces} { + catch {unset y} + set y(0) 1234 + set info {} + trace var y(0) r {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} { + catch {unset y} + set y(0) 1234 + set info {} + trace var y(0) r {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} { + catch {unset y} + set y(0) 1234 + set info {} + trace var y(0) r {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} { + catch {unset y} + set y 1234 + set info {} + trace var y w {traceUnset y} + trace var y u {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} { + catch {unset y} + set y(0) 1234 + set info {} + trace var y(0) w {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} { + catch {unset y} + set y(0) 1234 + set info {} + trace var y(0) w {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} { + catch {unset y} + set y 1234 + set info {} + trace var y w {traceReset y y} + lappend info [catch {set y xxx} msg] $msg +} {0 {} 0 xyzzy 0 xyzzy} +test trace-15.12 {unsets during write traces} { + catch {unset y} + set y(0) 1234 + set info {} + trace var y(0) w {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} { + catch {unset y} + set y(0) 1234 + set info {} + trace var y(0) w {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} { + catch {unset y} + set y(0) 1234 + set info {} + trace var y(0) w {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} { + catch {unset y} + set y 1234 + set info {} + trace var y u {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} { + catch {unset y} + set y(0) 1234 + set info {} + trace var y(0) u {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} { + catch {unset y} + set y(0) 1234 + set info {} + trace var y(0) u {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} { + catch {unset y} + set y 1234 + set info {} + trace var y u {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} { + catch {unset y} + set y(0) 1234 + set info {} + trace var y(0) u {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} { + catch {unset y} + set y(0) 1234 + set info {} + trace var y(0) u {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} { + 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} + 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} { + 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} + 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} { + catch {unset x} + set info {} + trace var x u {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} { + catch {unset x} + proc p1 {} {global x; trace var x w traceProc} + p1 + trace vinfo x +} {{w traceProc}} +test trace-16.3 {traced variables must survive procedure exits} { + catch {unset x} + set info {} + proc p1 {} {global x; trace var x w traceProc} + p1 + set x 44 + set info +} {x {} w} + +# Be sure that procedure frames are released before unset traces +# are invoked. + +test trace-17.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}]}}} + set info {} + p1 foo bar + set info +} {0 {a x y}} + +# Delete arrays when done, so they can be re-used as scalars +# elsewhere. + +catch {unset x} +catch {unset y} +concat {} diff --git a/contrib/tcl/tests/unknown.test b/contrib/tcl/tests/unknown.test new file mode 100644 index 0000000..fd41109 --- /dev/null +++ b/contrib/tcl/tests/unknown.test @@ -0,0 +1,60 @@ +# Commands covered: unknown +# +# 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) 1991-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: @(#) unknown.test 1.11 96/02/16 08:56:34 + +if {[string compare test [info procs test]] == 1} then {source defs} + +catch {rename unknown unknown.old} + +test unknown-1.1 {non-existent "unknown" command} { + list [catch {_non-existent_ foo bar} msg] $msg +} {1 {invalid command name "_non-existent_"}} + +proc unknown {args} { + global x + set x $args +} + +test unknown-2.1 {calling "unknown" command} { + foobar x y z + set x +} {foobar x y z} +test unknown-2.2 {calling "unknown" command with lots of args} { + foobar 1 2 3 4 5 6 7 + set x +} {foobar 1 2 3 4 5 6 7} +test unknown-2.3 {calling "unknown" command with lots of args} { + foobar 1 2 3 4 5 6 7 8 + set x +} {foobar 1 2 3 4 5 6 7 8} +test unknown-2.4 {calling "unknown" command with lots of args} { + foobar 1 2 3 4 5 6 7 8 9 + set x +} {foobar 1 2 3 4 5 6 7 8 9} + +test unknown-3.1 {argument quoting in calls to "unknown"} { + foobar \{ \} a\{b \; "\\" \$a a\[b \] + set x +} "foobar \\{ \\} a\\{b {;} \\\\ {\$a} {a\[b} \\]" + +proc unknown args { + error "unknown failed" +} + +test unknown-4.1 {errors in "unknown" procedure} { + list [catch {non-existent a b} msg] $msg $errorCode +} {1 {unknown failed} NONE} + +catch {rename unknown {}} +catch {rename unknown.old unknown} +return {} diff --git a/contrib/tcl/tests/uplevel.test b/contrib/tcl/tests/uplevel.test new file mode 100644 index 0000000..84daa03 --- /dev/null +++ b/contrib/tcl/tests/uplevel.test @@ -0,0 +1,109 @@ +# Commands covered: uplevel +# +# 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) 1991-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: @(#) uplevel.test 1.13 96/02/16 08:56:35 + +if {[string compare test [info procs test]] == 1} then {source defs} + +proc a {x y} { + newset z [expr $x+$y] + return $z +} +proc newset {name value} { + uplevel set $name $value + uplevel 1 {uplevel 1 {set xyz 22}} +} + +test uplevel-1.1 {simple operation} { + set xyz 0 + a 22 33 +} 55 +test uplevel-1.2 {command is another uplevel command} { + set xyz 0 + a 22 33 + set xyz +} 22 + +proc a1 {} { + b1 + global a a1 + set a $x + set a1 $y +} +proc b1 {} { + c1 + global b b1 + set b $x + set b1 $y +} +proc c1 {} { + uplevel 1 set x 111 + uplevel #2 set y 222 + uplevel 2 set x 333 + uplevel #1 set y 444 + uplevel 3 set x 555 + uplevel #0 set y 666 +} +a1 +test uplevel-2.1 {relative and absolute uplevel} {set a} 333 +test uplevel-2.2 {relative and absolute uplevel} {set a1} 444 +test uplevel-2.3 {relative and absolute uplevel} {set b} 111 +test uplevel-2.4 {relative and absolute uplevel} {set b1} 222 +test uplevel-2.5 {relative and absolute uplevel} {set x} 555 +test uplevel-2.6 {relative and absolute uplevel} {set y} 666 + +test uplevel-3.1 {uplevel to same level} { + set x 33 + uplevel #0 set x 44 + set x +} 44 +test uplevel-3.2 {uplevel to same level} { + set x 33 + uplevel 0 set x +} 33 +test uplevel-3.3 {uplevel to same level} { + set y xxx + proc a1 {} {set y 55; uplevel 0 set y 66; return $y} + a1 +} 66 +test uplevel-3.4 {uplevel to same level} { + set y zzz + proc a1 {} {set y 55; uplevel #1 set y} + a1 +} 55 + +test uplevel-4.1 {error: non-existent level} { + list [catch c1 msg] $msg +} {1 {bad level "#2"}} +test uplevel-4.2 {error: non-existent level} { + proc c2 {} {uplevel 3 {set a b}} + list [catch c2 msg] $msg +} {1 {bad level "3"}} +test uplevel-4.3 {error: not enough args} { + list [catch uplevel msg] $msg +} {1 {wrong # args: should be "uplevel ?level? command ?arg ...?"}} +test uplevel-4.4 {error: not enough args} { + proc upBug {} {uplevel 1} + list [catch upBug msg] $msg +} {1 {wrong # args: should be "uplevel ?level? command ?arg ...?"}} + +proc a2 {} { + uplevel a3 +} +proc a3 {} { + global x y + set x [info level] + set y [info level 1] +} +a2 +test uplevel-5.1 {info level} {set x} 1 +test uplevel-5.2 {info level} {set y} a3 diff --git a/contrib/tcl/tests/upvar.test b/contrib/tcl/tests/upvar.test new file mode 100644 index 0000000..accc74c --- /dev/null +++ b/contrib/tcl/tests/upvar.test @@ -0,0 +1,377 @@ +# Commands covered: upvar +# +# 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) 1991-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: @(#) upvar.test 1.11 96/02/28 21:45:36 + +if {[string compare test [info procs test]] == 1} then {source defs} + +test upvar-1.1 {reading variables with upvar} { + proc p1 {a b} {set c 22; set d 33; p2} + proc p2 {} {upvar a x1 b x2 c x3 d x4; set a abc; list $x1 $x2 $x3 $x4 $a} + p1 foo bar +} {foo bar 22 33 abc} +test upvar-1.2 {reading variables with upvar} { + proc p1 {a b} {set c 22; set d 33; p2} + proc p2 {} {p3} + proc p3 {} {upvar 2 a x1 b x2 c x3 d x4; set a abc; list $x1 $x2 $x3 $x4 $a} + p1 foo bar +} {foo bar 22 33 abc} +test upvar-1.3 {reading variables with upvar} { + proc p1 {a b} {set c 22; set d 33; p2} + proc p2 {} {p3} + proc p3 {} { + upvar #1 a x1 b x2 c x3 d x4 + set a abc + list $x1 $x2 $x3 $x4 $a + } + p1 foo bar +} {foo bar 22 33 abc} +test upvar-1.4 {reading variables with upvar} { + set x1 44 + set x2 55 + proc p1 {} {p2} + proc p2 {} { + upvar 2 x1 x1 x2 a + upvar #0 x1 b + set c $b + incr b 3 + list $x1 $a $b + } + p1 +} {47 55 47} +test upvar-1.5 {reading array elements with upvar} { + proc p1 {} {set a(0) zeroth; set a(1) first; p2} + proc p2 {} {upvar a(0) x; set x} + p1 +} {zeroth} + +test upvar-2.1 {writing variables with upvar} { + proc p1 {a b} {set c 22; set d 33; p2; list $a $b $c $d} + proc p2 {} { + upvar a x1 b x2 c x3 d x4 + set x1 14 + set x4 88 + } + p1 foo bar +} {14 bar 22 88} +test upvar-2.2 {writing variables with upvar} { + set x1 44 + set x2 55 + proc p1 {x1 x2} { + upvar #0 x1 a + upvar x2 b + set a $x1 + set b $x2 + } + p1 newbits morebits + list $x1 $x2 +} {newbits morebits} +test upvar-2.3 {writing variables with upvar} { + catch {unset x1} + catch {unset x2} + proc p1 {x1 x2} { + upvar #0 x1 a + upvar x2 b + set a $x1 + set b $x2 + } + p1 newbits morebits + list [catch {set x1} msg] $msg [catch {set x2} msg] $msg +} {0 newbits 0 morebits} +test upvar-2.4 {writing array elements with upvar} { + proc p1 {} {set a(0) zeroth; set a(1) first; list [p2] $a(0)} + proc p2 {} {upvar a(0) x; set x xyzzy} + p1 +} {xyzzy xyzzy} + +test upvar-3.1 {unsetting variables with upvar} { + proc p1 {a b} {set c 22; set d 33; p2; lsort [info vars]} + proc p2 {} { + upvar 1 a x1 d x2 + unset x1 x2 + } + p1 foo bar +} {b c} +test upvar-3.2 {unsetting variables with upvar} { + proc p1 {a b} {set c 22; set d 33; p2; lsort [info vars]} + proc p2 {} { + upvar 1 a x1 d x2 + unset x1 x2 + set x2 28 + } + p1 foo bar +} {b c d} +test upvar-3.3 {unsetting variables with upvar} { + set x1 44 + set x2 55 + proc p1 {} {p2} + proc p2 {} { + upvar 2 x1 a + upvar #0 x2 b + unset a b + } + p1 + list [info exists x1] [info exists x2] +} {0 0} +test upvar-3.4 {unsetting variables with upvar} { + set x1 44 + set x2 55 + proc p1 {} { + upvar x1 a x2 b + unset a b + set b 118 + } + p1 + list [info exists x1] [catch {set x2} msg] $msg +} {0 0 118} +test upvar-3.5 {unsetting array elements with upvar} { + proc p1 {} { + set a(0) zeroth + set a(1) first + set a(2) second + p2 + array names a + } + proc p2 {} {upvar a(0) x; unset x} + p1 +} {1 2} +test upvar-3.6 {unsetting then resetting array elements with upvar} { + proc p1 {} { + set a(0) zeroth + set a(1) first + set a(2) second + p2 + list [array names a] [catch {set a(0)} msg] $msg + } + proc p2 {} {upvar a(0) x; unset x; set x 12345} + p1 +} {{0 1 2} 0 12345} + +test upvar-4.1 {nested upvars} { + set x1 88 + proc p1 {a b} {set c 22; set d 33; p2} + proc p2 {} {global x1; upvar c x2; p3} + proc p3 {} { + upvar x1 a x2 b + list $a $b + } + p1 14 15 +} {88 22} +test upvar-4.2 {nested upvars} { + set x1 88 + proc p1 {a b} {set c 22; set d 33; p2; list $a $b $c $d} + proc p2 {} {global x1; upvar c x2; p3} + proc p3 {} { + upvar x1 a x2 b + set a foo + set b bar + } + list [p1 14 15] $x1 +} {{14 15 bar 33} foo} + +proc tproc {args} {global x; set x [list $args [uplevel info vars]]} +test upvar-5.1 {traces involving upvars} { + proc p1 {a b} {set c 22; set d 33; trace var c rw tproc; p2} + proc p2 {} {upvar c x1; set x1 22} + set x --- + p1 foo bar + set x +} {{x1 {} w} x1} +test upvar-5.2 {traces involving upvars} { + proc p1 {a b} {set c 22; set d 33; trace var c rw tproc; p2} + proc p2 {} {upvar c x1; set x1} + set x --- + p1 foo bar + set x +} {{x1 {} r} x1} +test upvar-5.3 {traces involving upvars} { + proc p1 {a b} {set c 22; set d 33; trace var c rwu tproc; p2} + proc p2 {} {upvar c x1; unset x1} + set x --- + p1 foo bar + set x +} {{x1 {} u} x1} + +test upvar-6.1 {retargeting an upvar} { + proc p1 {} { + set a(0) zeroth + set a(1) first + set a(2) second + p2 + } + proc p2 {} { + upvar a x + set result {} + foreach i [array names x] { + upvar a($i) x + lappend result $x + } + lsort $result + } + p1 +} {first second zeroth} +test upvar-6.2 {retargeting an upvar} { + set x 44 + set y abcde + proc p1 {} { + global x + set result $x + upvar y x + lappend result $x + } + p1 +} {44 abcde} +test upvar-6.3 {retargeting an upvar} { + set x 44 + set y abcde + proc p1 {} { + upvar y x + lappend result $x + global x + lappend result $x + } + p1 +} {abcde 44} + +test upvar-7.1 {upvar to same level} { + set x 44 + set y 55 + catch {unset uv} + upvar #0 x uv + set uv abc + upvar 0 y uv + set uv xyzzy + list $x $y +} {abc xyzzy} +test upvar-7.2 {upvar to same level} { + set x 1234 + set y 4567 + proc p1 {x y} { + upvar 0 x uv + set uv $y + return "$x $y" + } + p1 44 89 +} {89 89} +test upvar-7.3 {upvar to same level} { + set x 1234 + set y 4567 + proc p1 {x y} { + upvar #1 x uv + set uv $y + return "$x $y" + } + p1 xyz abc +} {abc abc} +test upvar-7.4 {upvar to same level: tricky problems when deleting variable table} { + proc tt {} {upvar #1 toto loc; return $loc} + list [catch tt msg] $msg +} {1 {can't read "loc": no such variable}} +test upvar-7.5 {potential memory leak when deleting variable table} { + proc leak {} { + array set foo {1 2 3 4} + upvar 0 foo(1) bar + } + leak +} {} + +test upvar-8.1 {errors in upvar command} { + list [catch upvar msg] $msg +} {1 {wrong # args: should be "upvar ?level? otherVar localVar ?otherVar localVar ...?"}} +test upvar-8.2 {errors in upvar command} { + list [catch {upvar 1} msg] $msg +} {1 {wrong # args: should be "upvar ?level? otherVar localVar ?otherVar localVar ...?"}} +test upvar-8.3 {errors in upvar command} { + proc p1 {} {upvar a b c} + list [catch p1 msg] $msg +} {1 {wrong # args: should be "upvar ?level? otherVar localVar ?otherVar localVar ...?"}} +test upvar-8.4 {errors in upvar command} { + proc p1 {} {upvar 0 b b} + list [catch p1 msg] $msg +} {1 {can't upvar from variable to itself}} +test upvar-8.5 {errors in upvar command} { + proc p1 {} {upvar 0 a b; upvar 0 b a} + list [catch p1 msg] $msg +} {1 {can't upvar from variable to itself}} +test upvar-8.6 {errors in upvar command} { + proc p1 {} {set a 33; upvar b a} + list [catch p1 msg] $msg +} {1 {variable "a" already exists}} +test upvar-8.7 {errors in upvar command} { + proc p1 {} {trace variable a w foo; upvar b a} + list [catch p1 msg] $msg +} {1 {variable "a" has traces: can't use for upvar}} + +if {[info commands testupvar] != {}} { + test upvar-9.1 {Tcl_UpVar2 procedure} { + list [catch {testupvar xyz a {} x global} msg] $msg + } {1 {bad level "xyz"}} + test upvar-9.2 {Tcl_UpVar2 procedure} { + catch {unset a} + catch {unset x} + set a 44 + list [catch {testupvar #0 a 1 x global} msg] $msg + } {1 {can't access "a(1)": variable isn't array}} + test upvar-9.3 {Tcl_UpVar2 procedure} { + proc foo {} { + testupvar 1 a {} x local + set x + } + catch {unset a} + catch {unset x} + set a 44 + foo + } {44} + test upvar-9.4 {Tcl_UpVar2 procedure} { + proc foo {} { + testupvar 1 a {} _up_ global + list [catch {set x} msg] $msg + } + catch {unset a} + catch {unset _up_} + set a 44 + concat [foo] $_up_ + } {1 {can't read "x": no such variable} 44} + test upvar-9.5 {Tcl_UpVar2 procedure} { + proc foo {} { + testupvar 1 a b x local + set x + } + catch {unset a} + catch {unset x} + set a(b) 1234 + foo + } {1234} + test upvar-9.6 {Tcl_UpVar procedure} { + proc foo {} { + testupvar 1 a x local + set x + } + catch {unset a} + catch {unset x} + set a xyzzy + foo + } {xyzzy} + test upvar-9.7 {Tcl_UpVar procedure} { + proc foo {} { + testupvar #0 a(b) x local + set x + } + catch {unset a} + catch {unset x} + set a(b) 1234 + foo + } {1234} +} +catch {unset a} + +concat diff --git a/contrib/tcl/tests/while.test b/contrib/tcl/tests/while.test new file mode 100644 index 0000000..ad3d328 --- /dev/null +++ b/contrib/tcl/tests/while.test @@ -0,0 +1,99 @@ +# Commands covered: while +# +# 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) 1991-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: @(#) while.test 1.9 96/02/16 08:56:37 + +if {[string compare test [info procs test]] == 1} then {source defs} + +test while-1.1 {basic while loops} { + set count 0 + while {$count < 10} {set count [expr $count+1]} + set count +} 10 +test while-1.2 {basic while loops} { + set value xxx + while {2 > 3} {set value yyy} + set value +} xxx +test while-1.3 {basic while loops} { + set value 1 + while {"true"} { + incr value; + if {$value > 5} { + break; + } + } + set value +} 6 + +test while-2.1 {continue in while loop} { + set list {1 2 3 4 5} + set index 0 + set result {} + while {$index < 5} { + if {$index == 2} {set index [expr $index+1]; continue} + set result [concat $result [lindex $list $index]] + set index [expr $index+1] + } + set result +} {1 2 4 5} + +test while-3.1 {break in while loop} { + set list {1 2 3 4 5} + set index 0 + set result {} + while {$index < 5} { + if {$index == 3} break + set result [concat $result [lindex $list $index]] + set index [expr $index+1] + } + set result +} {1 2 3} + +test while-4.1 {errors in while loops} { + set err [catch {while} msg] + list $err $msg +} {1 {wrong # args: should be "while test command"}} +test while-4.2 {errors in while loops} { + set err [catch {while 1} msg] + list $err $msg +} {1 {wrong # args: should be "while test command"}} +test while-4.3 {errors in while loops} { + set err [catch {while 1 2 3} msg] + list $err $msg +} {1 {wrong # args: should be "while test command"}} +test while-4.4 {errors in while loops} { + set err [catch {while {"a"+"b"} {error "loop aborted"}} msg] + list $err $msg +} {1 {can't use non-numeric string as operand of "+"}} +test while-4.5 {errors in while loops} { + set x 1 + set err [catch {while {$x} {set x foo}} msg] + list $err $msg +} {1 {expected boolean value but got "foo"}} +test while-4.6 {errors in while loops} { + set err [catch {while {1} {error "loop aborted"}} msg] + list $err $msg $errorInfo +} {1 {loop aborted} {loop aborted + while executing +"error "loop aborted"" + ("while" body line 1) + invoked from within +"while {1} {error "loop aborted"}"}} + +test while-5.1 {while return result} { + while {0} {set a 400} +} {} +test while-5.2 {while return result} { + set x 1 + while {$x} {set x 0} +} {} diff --git a/contrib/tcl/unix/Makefile.in b/contrib/tcl/unix/Makefile.in new file mode 100644 index 0000000..b89bb43 --- /dev/null +++ b/contrib/tcl/unix/Makefile.in @@ -0,0 +1,747 @@ +# +# This file is a Makefile for Tcl. If it has the name "Makefile.in" +# then it is a template for a Makefile; to generate the actual Makefile, +# run "./configure", which is a configuration script generated by the +# "autoconf" program (constructs like "@foo@" will get replaced in the +# actual Makefile. +# +# SCCS: @(#) Makefile.in 1.130 96/04/18 16:55:37 + +# Current Tcl version; used in various names. + +VERSION = @TCL_VERSION@ + +#---------------------------------------------------------------- +# Things you can change to personalize the Makefile for your own +# site (you can make these changes in either Makefile.in or +# Makefile, but changes to Makefile will get lost if you re-run +# the configuration script). +#---------------------------------------------------------------- + +# Default top-level directories in which to install architecture- +# specific files (exec_prefix) and machine-independent files such +# as scripts (prefix). The values specified here may be overridden +# at configure-time with the --exec-prefix and --prefix options +# to the "configure" script. + +prefix = @prefix@ +exec_prefix = @exec_prefix@ + +# The following definition can be set to non-null for special systems +# like AFS with replication. It allows the pathnames used for installation +# to be different than those used for actually reference files at +# run-time. INSTALL_ROOT is prepended to $prefix and $exec_prefix +# when installing files. +INSTALL_ROOT = + +# 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): +TCL_LIBRARY = $(prefix)/lib/tcl$(VERSION) + +# Path name to use when installing library scripts: +SCRIPT_INSTALL_DIR = $(INSTALL_ROOT)$(TCL_LIBRARY) + +# Directory in which to install libtcl.so or libtcl.a: +LIB_INSTALL_DIR = $(INSTALL_ROOT)$(exec_prefix)/lib + +# Directory in which to install the program tclsh: +BIN_INSTALL_DIR = $(INSTALL_ROOT)$(exec_prefix)/bin + +# Directory in which to install the include file tcl.h: +INCLUDE_INSTALL_DIR = $(INSTALL_ROOT)$(prefix)/include + +# Top-level directory in which to install manual entries: +MAN_INSTALL_DIR = $(INSTALL_ROOT)$(prefix)/man + +# Directory in which to install manual entry for tclsh: +MAN1_INSTALL_DIR = $(MAN_INSTALL_DIR)/man1 + +# Directory in which to install manual entries for Tcl's C library +# procedures: +MAN3_INSTALL_DIR = $(MAN_INSTALL_DIR)/man3 + +# Directory in which to install manual entries for the built-in +# Tcl commands: +MANN_INSTALL_DIR = $(MAN_INSTALL_DIR)/mann + +# To change the compiler switches, for example to change from -O +# to -g, change the following line: +CFLAGS = -O + +# To disable ANSI-C procedure prototypes reverse the comment characters +# on the following lines: +PROTO_FLAGS = +#PROTO_FLAGS = -DNO_PROTOTYPE + +# Mathematical functions like sin and atan2 are enabled for expressions +# by default. To disable them, reverse the comment characters on the +# following pairs of lines: +MATH_FLAGS = +#MATH_FLAGS = -DTCL_NO_MATH +MATH_LIBS = @MATH_LIBS@ +#MATH_LIBS = + +# If you use the setenv, putenv, or unsetenv procedures to modify +# environment variables in your application and you'd like those +# modifications to appear in the "env" Tcl variable, switch the +# comments on the two lines below so that Tcl provides these +# procedures instead of your standard C library. + +ENV_FLAGS = +#ENV_FLAGS = -DTclSetEnv=setenv -DTcl_PutEnv=putenv -DTclUnsetEnv=unsetenv + +# To compile for non-UNIX systems (so that only the non-UNIX-specific +# commands are available), reverse the comment characters on the +# following pairs of lines. In addition, you'll have to provide your +# own replacement for the "panic" procedure (see panic.c for what +# the current one does). +GENERIC_FLAGS = +#GENERIC_FLAGS = -DTCL_GENERIC_ONLY +UNIX_OBJS = tclMtherr.o tclUnixChan.o tclUnixFile.o \ + tclUnixNotfy.o tclUnixPipe.o tclUnixSock.o tclUnixTime.o \ + tclUnixInit.o +#UNIX_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. +MEM_DEBUG_FLAGS = +#MEM_DEBUG_FLAGS = -DTCL_MEM_DEBUG + +# Some versions of make, like SGI's, use the following variable to +# determine which shell to use for executing commands: +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} +INSTALL_DATA = ${INSTALL} -m 644 + +# 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 symbols below provide support for dynamic loading and shared +# libraries. See configure.in for a description of what the +# symbols mean. The values of the symbols are normally set by the +# configure script. You shouldn't normally need to modify any of +# these definitions by hand. + +SHLIB_LD = @SHLIB_LD@ + +SHLIB_SUFFIX = @SHLIB_SUFFIX@ +#SHLIB_SUFFIX = + +DLTEST_TARGETS = dltest/pkg5${SHLIB_SUFFIX} dltest/Makefile + +# The following symbol is defined to "$(DLTEST_TARGETS)" if dynamic +# loading is available; this causes everything in the "dltest" +# subdirectory to be built when making "tcltest. If dynamic loading +# isn't available, configure defines this symbol to an empty string, +# in which case the shared libraries aren't built. +BUILD_DLTEST = @BUILD_DLTEST@ +#BUILD_DLTEST = + +TCL_LIB_FILE = @TCL_LIB_FILE@ +#TCL_LIB_FILE = libtcl.a + +#---------------------------------------------------------------- +# The information below is modified by the configure script when +# Makefile is generated from Makefile.in. You shouldn't normally +# modify any of this stuff by hand. +#---------------------------------------------------------------- + +COMPAT_OBJS = @LIBOBJS@ + +AC_FLAGS = @DEFS@ +RANLIB = @RANLIB@ +SRC_DIR = @srcdir@ +TOP_DIR = @srcdir@/.. +GENERIC_DIR = $(TOP_DIR)/generic +COMPAT_DIR = $(TOP_DIR)/compat +DLTEST_DIR = @srcdir@/dltest +UNIX_DIR = @srcdir@ +CC = @CC@ + +#---------------------------------------------------------------- +# The information below should be usable as is. The configure +# script won't modify it and you shouldn't need to modify it +# either. +#---------------------------------------------------------------- + + +CC_SWITCHES = ${CFLAGS} ${TCL_SHLIB_CFLAGS} -I${GENERIC_DIR} -I${SRC_DIR} \ +${AC_FLAGS} ${MATH_FLAGS} ${GENERIC_FLAGS} ${PROTO_FLAGS} ${MEM_DEBUG_FLAGS} \ +${ENV_FLAGS} -DTCL_SHLIB_EXT=\"${SHLIB_SUFFIX}\" + +LIBS = @DL_LIBS@ @LIBS@ $(MATH_LIBS) -lc + +DEPEND_SWITCHES = ${CFLAGS} -I${GENERIC_DIR} -I${SRC_DIR} \ +${AC_FLAGS} ${MATH_FLAGS} \ +${GENERIC_FLAGS} ${PROTO_FLAGS} ${MEM_DEBUG_FLAGS} \ +-DTCL_SHLIB_EXT=\"${SHLIB_SUFFIX}\" + +TCLSH_OBJS = tclAppInit.o + +TCLTEST_OBJS = tclTestInit.o tclTest.o tclUnixTest.o + +GENERIC_OBJS = panic.o regexp.o tclAsync.o tclBasic.o tclCkalloc.o \ + tclClock.o tclCmdAH.o tclCmdIL.o tclCmdMZ.o tclDate.o tclEnv.o \ + tclEvent.o tclExpr.o tclFHandle.o tclFileName.o tclGet.o tclHash.o \ + tclHistory.o tclInterp.o tclIO.o tclIOCmd.o \ + tclIOSock.o tclIOUtil.o tclLink.o tclLoad.o tclMain.o tclNotify.o \ + tclParse.o tclPkg.o tclPosixStr.o tclPreserve.o tclProc.o \ + tclUtil.o tclVar.o + +OBJS = ${GENERIC_OBJS} ${UNIX_OBJS} ${COMPAT_OBJS} @DL_OBJS@ + +GENERIC_HDRS = \ + $(GENERIC_DIR)/tclRegexp.h \ + $(GENERIC_DIR)/tcl.h \ + $(GENERIC_DIR)/tclInt.h \ + $(GENERIC_DIR)/tclPort.h \ + $(GENERIC_DIR)/patchlevel.h + +GENERIC_SRCS = \ + $(GENERIC_DIR)/regexp.c \ + $(GENERIC_DIR)/tclAsync.c \ + $(GENERIC_DIR)/tclBasic.c \ + $(GENERIC_DIR)/tclCkalloc.c \ + $(GENERIC_DIR)/tclClock.c \ + $(GENERIC_DIR)/tclCmdAH.c \ + $(GENERIC_DIR)/tclCmdIL.c \ + $(GENERIC_DIR)/tclCmdMZ.c \ + $(GENERIC_DIR)/tclDate.c \ + $(GENERIC_DIR)/tclEnv.c \ + $(GENERIC_DIR)/tclEvent.c \ + $(GENERIC_DIR)/tclExpr.c \ + $(GENERIC_DIR)/tclFHandle.c \ + $(GENERIC_DIR)/tclFileName.c \ + $(GENERIC_DIR)/tclGet.c \ + $(GENERIC_DIR)/tclHash.c \ + $(GENERIC_DIR)/tclHistory.c \ + $(GENERIC_DIR)/tclInterp.c \ + $(GENERIC_DIR)/tclIO.c \ + $(GENERIC_DIR)/tclIOCmd.c \ + $(GENERIC_DIR)/tclIOSock.c \ + $(GENERIC_DIR)/tclIOUtil.c \ + $(GENERIC_DIR)/tclLink.c \ + $(GENERIC_DIR)/tclLoad.c \ + $(GENERIC_DIR)/tclMain.c \ + $(GENERIC_DIR)/tclNotify.c \ + $(GENERIC_DIR)/tclParse.c \ + $(GENERIC_DIR)/tclPkg.c \ + $(GENERIC_DIR)/tclPosixStr.c \ + $(GENERIC_DIR)/tclPreserve.c \ + $(GENERIC_DIR)/tclProc.c \ + $(GENERIC_DIR)/tclTest.c \ + $(GENERIC_DIR)/tclUtil.c \ + $(GENERIC_DIR)/tclVar.c + +UNIX_HDRS = \ + $(UNIX_DIR)/tclUnixPort.h + +UNIX_SRCS = \ + $(UNIX_DIR)/tclAppInit.c \ + $(UNIX_DIR)/tclMtherr.c \ + $(UNIX_DIR)/tclUnixChan.c \ + $(UNIX_DIR)/tclUnixFile.c \ + $(UNIX_DIR)/tclUnixNotfy.c \ + $(UNIX_DIR)/tclUnixPipe.c \ + $(UNIX_DIR)/tclUnixSock.c \ + $(UNIX_DIR)/tclUnixTest.c \ + $(UNIX_DIR)/tclUnixTime.c \ + $(UNIX_DIR)/tclUnixInit.c + +DL_SRCS = \ + $(UNIX_DIR)/tclLoadAix.c \ + $(UNIX_DIR)/tclLoadAout.c \ + $(UNIX_DIR)/tclLoadDl.c \ + $(UNIX_DIR)/tclLoadDl2.c \ + $(UNIX_DIR)/tclLoadDld.c \ + $(GENERIC_DIR)/tclLoadNone.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". + +SRCS = $(GENERIC_SRCS) $(UNIX_SRCS) + +all: ${TCL_LIB_FILE} tclsh + +# The following target is configured by autoconf to generate either +# a shared library or non-shared library for Tcl. + +${TCL_LIB_FILE}: ${OBJS} + rm -f ${TCL_LIB_FILE} + @MAKE_LIB@ + $(RANLIB) ${TCL_LIB_FILE} + +tclsh: ${TCLSH_OBJS} ${TCL_LIB_FILE} + ${CC} @LD_FLAGS@ ${TCLSH_OBJS} @TCL_BUILD_LIB_SPEC@ ${LIBS} \ + @TCL_LD_SEARCH_FLAGS@ -o tclsh + +tcltest: ${TCLTEST_OBJS} ${TCL_LIB_FILE} ${BUILD_DLTEST} + ${CC} @LD_FLAGS@ ${TCLTEST_OBJS} @TCL_BUILD_LIB_SPEC@ ${LIBS} \ + @TCL_LD_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. + +test: tcltest + LD_LIBRARY_PATH=`pwd`:${LD_LIBRARY_PATH}; export LD_LIBRARY_PATH; \ + TCL_LIBRARY=${TOP_DIR}/library; export TCL_LIBRARY; \ + ( echo cd $(TOP_DIR)/tests\; source all ) | ./tcltest + +# 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". + +.NO_PARALLEL: topDirName +topDirName: + @cd $(TOP_DIR); pwd + +# The following target generates the file generic/tclDate.c +# from the yacc grammar found in generic/tclGetDate.y. This is +# only run by hand as yacc is not available in all environments. +# The name of the .c file is different than the name of the .y file +# so that make doesn't try to automatically regenerate the .c file. + +gendate: + yacc -l $(GENERIC_DIR)/tclGetDate.y + sed -e 's/yy/TclDate/g' -e '/^#include <values.h>/d' \ + -e 's/SCCSID/%Z\% %M\% %I\% %E\% %U\%/g' \ + -e '/#ifdef __STDC__/,/#endif/d' -e '/TclDateerrlab:/d' \ + -e '/TclDatenewstate:/d' -e '/#pragma/d' \ + <y.tab.c >$(GENERIC_DIR)/tclDate.c + rm y.tab.c + +# The following targets generate 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 + cd dltest; PATH=..:${PATH} TCL_LIBRARY=../../library make + +dltest/Makefile: $(DLTEST_DIR)/configure $(DLTEST_DIR)/Makefile.in tclConfig.sh + if test ! -d dltest; then mkdir dltest; else true; fi + cd dltest; if test -f configure; then ./configure; else \ + $(DLTEST_DIR)/configure; fi + +install: install-binaries install-libraries install-man + +install-binaries: $(TCL_LIB_FILE) tclsh + @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; + @echo "Installing $(TCL_LIB_FILE)" + @$(INSTALL_DATA) $(TCL_LIB_FILE) $(LIB_INSTALL_DIR)/$(TCL_LIB_FILE) + @$(RANLIB) $(LIB_INSTALL_DIR)/$(TCL_LIB_FILE) + @chmod 555 $(LIB_INSTALL_DIR)/$(TCL_LIB_FILE) + @echo "Installing tclsh" + @$(INSTALL_PROGRAM) tclsh $(BIN_INSTALL_DIR)/tclsh$(VERSION) + +install-libraries: + @for i in $(INSTALL_ROOT)$(prefix)/lib $(INCLUDE_INSTALL_DIR) \ + $(SCRIPT_INSTALL_DIR) ; \ + do \ + if [ ! -d $$i ] ; then \ + echo "Making directory $$i"; \ + mkdir $$i; \ + chmod 755 $$i; \ + else true; \ + fi; \ + done; + @echo "Installing tcl.h" + @$(INSTALL_DATA) $(GENERIC_DIR)/tcl.h $(INCLUDE_INSTALL_DIR)/tcl.h + @echo "Installing tclConfig.sh" + @$(INSTALL_DATA) tclConfig.sh $(LIB_INSTALL_DIR)/tclConfig.sh + @for i in $(TOP_DIR)/library/*.tcl $(TOP_DIR)/library/tclIndex $(UNIX_DIR)/tclAppInit.c; \ + do \ + echo "Installing $$i"; \ + $(INSTALL_DATA) $$i $(SCRIPT_INSTALL_DIR); \ + done; + +install-man: + @for i in $(MAN_INSTALL_DIR) $(MAN1_INSTALL_DIR) $(MAN3_INSTALL_DIR) $(MANN_INSTALL_DIR) ; \ + do \ + if [ ! -d $$i ] ; then \ + echo "Making directory $$i"; \ + mkdir $$i; \ + chmod 755 $$i; \ + else true; \ + fi; \ + done; + @cd $(TOP_DIR)/doc; for i in *.1; \ + do \ + echo "Installing doc/$$i"; \ + rm -f $(MAN1_INSTALL_DIR)/$$i; \ + sed -e '/man\.macros/r man.macros' -e '/man\.macros/d' \ + $$i > $(MAN1_INSTALL_DIR)/$$i; \ + chmod 444 $(MAN1_INSTALL_DIR)/$$i; \ + done; + $(UNIX_DIR)/mkLinks $(MAN1_INSTALL_DIR) + @cd $(TOP_DIR)/doc; for i in *.3; \ + do \ + echo "Installing doc/$$i"; \ + rm -f $(MAN3_INSTALL_DIR)/$$i; \ + sed -e '/man\.macros/r man.macros' -e '/man\.macros/d' \ + $$i > $(MAN3_INSTALL_DIR)/$$i; \ + chmod 444 $(MAN3_INSTALL_DIR)/$$i; \ + done; + $(UNIX_DIR)/mkLinks $(MAN3_INSTALL_DIR) + @cd $(TOP_DIR)/doc; for i in *.n; \ + do \ + echo "Installing doc/$$i"; \ + rm -f $(MANN_INSTALL_DIR)/$$i; \ + sed -e '/man\.macros/r man.macros' -e '/man\.macros/d' \ + $$i > $(MANN_INSTALL_DIR)/$$i; \ + chmod 444 $(MANN_INSTALL_DIR)/$$i; \ + done; + $(UNIX_DIR)/mkLinks $(MANN_INSTALL_DIR) + +Makefile: $(UNIX_DIR)/Makefile.in + $(SHELL) config.status + +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 + +distclean: clean + rm -f Makefile config.* tclConfig.sh + if test -f dltest/Makefile; then cd dltest; make distclean; fi + +depend: + makedepend -- $(DEPEND_SWITCHES) -- $(SRCS) + +bp: $(UNIX_DIR)/bp.c + $(CC) $(CC_SWITCHES) $(UNIX_DIR)/bp.c -o bp + +# Test binaries. The rule for tclTestInit.o is complicated because +# it is is compiled from tclAppInit.c. Can't use the "-o" option +# because this doesn't work on some strange compilers (e.g. UnixWare). + +tclTestInit.o: $(UNIX_DIR)/tclAppInit.c + @if test -f tclAppInit.o ; then \ + rm -f tclAppInit.sav; \ + mv tclAppInit.o tclAppInit.sav; \ + fi; + $(CC) -c $(CC_SWITCHES) -DTCL_TEST $(UNIX_DIR)/tclAppInit.c + rm -f tclTestInit.o + mv tclAppInit.o tclTestInit.o + @if test -f tclAppInit.sav ; then \ + mv tclAppInit.sav tclAppInit.o; \ + fi; + +# Object files used on all Unix systems: + +panic.o: $(GENERIC_DIR)/panic.c + $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/panic.c + +regexp.o: $(GENERIC_DIR)/regexp.c + $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/regexp.c + +tclAppInit.o: $(UNIX_DIR)/tclAppInit.c + $(CC) -c $(CC_SWITCHES) $(UNIX_DIR)/tclAppInit.c + +tclAsync.o: $(GENERIC_DIR)/tclAsync.c + $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclAsync.c + +tclBasic.o: $(GENERIC_DIR)/tclBasic.c + $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclBasic.c + +tclCkalloc.o: $(GENERIC_DIR)/tclCkalloc.c + $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclCkalloc.c + +tclClock.o: $(GENERIC_DIR)/tclClock.c + $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclClock.c + +tclCmdAH.o: $(GENERIC_DIR)/tclCmdAH.c + $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclCmdAH.c + +tclCmdIL.o: $(GENERIC_DIR)/tclCmdIL.c + $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclCmdIL.c + +tclCmdMZ.o: $(GENERIC_DIR)/tclCmdMZ.c + $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclCmdMZ.c + +tclDate.o: $(GENERIC_DIR)/tclDate.c + $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclDate.c + +tclEnv.o: $(GENERIC_DIR)/tclEnv.c + $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclEnv.c + +tclEvent.o: $(GENERIC_DIR)/tclEvent.c + $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclEvent.c + +tclExpr.o: $(GENERIC_DIR)/tclExpr.c + $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclExpr.c + +tclFHandle.o: $(GENERIC_DIR)/tclFHandle.c + $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclFHandle.c + +tclFileName.o: $(GENERIC_DIR)/tclFileName.c + $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclFileName.c + +tclGet.o: $(GENERIC_DIR)/tclGet.c + $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclGet.c + +tclHash.o: $(GENERIC_DIR)/tclHash.c + $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclHash.c + +tclHistory.o: $(GENERIC_DIR)/tclHistory.c + $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclHistory.c + +tclInterp.o: $(GENERIC_DIR)/tclInterp.c + $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclInterp.c + +tclIO.o: $(GENERIC_DIR)/tclIO.c + $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclIO.c + +tclIOCmd.o: $(GENERIC_DIR)/tclIOCmd.c + $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclIOCmd.c + +tclIOSock.o: $(GENERIC_DIR)/tclIOSock.c + $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclIOSock.c + +tclIOUtil.o: $(GENERIC_DIR)/tclIOUtil.c + $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclIOUtil.c + +tclLink.o: $(GENERIC_DIR)/tclLink.c + $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclLink.c + +tclLoad.o: $(GENERIC_DIR)/tclLoad.c + $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclLoad.c + +tclLoadAix.o: $(UNIX_DIR)/tclLoadAix.c + $(CC) -c $(CC_SWITCHES) $(UNIX_DIR)/tclLoadAix.c + +tclLoadAout.o: $(UNIX_DIR)/tclLoadAout.c + $(CC) -c $(CC_SWITCHES) $(UNIX_DIR)/tclLoadAout.c + +tclLoadDl.o: $(UNIX_DIR)/tclLoadDl.c + $(CC) -c $(CC_SWITCHES) $(UNIX_DIR)/tclLoadDl.c + +tclLoadDl2.o: $(UNIX_DIR)/tclLoadDl2.c + $(CC) -c $(CC_SWITCHES) $(UNIX_DIR)/tclLoadDl2.c + +tclLoadDld.o: $(UNIX_DIR)/tclLoadDld.c + $(CC) -c $(CC_SWITCHES) $(UNIX_DIR)/tclLoadDld.c + +tclLoadNone.o: $(GENERIC_DIR)/tclLoadNone.c + $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclLoadNone.c + +tclLoadOSF.o: $(UNIX_DIR)/tclLoadOSF.c + $(CC) -c $(CC_SWITCHES) $(UNIX_DIR)/tclLoadOSF.c + +tclLoadShl.o: $(UNIX_DIR)/tclLoadShl.c + $(CC) -c $(CC_SWITCHES) $(UNIX_DIR)/tclLoadShl.c + +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 + +tclNotify.o: $(GENERIC_DIR)/tclNotify.c + $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclNotify.c + +tclParse.o: $(GENERIC_DIR)/tclParse.c + $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclParse.c + +tclPkg.o: $(GENERIC_DIR)/tclPkg.c + $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclPkg.c + +tclPosixStr.o: $(GENERIC_DIR)/tclPosixStr.c + $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclPosixStr.c + +tclPreserve.o: $(GENERIC_DIR)/tclPreserve.c + $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclPreserve.c + +tclProc.o: $(GENERIC_DIR)/tclProc.c + $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclProc.c + +tclUtil.o: $(GENERIC_DIR)/tclUtil.c + $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclUtil.c + +tclVar.o: $(GENERIC_DIR)/tclVar.c + $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclVar.c + +tclTest.o: $(GENERIC_DIR)/tclTest.c + $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclTest.c + +tclUnixChan.o: $(UNIX_DIR)/tclUnixChan.c + $(CC) -c $(CC_SWITCHES) $(UNIX_DIR)/tclUnixChan.c + +tclUnixFile.o: $(UNIX_DIR)/tclUnixFile.c + $(CC) -c $(CC_SWITCHES) $(UNIX_DIR)/tclUnixFile.c + +tclUnixNotfy.o: $(UNIX_DIR)/tclUnixNotfy.c + $(CC) -c $(CC_SWITCHES) $(UNIX_DIR)/tclUnixNotfy.c + +tclUnixPipe.o: $(UNIX_DIR)/tclUnixPipe.c + $(CC) -c $(CC_SWITCHES) $(UNIX_DIR)/tclUnixPipe.c + +tclUnixSock.o: $(UNIX_DIR)/tclUnixSock.c + $(CC) -c $(CC_SWITCHES) $(UNIX_DIR)/tclUnixSock.c + +tclUnixTest.o: $(UNIX_DIR)/tclUnixTest.c + $(CC) -c $(CC_SWITCHES) $(UNIX_DIR)/tclUnixTest.c + +tclUnixTime.o: $(UNIX_DIR)/tclUnixTime.c + $(CC) -c $(CC_SWITCHES) $(UNIX_DIR)/tclUnixTime.c + +tclUnixInit.o: $(UNIX_DIR)/tclUnixInit.c tclConfig.sh + $(CC) -c $(CC_SWITCHES) -DTCL_LIBRARY=\"${TCL_LIBRARY}\" \ + $(UNIX_DIR)/tclUnixInit.c + +# compat binaries + +fixstrtod.o: $(COMPAT_DIR)/fixstrtod.c + $(CC) -c $(CC_SWITCHES) $(COMPAT_DIR)/fixstrtod.c + +getcwd.o: $(COMPAT_DIR)/getcwd.c + $(CC) -c $(CC_SWITCHES) $(COMPAT_DIR)/getcwd.c + +opendir.o: $(COMPAT_DIR)/opendir.c + $(CC) -c $(CC_SWITCHES) $(COMPAT_DIR)/opendir.c + +strncasecmp.o: $(COMPAT_DIR)/strncasecmp.c + $(CC) -c $(CC_SWITCHES) $(COMPAT_DIR)/strncasecmp.c + +strstr.o: $(COMPAT_DIR)/strstr.c + $(CC) -c $(CC_SWITCHES) $(COMPAT_DIR)/strstr.c + +strtod.o: $(COMPAT_DIR)/strtod.c + $(CC) -c $(CC_SWITCHES) $(COMPAT_DIR)/strtod.c + +strtol.o: $(COMPAT_DIR)/strtol.c + $(CC) -c $(CC_SWITCHES) $(COMPAT_DIR)/strtol.c + +strtoul.o: $(COMPAT_DIR)/strtoul.c + $(CC) -c $(CC_SWITCHES) $(COMPAT_DIR)/strtoul.c + +tmpnam.o: $(COMPAT_DIR)/tmpnam.c + $(CC) -c $(CC_SWITCHES) $(COMPAT_DIR)/tmpnam.c + +waitpid.o: $(COMPAT_DIR)/waitpid.c + $(CC) -c $(CC_SWITCHES) $(COMPAT_DIR)/waitpid.c + +.c.o: + $(CC) -c $(CC_SWITCHES) $< + +# +# Target to check for proper usage of UCHAR macro. +# + +checkuchar: + -egrep isalnum\|isalpha\|iscntrl\|isdigit\|islower\|isprint\|ispunct\|isspace\|isupper\|isxdigit\|toupper\|tolower $(SRCS) | grep -v UCHAR + +# +# Target to make sure that only symbols with "Tcl" prefixes are +# exported. +# + +checkexports: $(TCL_LIB_FILE) + -nm -p $(TCL_LIB_FILE) | awk '$$2 ~ /[TDB]/ { print $$3 }' | sort -n | grep -v '^[Tt]cl' + +# +# 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. +# + +DISTDIR = /proj/tcl/dist/tcl7.5 +configure: configure.in + autoconf +dist: configure + rm -rf $(DISTDIR) + mkdir $(DISTDIR) + mkdir $(DISTDIR)/unix + cp -p $(UNIX_DIR)/*.c $(UNIX_DIR)/*.h $(DISTDIR)/unix + cp Makefile.in $(DISTDIR)/unix + chmod 664 $(DISTDIR)/unix/Makefile.in + cp configure configure.in tclConfig.sh.in install-sh porting.notes \ + porting.old README ldAix $(DISTDIR)/unix + chmod 775 $(DISTDIR)/unix/configure $(DISTDIR)/unix/configure.in + chmod 775 $(DISTDIR)/unix/ldAix + chmod +x $(DISTDIR)/unix/install-sh + tclsh mkLinks.tcl ../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)/README $(DISTDIR)/generic + cp -p $(GENERIC_DIR)/tclGetDate.y $(DISTDIR)/generic + cp -p ../changes ../README ../license.terms $(DISTDIR) + mkdir $(DISTDIR)/library + cp -p ../license.terms ../library/*.tcl ../library/tclIndex \ + $(DISTDIR)/library + mkdir $(DISTDIR)/doc + cp -p ../license.terms ../doc/*.[13n] ../doc/man.macros $(DISTDIR)/doc + mkdir $(DISTDIR)/compat + cp -p ../license.terms ../compat/*.c ../compat/*.h ../compat/README \ + $(DISTDIR)/compat + mkdir $(DISTDIR)/tests + cp -p ../license.terms $(DISTDIR)/tests + cp -p ../tests/*.test ../tests/README ../tests/all \ + ../tests/remote.tcl ../tests/defs $(DISTDIR)/tests + mkdir $(DISTDIR)/win + cp -p ../win/*.c ../win/*.h ../win/*.rc $(DISTDIR)/win + cp -p ../win/makefile.* $(DISTDIR)/win + cp -p ../win/README $(DISTDIR)/win + cp -p ../license.terms $(DISTDIR)/win + mkdir $(DISTDIR)/mac + sccs edit -s ../mac/tclMacProjects.sit.hqx + cp -p tclMacProjects.sit.hqx $(DISTDIR)/mac + sccs unedit ../mac/tclMacProjects.sit.hqx + rm -f tclMacProjects.sit.hqx + cp -p ../mac/*.c ../mac/*.h ../mac/*.r $(DISTDIR)/mac + cp -p ../mac/porting.notes ../mac/README $(DISTDIR)/mac + cp -p ../license.terms $(DISTDIR)/mac + mkdir $(DISTDIR)/unix/dltest + cp -p dltest/*.c dltest/Makefile.in $(DISTDIR)/unix/dltest + cp -p dltest/configure.in dltest/configure $(DISTDIR)/unix/dltest + cp -p dltest/README $(DISTDIR)/unix/dltest + +# +# Target to create a Macintosh version of the distribution. This will +# do a normal distribution and then massage the output to prepare it +# for moving to the Mac platform. This requires a few scripts and +# programs found only in the Tcl greoup's tool workspace. +# + +TOOLDIR = /home/rjohnson/Projects/tools +macdist: dist + rm -f $(DISTDIR)/mac/tclMacProjects.sit.hqx + tclsh $(TOOLDIR)/generic/man2html.tcl $(DISTDIR)/tmp ../.. tcl$(VERSION) + mv $(DISTDIR)/tmp/tcl$(VERSION) $(DISTDIR)/html + rm -rf $(DISTDIR)/doc + rm -rf $(DISTDIR)/tmp + tclsh $(TOOLDIR)/mac/cvtEOL.tcl $(DISTDIR) + +# DO NOT DELETE THIS LINE -- make depend depends on it. diff --git a/contrib/tcl/unix/README b/contrib/tcl/unix/README new file mode 100644 index 0000000..ea1d01f --- /dev/null +++ b/contrib/tcl/unix/README @@ -0,0 +1,105 @@ +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 +used on the PC or Mac platform too, but they all depend on UNIX +(POSIX/ANSI C) interfaces and some of them only make sense under UNIX. + +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 +changes on any UNIX-like system that approximates POSIX, BSD, or System +V. We know that it runs on workstations from Sun, H-P, DEC, IBM, and +SGI, as well as PCs running Linux, BSDI, and SCO UNIX. To compile for +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. + +SCCS: @(#) README 1.10 96/04/17 11:40:24 + +How To Compile And Install Tcl: +------------------------------- + +(a) Check for patches as described in ../README. + +(b) 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 autoconf is run; + if you do this, then information related to + dynamic linking will be incorrect. + --disable-load If this switch is specified then Tcl will + configure itself not to allow dynamic loading, + even if your system appears to support it. + Normally you can leave this switch out and + Tcl will build itself for dynamic loading + if your system supports it. + --enable-shared If this switch is specified, Tcl will compile + itself as a shared library if it can figure + out how to do that on this platform. + Note: be sure to use only absolute path names (those starting with "/") + in the --prefix and --exec_prefix options. + +(c) Type "make". This will create a library archive called "libtcl.a" + or "libtcl.so" and an interpreter application called "tclsh" that + allows you to type Tcl commands interactively or execute script files. + +(d) 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 file "porting.notes" to see if there are hints + for compiling on your system. Then look at the porting Web page + described later in this file. If you need to modify Makefile, there + are comments at the beginning of it that describe the things you + might want to change and how to change them. + +(e) 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 + Makefile for information on what directories were chosen; you + can override these choices by modifying the "prefix" and + "exec_prefix" variables in the Makefile. + +(f) 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 "tclsh7.5" or "libtcl7.5.so"; + to use the installed versions, either specify the version number + or create a symbolic link (e.g. from "tclsh" to "tclsh7.5"). + +If you have trouble compiling Tcl, read through the file" porting.notes". +It contains information that people have provided about changes they had +to make to compile Tcl in various environments. Or, check out the +following Web URL: + http://www.sunlabs.com/cgi-bin/tcl/info.4.1 +This is an on-line database of porting information. We make no guarantees +that this information is accurate, complete, or up-to-date, but you may +find it useful. If you get Tcl running on a new configuration, we would +be happy to receive new information to add to "porting.notes". You can +also make a new entry into the on-line Web database. We're also interested +in hearing how to change the configuration setup so that Tcl compiles out +of the box on more platforms. + +Test suite +---------- + +There is a relatively complete test suite for all of the Tcl core in +the subdirectory "tests". To use it just type "make test" in this +directory. You should then see a printout of the test files processed. +If any errors occur, you'll see a much more substantial printout for +each error. See the README file in the "tests" directory for more +information on the test suite. Note: don't run the tests as superuser: +this will cause several of them to fail. + +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. diff --git a/contrib/tcl/unix/bp.c b/contrib/tcl/unix/bp.c new file mode 100644 index 0000000..b8c7a49 --- /dev/null +++ b/contrib/tcl/unix/bp.c @@ -0,0 +1,127 @@ +/* + * 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); +} diff --git a/contrib/tcl/unix/configure b/contrib/tcl/unix/configure new file mode 100755 index 0000000..47627f4 --- /dev/null +++ b/contrib/tcl/unix/configure @@ -0,0 +1,3856 @@ +#! /bin/sh + +# Guess values for system-dependent variables and create Makefiles. +# Generated automatically using autoconf version 2.4 +# Copyright (C) 1992, 1993, 1994 Free Software Foundation, Inc. +# +# This configure script is free software; the Free Software Foundation +# gives unlimited permission to copy, distribute and modify it. + +# Defaults: +ac_help= +ac_default_prefix=/usr/local +# Any additions from configure.in: +ac_help="$ac_help + --enable-gcc allow use of gcc if available" +ac_help="$ac_help + --disable-load disallow dynamic loading and "load" command" +ac_help="$ac_help + --enable-shared build libtcl as a shared library" + +# Initialize some variables set by options. +# The variables have the same names as the options, with +# dashes changed to underlines. +build=NONE +cache_file=./config.cache +exec_prefix=NONE +host=NONE +no_create= +nonopt=NONE +no_recursion= +prefix=NONE +program_prefix=NONE +program_suffix=NONE +program_transform_name=s,x,x, +silent= +site= +srcdir= +target=NONE +verbose= +x_includes=NONE +x_libraries=NONE + +# Initialize some other variables. +subdirs= + +ac_prev= +for ac_option +do + + # If the previous option needs an argument, assign it. + if test -n "$ac_prev"; then + eval "$ac_prev=\$ac_option" + ac_prev= + continue + fi + + case "$ac_option" in + -*=*) ac_optarg=`echo "$ac_option" | sed 's/[-_a-zA-Z0-9]*=//'` ;; + *) ac_optarg= ;; + esac + + # Accept the important Cygnus configure options, so we can diagnose typos. + + case "$ac_option" in + + -build | --build | --buil | --bui | --bu | --b) + ac_prev=build ;; + -build=* | --build=* | --buil=* | --bui=* | --bu=* | --b=*) + build="$ac_optarg" ;; + + -cache-file | --cache-file | --cache-fil | --cache-fi \ + | --cache-f | --cache- | --cache | --cach | --cac | --ca | --c) + ac_prev=cache_file ;; + -cache-file=* | --cache-file=* | --cache-fil=* | --cache-fi=* \ + | --cache-f=* | --cache-=* | --cache=* | --cach=* | --cac=* | --ca=* | --c=*) + cache_file="$ac_optarg" ;; + + -disable-* | --disable-*) + ac_feature=`echo $ac_option|sed -e 's/-*disable-//'` + # Reject names that are not valid shell variable names. + if test -n "`echo $ac_feature| sed 's/[-a-zA-Z0-9_]//g'`"; then + { echo "configure: error: $ac_feature: invalid feature name" 1>&2; exit 1; } + fi + ac_feature=`echo $ac_feature| sed 's/-/_/g'` + eval "enable_${ac_feature}=no" ;; + + -enable-* | --enable-*) + ac_feature=`echo $ac_option|sed -e 's/-*enable-//' -e 's/=.*//'` + # Reject names that are not valid shell variable names. + if test -n "`echo $ac_feature| sed 's/[-_a-zA-Z0-9]//g'`"; then + { echo "configure: error: $ac_feature: invalid feature name" 1>&2; exit 1; } + fi + ac_feature=`echo $ac_feature| sed 's/-/_/g'` + case "$ac_option" in + *=*) ;; + *) ac_optarg=yes ;; + esac + eval "enable_${ac_feature}='$ac_optarg'" ;; + + -exec-prefix | --exec_prefix | --exec-prefix | --exec-prefi \ + | --exec-pref | --exec-pre | --exec-pr | --exec-p | --exec- \ + | --exec | --exe | --ex) + ac_prev=exec_prefix ;; + -exec-prefix=* | --exec_prefix=* | --exec-prefix=* | --exec-prefi=* \ + | --exec-pref=* | --exec-pre=* | --exec-pr=* | --exec-p=* | --exec-=* \ + | --exec=* | --exe=* | --ex=*) + exec_prefix="$ac_optarg" ;; + + -gas | --gas | --ga | --g) + # Obsolete; use --with-gas. + with_gas=yes ;; + + -help | --help | --hel | --he) + # Omit some internal or obsolete options to make the list less imposing. + # This message is too long to be a string in the A/UX 3.1 sh. + cat << EOF +Usage: configure [options] [host] +Options: [defaults in brackets after descriptions] +Configuration: + --cache-file=FILE cache test results in FILE + --help print this message + --no-create do not create output files + --quiet, --silent do not print \`checking...' messages + --version print the version of autoconf that created configure +Directory and file names: + --prefix=PREFIX install architecture-independent files in PREFIX + [$ac_default_prefix] + --exec-prefix=PREFIX install architecture-dependent files in PREFIX + [same as prefix] + --srcdir=DIR find the sources in DIR [configure dir or ..] + --program-prefix=PREFIX prepend PREFIX to installed program names + --program-suffix=SUFFIX append SUFFIX to installed program names + --program-transform-name=PROGRAM run sed PROGRAM on installed program names +Host type: + --build=BUILD configure for building on BUILD [BUILD=HOST] + --host=HOST configure for HOST [guessed] + --target=TARGET configure for TARGET [TARGET=HOST] +Features and packages: + --disable-FEATURE do not include FEATURE (same as --enable-FEATURE=no) + --enable-FEATURE[=ARG] include FEATURE [ARG=yes] + --with-PACKAGE[=ARG] use PACKAGE [ARG=yes] + --without-PACKAGE do not use PACKAGE (same as --with-PACKAGE=no) + --x-includes=DIR X include files are in DIR + --x-libraries=DIR X library files are in DIR +--enable and --with options recognized:$ac_help +EOF + exit 0 ;; + + -host | --host | --hos | --ho) + ac_prev=host ;; + -host=* | --host=* | --hos=* | --ho=*) + host="$ac_optarg" ;; + + -nfp | --nfp | --nf) + # Obsolete; use --without-fp. + with_fp=no ;; + + -no-create | --no-create | --no-creat | --no-crea | --no-cre \ + | --no-cr | --no-c) + no_create=yes ;; + + -no-recursion | --no-recursion | --no-recursio | --no-recursi \ + | --no-recurs | --no-recur | --no-recu | --no-rec | --no-re | --no-r) + no_recursion=yes ;; + + -prefix | --prefix | --prefi | --pref | --pre | --pr | --p) + ac_prev=prefix ;; + -prefix=* | --prefix=* | --prefi=* | --pref=* | --pre=* | --pr=* | --p=*) + prefix="$ac_optarg" ;; + + -program-prefix | --program-prefix | --program-prefi | --program-pref \ + | --program-pre | --program-pr | --program-p) + ac_prev=program_prefix ;; + -program-prefix=* | --program-prefix=* | --program-prefi=* \ + | --program-pref=* | --program-pre=* | --program-pr=* | --program-p=*) + program_prefix="$ac_optarg" ;; + + -program-suffix | --program-suffix | --program-suffi | --program-suff \ + | --program-suf | --program-su | --program-s) + ac_prev=program_suffix ;; + -program-suffix=* | --program-suffix=* | --program-suffi=* \ + | --program-suff=* | --program-suf=* | --program-su=* | --program-s=*) + program_suffix="$ac_optarg" ;; + + -program-transform-name | --program-transform-name \ + | --program-transform-nam | --program-transform-na \ + | --program-transform-n | --program-transform- \ + | --program-transform | --program-transfor \ + | --program-transfo | --program-transf \ + | --program-trans | --program-tran \ + | --progr-tra | --program-tr | --program-t) + ac_prev=program_transform_name ;; + -program-transform-name=* | --program-transform-name=* \ + | --program-transform-nam=* | --program-transform-na=* \ + | --program-transform-n=* | --program-transform-=* \ + | --program-transform=* | --program-transfor=* \ + | --program-transfo=* | --program-transf=* \ + | --program-trans=* | --program-tran=* \ + | --progr-tra=* | --program-tr=* | --program-t=*) + program_transform_name="$ac_optarg" ;; + + -q | -quiet | --quiet | --quie | --qui | --qu | --q \ + | -silent | --silent | --silen | --sile | --sil) + silent=yes ;; + + -site | --site | --sit) + ac_prev=site ;; + -site=* | --site=* | --sit=*) + site="$ac_optarg" ;; + + -srcdir | --srcdir | --srcdi | --srcd | --src | --sr) + ac_prev=srcdir ;; + -srcdir=* | --srcdir=* | --srcdi=* | --srcd=* | --src=* | --sr=*) + srcdir="$ac_optarg" ;; + + -target | --target | --targe | --targ | --tar | --ta | --t) + ac_prev=target ;; + -target=* | --target=* | --targe=* | --targ=* | --tar=* | --ta=* | --t=*) + target="$ac_optarg" ;; + + -v | -verbose | --verbose | --verbos | --verbo | --verb) + verbose=yes ;; + + -version | --version | --versio | --versi | --vers) + echo "configure generated by autoconf version 2.4" + exit 0 ;; + + -with-* | --with-*) + ac_package=`echo $ac_option|sed -e 's/-*with-//' -e 's/=.*//'` + # Reject names that are not valid shell variable names. + if test -n "`echo $ac_package| sed 's/[-_a-zA-Z0-9]//g'`"; then + { echo "configure: error: $ac_package: invalid package name" 1>&2; exit 1; } + fi + ac_package=`echo $ac_package| sed 's/-/_/g'` + case "$ac_option" in + *=*) ;; + *) ac_optarg=yes ;; + esac + eval "with_${ac_package}='$ac_optarg'" ;; + + -without-* | --without-*) + ac_package=`echo $ac_option|sed -e 's/-*without-//'` + # Reject names that are not valid shell variable names. + if test -n "`echo $ac_package| sed 's/[-a-zA-Z0-9_]//g'`"; then + { echo "configure: error: $ac_package: invalid package name" 1>&2; exit 1; } + fi + ac_package=`echo $ac_package| sed 's/-/_/g'` + eval "with_${ac_package}=no" ;; + + --x) + # Obsolete; use --with-x. + with_x=yes ;; + + -x-includes | --x-includes | --x-include | --x-includ | --x-inclu \ + | --x-incl | --x-inc | --x-in | --x-i) + ac_prev=x_includes ;; + -x-includes=* | --x-includes=* | --x-include=* | --x-includ=* | --x-inclu=* \ + | --x-incl=* | --x-inc=* | --x-in=* | --x-i=*) + x_includes="$ac_optarg" ;; + + -x-libraries | --x-libraries | --x-librarie | --x-librari \ + | --x-librar | --x-libra | --x-libr | --x-lib | --x-li | --x-l) + ac_prev=x_libraries ;; + -x-libraries=* | --x-libraries=* | --x-librarie=* | --x-librari=* \ + | --x-librar=* | --x-libra=* | --x-libr=* | --x-lib=* | --x-li=* | --x-l=*) + x_libraries="$ac_optarg" ;; + + -*) { echo "configure: error: $ac_option: invalid option; use --help to show usage" 1>&2; exit 1; } + ;; + + *) + if test -n "`echo $ac_option| sed 's/[-a-z0-9.]//g'`"; then + echo "configure: warning: $ac_option: invalid host type" 1>&2 + fi + if test "x$nonopt" != xNONE; then + { echo "configure: error: can only configure for one host and one target at a time" 1>&2; exit 1; } + fi + nonopt="$ac_option" + ;; + + esac +done + +if test -n "$ac_prev"; then + { echo "configure: error: missing argument to --`echo $ac_prev | sed 's/_/-/g'`" 1>&2; exit 1; } +fi + +trap 'rm -fr conftest* confdefs* core core.* *.core $ac_clean_files; exit 1' 1 2 15 + +# File descriptor usage: +# 0 standard input +# 1 file creation +# 2 errors and warnings +# 3 some systems may open it to /dev/tty +# 4 used on the Kubota Titan +# 6 checking for... messages and results +# 5 compiler messages saved in config.log +if test "$silent" = yes; then + exec 6>/dev/null +else + exec 6>&1 +fi +exec 5>./config.log + +echo "\ +This file contains any messages produced by compilers while +running configure, to aid debugging if configure makes a mistake. +" 1>&5 + +# Strip out --no-create and --no-recursion so they do not pile up. +# Also quote any args containing shell metacharacters. +ac_configure_args= +for ac_arg +do + case "$ac_arg" in + -no-create | --no-create | --no-creat | --no-crea | --no-cre \ + | --no-cr | --no-c) ;; + -no-recursion | --no-recursion | --no-recursio | --no-recursi \ + | --no-recurs | --no-recur | --no-recu | --no-rec | --no-re | --no-r) ;; + *" "*|*" "*|*[\[\]\~\#\$\^\&\*\(\)\{\}\\\|\;\<\>\?]*) + ac_configure_args="$ac_configure_args '$ac_arg'" ;; + *) ac_configure_args="$ac_configure_args $ac_arg" ;; + esac +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 +if test "${LANG+set}" = set; then LANG=C; export LANG; fi + +# confdefs.h avoids OS command line length limits that DEFS can exceed. +rm -rf conftest* confdefs.h +# AIX cpp loses on an empty file, so make sure it contains at least a newline. +echo > confdefs.h + +# A filename unique to this package, relative to the directory that +# configure is in, which we can look for to find out if srcdir is correct. +ac_unique_file=../generic/tcl.h + +# Find the source files, if location was not specified. +if test -z "$srcdir"; then + ac_srcdir_defaulted=yes + # Try the directory containing this script, then its parent. + ac_prog=$0 + ac_confdir=`echo $ac_prog|sed 's%/[^/][^/]*$%%'` + test "x$ac_confdir" = "x$ac_prog" && ac_confdir=. + srcdir=$ac_confdir + if test ! -r $srcdir/$ac_unique_file; then + srcdir=.. + fi +else + ac_srcdir_defaulted=no +fi +if test ! -r $srcdir/$ac_unique_file; then + if test "$ac_srcdir_defaulted" = yes; then + { echo "configure: error: can not find sources in $ac_confdir or .." 1>&2; exit 1; } + else + { echo "configure: error: can not find sources in $srcdir" 1>&2; exit 1; } + fi +fi +srcdir=`echo "${srcdir}" | sed 's%\([^/]\)/*$%\1%'` + +# Prefer explicitly selected file to automatically selected ones. +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 +fi +for ac_site_file in $CONFIG_SITE; do + if test -r "$ac_site_file"; then + echo "loading site script $ac_site_file" + . "$ac_site_file" + fi +done + +if test -r "$cache_file"; then + echo "loading cache $cache_file" + . $cache_file +else + echo "creating cache $cache_file" + > $cache_file +fi + +ac_ext=c +# 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 2>&5' +ac_link='${CC-cc} -o conftest $CFLAGS $CPPFLAGS $LDFLAGS conftest.$ac_ext $LIBS 1>&5 2>&5' + +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 + ac_n= ac_c=' +' ac_t=' ' + else + ac_n=-n ac_c= ac_t= + fi +else + ac_n= ac_c='\c' ac_t= +fi + + +# SCCS: @(#) configure.in 1.102 96/04/17 10:46:25 + +TCL_VERSION=7.5 +TCL_MAJOR_VERSION=7 +TCL_MINOR_VERSION=5 +VERSION=${TCL_VERSION} + +if test "${prefix}" = "NONE"; then + prefix=/usr/local +fi +if test "${exec_prefix}" = "NONE"; then + exec_prefix=$prefix +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 +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="${IFS}:" + for ac_dir in $PATH; 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 + +# Check whether --enable-gcc or --disable-gcc was given. +enableval="$enable_gcc" +if test -n "$enableval"; then + tcl_ok=$enableval +else + tcl_ok=no +fi + +if test "$tcl_ok" = "yes"; then + # 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 +if eval "test \"`echo '$''{'ac_cv_prog_CC'+set}'`\" = set"; then + echo $ac_n "(cached) $ac_c" 1>&6 +else + if test -n "$CC"; then + ac_cv_prog_CC="$CC" # Let the user override the test. +else + IFS="${IFS= }"; ac_save_ifs="$IFS"; IFS="${IFS}:" + for ac_dir in $PATH; do + test -z "$ac_dir" && ac_dir=. + if test -f $ac_dir/$ac_word; then + ac_cv_prog_CC="gcc" + break + fi + done + IFS="$ac_save_ifs" + test -z "$ac_cv_prog_CC" && ac_cv_prog_CC="cc" +fi +fi +CC="$ac_cv_prog_CC" +if test -n "$CC"; then + echo "$ac_t""$CC" 1>&6 +else + echo "$ac_t""no" 1>&6 +fi + + +echo $ac_n "checking whether we are using GNU C""... $ac_c" 1>&6 +if eval "test \"`echo '$''{'ac_cv_prog_gcc'+set}'`\" = set"; then + echo $ac_n "(cached) $ac_c" 1>&6 +else + cat > conftest.c <<EOF +#ifdef __GNUC__ + yes; +#endif +EOF +if ${CC-cc} -E conftest.c 2>&5 | egrep yes >/dev/null 2>&1; then + ac_cv_prog_gcc=yes +else + ac_cv_prog_gcc=no +fi +fi +echo "$ac_t""$ac_cv_prog_gcc" 1>&6 +if test $ac_cv_prog_gcc = yes; then + GCC=yes + if test "${CFLAGS+set}" != set; then + echo $ac_n "checking whether ${CC-cc} accepts -g""... $ac_c" 1>&6 +if eval "test \"`echo '$''{'ac_cv_prog_gcc_g'+set}'`\" = set"; then + echo $ac_n "(cached) $ac_c" 1>&6 +else + echo 'void f(){}' > conftest.c +if test -z "`${CC-cc} -g -c conftest.c 2>&1`"; then + ac_cv_prog_gcc_g=yes +else + ac_cv_prog_gcc_g=no +fi +rm -f conftest* + +fi + echo "$ac_t""$ac_cv_prog_gcc_g" 1>&6 + if test $ac_cv_prog_gcc_g = yes; then + CFLAGS="-g -O" + else + CFLAGS="-O" + fi + fi +else + GCC= + test "${CFLAGS+set}" = set || CFLAGS="-g" +fi + +else + CC=${CC-cc} + +fi +# If we cannot run a trivial program, we must be cross compiling. +echo $ac_n "checking whether cross-compiling""... $ac_c" 1>&6 +if eval "test \"`echo '$''{'ac_cv_c_cross'+set}'`\" = set"; then + echo $ac_n "(cached) $ac_c" 1>&6 +else + if test "$cross_compiling" = yes; then + ac_cv_c_cross=yes +else +cat > conftest.$ac_ext <<EOF +#line 545 "configure" +#include "confdefs.h" +main(){return(0);} +EOF +eval $ac_link +if test -s conftest && (./conftest; exit) 2>/dev/null; then + ac_cv_c_cross=no +else + ac_cv_c_cross=yes +fi +fi +rm -fr conftest* +fi +cross_compiling=$ac_cv_c_cross +echo "$ac_t""$ac_cv_c_cross" 1>&6 + + +#-------------------------------------------------------------------- +# Supply substitutes for missing POSIX library procedures, or +# set flags so Tcl uses alternate procedures. +#-------------------------------------------------------------------- + +for ac_func in getcwd opendir strstr +do +echo $ac_n "checking for $ac_func""... $ac_c" 1>&6 +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 574 "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. */ +char $ac_func(); + +int main() { return 0; } +int t() { + +/* 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 $ac_link; then + rm -rf conftest* + eval "ac_cv_func_$ac_func=yes" +else + 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 + : +else + echo "$ac_t""no" 1>&6 +LIBOBJS="$LIBOBJS ${ac_func}.o" +fi + +done + +for ac_func in strtol tmpnam waitpid +do +echo $ac_n "checking for $ac_func""... $ac_c" 1>&6 +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 623 "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. */ +char $ac_func(); + +int main() { return 0; } +int t() { + +/* 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 $ac_link; then + rm -rf conftest* + eval "ac_cv_func_$ac_func=yes" +else + 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 + : +else + echo "$ac_t""no" 1>&6 +LIBOBJS="$LIBOBJS ${ac_func}.o" +fi + +done + +echo $ac_n "checking for strerror""... $ac_c" 1>&6 +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 670 "configure" +#include "confdefs.h" +/* System header to define __stub macros and hopefully few prototypes, + which can conflict with char strerror(); below. */ +#include <assert.h> +/* Override any gcc2 internal prototype to avoid an error. */ +char strerror(); + +int main() { return 0; } +int t() { + +/* 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_strerror) || defined (__stub___strerror) +choke me +#else +strerror(); +#endif + +; return 0; } +EOF +if eval $ac_link; then + rm -rf conftest* + eval "ac_cv_func_strerror=yes" +else + rm -rf conftest* + eval "ac_cv_func_strerror=no" +fi +rm -f conftest* + +fi +if eval "test \"`echo '$ac_cv_func_'strerror`\" = yes"; then + echo "$ac_t""yes" 1>&6 + : +else + echo "$ac_t""no" 1>&6 +cat >> confdefs.h <<\EOF +#define NO_STRERROR 1 +EOF + +fi + +echo $ac_n "checking for getwd""... $ac_c" 1>&6 +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 718 "configure" +#include "confdefs.h" +/* System header to define __stub macros and hopefully few prototypes, + which can conflict with char getwd(); below. */ +#include <assert.h> +/* Override any gcc2 internal prototype to avoid an error. */ +char getwd(); + +int main() { return 0; } +int t() { + +/* 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_getwd) || defined (__stub___getwd) +choke me +#else +getwd(); +#endif + +; return 0; } +EOF +if eval $ac_link; then + rm -rf conftest* + eval "ac_cv_func_getwd=yes" +else + rm -rf conftest* + eval "ac_cv_func_getwd=no" +fi +rm -f conftest* + +fi +if eval "test \"`echo '$ac_cv_func_'getwd`\" = yes"; then + echo "$ac_t""yes" 1>&6 + : +else + echo "$ac_t""no" 1>&6 +cat >> confdefs.h <<\EOF +#define NO_GETWD 1 +EOF + +fi + +echo $ac_n "checking for wait3""... $ac_c" 1>&6 +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 766 "configure" +#include "confdefs.h" +/* System header to define __stub macros and hopefully few prototypes, + which can conflict with char wait3(); below. */ +#include <assert.h> +/* Override any gcc2 internal prototype to avoid an error. */ +char wait3(); + +int main() { return 0; } +int t() { + +/* 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_wait3) || defined (__stub___wait3) +choke me +#else +wait3(); +#endif + +; return 0; } +EOF +if eval $ac_link; then + rm -rf conftest* + eval "ac_cv_func_wait3=yes" +else + rm -rf conftest* + eval "ac_cv_func_wait3=no" +fi +rm -f conftest* + +fi +if eval "test \"`echo '$ac_cv_func_'wait3`\" = yes"; then + echo "$ac_t""yes" 1>&6 + : +else + echo "$ac_t""no" 1>&6 +cat >> confdefs.h <<\EOF +#define NO_WAIT3 1 +EOF + +fi + +echo $ac_n "checking for uname""... $ac_c" 1>&6 +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 814 "configure" +#include "confdefs.h" +/* System header to define __stub macros and hopefully few prototypes, + which can conflict with char uname(); below. */ +#include <assert.h> +/* Override any gcc2 internal prototype to avoid an error. */ +char uname(); + +int main() { return 0; } +int t() { + +/* 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_uname) || defined (__stub___uname) +choke me +#else +uname(); +#endif + +; return 0; } +EOF +if eval $ac_link; then + rm -rf conftest* + eval "ac_cv_func_uname=yes" +else + rm -rf conftest* + eval "ac_cv_func_uname=no" +fi +rm -f conftest* + +fi +if eval "test \"`echo '$ac_cv_func_'uname`\" = yes"; then + echo "$ac_t""yes" 1>&6 + : +else + echo "$ac_t""no" 1>&6 +cat >> confdefs.h <<\EOF +#define NO_UNAME 1 +EOF + +fi + + +#-------------------------------------------------------------------- +# On a few very rare systems, all of the libm.a stuff is +# already in libc.a. Set compiler flags accordingly. +# Also, Linux requires the "ieee" library for math to work +# right (and it must appear before "-lm"). +#-------------------------------------------------------------------- + +echo $ac_n "checking for sin""... $ac_c" 1>&6 +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 870 "configure" +#include "confdefs.h" +/* System header to define __stub macros and hopefully few prototypes, + which can conflict with char sin(); below. */ +#include <assert.h> +/* Override any gcc2 internal prototype to avoid an error. */ +char sin(); + +int main() { return 0; } +int t() { + +/* 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_sin) || defined (__stub___sin) +choke me +#else +sin(); +#endif + +; return 0; } +EOF +if eval $ac_link; then + rm -rf conftest* + eval "ac_cv_func_sin=yes" +else + rm -rf conftest* + eval "ac_cv_func_sin=no" +fi +rm -f conftest* + +fi +if eval "test \"`echo '$ac_cv_func_'sin`\" = yes"; then + echo "$ac_t""yes" 1>&6 + MATH_LIBS="" +else + echo "$ac_t""no" 1>&6 +MATH_LIBS="-lm" +fi + +echo $ac_n "checking for -lieee""... $ac_c" 1>&6 +if eval "test \"`echo '$''{'ac_cv_lib_ieee'+set}'`\" = set"; then + echo $ac_n "(cached) $ac_c" 1>&6 +else + ac_save_LIBS="$LIBS" +LIBS="-lieee $LIBS" +cat > conftest.$ac_ext <<EOF +#line 917 "configure" +#include "confdefs.h" + +int main() { return 0; } +int t() { +main() +; return 0; } +EOF +if eval $ac_link; then + rm -rf conftest* + eval "ac_cv_lib_ieee=yes" +else + rm -rf conftest* + eval "ac_cv_lib_ieee=no" +fi +rm -f conftest* +LIBS="$ac_save_LIBS" + +fi +if eval "test \"`echo '$ac_cv_lib_'ieee`\" = yes"; then + echo "$ac_t""yes" 1>&6 + MATH_LIBS="-lieee $MATH_LIBS" +else + echo "$ac_t""no" 1>&6 +fi + + +#-------------------------------------------------------------------- +# Supply substitutes for missing POSIX header files. Special +# notes: +# - stdlib.h doesn't define strtol, strtoul, or +# strtod insome versions of SunOS +# - some versions of string.h don't declare procedures such +# as strstr +#-------------------------------------------------------------------- + +echo $ac_n "checking dirent.h""... $ac_c" 1>&6 +cat > conftest.$ac_ext <<EOF +#line 955 "configure" +#include "confdefs.h" +#include <sys/types.h> +#include <dirent.h> +int main() { return 0; } +int t() { + +#ifndef _POSIX_SOURCE +# ifdef __Lynx__ + /* + * Generate compilation error to make the test fail: Lynx headers + * are only valid if really in the POSIX environment. + */ + + missing_procedure(); +# endif +#endif +DIR *d; +struct dirent *entryPtr; +char *p; +d = opendir("foobar"); +entryPtr = readdir(d); +p = entryPtr->d_name; +closedir(d); + +; return 0; } +EOF +if eval $ac_link; then + rm -rf conftest* + tcl_ok=yes +else + rm -rf conftest* + tcl_ok=no +fi +rm -f conftest* + +if test $tcl_ok = no; then + cat >> confdefs.h <<\EOF +#define NO_DIRENT_H 1 +EOF + +fi +echo "$ac_t""$tcl_ok" 1>&6 +echo $ac_n "checking how to run the C preprocessor""... $ac_c" 1>&6 +# On Suns, sometimes $CPP names a directory. +if test -n "$CPP" && test -d "$CPP"; then + CPP= +fi +if test -z "$CPP"; then +if eval "test \"`echo '$''{'ac_cv_prog_CPP'+set}'`\" = set"; then + echo $ac_n "(cached) $ac_c" 1>&6 +else + # This must be in double quotes, not single quotes, because CPP may get + # substituted into the Makefile and "${CC-cc}" will confuse make. + CPP="${CC-cc} -E" + # On the NeXT, cc -E runs the code through the compiler's parser, + # not just through cpp. + cat > conftest.$ac_ext <<EOF +#line 1013 "configure" +#include "confdefs.h" +#include <assert.h> +Syntax Error +EOF +eval "$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out" +ac_err=`grep -v '^ *+' conftest.out` +if test -z "$ac_err"; then + : +else + echo "$ac_err" >&5 + rm -rf conftest* + CPP="${CC-cc} -E -traditional-cpp" + cat > conftest.$ac_ext <<EOF +#line 1027 "configure" +#include "confdefs.h" +#include <assert.h> +Syntax Error +EOF +eval "$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out" +ac_err=`grep -v '^ *+' conftest.out` +if test -z "$ac_err"; then + : +else + echo "$ac_err" >&5 + rm -rf conftest* + CPP=/lib/cpp +fi +rm -f conftest* +fi +rm -f conftest* + ac_cv_prog_CPP="$CPP" +fi + CPP="$ac_cv_prog_CPP" +else + ac_cv_prog_CPP="$CPP" +fi +echo "$ac_t""$CPP" 1>&6 + +ac_safe=`echo "errno.h" | tr './\055' '___'` +echo $ac_n "checking for errno.h""... $ac_c" 1>&6 +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 1058 "configure" +#include "confdefs.h" +#include <errno.h> +EOF +eval "$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out" +ac_err=`grep -v '^ *+' conftest.out` +if test -z "$ac_err"; then + rm -rf conftest* + eval "ac_cv_header_$ac_safe=yes" +else + echo "$ac_err" >&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 + : +else + echo "$ac_t""no" 1>&6 +cat >> confdefs.h <<\EOF +#define NO_ERRNO_H 1 +EOF + +fi + +ac_safe=`echo "float.h" | tr './\055' '___'` +echo $ac_n "checking for float.h""... $ac_c" 1>&6 +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 1091 "configure" +#include "confdefs.h" +#include <float.h> +EOF +eval "$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out" +ac_err=`grep -v '^ *+' conftest.out` +if test -z "$ac_err"; then + rm -rf conftest* + eval "ac_cv_header_$ac_safe=yes" +else + echo "$ac_err" >&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 + : +else + echo "$ac_t""no" 1>&6 +cat >> confdefs.h <<\EOF +#define NO_FLOAT_H 1 +EOF + +fi + +ac_safe=`echo "limits.h" | tr './\055' '___'` +echo $ac_n "checking for limits.h""... $ac_c" 1>&6 +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 1124 "configure" +#include "confdefs.h" +#include <limits.h> +EOF +eval "$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out" +ac_err=`grep -v '^ *+' conftest.out` +if test -z "$ac_err"; then + rm -rf conftest* + eval "ac_cv_header_$ac_safe=yes" +else + echo "$ac_err" >&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 + : +else + echo "$ac_t""no" 1>&6 +cat >> confdefs.h <<\EOF +#define NO_LIMITS_H 1 +EOF + +fi + +ac_safe=`echo "stdlib.h" | tr './\055' '___'` +echo $ac_n "checking for stdlib.h""... $ac_c" 1>&6 +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 1157 "configure" +#include "confdefs.h" +#include <stdlib.h> +EOF +eval "$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out" +ac_err=`grep -v '^ *+' conftest.out` +if test -z "$ac_err"; then + rm -rf conftest* + eval "ac_cv_header_$ac_safe=yes" +else + echo "$ac_err" >&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 + tcl_ok=1 +else + echo "$ac_t""no" 1>&6 +tcl_ok=0 +fi + +cat > conftest.$ac_ext <<EOF +#line 1182 "configure" +#include "confdefs.h" +#include <stdlib.h> +EOF +if (eval "$ac_cpp conftest.$ac_ext") 2>&5 | + egrep "strtol" >/dev/null 2>&1; then + : +else + rm -rf conftest* + tcl_ok=0 +fi +rm -f conftest* + +cat > conftest.$ac_ext <<EOF +#line 1196 "configure" +#include "confdefs.h" +#include <stdlib.h> +EOF +if (eval "$ac_cpp conftest.$ac_ext") 2>&5 | + egrep "strtoul" >/dev/null 2>&1; then + : +else + rm -rf conftest* + tcl_ok=0 +fi +rm -f conftest* + +cat > conftest.$ac_ext <<EOF +#line 1210 "configure" +#include "confdefs.h" +#include <stdlib.h> +EOF +if (eval "$ac_cpp conftest.$ac_ext") 2>&5 | + egrep "strtod" >/dev/null 2>&1; then + : +else + rm -rf conftest* + tcl_ok=0 +fi +rm -f conftest* + +if test $tcl_ok = 0; then + cat >> confdefs.h <<\EOF +#define NO_STDLIB_H 1 +EOF + +fi +ac_safe=`echo "string.h" | tr './\055' '___'` +echo $ac_n "checking for string.h""... $ac_c" 1>&6 +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 1235 "configure" +#include "confdefs.h" +#include <string.h> +EOF +eval "$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out" +ac_err=`grep -v '^ *+' conftest.out` +if test -z "$ac_err"; then + rm -rf conftest* + eval "ac_cv_header_$ac_safe=yes" +else + echo "$ac_err" >&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 + tcl_ok=1 +else + echo "$ac_t""no" 1>&6 +tcl_ok=0 +fi + +cat > conftest.$ac_ext <<EOF +#line 1260 "configure" +#include "confdefs.h" +#include <string.h> +EOF +if (eval "$ac_cpp conftest.$ac_ext") 2>&5 | + egrep "strstr" >/dev/null 2>&1; then + : +else + rm -rf conftest* + tcl_ok=0 +fi +rm -f conftest* + +cat > conftest.$ac_ext <<EOF +#line 1274 "configure" +#include "confdefs.h" +#include <string.h> +EOF +if (eval "$ac_cpp conftest.$ac_ext") 2>&5 | + egrep "strerror" >/dev/null 2>&1; then + : +else + rm -rf conftest* + tcl_ok=0 +fi +rm -f conftest* + +if test $tcl_ok = 0; then + cat >> confdefs.h <<\EOF +#define NO_STRING_H 1 +EOF + +fi +ac_safe=`echo "sys/wait.h" | tr './\055' '___'` +echo $ac_n "checking for sys/wait.h""... $ac_c" 1>&6 +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 1299 "configure" +#include "confdefs.h" +#include <sys/wait.h> +EOF +eval "$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out" +ac_err=`grep -v '^ *+' conftest.out` +if test -z "$ac_err"; then + rm -rf conftest* + eval "ac_cv_header_$ac_safe=yes" +else + echo "$ac_err" >&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 + : +else + echo "$ac_t""no" 1>&6 +cat >> confdefs.h <<\EOF +#define NO_SYS_WAIT_H 1 +EOF + +fi + +for ac_hdr in unistd.h +do +ac_safe=`echo "$ac_hdr" | tr './\055' '___'` +echo $ac_n "checking for $ac_hdr""... $ac_c" 1>&6 +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 1334 "configure" +#include "confdefs.h" +#include <$ac_hdr> +EOF +eval "$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out" +ac_err=`grep -v '^ *+' conftest.out` +if test -z "$ac_err"; then + rm -rf conftest* + eval "ac_cv_header_$ac_safe=yes" +else + echo "$ac_err" >&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 | tr 'abcdefghijklmnopqrstuvwxyz./\055' 'ABCDEFGHIJKLMNOPQRSTUVWXYZ___'` + cat >> confdefs.h <<EOF +#define $ac_tr_hdr 1 +EOF + +else + echo "$ac_t""no" 1>&6 +fi +done + + +#-------------------------------------------------------------------- +# Include sys/select.h if it exists and if it supplies things +# that appear to be useful and aren't already in sys/types.h. +# This appears to be true only on the RS/6000 under AIX. Some +# systems like OSF/1 have a sys/select.h that's of no use, and +# other systems like SCO UNIX have a sys/select.h that's +# pernicious. If "fd_set" isn't defined anywhere then set a +# special flag. +#-------------------------------------------------------------------- + +echo $ac_n "checking fd_set and sys/select""... $ac_c" 1>&6 +cat > conftest.$ac_ext <<EOF +#line 1375 "configure" +#include "confdefs.h" +#include <sys/types.h> +int main() { return 0; } +int t() { +fd_set readMask, writeMask; +; return 0; } +EOF +if eval $ac_compile; then + rm -rf conftest* + tk_ok=yes +else + rm -rf conftest* + tk_ok=no +fi +rm -f conftest* + +if test $tk_ok = no; then + cat > conftest.$ac_ext <<EOF +#line 1394 "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 +fi +rm -f conftest* + + if test $tk_ok = yes; then + cat >> confdefs.h <<\EOF +#define HAVE_SYS_SELECT_H 1 +EOF + + fi +fi +echo "$ac_t""$tk_ok" 1>&6 +if test $tk_ok = no; then + cat >> confdefs.h <<\EOF +#define NO_FD_SET 1 +EOF + +fi + +#------------------------------------------------------------------------------ +# Find out all about time handling differences. +#------------------------------------------------------------------------------ + +for ac_hdr in sys/time.h +do +ac_safe=`echo "$ac_hdr" | tr './\055' '___'` +echo $ac_n "checking for $ac_hdr""... $ac_c" 1>&6 +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 1432 "configure" +#include "confdefs.h" +#include <$ac_hdr> +EOF +eval "$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out" +ac_err=`grep -v '^ *+' conftest.out` +if test -z "$ac_err"; then + rm -rf conftest* + eval "ac_cv_header_$ac_safe=yes" +else + echo "$ac_err" >&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 | tr 'abcdefghijklmnopqrstuvwxyz./\055' '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 +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 1465 "configure" +#include "confdefs.h" +#include <sys/types.h> +#include <sys/time.h> +#include <time.h> +int main() { return 0; } +int t() { +struct tm *tp; +; return 0; } +EOF +if eval $ac_compile; then + rm -rf conftest* + ac_cv_header_time=yes +else + 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 whether struct tm is in sys/time.h or time.h""... $ac_c" 1>&6 +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 1498 "configure" +#include "confdefs.h" +#include <sys/types.h> +#include <time.h> +int main() { return 0; } +int t() { +struct tm *tp; tp->tm_sec; +; return 0; } +EOF +if eval $ac_compile; then + rm -rf conftest* + ac_cv_struct_tm=time.h +else + 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 + +echo $ac_n "checking for tm_zone in struct tm""... $ac_c" 1>&6 +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 1530 "configure" +#include "confdefs.h" +#include <sys/types.h> +#include <$ac_cv_struct_tm> +int main() { return 0; } +int t() { +struct tm tm; tm.tm_zone; +; return 0; } +EOF +if eval $ac_compile; then + rm -rf conftest* + ac_cv_struct_tm_zone=yes +else + 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 +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 1561 "configure" +#include "confdefs.h" +#include <time.h> +#ifndef tzname /* For SGI. */ +extern char *tzname[]; /* RS6000 and others reject char **tzname. */ +#endif +int main() { return 0; } +int t() { +atoi(*tzname); +; return 0; } +EOF +if eval $ac_link; then + rm -rf conftest* + ac_cv_var_tzname=yes +else + 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 +cat > conftest.$ac_ext <<EOF +#line 1594 "configure" +#include "confdefs.h" +#include <time.h> +int main() { return 0; } +int t() { +struct tm tm; tm.tm_tzadj; +; return 0; } +EOF +if eval $ac_compile; then + rm -rf conftest* + cat >> confdefs.h <<\EOF +#define HAVE_TM_TZADJ 1 +EOF + + echo "$ac_t""yes" 1>&6 +else + 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 +cat > conftest.$ac_ext <<EOF +#line 1618 "configure" +#include "confdefs.h" +#include <time.h> +int main() { return 0; } +int t() { +struct tm tm; tm.tm_gmtoff; +; return 0; } +EOF +if eval $ac_compile; then + rm -rf conftest* + cat >> confdefs.h <<\EOF +#define HAVE_TM_GMTOFF 1 +EOF + + echo "$ac_t""yes" 1>&6 +else + 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. +# +echo $ac_n "checking timezone variable""... $ac_c" 1>&6 +cat > conftest.$ac_ext <<EOF +#line 1646 "configure" +#include "confdefs.h" +#include <time.h> +int main() { return 0; } +int t() { +extern long timezone; + timezone += 1; + exit (0); +; return 0; } +EOF +if eval $ac_compile; then + rm -rf conftest* + cat >> confdefs.h <<\EOF +#define HAVE_TIMEZONE_VAR 1 +EOF + + echo "$ac_t""yes" 1>&6 +else + rm -rf conftest* + echo "$ac_t""no" 1>&6 +fi +rm -f conftest* + + +#-------------------------------------------------------------------- +# On some systems strstr is broken: it returns a pointer even +# even if the original string is empty. +#-------------------------------------------------------------------- + +echo $ac_n "checking proper strstr implementation""... $ac_c" 1>&6 +if test "$cross_compiling" = yes; then + tcl_ok=no +else +cat > conftest.$ac_ext <<EOF +#line 1680 "configure" +#include "confdefs.h" + +extern int strstr(); +int main() +{ + exit(strstr("\0test", "test") ? 1 : 0); +} + +EOF +eval $ac_link +if test -s conftest && (./conftest; exit) 2>/dev/null; then + tcl_ok=yes +else + tcl_ok=no +fi +fi +rm -fr conftest* +if test $tcl_ok = yes; then + echo "$ac_t""yes" 1>&6 +else + echo "$ac_t""broken, using substitute" 1>&6 + LIBOBJS="$LIBOBJS strstr.o" +fi + +#-------------------------------------------------------------------- +# Check for strtoul function. This is tricky because under some +# versions of AIX strtoul returns an incorrect terminator +# pointer for the string "0". +#-------------------------------------------------------------------- + +echo $ac_n "checking for strtoul""... $ac_c" 1>&6 +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 1716 "configure" +#include "confdefs.h" +/* System header to define __stub macros and hopefully few prototypes, + which can conflict with char strtoul(); below. */ +#include <assert.h> +/* Override any gcc2 internal prototype to avoid an error. */ +char strtoul(); + +int main() { return 0; } +int t() { + +/* 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_strtoul) || defined (__stub___strtoul) +choke me +#else +strtoul(); +#endif + +; return 0; } +EOF +if eval $ac_link; then + rm -rf conftest* + eval "ac_cv_func_strtoul=yes" +else + rm -rf conftest* + eval "ac_cv_func_strtoul=no" +fi +rm -f conftest* + +fi +if eval "test \"`echo '$ac_cv_func_'strtoul`\" = yes"; then + echo "$ac_t""yes" 1>&6 + tcl_ok=1 +else + echo "$ac_t""no" 1>&6 +tcl_ok=0 +fi + +if test "$cross_compiling" = yes; then + tcl_ok=0 +else +cat > conftest.$ac_ext <<EOF +#line 1760 "configure" +#include "confdefs.h" + +extern int strtoul(); +int main() +{ + char *string = "0"; + char *term; + int value; + value = strtoul(string, &term, 0); + if ((value != 0) || (term != (string+1))) { + exit(1); + } + exit(0); +} +EOF +eval $ac_link +if test -s conftest && (./conftest; exit) 2>/dev/null; then + : +else + tcl_ok=0 +fi +fi +rm -fr conftest* +if test "$tcl_ok" = 0; then + test -n "$verbose" && echo " Adding strtoul.o." + LIBOBJS="$LIBOBJS strtoul.o" +fi + +#-------------------------------------------------------------------- +# Check for the strtod function. This is tricky because in some +# versions of Linux strtod mis-parses strings starting with "+". +#-------------------------------------------------------------------- + +echo $ac_n "checking for strtod""... $ac_c" 1>&6 +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 1799 "configure" +#include "confdefs.h" +/* System header to define __stub macros and hopefully few prototypes, + which can conflict with char strtod(); below. */ +#include <assert.h> +/* Override any gcc2 internal prototype to avoid an error. */ +char strtod(); + +int main() { return 0; } +int t() { + +/* 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_strtod) || defined (__stub___strtod) +choke me +#else +strtod(); +#endif + +; return 0; } +EOF +if eval $ac_link; then + rm -rf conftest* + eval "ac_cv_func_strtod=yes" +else + rm -rf conftest* + eval "ac_cv_func_strtod=no" +fi +rm -f conftest* + +fi +if eval "test \"`echo '$ac_cv_func_'strtod`\" = yes"; then + echo "$ac_t""yes" 1>&6 + tcl_ok=1 +else + echo "$ac_t""no" 1>&6 +tcl_ok=0 +fi + +if test "$cross_compiling" = yes; then + tcl_ok=0 +else +cat > conftest.$ac_ext <<EOF +#line 1843 "configure" +#include "confdefs.h" + +extern double strtod(); +int main() +{ + char *string = " +69"; + char *term; + double value; + value = strtod(string, &term); + if ((value != 69) || (term != (string+4))) { + exit(1); + } + exit(0); +} +EOF +eval $ac_link +if test -s conftest && (./conftest; exit) 2>/dev/null; then + : +else + tcl_ok=0 +fi +fi +rm -fr conftest* +if test "$tcl_ok" = 0; then + test -n "$verbose" && echo " Adding strtod.o." + LIBOBJS="$LIBOBJS strtod.o" +fi + +#-------------------------------------------------------------------- +# Under Solaris 2.4, strtod returns the wrong value for the +# terminating character under some conditions. Check for this +# and if the problem exists use a substitute procedure +# "fixstrtod" that corrects the error. +#-------------------------------------------------------------------- + +echo $ac_n "checking for strtod""... $ac_c" 1>&6 +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 1884 "configure" +#include "confdefs.h" +/* System header to define __stub macros and hopefully few prototypes, + which can conflict with char strtod(); below. */ +#include <assert.h> +/* Override any gcc2 internal prototype to avoid an error. */ +char strtod(); + +int main() { return 0; } +int t() { + +/* 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_strtod) || defined (__stub___strtod) +choke me +#else +strtod(); +#endif + +; return 0; } +EOF +if eval $ac_link; then + rm -rf conftest* + eval "ac_cv_func_strtod=yes" +else + rm -rf conftest* + eval "ac_cv_func_strtod=no" +fi +rm -f conftest* + +fi +if eval "test \"`echo '$ac_cv_func_'strtod`\" = yes"; then + echo "$ac_t""yes" 1>&6 + tcl_strtod=1 +else + echo "$ac_t""no" 1>&6 +tcl_strtod=0 +fi + +if test "$tcl_strtod" = 1; then + echo $ac_n "checking for Solaris strtod bug""... $ac_c" 1>&6 + if test "$cross_compiling" = yes; then + tcl_ok=0 +else +cat > conftest.$ac_ext <<EOF +#line 1930 "configure" +#include "confdefs.h" + + extern double strtod(); + int main() + { + char *string = "NaN"; + char *term; + strtod(string, &term); + if ((term != string) && (term[-1] == 0)) { + exit(1); + } + exit(0); + } +EOF +eval $ac_link +if test -s conftest && (./conftest; exit) 2>/dev/null; then + tcl_ok=1 +else + tcl_ok=0 +fi +fi +rm -fr conftest* + if test $tcl_ok = 1; then + echo "$ac_t""ok" 1>&6 + else + echo "$ac_t""buggy" 1>&6 + LIBOBJS="$LIBOBJS fixstrtod.o" + cat >> confdefs.h <<\EOF +#define strtod fixstrtod +EOF + + fi +fi + +#-------------------------------------------------------------------- +# Check for various typedefs and provide substitutes if +# they don't exist. +#-------------------------------------------------------------------- + +echo $ac_n "checking for ANSI C header files""... $ac_c" 1>&6 +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 1975 "configure" +#include "confdefs.h" +#include <stdlib.h> +#include <stdarg.h> +#include <string.h> +#include <float.h> +EOF +eval "$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out" +ac_err=`grep -v '^ *+' conftest.out` +if test -z "$ac_err"; then + rm -rf conftest* + ac_cv_header_stdc=yes +else + echo "$ac_err" >&5 + rm -rf conftest* + ac_cv_header_stdc=no +fi +rm -f 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 1997 "configure" +#include "confdefs.h" +#include <string.h> +EOF +if (eval "$ac_cpp conftest.$ac_ext") 2>&5 | + egrep "memchr" >/dev/null 2>&1; then + : +else + rm -rf conftest* + ac_cv_header_stdc=no +fi +rm -f conftest* + +fi + +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 2015 "configure" +#include "confdefs.h" +#include <stdlib.h> +EOF +if (eval "$ac_cpp conftest.$ac_ext") 2>&5 | + egrep "free" >/dev/null 2>&1; then + : +else + rm -rf conftest* + ac_cv_header_stdc=no +fi +rm -f conftest* + +fi + +if test $ac_cv_header_stdc = yes; then + # /bin/cc in Irix-4.0.5 gets non-ANSI ctype macros unless using -ansi. +if test "$cross_compiling" = yes; then + ac_cv_header_stdc=no +else +cat > conftest.$ac_ext <<EOF +#line 2036 "configure" +#include "confdefs.h" +#include <ctype.h> +#define ISLOWER(c) ('a' <= (c) && (c) <= 'z') +#define TOUPPER(c) (ISLOWER(c) ? 'A' + ((c) - 'a') : (c)) +#define XOR(e, f) (((e) && !(f)) || (!(e) && (f))) +int main () { int i; for (i = 0; i < 256; i++) +if (XOR (islower (i), ISLOWER (i)) || toupper (i) != TOUPPER (i)) exit(2); +exit (0); } + +EOF +eval $ac_link +if test -s conftest && (./conftest; exit) 2>/dev/null; then + : +else + ac_cv_header_stdc=no +fi +fi +rm -fr conftest* +fi +fi +echo "$ac_t""$ac_cv_header_stdc" 1>&6 +if test $ac_cv_header_stdc = yes; then + cat >> confdefs.h <<\EOF +#define STDC_HEADERS 1 +EOF + +fi + +echo $ac_n "checking for mode_t""... $ac_c" 1>&6 +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 2070 "configure" +#include "confdefs.h" +#include <sys/types.h> +#if STDC_HEADERS +#include <stdlib.h> +#endif +EOF +if (eval "$ac_cpp conftest.$ac_ext") 2>&5 | + egrep "mode_t" >/dev/null 2>&1; then + rm -rf conftest* + ac_cv_type_mode_t=yes +else + rm -rf conftest* + ac_cv_type_mode_t=no +fi +rm -f conftest* + +fi +echo "$ac_t""$ac_cv_type_mode_t" 1>&6 +if test $ac_cv_type_mode_t = no; then + cat >> confdefs.h <<\EOF +#define mode_t int +EOF + +fi + +echo $ac_n "checking for pid_t""... $ac_c" 1>&6 +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 2101 "configure" +#include "confdefs.h" +#include <sys/types.h> +#if STDC_HEADERS +#include <stdlib.h> +#endif +EOF +if (eval "$ac_cpp conftest.$ac_ext") 2>&5 | + egrep "pid_t" >/dev/null 2>&1; then + rm -rf conftest* + ac_cv_type_pid_t=yes +else + rm -rf conftest* + ac_cv_type_pid_t=no +fi +rm -f conftest* + +fi +echo "$ac_t""$ac_cv_type_pid_t" 1>&6 +if test $ac_cv_type_pid_t = no; then + cat >> confdefs.h <<\EOF +#define pid_t int +EOF + +fi + +echo $ac_n "checking for size_t""... $ac_c" 1>&6 +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 2132 "configure" +#include "confdefs.h" +#include <sys/types.h> +#if STDC_HEADERS +#include <stdlib.h> +#endif +EOF +if (eval "$ac_cpp conftest.$ac_ext") 2>&5 | + egrep "size_t" >/dev/null 2>&1; then + rm -rf conftest* + ac_cv_type_size_t=yes +else + rm -rf conftest* + ac_cv_type_size_t=no +fi +rm -f conftest* + +fi +echo "$ac_t""$ac_cv_type_size_t" 1>&6 +if test $ac_cv_type_size_t = no; then + cat >> confdefs.h <<\EOF +#define size_t unsigned +EOF + +fi + +echo $ac_n "checking for uid_t in sys/types.h""... $ac_c" 1>&6 +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 2163 "configure" +#include "confdefs.h" +#include <sys/types.h> +EOF +if (eval "$ac_cpp conftest.$ac_ext") 2>&5 | + egrep "uid_t" >/dev/null 2>&1; then + rm -rf conftest* + ac_cv_type_uid_t=yes +else + rm -rf conftest* + ac_cv_type_uid_t=no +fi +rm -f conftest* + +fi +echo "$ac_t""$ac_cv_type_uid_t" 1>&6 +if test $ac_cv_type_uid_t = no; then + cat >> confdefs.h <<\EOF +#define uid_t int +EOF + + cat >> confdefs.h <<\EOF +#define gid_t int +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 +# is compatible with the substitute version of opendir that's +# provided. This version only works with V7-style directories. +#-------------------------------------------------------------------- + +echo $ac_n "checking for opendir""... $ac_c" 1>&6 +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 2203 "configure" +#include "confdefs.h" +/* System header to define __stub macros and hopefully few prototypes, + which can conflict with char opendir(); below. */ +#include <assert.h> +/* Override any gcc2 internal prototype to avoid an error. */ +char opendir(); + +int main() { return 0; } +int t() { + +/* 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_opendir) || defined (__stub___opendir) +choke me +#else +opendir(); +#endif + +; return 0; } +EOF +if eval $ac_link; then + rm -rf conftest* + eval "ac_cv_func_opendir=yes" +else + rm -rf conftest* + eval "ac_cv_func_opendir=no" +fi +rm -f conftest* + +fi +if eval "test \"`echo '$ac_cv_func_'opendir`\" = yes"; then + echo "$ac_t""yes" 1>&6 + : +else + echo "$ac_t""no" 1>&6 +cat >> confdefs.h <<\EOF +#define USE_DIRENT2_H 1 +EOF + +fi + + +#-------------------------------------------------------------------- +# The check below checks whether <sys/wait.h> defines the type +# "union wait" correctly. It's needed because of weirdness in +# HP-UX where "union wait" is defined in both the BSD and SYS-V +# environments. Checking the usability of WIFEXITED seems to do +# the trick. +#-------------------------------------------------------------------- + +echo $ac_n "checking union wait""... $ac_c" 1>&6 +cat > conftest.$ac_ext <<EOF +#line 2257 "configure" +#include "confdefs.h" +#include <sys/types.h> +#include <sys/wait.h> +int main() { return 0; } +int t() { + +union wait x; +WIFEXITED(x); /* Generates compiler error if WIFEXITED + * uses an int. */ + +; return 0; } +EOF +if eval $ac_link; then + rm -rf conftest* + tcl_ok=yes +else + 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 +cat > conftest.$ac_ext <<EOF +#line 2294 "configure" +#include "confdefs.h" +#include <math.h> +int main() { return 0; } +int t() { + +struct exception x; +x.type = DOMAIN; +x.type = SING; + +; return 0; } +EOF +if eval $ac_compile; then + rm -rf conftest* + tcl_ok=yes +else + 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 for vfork""... $ac_c" 1>&6 +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 2336 "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. */ +char vfork(); + +int main() { return 0; } +int t() { + +/* 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 $ac_link; then + rm -rf conftest* + eval "ac_cv_func_vfork=yes" +else + 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; + if test "$cross_compiling" = yes; then + tcl_ok=0 +else +cat > conftest.$ac_ext <<EOF +#line 2382 "configure" +#include "confdefs.h" + + #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); + } +EOF +eval $ac_link +if test -s conftest && (./conftest; exit) 2>/dev/null; then + tcl_ok=1 +else + tcl_ok=0 +fi +fi +rm -fr conftest* + 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 + cat >> confdefs.h <<\EOF +#define vfork fork +EOF + +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. +#-------------------------------------------------------------------- + +echo $ac_n "checking for strncasecmp""... $ac_c" 1>&6 +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 2443 "configure" +#include "confdefs.h" +/* System header to define __stub macros and hopefully few prototypes, + which can conflict with char strncasecmp(); below. */ +#include <assert.h> +/* Override any gcc2 internal prototype to avoid an error. */ +char strncasecmp(); + +int main() { return 0; } +int t() { + +/* 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_strncasecmp) || defined (__stub___strncasecmp) +choke me +#else +strncasecmp(); +#endif + +; return 0; } +EOF +if eval $ac_link; then + rm -rf conftest* + eval "ac_cv_func_strncasecmp=yes" +else + rm -rf conftest* + eval "ac_cv_func_strncasecmp=no" +fi +rm -f conftest* + +fi +if eval "test \"`echo '$ac_cv_func_'strncasecmp`\" = 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" = 0; then + echo $ac_n "checking for -lsocket""... $ac_c" 1>&6 +if eval "test \"`echo '$''{'ac_cv_lib_socket'+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 2491 "configure" +#include "confdefs.h" + +int main() { return 0; } +int t() { +strncasecmp() +; return 0; } +EOF +if eval $ac_link; then + rm -rf conftest* + eval "ac_cv_lib_socket=yes" +else + rm -rf conftest* + eval "ac_cv_lib_socket=no" +fi +rm -f conftest* +LIBS="$ac_save_LIBS" + +fi +if eval "test \"`echo '$ac_cv_lib_'socket`\" = yes"; then + echo "$ac_t""yes" 1>&6 + tcl_ok=1 +else + echo "$ac_t""no" 1>&6 +tcl_ok=0 +fi + +fi +if test "$tcl_ok" = 0; then + echo $ac_n "checking for -linet""... $ac_c" 1>&6 +if eval "test \"`echo '$''{'ac_cv_lib_inet'+set}'`\" = set"; then + echo $ac_n "(cached) $ac_c" 1>&6 +else + ac_save_LIBS="$LIBS" +LIBS="-linet $LIBS" +cat > conftest.$ac_ext <<EOF +#line 2527 "configure" +#include "confdefs.h" + +int main() { return 0; } +int t() { +strncasecmp() +; return 0; } +EOF +if eval $ac_link; then + rm -rf conftest* + eval "ac_cv_lib_inet=yes" +else + rm -rf conftest* + eval "ac_cv_lib_inet=no" +fi +rm -f conftest* +LIBS="$ac_save_LIBS" + +fi +if eval "test \"`echo '$ac_cv_lib_'inet`\" = yes"; then + echo "$ac_t""yes" 1>&6 + tcl_ok=1 +else + echo "$ac_t""no" 1>&6 +tcl_ok=0 +fi + +fi +if test "$tcl_ok" = 0; then + LIBOBJS="$LIBOBJS strncasecmp.o" +fi + +#-------------------------------------------------------------------- +# The code below deals with several issues related to gettimeofday: +# 1. Some systems don't provide a gettimeofday function at all +# (set NO_GETTOD if this is the case). +# 2. SGI systems don't use the BSD form of the gettimeofday function, +# but they have a BSDgettimeofday function that can be used instead. +# 3. See if gettimeofday is declared in the <sys/time.h> header file. +# if not, set the GETTOD_NOT_DECLARED flag so that tclPort.h can +# declare it. +#-------------------------------------------------------------------- + +echo $ac_n "checking for BSDgettimeofday""... $ac_c" 1>&6 +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 2575 "configure" +#include "confdefs.h" +/* System header to define __stub macros and hopefully few prototypes, + which can conflict with char BSDgettimeofday(); below. */ +#include <assert.h> +/* Override any gcc2 internal prototype to avoid an error. */ +char BSDgettimeofday(); + +int main() { return 0; } +int t() { + +/* 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_BSDgettimeofday) || defined (__stub___BSDgettimeofday) +choke me +#else +BSDgettimeofday(); +#endif + +; return 0; } +EOF +if eval $ac_link; then + rm -rf conftest* + eval "ac_cv_func_BSDgettimeofday=yes" +else + rm -rf conftest* + eval "ac_cv_func_BSDgettimeofday=no" +fi +rm -f conftest* + +fi +if eval "test \"`echo '$ac_cv_func_'BSDgettimeofday`\" = yes"; then + echo "$ac_t""yes" 1>&6 + cat >> confdefs.h <<\EOF +#define HAVE_BSDGETTIMEOFDAY 1 +EOF + +else + echo "$ac_t""no" 1>&6 +echo $ac_n "checking for gettimeofday""... $ac_c" 1>&6 +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 2620 "configure" +#include "confdefs.h" +/* System header to define __stub macros and hopefully few prototypes, + which can conflict with char gettimeofday(); below. */ +#include <assert.h> +/* Override any gcc2 internal prototype to avoid an error. */ +char gettimeofday(); + +int main() { return 0; } +int t() { + +/* 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_gettimeofday) || defined (__stub___gettimeofday) +choke me +#else +gettimeofday(); +#endif + +; return 0; } +EOF +if eval $ac_link; then + rm -rf conftest* + eval "ac_cv_func_gettimeofday=yes" +else + rm -rf conftest* + eval "ac_cv_func_gettimeofday=no" +fi +rm -f conftest* + +fi +if eval "test \"`echo '$ac_cv_func_'gettimeofday`\" = yes"; then + echo "$ac_t""yes" 1>&6 + : +else + echo "$ac_t""no" 1>&6 +cat >> confdefs.h <<\EOF +#define NO_GETTOD 1 +EOF + +fi + +fi + +echo $ac_n "checking for gettimeofday declaration""... $ac_c" 1>&6 +cat > conftest.$ac_ext <<EOF +#line 2667 "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 +else + rm -rf conftest* + + echo "$ac_t""missing" 1>&6 + cat >> confdefs.h <<\EOF +#define GETTOD_NOT_DECLARED 1 +EOF + + +fi +rm -f conftest* + + +#-------------------------------------------------------------------- +# 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 -linet""... $ac_c" 1>&6 +if eval "test \"`echo '$''{'ac_cv_lib_inet'+set}'`\" = set"; then + echo $ac_n "(cached) $ac_c" 1>&6 +else + ac_save_LIBS="$LIBS" +LIBS="-linet $LIBS" +cat > conftest.$ac_ext <<EOF +#line 2700 "configure" +#include "confdefs.h" + +int main() { return 0; } +int t() { +main() +; return 0; } +EOF +if eval $ac_link; then + rm -rf conftest* + eval "ac_cv_lib_inet=yes" +else + rm -rf conftest* + eval "ac_cv_lib_inet=no" +fi +rm -f conftest* +LIBS="$ac_save_LIBS" + +fi +if eval "test \"`echo '$ac_cv_lib_'inet`\" = yes"; then + echo "$ac_t""yes" 1>&6 + LIBS="$LIBS -linet" +else + echo "$ac_t""no" 1>&6 +fi + +ac_safe=`echo "net/errno.h" | tr './\055' '___'` +echo $ac_n "checking for net/errno.h""... $ac_c" 1>&6 +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 2732 "configure" +#include "confdefs.h" +#include <net/errno.h> +EOF +eval "$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out" +ac_err=`grep -v '^ *+' conftest.out` +if test -z "$ac_err"; then + rm -rf conftest* + eval "ac_cv_header_$ac_safe=yes" +else + echo "$ac_err" >&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 + cat >> confdefs.h <<\EOF +#define HAVE_NET_ERRNO_H 1 +EOF + +else + echo "$ac_t""no" 1>&6 +fi + + +#-------------------------------------------------------------------- +# Check for the existence of the -lsocket and -lnsl libraries. +# The order here is important, so that they end up in the right +# order in the command line generated by make. Here are some +# special considerations: +# 1. Use "connect" and "accept" to check for -lsocket, and +# "gethostbyname" to check for -lnsl. +# 2. Use each function name only once: can't redo a check because +# autoconf caches the results of the last check and won't redo it. +# 3. Use -lnsl and -lsocket only if they supply procedures that +# aren't already present in the normal libraries. This is because +# IRIX 5.2 has libraries, but they aren't needed and they're +# bogus: they goof up name resolution if used. +# 4. On some SVR4 systems, can't use -lsocket without -lnsl too. +# To get around this problem, check for both libraries together +# if -lsocket doesn't work by itself. +#-------------------------------------------------------------------- + +tcl_checkBoth=0 +echo $ac_n "checking for connect""... $ac_c" 1>&6 +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 2783 "configure" +#include "confdefs.h" +/* System header to define __stub macros and hopefully few prototypes, + which can conflict with char connect(); below. */ +#include <assert.h> +/* Override any gcc2 internal prototype to avoid an error. */ +char connect(); + +int main() { return 0; } +int t() { + +/* 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_connect) || defined (__stub___connect) +choke me +#else +connect(); +#endif + +; return 0; } +EOF +if eval $ac_link; then + rm -rf conftest* + eval "ac_cv_func_connect=yes" +else + rm -rf conftest* + eval "ac_cv_func_connect=no" +fi +rm -f conftest* + +fi +if eval "test \"`echo '$ac_cv_func_'connect`\" = yes"; then + echo "$ac_t""yes" 1>&6 + tcl_checkSocket=0 +else + echo "$ac_t""no" 1>&6 +tcl_checkSocket=1 +fi + +if test "$tcl_checkSocket" = 1; then + echo $ac_n "checking for -lsocket""... $ac_c" 1>&6 +if eval "test \"`echo '$''{'ac_cv_lib_socket'+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 2831 "configure" +#include "confdefs.h" + +int main() { return 0; } +int t() { +main() +; return 0; } +EOF +if eval $ac_link; then + rm -rf conftest* + eval "ac_cv_lib_socket=yes" +else + rm -rf conftest* + eval "ac_cv_lib_socket=no" +fi +rm -f conftest* +LIBS="$ac_save_LIBS" + +fi +if eval "test \"`echo '$ac_cv_lib_'socket`\" = yes"; then + echo "$ac_t""yes" 1>&6 + LIBS="$LIBS -lsocket" +else + echo "$ac_t""no" 1>&6 +tcl_checkBoth=1 +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 +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 2867 "configure" +#include "confdefs.h" +/* System header to define __stub macros and hopefully few prototypes, + which can conflict with char accept(); below. */ +#include <assert.h> +/* Override any gcc2 internal prototype to avoid an error. */ +char accept(); + +int main() { return 0; } +int t() { + +/* 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_accept) || defined (__stub___accept) +choke me +#else +accept(); +#endif + +; return 0; } +EOF +if eval $ac_link; then + rm -rf conftest* + eval "ac_cv_func_accept=yes" +else + rm -rf conftest* + eval "ac_cv_func_accept=no" +fi +rm -f conftest* + +fi +if eval "test \"`echo '$ac_cv_func_'accept`\" = yes"; then + echo "$ac_t""yes" 1>&6 + tcl_checkNsl=0 +else + echo "$ac_t""no" 1>&6 +LIBS=$tk_oldLibs +fi + +fi +echo $ac_n "checking for gethostbyname""... $ac_c" 1>&6 +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 2913 "configure" +#include "confdefs.h" +/* System header to define __stub macros and hopefully few prototypes, + which can conflict with char gethostbyname(); below. */ +#include <assert.h> +/* Override any gcc2 internal prototype to avoid an error. */ +char gethostbyname(); + +int main() { return 0; } +int t() { + +/* 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_gethostbyname) || defined (__stub___gethostbyname) +choke me +#else +gethostbyname(); +#endif + +; return 0; } +EOF +if eval $ac_link; then + rm -rf conftest* + eval "ac_cv_func_gethostbyname=yes" +else + rm -rf conftest* + eval "ac_cv_func_gethostbyname=no" +fi +rm -f conftest* + +fi +if eval "test \"`echo '$ac_cv_func_'gethostbyname`\" = yes"; then + echo "$ac_t""yes" 1>&6 + : +else + echo "$ac_t""no" 1>&6 +echo $ac_n "checking for -lnsl""... $ac_c" 1>&6 +if eval "test \"`echo '$''{'ac_cv_lib_nsl'+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 2957 "configure" +#include "confdefs.h" + +int main() { return 0; } +int t() { +main() +; return 0; } +EOF +if eval $ac_link; then + rm -rf conftest* + eval "ac_cv_lib_nsl=yes" +else + rm -rf conftest* + eval "ac_cv_lib_nsl=no" +fi +rm -f conftest* +LIBS="$ac_save_LIBS" + +fi +if eval "test \"`echo '$ac_cv_lib_'nsl`\" = yes"; then + echo "$ac_t""yes" 1>&6 + LIBS="$LIBS -lnsl" +else + echo "$ac_t""no" 1>&6 +fi + +fi + + +#-------------------------------------------------------------------- +# The statements below define a collection of symbols related to +# dynamic loading and shared libraries: +# +# DL_OBJS - Name of the object file that implements dynamic +# loading for Tcl on this system. +# DL_LIBS - Library file(s) to include in tclsh and other base +# applications in order for the "load" command to work. +# LD_FLAGS - Flags to pass to the compiler when linking object +# files into an executable application binary such +# as tclsh. +# 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_INSTALL_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. +# SHLIB_CFLAGS - Flags to pass to cc when compiling the components +# of a shared library (may request position-independent +# code, among other things). +# SHLIB_LD - Base command to use for combining object files +# into a shared library. +# 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 +# shared libraries. The value of the symbol is +# "${LIBS}" if all of the dependent libraries should +# be specified when creating a shared library. If +# dependent libraries should not be specified (as on +# SunOS 4.x, where they cause the link to fail, or in +# general if Tcl and Tk aren't themselves shared +# libraries), then this symbol has an empty string +# as its value. +# 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.5.so or libtcl7.5.a. +# TCL_LIB_SUFFIX -Specifies everything that comes after the "libtcl" +# in the 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 +# a .a extension whereas shared objects for loadable +# extensions have a .so extension. Defaults to +# ${VERSION}${SHLIB_SUFFIX}. +#-------------------------------------------------------------------- + +# Step 1: set the variable "system" to hold the name and version number +# for the system. This can usually be done via the "uname" command, but +# 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 +if test -f /usr/lib/NextStep/software_version; then + system=NEXTSTEP-`awk '/3/,/3/' /usr/lib/NextStep/software_version` +else + system=`uname -s`-`uname -r` + if test "$?" -ne 0 ; then + echo "$ac_t""unknown (can't find uname command)" 1>&6 + system=unknown + else + # Special check for weird MP-RAS system (uname returns weird + # results, and the version is kept in special file). + + if test -r /etc/.relid -a "X`uname -n`" = "X`uname -s`" ; then + system=MP-RAS-`awk '{print $3}' /etc/.relid'` + fi + if test "`uname -s`" = "AIX" ; then + system=AIX-`uname -v`.`uname -r` + fi + echo "$ac_t""$system" 1>&6 + fi +fi + +# 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 -ldl""... $ac_c" 1>&6 +if eval "test \"`echo '$''{'ac_cv_lib_dl'+set}'`\" = set"; then + echo $ac_n "(cached) $ac_c" 1>&6 +else + ac_save_LIBS="$LIBS" +LIBS="-ldl $LIBS" +cat > conftest.$ac_ext <<EOF +#line 3073 "configure" +#include "confdefs.h" + +int main() { return 0; } +int t() { +dlopen() +; return 0; } +EOF +if eval $ac_link; then + rm -rf conftest* + eval "ac_cv_lib_dl=yes" +else + rm -rf conftest* + eval "ac_cv_lib_dl=no" +fi +rm -f conftest* +LIBS="$ac_save_LIBS" + +fi +if eval "test \"`echo '$ac_cv_lib_'dl`\" = yes"; then + echo "$ac_t""yes" 1>&6 + have_dl=yes +else + echo "$ac_t""no" 1>&6 +have_dl=no +fi + + +# Step 3: disable dynamic loading if requested via a command-line switch. + +# Check whether --enable-load or --disable-load was given. +enableval="$enable_load" +if test -n "$enableval"; then + tcl_ok=$enableval +else + tcl_ok=yes +fi + +if test "$tcl_ok" = "no"; then + system=unknown +fi + +# Step 4: set configuration options based on system name and version. + +fullSrcDir=`cd $srcdir; pwd` +AIX=no +TCL_SHARED_LIB_SUFFIX="" +TCL_UNSHARED_LIB_SUFFIX="" +TCL_LIB_VERSIONS_OK=ok +case $system in + AIX-*) + SHLIB_CFLAGS="" + SHLIB_LD="$fullSrcDir/ldAix /bin/ld -bhalt:4 -bM:SRE -bE:lib.exp -H512 -T512" + SHLIB_LD_LIBS='${LIBS}' + SHLIB_SUFFIX=".so" + DL_OBJS="tclLoadDl.o tclLoadAix.o" + DL_LIBS="-lld" + LD_FLAGS="" + LD_SEARCH_FLAGS='-L${LIB_INSTALL_DIR}' + cat >> confdefs.h <<\EOF +#define NO_DLFCN_H 1 +EOF + + AIX=yes + TCL_SHARED_LIB_SUFFIX='${VERSION}.a' + ;; + HP-UX-*.08.*|HP-UX-*.09.*|HP-UX-*.10.*) + SHLIB_CFLAGS="+z" + SHLIB_LD="ld -b" + SHLIB_LD_LIBS='${LIBS}' + SHLIB_SUFFIX=".sl" + DL_OBJS="tclLoadShl.o" + DL_LIBS="-ldld" + LD_FLAGS="-Wl,-E" + LD_SEARCH_FLAGS='-Wl,+b,${LIB_INSTALL_DIR}:.' + ;; + IRIX-4.*) + SHLIB_CFLAGS="-G 0" + SHLIB_SUFFIX="..o" + SHLIB_LD="echo tclLdAout $CC \{$SHLIB_CFLAGS\} | `pwd`/tclsh -r -G 0" + SHLIB_LD_LIBS="" + DL_OBJS="tclLoadAout.o" + DL_LIBS="" + LD_FLAGS="-Wl,-D,08000000" + LD_SEARCH_FLAGS="" + ;; + IRIX-5.*) + SHLIB_CFLAGS="" + SHLIB_LD="ld -shared -rdata_shared" + SHLIB_LD_LIBS="" + SHLIB_SUFFIX=".so" + DL_OBJS="tclLoadDl.o" + DL_LIBS="" + LD_FLAGS="" + LD_SEARCH_FLAGS='-Wl,-rpath,${LIB_INSTALL_DIR}' + ;; + Linux*) + SHLIB_CFLAGS="-fPIC" + SHLIB_LD_LIBS="" + SHLIB_SUFFIX=".so" + if test "$have_dl" = yes; then + SHLIB_LD="${CC} -shared" + DL_OBJS="tclLoadDl.o" + DL_LIBS="-ldl" + LD_FLAGS="-rdynamic" + LD_SEARCH_FLAGS="" + else + ac_safe=`echo "dld.h" | tr './\055' '___'` +echo $ac_n "checking for dld.h""... $ac_c" 1>&6 +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 3186 "configure" +#include "confdefs.h" +#include <dld.h> +EOF +eval "$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out" +ac_err=`grep -v '^ *+' conftest.out` +if test -z "$ac_err"; then + rm -rf conftest* + eval "ac_cv_header_$ac_safe=yes" +else + echo "$ac_err" >&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" + LD_FLAGS="" + LD_SEARCH_FLAGS="" +else + echo "$ac_t""no" 1>&6 +fi + + fi + ;; + MP-RAS-02*) + SHLIB_CFLAGS="-K PIC" + SHLIB_LD="cc -G" + SHLIB_LD_LIBS="" + SHLIB_SUFFIX=".so" + DL_OBJS="tclLoadDl.o" + DL_LIBS="-ldl" + LD_FLAGS="" + LD_SEARCH_FLAGS="" + ;; + MP-RAS-*) + SHLIB_CFLAGS="-K PIC" + SHLIB_LD="cc -G" + SHLIB_LD_LIBS="" + SHLIB_SUFFIX=".so" + DL_OBJS="tclLoadDl.o" + DL_LIBS="-ldl" + LD_FLAGS="-Wl,-Bexport" + LD_SEARCH_FLAGS="" + ;; + NetBSD-*|FreeBSD-*) + # Not available on all versions: check for include file. + ac_safe=`echo "dlfcn.h" | tr './\055' '___'` +echo $ac_n "checking for dlfcn.h""... $ac_c" 1>&6 +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 3244 "configure" +#include "confdefs.h" +#include <dlfcn.h> +EOF +eval "$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out" +ac_err=`grep -v '^ *+' conftest.out` +if test -z "$ac_err"; then + rm -rf conftest* + eval "ac_cv_header_$ac_safe=yes" +else + echo "$ac_err" >&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_CFLAGS="-fpic" + SHLIB_LD="ld -Bshareable" + SHLIB_LD_LIBS="" + SHLIB_SUFFIX=".so" + DL_OBJS="tclLoadDl2.o" + DL_LIBS="" + LD_FLAGS="" + LD_SEARCH_FLAGS="" + +else + echo "$ac_t""no" 1>&6 + + SHLIB_CFLAGS="" + SHLIB_LD="echo tclLdAout $CC \{$SHLIB_CFLAGS\} | `pwd`/tclsh -r -G 0" + SHLIB_LD_LIBS="" + SHLIB_SUFFIX="..o" + DL_OBJS="tclLoadAout.o" + DL_LIBS="" + LD_FLAGS="" + LD_SEARCH_FLAGS="" + +fi + + + # FreeBSD doesn't handle version numbers with dots. Also, have to + # append a dummy version number to .so file names. + + TCL_SHARED_LIB_SUFFIX='`echo ${VERSION} | tr -d .`.so.1.0' + TCL_UNSHARED_LIB_SUFFIX='`echo ${VERSION} | tr -d .`.a' + TCL_LIB_VERSIONS_OK=nodots + ;; + NEXTSTEP-*) + SHLIB_CFLAGS="" + SHLIB_LD="cc -nostdlib -r" + SHLIB_LD_LIBS="" + SHLIB_SUFFIX=".so" + DL_OBJS="tclLoadNext.o" + DL_LIBS="" + LD_FLAGS="" + LD_SEARCH_FLAGS="" + ;; + OSF1-1.012) + # OSF/1 1.[012] from OSF, and derivatives, including Paragon OSF/1 + SHLIB_CFLAGS="" + # Hack: make package name same as library name + SHLIB_LD='ld -R -export $@:' + SHLIB_LD_LIBS="" + SHLIB_SUFFIX=".so" + DL_OBJS="tclLoadOSF.o" + DL_LIBS="" + LD_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" + SHLIB_LD_LIBS="" + SHLIB_SUFFIX=".so" + DL_OBJS="tclLoadDl.o" + DL_LIBS="" + LD_FLAGS="" + LD_SEARCH_FLAGS="" + ;; + OSF1-V*) + # Digital OSF/1 + SHLIB_CFLAGS="" + SHLIB_LD='ld -shared -expect_unresolved "*"' + SHLIB_LD_LIBS="" + SHLIB_SUFFIX=".so" + DL_OBJS="tclLoadDl.o" + DL_LIBS="" + LD_FLAGS="" + LD_SEARCH_FLAGS='-Wl,-rpath,${LIB_INSTALL_DIR}' + ;; + RISCos-*) + SHLIB_CFLAGS="-G 0" + SHLIB_LD="echo tclLdAout $CC \{$SHLIB_CFLAGS\} | `pwd`/tclsh -r -G 0" + SHLIB_LD_LIBS="" + SHLIB_SUFFIX="..o" + DL_OBJS="tclLoadAout.o" + DL_LIBS="" + LD_FLAGS="-Wl,-D,08000000" + LD_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. + SHLIB_CFLAGS="-Kpic -belf" + SHLIB_LD="ld -G" + SHLIB_LD_LIBS="" + SHLIB_SUFFIX=".so" + DL_OBJS="tclLoadDl.o" + DL_LIBS="" + LD_FLAGS="-belf -Wl,-Bexport" + LD_SEARCH_FLAGS="" + ;; + SINIX*5.4*) + SHLIB_CFLAGS="-K PIC" + SHLIB_LD="cc -G" + SHLIB_LD_LIBS="" + SHLIB_SUFFIX=".so" + DL_OBJS="tclLoadDl.o" + DL_LIBS="-ldl" + LD_FLAGS="" + LD_SEARCH_FLAGS="" + ;; + SunOS-4*) + SHLIB_CFLAGS="-PIC" + SHLIB_LD="ld" + SHLIB_LD_LIBS="" + SHLIB_SUFFIX=".so" + DL_OBJS="tclLoadDl.o" + DL_LIBS="-ldl" + LD_FLAGS="" + LD_SEARCH_FLAGS='-L${LIB_INSTALL_DIR}' + + # SunOS can't handle version numbers with dots in them in library + # specs, like -ltcl7.5, so use -ltcl75 instead. Also, it + # requires an extra version number at the end of .so file names. + # So, the library has to have a name like libtcl75.so.1.0 + + TCL_SHARED_LIB_SUFFIX='`echo ${VERSION} | tr -d .`.so.1.0' + TCL_UNSHARED_LIB_SUFFIX='`echo ${VERSION} | tr -d .`.a' + TCL_LIB_VERSIONS_OK=nodots + ;; + SunOS-5*) + SHLIB_CFLAGS="-K PIC" + SHLIB_LD="/usr/ccs/bin/ld -G -z text" + SHLIB_LD_LIBS='${LIBS}' + SHLIB_SUFFIX=".so" + DL_OBJS="tclLoadDl.o" + DL_LIBS="-ldl" + LD_FLAGS="" + LD_SEARCH_FLAGS='-R ${LIB_INSTALL_DIR}' + ;; + ULTRIX-4.*) + SHLIB_CFLAGS="-G 0" + SHLIB_SUFFIX="..o" + SHLIB_LD="echo tclLdAout $CC \{$SHLIB_CFLAGS\} | `pwd`/tclsh -r -G 0" + SHLIB_LD_LIBS="" + DL_OBJS="tclLoadAout.o" + DL_LIBS="" + LD_FLAGS="-Wl,-D,08000000" + LD_SEARCH_FLAGS="" + ;; + UNIX_SV*) + SHLIB_CFLAGS="-K PIC" + SHLIB_LD="cc -G" + SHLIB_LD_LIBS="" + SHLIB_SUFFIX=".so" + DL_OBJS="tclLoadDl.o" + DL_LIBS="-ldl" + LD_FLAGS="-Wl,-Bexport" + LD_SEARCH_FLAGS="" + ;; +esac + +# If pseudo-static linking is in use (see K. B. Kenny, "Dynamic Loading for +# Tcl -- What Became of It?". Proc. 2nd Tcl/Tk Workshop, New Orleans, LA, +# Computerized Processes Unlimited, 1994), then we need to determine which +# of several header files defines the a.out file format (a.out.h, sys/exec.h, +# or sys/exec_aout.h). At present, we support only a file format that +# is more or less version-7-compatible. In particular, +# - a.out files must begin with `struct exec'. +# - the N_TXTOFF on the `struct exec' must compute the seek address +# of the text segment +# - The `struct exec' must contain a_magic, a_text, a_data, a_bss +# and a_entry fields. +# The following compilation should succeed if and only if either sys/exec.h +# or a.out.h is usable for the purpose. +# +# Note that the modified COFF format used on MIPS Ultrix 4.x is usable; the +# `struct exec' includes a second header that contains information that +# duplicates the v7 fields that are needed. + +if test "x$DL_OBJS" = "xtclLoadAout.o" ; then + echo $ac_n "checking sys/exec.h""... $ac_c" 1>&6 + cat > conftest.$ac_ext <<EOF +#line 3443 "configure" +#include "confdefs.h" +#include <sys/exec.h> +int main() { return 0; } +int t() { + + struct exec foo; + unsigned long seek; + int flag; +#if defined(__mips) || defined(mips) + seek = N_TXTOFF (foo.ex_f, foo.ex_o); +#else + seek = N_TXTOFF (foo); +#endif + flag = (foo.a_magic == OMAGIC); + return foo.a_text + foo.a_data + foo.a_bss + foo.a_entry; + +; return 0; } +EOF +if eval $ac_compile; then + rm -rf conftest* + tcl_ok=usable +else + rm -rf conftest* + tcl_ok=unusable +fi +rm -f conftest* + + echo "$ac_t""$tcl_ok" 1>&6 + if test $tcl_ok = usable; then + cat >> confdefs.h <<\EOF +#define USE_SYS_EXEC_H 1 +EOF + + else + echo $ac_n "checking a.out.h""... $ac_c" 1>&6 + cat > conftest.$ac_ext <<EOF +#line 3480 "configure" +#include "confdefs.h" +#include <a.out.h> +int main() { return 0; } +int t() { + + struct exec foo; + unsigned long seek; + int flag; +#if defined(__mips) || defined(mips) + seek = N_TXTOFF (foo.ex_f, foo.ex_o); +#else + seek = N_TXTOFF (foo); +#endif + flag = (foo.a_magic == OMAGIC); + return foo.a_text + foo.a_data + foo.a_bss + foo.a_entry; + +; return 0; } +EOF +if eval $ac_compile; then + rm -rf conftest* + tcl_ok=usable +else + rm -rf conftest* + tcl_ok=unusable +fi +rm -f conftest* + + echo "$ac_t""$tcl_ok" 1>&6 + if test $tcl_ok = usable; then + cat >> confdefs.h <<\EOF +#define USE_A_OUT_H 1 +EOF + + else + echo $ac_n "checking sys/exec_aout.h""... $ac_c" 1>&6 + cat > conftest.$ac_ext <<EOF +#line 3517 "configure" +#include "confdefs.h" +#include <sys/exec_aout.h> +int main() { return 0; } +int t() { + + struct exec foo; + unsigned long seek; + int flag; +#if defined(__mips) || defined(mips) + seek = N_TXTOFF (foo.ex_f, foo.ex_o); +#else + seek = N_TXTOFF (foo); +#endif + flag = (foo.a_midmag == OMAGIC); + return foo.a_text + foo.a_data + foo.a_bss + foo.a_entry; + +; return 0; } +EOF +if eval $ac_compile; then + rm -rf conftest* + tcl_ok=usable +else + rm -rf conftest* + tcl_ok=unusable +fi +rm -f conftest* + + echo "$ac_t""$tcl_ok" 1>&6 + if test $tcl_ok = usable; then + cat >> confdefs.h <<\EOF +#define USE_SYS_EXEC_AOUT_H 1 +EOF + + else + DL_OBJS="" + fi + fi + fi +fi + +if test "x$DL_OBJS" != "x" ; then + BUILD_DLTEST="\$(DLTEST_TARGETS)" +else + echo "Can't figure out how to do dynamic loading or shared libraries" + echo "on this system." + SHLIB_CFLAGS="" + SHLIB_LD="" + SHLIB_SUFFIX="" + DL_OBJS="tclLoadNone.o" + DL_LIBS="" + LD_FLAGS="" + LD_SEARCH_FLAGS="" + BUILD_DLTEST="" +fi + +# If we're running gcc, then change the C flags for compiling shared +# libraries to the right flags for gcc, instead of those for the +# standard manufacturer compiler. + +if test "$DL_OBJS" != "tclLoadNone.o" ; then + if test "$CC" = "gcc" -o `$CC -v 2>&1 | grep -c gcc` != "0" ; then + SHLIB_CFLAGS="-fPIC" + fi +fi + +#-------------------------------------------------------------------- +# The statements below define a collection of symbols related to +# building libtcl as a shared library instead of a static library. +#-------------------------------------------------------------------- + +realRanlib=$RANLIB +if test "$TCL_SHARED_LIB_SUFFIX" = "" ; then + TCL_SHARED_LIB_SUFFIX='${VERSION}${SHLIB_SUFFIX}' +fi +if test "$TCL_UNSHARED_LIB_SUFFIX" = "" ; then + TCL_UNSHARED_LIB_SUFFIX='${VERSION}.a' +fi +# Check whether --enable-shared or --disable-shared was given. +enableval="$enable_shared" +if test -n "$enableval"; then + tcl_ok=$enableval +else + tcl_ok=no +fi + +if test "$tcl_ok" = "yes" -a "${SHLIB_SUFFIX}" != "" \ + -a "${DL_OBJS}" != "tclLoadAout.o" ; then + TCL_SHLIB_CFLAGS="${SHLIB_CFLAGS}" + TCL_LD_SEARCH_FLAGS="${LD_SEARCH_FLAGS}" + eval "TCL_LIB_FILE=libtcl${TCL_SHARED_LIB_SUFFIX}" + MAKE_LIB="\${SHLIB_LD} -o ${TCL_LIB_FILE} \${OBJS} ${SHLIB_LD_LIBS}" + RANLIB=":" +else + if test "$AIX" = "no" ; then + SHLIB_LD_LIBS="" + fi + TCL_SHLIB_CFLAGS="" + TCL_LD_SEARCH_FLAGS="" + eval "TCL_LIB_FILE=libtcl${TCL_UNSHARED_LIB_SUFFIX}" + MAKE_LIB="ar cr ${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 "${TCL_LIB_VERSIONS_OK}" = "ok"; then + TCL_BUILD_LIB_SPEC="-L`pwd` -ltcl${VERSION}" + TCL_LIB_SPEC="-L${exec_prefix}/lib -ltcl${VERSION}" +else + TCL_BUILD_LIB_SPEC="-L`pwd` -ltcl`echo ${VERSION} | tr -d .`" + TCL_LIB_SPEC="-L${exec_prefix}/lib -ltcl`echo ${VERSION} | tr -d .`" +fi + + + + + + + + + + + + + + + + + + + + + + + +trap '' 1 2 15 +cat > confcache <<\EOF +# This file is a shell script that caches the results of configure +# tests run on this system so they can be shared between configure +# scripts and configure runs. It is not useful on other systems. +# If it contains results you don't want to keep, you may remove or edit it. +# +# By default, configure uses ./config.cache as the cache file, +# creating it if it does not exist already. You can give configure +# the --cache-file=FILE option to use a different cache file; that is +# what configure does when it calls configure scripts in +# subdirectories, so they share the cache. +# Giving --cache-file=/dev/null disables caching, for debugging configure. +# config.status only pays attention to the cache file if you give it the +# --recheck option to rerun configure. +# +EOF +# 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 +if cmp -s $cache_file confcache; then + : +else + if test -w $cache_file; then + echo "updating cache $cache_file" + cat confcache > $cache_file + else + echo "not updating unwritable cache $cache_file" + fi +fi +rm -f confcache + +trap 'rm -fr conftest* confdefs* core core.* *.core $ac_clean_files; exit 1' 1 2 15 + +test "x$prefix" = xNONE && prefix=$ac_default_prefix +# Let make expand exec_prefix. +test "x$exec_prefix" = xNONE && exec_prefix='${prefix}' + +# Any assignment to VPATH causes Sun make to only execute +# the first set of double-colon rules, so remove it if not needed. +# If there is a colon in the path, we need to keep it. +if test "x$srcdir" = x.; then + ac_vpsub='/^[ ]*VPATH[ ]*=[^:]*$/d' +fi + +trap 'rm -f $CONFIG_STATUS conftest*; exit 1' 1 2 15 + +# 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 + + +# Without the "./", some shells look in PATH for config.status. +: ${CONFIG_STATUS=./config.status} + +echo creating $CONFIG_STATUS +rm -f $CONFIG_STATUS +cat > $CONFIG_STATUS <<EOF +#! /bin/sh +# Generated automatically by configure. +# Run this file to recreate the current configuration. +# This directory was configured as follows, +# on host `(hostname || uname -n) 2>/dev/null | sed 1q`: +# +# $0 $ac_configure_args +# +# Compiler output produced by configure, useful for debugging +# configure, is in ./config.log if it exists. + +ac_cs_usage="Usage: $CONFIG_STATUS [--recheck] [--version] [--help]" +for ac_option +do + case "\$ac_option" in + -recheck | --recheck | --rechec | --reche | --rech | --rec | --re | --r) + 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.4" + exit 0 ;; + -help | --help | --hel | --he | --h) + echo "\$ac_cs_usage"; exit 0 ;; + *) echo "\$ac_cs_usage"; exit 1 ;; + esac +done + +ac_given_srcdir=$srcdir + +trap 'rm -fr `echo "Makefile tclConfig.sh" | sed "s/:[^ ]*//g"` conftest*; exit 1' 1 2 15 + +# Protect against being on the right side of a sed subst in config.status. +sed 's/%@/@@/; s/@%/@@/; s/%g$/@g/; /@g$/s/[\\\\&%]/\\\\&/g; + s/@@/%@/; s/@@/@%/; s/@g$/%g/' > conftest.subs <<\CEOF +$ac_vpsub +$extrasub +s%@CFLAGS@%$CFLAGS%g +s%@CPPFLAGS@%$CPPFLAGS%g +s%@CXXFLAGS@%$CXXFLAGS%g +s%@DEFS@%$DEFS%g +s%@LDFLAGS@%$LDFLAGS%g +s%@LIBS@%$LIBS%g +s%@exec_prefix@%$exec_prefix%g +s%@prefix@%$prefix%g +s%@program_transform_name@%$program_transform_name%g +s%@RANLIB@%$RANLIB%g +s%@CC@%$CC%g +s%@LIBOBJS@%$LIBOBJS%g +s%@CPP@%$CPP%g +s%@BUILD_DLTEST@%$BUILD_DLTEST%g +s%@DL_LIBS@%$DL_LIBS%g +s%@DL_OBJS@%$DL_OBJS%g +s%@LD_FLAGS@%$LD_FLAGS%g +s%@MAKE_LIB@%$MAKE_LIB%g +s%@MATH_LIBS@%$MATH_LIBS%g +s%@SHLIB_CFLAGS@%$SHLIB_CFLAGS%g +s%@SHLIB_LD@%$SHLIB_LD%g +s%@SHLIB_LD_LIBS@%$SHLIB_LD_LIBS%g +s%@SHLIB_SUFFIX@%$SHLIB_SUFFIX%g +s%@TCL_BUILD_LIB_SPEC@%$TCL_BUILD_LIB_SPEC%g +s%@TCL_LD_SEARCH_FLAGS@%$TCL_LD_SEARCH_FLAGS%g +s%@TCL_LIB_FILE@%$TCL_LIB_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_SHARED_LIB_SUFFIX@%$TCL_SHARED_LIB_SUFFIX%g +s%@TCL_SHLIB_CFLAGS@%$TCL_SHLIB_CFLAGS%g +s%@TCL_UNSHARED_LIB_SUFFIX@%$TCL_UNSHARED_LIB_SUFFIX%g +s%@TCL_VERSION@%$TCL_VERSION%g + +CEOF +EOF +cat >> $CONFIG_STATUS <<EOF + +CONFIG_FILES=\${CONFIG_FILES-"Makefile tclConfig.sh"} +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". + case "$ac_file" in + *:*) 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. + + # Remove last slash and all that follows it. Not all systems have dirname. + ac_dir=`echo $ac_file|sed 's%/[^/][^/]*$%%'` + if test "$ac_dir" != "$ac_file" && test "$ac_dir" != .; then + # The file is in a subdirectory. + test ! -d "$ac_dir" && mkdir "$ac_dir" + ac_dir_suffix="/`echo $ac_dir|sed 's%^\./%%'`" + # A "../" for each directory in $ac_dir_suffix. + ac_dots=`echo $ac_dir_suffix|sed 's%/[^/]*%../%g'` + else + ac_dir_suffix= ac_dots= + fi + + case "$ac_given_srcdir" in + .) srcdir=. + if test -z "$ac_dots"; then top_srcdir=. + else top_srcdir=`echo $ac_dots|sed 's%/$%%'`; fi ;; + /*) srcdir="$ac_given_srcdir$ac_dir_suffix"; top_srcdir="$ac_given_srcdir" ;; + *) # Relative path. + srcdir="$ac_dots$ac_given_srcdir$ac_dir_suffix" + 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." + case "$ac_file" in + *Makefile*) ac_comsub="1i\\ +# $configure_input" ;; + *) ac_comsub= ;; + esac + 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 +fi; done +rm -f conftest.subs + + + +exit 0 +EOF +chmod +x $CONFIG_STATUS +rm -fr confdefs* $ac_clean_files +test "$no_create" = yes || ${CONFIG_SHELL-/bin/sh} $CONFIG_STATUS || exit 1 + diff --git a/contrib/tcl/unix/configure.in b/contrib/tcl/unix/configure.in new file mode 100755 index 0000000..e57218c --- /dev/null +++ b/contrib/tcl/unix/configure.in @@ -0,0 +1,943 @@ +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. +AC_INIT(../generic/tcl.h) +# SCCS: @(#) configure.in 1.102 96/04/17 10:46:25 + +TCL_VERSION=7.5 +TCL_MAJOR_VERSION=7 +TCL_MINOR_VERSION=5 +VERSION=${TCL_VERSION} + +if test "${prefix}" = "NONE"; then + prefix=/usr/local +fi +if test "${exec_prefix}" = "NONE"; then + exec_prefix=$prefix +fi + +AC_PROG_RANLIB +AC_ARG_ENABLE(gcc, [ --enable-gcc allow use of gcc if available], + [tcl_ok=$enableval], [tcl_ok=no]) +if test "$tcl_ok" = "yes"; then + AC_PROG_CC +else + CC=${CC-cc} +AC_SUBST(CC) +fi +AC_C_CROSS + +#-------------------------------------------------------------------- +# Supply substitutes for missing POSIX library procedures, or +# set flags so Tcl uses alternate procedures. +#-------------------------------------------------------------------- + +AC_REPLACE_FUNCS(getcwd 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)) + +#-------------------------------------------------------------------- +# On a few very rare systems, all of the libm.a stuff is +# already in libc.a. Set compiler flags accordingly. +# Also, Linux requires the "ieee" library for math to work +# right (and it must appear before "-lm"). +#-------------------------------------------------------------------- + +AC_CHECK_FUNC(sin, MATH_LIBS="", MATH_LIBS="-lm") +AC_CHECK_LIB(ieee, main, [MATH_LIBS="-lieee $MATH_LIBS"]) + +#-------------------------------------------------------------------- +# Supply substitutes for missing POSIX header files. Special +# notes: +# - stdlib.h doesn't define strtol, strtoul, or +# strtod insome versions of SunOS +# - some versions of string.h don't declare procedures such +# as strstr +#-------------------------------------------------------------------- + +AC_MSG_CHECKING(dirent.h) +AC_TRY_LINK([#include <sys/types.h> +#include <dirent.h>], [ +#ifndef _POSIX_SOURCE +# ifdef __Lynx__ + /* + * Generate compilation error to make the test fail: Lynx headers + * are only valid if really in the POSIX environment. + */ + + missing_procedure(); +# endif +#endif +DIR *d; +struct dirent *entryPtr; +char *p; +d = opendir("foobar"); +entryPtr = readdir(d); +p = entryPtr->d_name; +closedir(d); +], tcl_ok=yes, tcl_ok=no) +if test $tcl_ok = no; then + AC_DEFINE(NO_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(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_EGREP_HEADER(strtod, stdlib.h, , tcl_ok=0) +if test $tcl_ok = 0; then + AC_DEFINE(NO_STDLIB_H) +fi +AC_CHECK_HEADER(string.h, tcl_ok=1, tcl_ok=0) +AC_EGREP_HEADER(strstr, string.h, , tcl_ok=0) +AC_EGREP_HEADER(strerror, string.h, , tcl_ok=0) +if test $tcl_ok = 0; then + AC_DEFINE(NO_STRING_H) +fi +AC_CHECK_HEADER(sys/wait.h, , AC_DEFINE(NO_SYS_WAIT_H)) +AC_HAVE_HEADERS(unistd.h) + +#-------------------------------------------------------------------- +# Include sys/select.h if it exists and if it supplies things +# that appear to be useful and aren't already in sys/types.h. +# This appears to be true only on the RS/6000 under AIX. Some +# systems like OSF/1 have a sys/select.h that's of no use, and +# other systems like SCO UNIX have a sys/select.h that's +# pernicious. If "fd_set" isn't defined anywhere then set a +# 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_DEFINE(HAVE_SYS_SELECT_H) + fi +fi +AC_MSG_RESULT($tk_ok) +if test $tk_ok = no; then + AC_DEFINE(NO_FD_SET) +fi + +#------------------------------------------------------------------------------ +# Find out all about time handling differences. +#------------------------------------------------------------------------------ + +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. +# +AC_MSG_CHECKING([timezone variable]) +AC_TRY_COMPILE([#include <time.h>], + [extern long timezone; + timezone += 1; + exit (0);], + [AC_DEFINE(HAVE_TIMEZONE_VAR) + AC_MSG_RESULT(yes)], + AC_MSG_RESULT(no)) + +#-------------------------------------------------------------------- +# On some systems strstr is broken: it returns a pointer even +# even if the original string is empty. +#-------------------------------------------------------------------- + +AC_MSG_CHECKING([proper strstr implementation]) +AC_TRY_RUN([ +extern int strstr(); +int main() +{ + exit(strstr("\0test", "test") ? 1 : 0); +} +], tcl_ok=yes, tcl_ok=no, tcl_ok=no) +if test $tcl_ok = yes; then + AC_MSG_RESULT(yes) +else + AC_MSG_RESULT([broken, using substitute]) + LIBOBJS="$LIBOBJS strstr.o" +fi + +#-------------------------------------------------------------------- +# Check for strtoul function. This is tricky because under some +# versions of AIX strtoul returns an incorrect terminator +# pointer for the string "0". +#-------------------------------------------------------------------- + +AC_CHECK_FUNC(strtoul, tcl_ok=1, tcl_ok=0) +AC_TRY_RUN([ +extern int strtoul(); +int main() +{ + char *string = "0"; + char *term; + int value; + value = strtoul(string, &term, 0); + if ((value != 0) || (term != (string+1))) { + exit(1); + } + exit(0); +}], , tcl_ok=0, tcl_ok=0) +if test "$tcl_ok" = 0; then + test -n "$verbose" && echo " Adding strtoul.o." + LIBOBJS="$LIBOBJS strtoul.o" +fi + +#-------------------------------------------------------------------- +# Check for the strtod function. This is tricky because in some +# versions of Linux strtod mis-parses strings starting with "+". +#-------------------------------------------------------------------- + +AC_CHECK_FUNC(strtod, tcl_ok=1, tcl_ok=0) +AC_TRY_RUN([ +extern double strtod(); +int main() +{ + char *string = " +69"; + char *term; + double value; + value = strtod(string, &term); + if ((value != 69) || (term != (string+4))) { + exit(1); + } + exit(0); +}], , tcl_ok=0, tcl_ok=0) +if test "$tcl_ok" = 0; then + test -n "$verbose" && echo " Adding strtod.o." + LIBOBJS="$LIBOBJS strtod.o" +fi + +#-------------------------------------------------------------------- +# Under Solaris 2.4, strtod returns the wrong value for the +# terminating character under some conditions. Check for this +# and if the problem exists use a substitute procedure +# "fixstrtod" that corrects the error. +#-------------------------------------------------------------------- + +AC_CHECK_FUNC(strtod, tcl_strtod=1, tcl_strtod=0) +if test "$tcl_strtod" = 1; then + AC_MSG_CHECKING([for Solaris strtod bug]) + AC_TRY_RUN([ + extern double strtod(); + int main() + { + char *string = "NaN"; + char *term; + strtod(string, &term); + if ((term != string) && (term[-1] == 0)) { + exit(1); + } + exit(0); + }], tcl_ok=1, tcl_ok=0, tcl_ok=0) + if test $tcl_ok = 1; then + AC_MSG_RESULT(ok) + else + AC_MSG_RESULT(buggy) + LIBOBJS="$LIBOBJS fixstrtod.o" + AC_DEFINE(strtod, fixstrtod) + fi +fi + +#-------------------------------------------------------------------- +# Check for various typedefs and provide substitutes if +# they don't exist. +#-------------------------------------------------------------------- + +AC_TYPE_MODE_T +AC_TYPE_PID_T +AC_TYPE_SIZE_T +AC_TYPE_UID_T + +#-------------------------------------------------------------------- +# 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 +# is compatible with the substitute version of opendir that's +# provided. This version only works with V7-style directories. +#-------------------------------------------------------------------- + +AC_CHECK_FUNC(opendir, , AC_DEFINE(USE_DIRENT2_H)) + +#-------------------------------------------------------------------- +# The check below checks whether <sys/wait.h> defines the type +# "union wait" correctly. It's needed because of weirdness in +# HP-UX where "union wait" is defined in both the BSD and SYS-V +# environments. Checking the usability of WIFEXITED seems to do +# the trick. +#-------------------------------------------------------------------- + +AC_MSG_CHECKING([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 + 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_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. +#-------------------------------------------------------------------- + +AC_CHECK_FUNC(strncasecmp, tcl_ok=1, tcl_ok=0) +if test "$tcl_ok" = 0; then + AC_CHECK_LIB(socket, strncasecmp, tcl_ok=1, tcl_ok=0) +fi +if test "$tcl_ok" = 0; then + AC_CHECK_LIB(inet, strncasecmp, tcl_ok=1, tcl_ok=0) +fi +if test "$tcl_ok" = 0; then + LIBOBJS="$LIBOBJS strncasecmp.o" +fi + +#-------------------------------------------------------------------- +# The code below deals with several issues related to gettimeofday: +# 1. Some systems don't provide a gettimeofday function at all +# (set NO_GETTOD if this is the case). +# 2. SGI systems don't use the BSD form of the gettimeofday function, +# but they have a BSDgettimeofday function that can be used instead. +# 3. See if gettimeofday is declared in the <sys/time.h> header file. +# if not, set the GETTOD_NOT_DECLARED flag so that tclPort.h can +# declare it. +#-------------------------------------------------------------------- + +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_DEFINE(GETTOD_NOT_DECLARED) +]) + +#-------------------------------------------------------------------- +# 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)) + +#-------------------------------------------------------------------- +# Check for the existence of the -lsocket and -lnsl libraries. +# The order here is important, so that they end up in the right +# order in the command line generated by make. Here are some +# special considerations: +# 1. Use "connect" and "accept" to check for -lsocket, and +# "gethostbyname" to check for -lnsl. +# 2. Use each function name only once: can't redo a check because +# autoconf caches the results of the last check and won't redo it. +# 3. Use -lnsl and -lsocket only if they supply procedures that +# aren't already present in the normal libraries. This is because +# IRIX 5.2 has libraries, but they aren't needed and they're +# bogus: they goof up name resolution if used. +# 4. On some SVR4 systems, can't use -lsocket without -lnsl too. +# To get around this problem, check for both libraries together +# if -lsocket doesn't work by itself. +#-------------------------------------------------------------------- + +tcl_checkBoth=0 +AC_CHECK_FUNC(connect, tcl_checkSocket=0, tcl_checkSocket=1) +if test "$tcl_checkSocket" = 1; then + AC_CHECK_LIB(socket, main, 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, main, [LIBS="$LIBS -lnsl"])) + +#-------------------------------------------------------------------- +# The statements below define a collection of symbols related to +# dynamic loading and shared libraries: +# +# DL_OBJS - Name of the object file that implements dynamic +# loading for Tcl on this system. +# DL_LIBS - Library file(s) to include in tclsh and other base +# applications in order for the "load" command to work. +# LD_FLAGS - Flags to pass to the compiler when linking object +# files into an executable application binary such +# as tclsh. +# 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_INSTALL_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. +# SHLIB_CFLAGS - Flags to pass to cc when compiling the components +# of a shared library (may request position-independent +# code, among other things). +# SHLIB_LD - Base command to use for combining object files +# into a shared library. +# 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 +# shared libraries. The value of the symbol is +# "${LIBS}" if all of the dependent libraries should +# be specified when creating a shared library. If +# dependent libraries should not be specified (as on +# SunOS 4.x, where they cause the link to fail, or in +# general if Tcl and Tk aren't themselves shared +# libraries), then this symbol has an empty string +# as its value. +# 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.5.so or libtcl7.5.a. +# TCL_LIB_SUFFIX -Specifies everything that comes after the "libtcl" +# in the 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 +# a .a extension whereas shared objects for loadable +# extensions have a .so extension. Defaults to +# ${VERSION}${SHLIB_SUFFIX}. +#-------------------------------------------------------------------- + +# Step 1: set the variable "system" to hold the name and version number +# for the system. This can usually be done via the "uname" command, but +# there are a few systems, like Next, where this doesn't work. + +AC_MSG_CHECKING([system version (for dynamic loading)]) +if test -f /usr/lib/NextStep/software_version; then + system=NEXTSTEP-`awk '/3/,/3/' /usr/lib/NextStep/software_version` +else + system=`uname -s`-`uname -r` + if test "$?" -ne 0 ; then + AC_MSG_RESULT([unknown (can't find uname command)]) + system=unknown + else + # Special check for weird MP-RAS system (uname returns weird + # results, and the version is kept in special file). + + if test -r /etc/.relid -a "X`uname -n`" = "X`uname -s`" ; then + system=MP-RAS-`awk '{print $3}' /etc/.relid'` + fi + if test "`uname -s`" = "AIX" ; then + system=AIX-`uname -v`.`uname -r` + fi + AC_MSG_RESULT($system) + fi +fi + +# 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) + +# Step 3: disable dynamic loading if requested via a command-line switch. + +AC_ARG_ENABLE(load, [ --disable-load disallow dynamic loading and "load" command], + [tcl_ok=$enableval], [tcl_ok=yes]) +if test "$tcl_ok" = "no"; then + system=unknown +fi + +# Step 4: set configuration options based on system name and version. + +fullSrcDir=`cd $srcdir; pwd` +AIX=no +TCL_SHARED_LIB_SUFFIX="" +TCL_UNSHARED_LIB_SUFFIX="" +TCL_LIB_VERSIONS_OK=ok +case $system in + AIX-*) + SHLIB_CFLAGS="" + SHLIB_LD="$fullSrcDir/ldAix /bin/ld -bhalt:4 -bM:SRE -bE:lib.exp -H512 -T512" + SHLIB_LD_LIBS='${LIBS}' + SHLIB_SUFFIX=".so" + DL_OBJS="tclLoadDl.o tclLoadAix.o" + DL_LIBS="-lld" + LD_FLAGS="" + LD_SEARCH_FLAGS='-L${LIB_INSTALL_DIR}' + AC_DEFINE(NO_DLFCN_H) + AIX=yes + TCL_SHARED_LIB_SUFFIX='${VERSION}.a' + ;; + HP-UX-*.08.*|HP-UX-*.09.*|HP-UX-*.10.*) + SHLIB_CFLAGS="+z" + SHLIB_LD="ld -b" + SHLIB_LD_LIBS='${LIBS}' + SHLIB_SUFFIX=".sl" + DL_OBJS="tclLoadShl.o" + DL_LIBS="-ldld" + LD_FLAGS="-Wl,-E" + LD_SEARCH_FLAGS='-Wl,+b,${LIB_INSTALL_DIR}:.' + ;; + IRIX-4.*) + SHLIB_CFLAGS="-G 0" + SHLIB_SUFFIX="..o" + SHLIB_LD="echo tclLdAout $CC \{$SHLIB_CFLAGS\} | `pwd`/tclsh -r -G 0" + SHLIB_LD_LIBS="" + DL_OBJS="tclLoadAout.o" + DL_LIBS="" + LD_FLAGS="-Wl,-D,08000000" + LD_SEARCH_FLAGS="" + ;; + IRIX-5.*) + SHLIB_CFLAGS="" + SHLIB_LD="ld -shared -rdata_shared" + SHLIB_LD_LIBS="" + SHLIB_SUFFIX=".so" + DL_OBJS="tclLoadDl.o" + DL_LIBS="" + LD_FLAGS="" + LD_SEARCH_FLAGS='-Wl,-rpath,${LIB_INSTALL_DIR}' + ;; + Linux*) + SHLIB_CFLAGS="-fPIC" + SHLIB_LD_LIBS="" + SHLIB_SUFFIX=".so" + if test "$have_dl" = yes; then + SHLIB_LD="${CC} -shared" + DL_OBJS="tclLoadDl.o" + DL_LIBS="-ldl" + LD_FLAGS="-rdynamic" + LD_SEARCH_FLAGS="" + else + AC_CHECK_HEADER(dld.h, [ + SHLIB_LD="ld -shared" + DL_OBJS="tclLoadDld.o" + DL_LIBS="-ldld" + LD_FLAGS="" + LD_SEARCH_FLAGS=""]) + fi + ;; + MP-RAS-02*) + SHLIB_CFLAGS="-K PIC" + SHLIB_LD="cc -G" + SHLIB_LD_LIBS="" + SHLIB_SUFFIX=".so" + DL_OBJS="tclLoadDl.o" + DL_LIBS="-ldl" + LD_FLAGS="" + LD_SEARCH_FLAGS="" + ;; + MP-RAS-*) + SHLIB_CFLAGS="-K PIC" + SHLIB_LD="cc -G" + SHLIB_LD_LIBS="" + SHLIB_SUFFIX=".so" + DL_OBJS="tclLoadDl.o" + DL_LIBS="-ldl" + LD_FLAGS="-Wl,-Bexport" + LD_SEARCH_FLAGS="" + ;; + NetBSD-*|FreeBSD-*) + # Not available on all versions: check for include file. + AC_CHECK_HEADER(dlfcn.h, [ + SHLIB_CFLAGS="-fpic" + SHLIB_LD="ld -Bshareable" + SHLIB_LD_LIBS="" + SHLIB_SUFFIX=".so" + DL_OBJS="tclLoadDl2.o" + DL_LIBS="" + LD_FLAGS="" + LD_SEARCH_FLAGS="" + ], [ + SHLIB_CFLAGS="" + SHLIB_LD="echo tclLdAout $CC \{$SHLIB_CFLAGS\} | `pwd`/tclsh -r -G 0" + SHLIB_LD_LIBS="" + SHLIB_SUFFIX="..o" + DL_OBJS="tclLoadAout.o" + DL_LIBS="" + LD_FLAGS="" + LD_SEARCH_FLAGS="" + ]) + + # FreeBSD doesn't handle version numbers with dots. Also, have to + # append a dummy version number to .so file names. + + TCL_SHARED_LIB_SUFFIX='`echo ${VERSION} | tr -d .`.so.1.0' + TCL_UNSHARED_LIB_SUFFIX='`echo ${VERSION} | tr -d .`.a' + TCL_LIB_VERSIONS_OK=nodots + ;; + NEXTSTEP-*) + SHLIB_CFLAGS="" + SHLIB_LD="cc -nostdlib -r" + SHLIB_LD_LIBS="" + SHLIB_SUFFIX=".so" + DL_OBJS="tclLoadNext.o" + DL_LIBS="" + LD_FLAGS="" + LD_SEARCH_FLAGS="" + ;; + OSF1-1.[012]) + # OSF/1 1.[012] from OSF, and derivatives, including Paragon OSF/1 + SHLIB_CFLAGS="" + # Hack: make package name same as library name + SHLIB_LD='ld -R -export $@:' + SHLIB_LD_LIBS="" + SHLIB_SUFFIX=".so" + DL_OBJS="tclLoadOSF.o" + DL_LIBS="" + LD_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" + SHLIB_LD_LIBS="" + SHLIB_SUFFIX=".so" + DL_OBJS="tclLoadDl.o" + DL_LIBS="" + LD_FLAGS="" + LD_SEARCH_FLAGS="" + ;; + OSF1-V*) + # Digital OSF/1 + SHLIB_CFLAGS="" + SHLIB_LD='ld -shared -expect_unresolved "*"' + SHLIB_LD_LIBS="" + SHLIB_SUFFIX=".so" + DL_OBJS="tclLoadDl.o" + DL_LIBS="" + LD_FLAGS="" + LD_SEARCH_FLAGS='-Wl,-rpath,${LIB_INSTALL_DIR}' + ;; + RISCos-*) + SHLIB_CFLAGS="-G 0" + SHLIB_LD="echo tclLdAout $CC \{$SHLIB_CFLAGS\} | `pwd`/tclsh -r -G 0" + SHLIB_LD_LIBS="" + SHLIB_SUFFIX="..o" + DL_OBJS="tclLoadAout.o" + DL_LIBS="" + LD_FLAGS="-Wl,-D,08000000" + LD_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. + SHLIB_CFLAGS="-Kpic -belf" + SHLIB_LD="ld -G" + SHLIB_LD_LIBS="" + SHLIB_SUFFIX=".so" + DL_OBJS="tclLoadDl.o" + DL_LIBS="" + LD_FLAGS="-belf -Wl,-Bexport" + LD_SEARCH_FLAGS="" + ;; + SINIX*5.4*) + SHLIB_CFLAGS="-K PIC" + SHLIB_LD="cc -G" + SHLIB_LD_LIBS="" + SHLIB_SUFFIX=".so" + DL_OBJS="tclLoadDl.o" + DL_LIBS="-ldl" + LD_FLAGS="" + LD_SEARCH_FLAGS="" + ;; + SunOS-4*) + SHLIB_CFLAGS="-PIC" + SHLIB_LD="ld" + SHLIB_LD_LIBS="" + SHLIB_SUFFIX=".so" + DL_OBJS="tclLoadDl.o" + DL_LIBS="-ldl" + LD_FLAGS="" + LD_SEARCH_FLAGS='-L${LIB_INSTALL_DIR}' + + # SunOS can't handle version numbers with dots in them in library + # specs, like -ltcl7.5, so use -ltcl75 instead. Also, it + # requires an extra version number at the end of .so file names. + # So, the library has to have a name like libtcl75.so.1.0 + + TCL_SHARED_LIB_SUFFIX='`echo ${VERSION} | tr -d .`.so.1.0' + TCL_UNSHARED_LIB_SUFFIX='`echo ${VERSION} | tr -d .`.a' + TCL_LIB_VERSIONS_OK=nodots + ;; + SunOS-5*) + SHLIB_CFLAGS="-K PIC" + SHLIB_LD="/usr/ccs/bin/ld -G -z text" + SHLIB_LD_LIBS='${LIBS}' + SHLIB_SUFFIX=".so" + DL_OBJS="tclLoadDl.o" + DL_LIBS="-ldl" + LD_FLAGS="" + LD_SEARCH_FLAGS='-R ${LIB_INSTALL_DIR}' + ;; + ULTRIX-4.*) + SHLIB_CFLAGS="-G 0" + SHLIB_SUFFIX="..o" + SHLIB_LD="echo tclLdAout $CC \{$SHLIB_CFLAGS\} | `pwd`/tclsh -r -G 0" + SHLIB_LD_LIBS="" + DL_OBJS="tclLoadAout.o" + DL_LIBS="" + LD_FLAGS="-Wl,-D,08000000" + LD_SEARCH_FLAGS="" + ;; + UNIX_SV*) + SHLIB_CFLAGS="-K PIC" + SHLIB_LD="cc -G" + SHLIB_LD_LIBS="" + SHLIB_SUFFIX=".so" + DL_OBJS="tclLoadDl.o" + DL_LIBS="-ldl" + LD_FLAGS="-Wl,-Bexport" + LD_SEARCH_FLAGS="" + ;; +esac + +# If pseudo-static linking is in use (see K. B. Kenny, "Dynamic Loading for +# Tcl -- What Became of It?". Proc. 2nd Tcl/Tk Workshop, New Orleans, LA, +# Computerized Processes Unlimited, 1994), then we need to determine which +# of several header files defines the a.out file format (a.out.h, sys/exec.h, +# or sys/exec_aout.h). At present, we support only a file format that +# is more or less version-7-compatible. In particular, +# - a.out files must begin with `struct exec'. +# - the N_TXTOFF on the `struct exec' must compute the seek address +# of the text segment +# - The `struct exec' must contain a_magic, a_text, a_data, a_bss +# and a_entry fields. +# The following compilation should succeed if and only if either sys/exec.h +# or a.out.h is usable for the purpose. +# +# Note that the modified COFF format used on MIPS Ultrix 4.x is usable; the +# `struct exec' includes a second header that contains information that +# duplicates the v7 fields that are needed. + +if test "x$DL_OBJS" = "xtclLoadAout.o" ; then + AC_MSG_CHECKING(sys/exec.h) + AC_TRY_COMPILE([#include <sys/exec.h>],[ + struct exec foo; + unsigned long seek; + int flag; +#if defined(__mips) || defined(mips) + seek = N_TXTOFF (foo.ex_f, foo.ex_o); +#else + seek = N_TXTOFF (foo); +#endif + flag = (foo.a_magic == OMAGIC); + return foo.a_text + foo.a_data + foo.a_bss + foo.a_entry; +], tcl_ok=usable, tcl_ok=unusable) + AC_MSG_RESULT($tcl_ok) + if test $tcl_ok = usable; then + AC_DEFINE(USE_SYS_EXEC_H) + else + AC_MSG_CHECKING(a.out.h) + AC_TRY_COMPILE([#include <a.out.h>],[ + struct exec foo; + unsigned long seek; + int flag; +#if defined(__mips) || defined(mips) + seek = N_TXTOFF (foo.ex_f, foo.ex_o); +#else + seek = N_TXTOFF (foo); +#endif + flag = (foo.a_magic == OMAGIC); + return foo.a_text + foo.a_data + foo.a_bss + foo.a_entry; + ], tcl_ok=usable, tcl_ok=unusable) + AC_MSG_RESULT($tcl_ok) + if test $tcl_ok = usable; then + AC_DEFINE(USE_A_OUT_H) + else + AC_MSG_CHECKING(sys/exec_aout.h) + AC_TRY_COMPILE([#include <sys/exec_aout.h>],[ + struct exec foo; + unsigned long seek; + int flag; +#if defined(__mips) || defined(mips) + seek = N_TXTOFF (foo.ex_f, foo.ex_o); +#else + seek = N_TXTOFF (foo); +#endif + flag = (foo.a_midmag == OMAGIC); + return foo.a_text + foo.a_data + foo.a_bss + foo.a_entry; + ], tcl_ok=usable, tcl_ok=unusable) + AC_MSG_RESULT($tcl_ok) + if test $tcl_ok = usable; then + AC_DEFINE(USE_SYS_EXEC_AOUT_H) + else + DL_OBJS="" + fi + fi + fi +fi + +if test "x$DL_OBJS" != "x" ; then + BUILD_DLTEST="\$(DLTEST_TARGETS)" +else + echo "Can't figure out how to do dynamic loading or shared libraries" + echo "on this system." + SHLIB_CFLAGS="" + SHLIB_LD="" + SHLIB_SUFFIX="" + DL_OBJS="tclLoadNone.o" + DL_LIBS="" + LD_FLAGS="" + LD_SEARCH_FLAGS="" + BUILD_DLTEST="" +fi + +# If we're running gcc, then change the C flags for compiling shared +# libraries to the right flags for gcc, instead of those for the +# standard manufacturer compiler. + +if test "$DL_OBJS" != "tclLoadNone.o" ; then + if test "$CC" = "gcc" -o `$CC -v 2>&1 | grep -c gcc` != "0" ; then + SHLIB_CFLAGS="-fPIC" + fi +fi + +#-------------------------------------------------------------------- +# The statements below define a collection of symbols related to +# building libtcl as a shared library instead of a static library. +#-------------------------------------------------------------------- + +realRanlib=$RANLIB +if test "$TCL_SHARED_LIB_SUFFIX" = "" ; then + TCL_SHARED_LIB_SUFFIX='${VERSION}${SHLIB_SUFFIX}' +fi +if test "$TCL_UNSHARED_LIB_SUFFIX" = "" ; then + TCL_UNSHARED_LIB_SUFFIX='${VERSION}.a' +fi +AC_ARG_ENABLE(shared, + [ --enable-shared build libtcl as a shared library], + [tcl_ok=$enableval], [tcl_ok=no]) +if test "$tcl_ok" = "yes" -a "${SHLIB_SUFFIX}" != "" \ + -a "${DL_OBJS}" != "tclLoadAout.o" ; then + TCL_SHLIB_CFLAGS="${SHLIB_CFLAGS}" + TCL_LD_SEARCH_FLAGS="${LD_SEARCH_FLAGS}" + eval "TCL_LIB_FILE=libtcl${TCL_SHARED_LIB_SUFFIX}" + MAKE_LIB="\${SHLIB_LD} -o ${TCL_LIB_FILE} \${OBJS} ${SHLIB_LD_LIBS}" + RANLIB=":" +else + if test "$AIX" = "no" ; then + SHLIB_LD_LIBS="" + fi + TCL_SHLIB_CFLAGS="" + TCL_LD_SEARCH_FLAGS="" + eval "TCL_LIB_FILE=libtcl${TCL_UNSHARED_LIB_SUFFIX}" + MAKE_LIB="ar cr ${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 "${TCL_LIB_VERSIONS_OK}" = "ok"; then + TCL_BUILD_LIB_SPEC="-L`pwd` -ltcl${VERSION}" + TCL_LIB_SPEC="-L${exec_prefix}/lib -ltcl${VERSION}" +else + TCL_BUILD_LIB_SPEC="-L`pwd` -ltcl`echo ${VERSION} | tr -d .`" + TCL_LIB_SPEC="-L${exec_prefix}/lib -ltcl`echo ${VERSION} | tr -d .`" +fi + +AC_SUBST(BUILD_DLTEST) +AC_SUBST(DL_LIBS) +AC_SUBST(DL_OBJS) +AC_SUBST(LD_FLAGS) +AC_SUBST(MAKE_LIB) +AC_SUBST(MATH_LIBS) +AC_SUBST(SHLIB_CFLAGS) +AC_SUBST(SHLIB_LD) +AC_SUBST(SHLIB_LD_LIBS) +AC_SUBST(SHLIB_SUFFIX) +AC_SUBST(TCL_BUILD_LIB_SPEC) +AC_SUBST(TCL_LD_SEARCH_FLAGS) +AC_SUBST(TCL_LIB_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_SHARED_LIB_SUFFIX) +AC_SUBST(TCL_SHLIB_CFLAGS) +AC_SUBST(TCL_UNSHARED_LIB_SUFFIX) +AC_SUBST(TCL_VERSION) + +AC_OUTPUT(Makefile tclConfig.sh) diff --git a/contrib/tcl/unix/dltest/Makefile.in b/contrib/tcl/unix/dltest/Makefile.in new file mode 100644 index 0000000..130ea18 --- /dev/null +++ b/contrib/tcl/unix/dltest/Makefile.in @@ -0,0 +1,45 @@ +# This Makefile is used to create several test cases for Tcl's load +# command. It also illustrates how to take advantage of configuration +# exported by Tcl to set up Makefiles for shared libraries. +# SCCS: @(#) Makefile.in 1.11 96/04/15 09:50:19 + +CC = @CC@ +LIBS = @TCL_BUILD_LIB_SPEC@ @TCL_LIBS@ -lc +SHLIB_CFLAGS = @SHLIB_CFLAGS@ +SHLIB_LD = @SHLIB_LD@ +SHLIB_SUFFIX = @SHLIB_SUFFIX@ +SHLIB_VERSION = @SHLIB_VERSION@ +SRC_DIR = @srcdir@ +TCL_VERSION= @TCL_VERSION@ + +CFLAGS = -g +CC_SWITCHES = $(CFLAGS) -I${SRC_DIR}/../../generic -DTCL_MEM_DEBUG \ + ${SHLIB_CFLAGS} + +all: pkga${SHLIB_SUFFIX} pkgb${SHLIB_SUFFIX} pkgc${SHLIB_SUFFIX} pkgd${SHLIB_SUFFIX} pkge${SHLIB_SUFFIX} + +pkga${SHLIB_SUFFIX}: $(SRC_DIR)/pkga.c + $(CC) -c $(CC_SWITCHES) $(SRC_DIR)/pkga.c + ${SHLIB_LD} pkga.o -o pkga${SHLIB_SUFFIX} @SHLIB_LD_LIBS@ + +pkgb${SHLIB_SUFFIX}: $(SRC_DIR)/pkgb.c + $(CC) -c $(CC_SWITCHES) $(SRC_DIR)/pkgb.c + ${SHLIB_LD} pkgb.o -o pkgb${SHLIB_SUFFIX} @SHLIB_LD_LIBS@ + +pkgc${SHLIB_SUFFIX}: $(SRC_DIR)/pkgc.c + $(CC) -c $(CC_SWITCHES) $(SRC_DIR)/pkgc.c + ${SHLIB_LD} pkgc.o -o pkgc${SHLIB_SUFFIX} @SHLIB_LD_LIBS@ + +pkgd${SHLIB_SUFFIX}: $(SRC_DIR)/pkgd.c + $(CC) -c $(CC_SWITCHES) $(SRC_DIR)/pkgd.c + ${SHLIB_LD} pkgd.o -o pkgd${SHLIB_SUFFIX} @SHLIB_LD_LIBS@ + +pkge${SHLIB_SUFFIX}: $(SRC_DIR)/pkge.c + $(CC) -c $(CC_SWITCHES) $(SRC_DIR)/pkge.c + ${SHLIB_LD} pkge.o -o pkge${SHLIB_SUFFIX} @SHLIB_LD_LIBS@ + +clean: + rm -f *.o *${SHLIB_SUFFIX} config.cache config.log config.status lib.exp + +distclean: clean + rm -f Makefile diff --git a/contrib/tcl/unix/dltest/README b/contrib/tcl/unix/dltest/README new file mode 100644 index 0000000..f4e54d4 --- /dev/null +++ b/contrib/tcl/unix/dltest/README @@ -0,0 +1,12 @@ +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. + +sccsid: @(#) README 1.2 95/08/22 08:13:23 diff --git a/contrib/tcl/unix/dltest/configure b/contrib/tcl/unix/dltest/configure new file mode 100755 index 0000000..219d63d --- /dev/null +++ b/contrib/tcl/unix/dltest/configure @@ -0,0 +1,611 @@ +#! /bin/sh + +# Guess values for system-dependent variables and create Makefiles. +# Generated automatically using autoconf version 2.4 +# Copyright (C) 1992, 1993, 1994 Free Software Foundation, Inc. +# +# This configure script is free software; the Free Software Foundation +# gives unlimited permission to copy, distribute and modify it. + +# Defaults: +ac_help= +ac_default_prefix=/usr/local +# Any additions from configure.in: + +# Initialize some variables set by options. +# The variables have the same names as the options, with +# dashes changed to underlines. +build=NONE +cache_file=./config.cache +exec_prefix=NONE +host=NONE +no_create= +nonopt=NONE +no_recursion= +prefix=NONE +program_prefix=NONE +program_suffix=NONE +program_transform_name=s,x,x, +silent= +site= +srcdir= +target=NONE +verbose= +x_includes=NONE +x_libraries=NONE + +# Initialize some other variables. +subdirs= + +ac_prev= +for ac_option +do + + # If the previous option needs an argument, assign it. + if test -n "$ac_prev"; then + eval "$ac_prev=\$ac_option" + ac_prev= + continue + fi + + case "$ac_option" in + -*=*) ac_optarg=`echo "$ac_option" | sed 's/[-_a-zA-Z0-9]*=//'` ;; + *) ac_optarg= ;; + esac + + # Accept the important Cygnus configure options, so we can diagnose typos. + + case "$ac_option" in + + -build | --build | --buil | --bui | --bu | --b) + ac_prev=build ;; + -build=* | --build=* | --buil=* | --bui=* | --bu=* | --b=*) + build="$ac_optarg" ;; + + -cache-file | --cache-file | --cache-fil | --cache-fi \ + | --cache-f | --cache- | --cache | --cach | --cac | --ca | --c) + ac_prev=cache_file ;; + -cache-file=* | --cache-file=* | --cache-fil=* | --cache-fi=* \ + | --cache-f=* | --cache-=* | --cache=* | --cach=* | --cac=* | --ca=* | --c=*) + cache_file="$ac_optarg" ;; + + -disable-* | --disable-*) + ac_feature=`echo $ac_option|sed -e 's/-*disable-//'` + # Reject names that are not valid shell variable names. + if test -n "`echo $ac_feature| sed 's/[-a-zA-Z0-9_]//g'`"; then + { echo "configure: error: $ac_feature: invalid feature name" 1>&2; exit 1; } + fi + ac_feature=`echo $ac_feature| sed 's/-/_/g'` + eval "enable_${ac_feature}=no" ;; + + -enable-* | --enable-*) + ac_feature=`echo $ac_option|sed -e 's/-*enable-//' -e 's/=.*//'` + # Reject names that are not valid shell variable names. + if test -n "`echo $ac_feature| sed 's/[-_a-zA-Z0-9]//g'`"; then + { echo "configure: error: $ac_feature: invalid feature name" 1>&2; exit 1; } + fi + ac_feature=`echo $ac_feature| sed 's/-/_/g'` + case "$ac_option" in + *=*) ;; + *) ac_optarg=yes ;; + esac + eval "enable_${ac_feature}='$ac_optarg'" ;; + + -exec-prefix | --exec_prefix | --exec-prefix | --exec-prefi \ + | --exec-pref | --exec-pre | --exec-pr | --exec-p | --exec- \ + | --exec | --exe | --ex) + ac_prev=exec_prefix ;; + -exec-prefix=* | --exec_prefix=* | --exec-prefix=* | --exec-prefi=* \ + | --exec-pref=* | --exec-pre=* | --exec-pr=* | --exec-p=* | --exec-=* \ + | --exec=* | --exe=* | --ex=*) + exec_prefix="$ac_optarg" ;; + + -gas | --gas | --ga | --g) + # Obsolete; use --with-gas. + with_gas=yes ;; + + -help | --help | --hel | --he) + # Omit some internal or obsolete options to make the list less imposing. + # This message is too long to be a string in the A/UX 3.1 sh. + cat << EOF +Usage: configure [options] [host] +Options: [defaults in brackets after descriptions] +Configuration: + --cache-file=FILE cache test results in FILE + --help print this message + --no-create do not create output files + --quiet, --silent do not print \`checking...' messages + --version print the version of autoconf that created configure +Directory and file names: + --prefix=PREFIX install architecture-independent files in PREFIX + [$ac_default_prefix] + --exec-prefix=PREFIX install architecture-dependent files in PREFIX + [same as prefix] + --srcdir=DIR find the sources in DIR [configure dir or ..] + --program-prefix=PREFIX prepend PREFIX to installed program names + --program-suffix=SUFFIX append SUFFIX to installed program names + --program-transform-name=PROGRAM run sed PROGRAM on installed program names +Host type: + --build=BUILD configure for building on BUILD [BUILD=HOST] + --host=HOST configure for HOST [guessed] + --target=TARGET configure for TARGET [TARGET=HOST] +Features and packages: + --disable-FEATURE do not include FEATURE (same as --enable-FEATURE=no) + --enable-FEATURE[=ARG] include FEATURE [ARG=yes] + --with-PACKAGE[=ARG] use PACKAGE [ARG=yes] + --without-PACKAGE do not use PACKAGE (same as --with-PACKAGE=no) + --x-includes=DIR X include files are in DIR + --x-libraries=DIR X library files are in DIR +--enable and --with options recognized:$ac_help +EOF + exit 0 ;; + + -host | --host | --hos | --ho) + ac_prev=host ;; + -host=* | --host=* | --hos=* | --ho=*) + host="$ac_optarg" ;; + + -nfp | --nfp | --nf) + # Obsolete; use --without-fp. + with_fp=no ;; + + -no-create | --no-create | --no-creat | --no-crea | --no-cre \ + | --no-cr | --no-c) + no_create=yes ;; + + -no-recursion | --no-recursion | --no-recursio | --no-recursi \ + | --no-recurs | --no-recur | --no-recu | --no-rec | --no-re | --no-r) + no_recursion=yes ;; + + -prefix | --prefix | --prefi | --pref | --pre | --pr | --p) + ac_prev=prefix ;; + -prefix=* | --prefix=* | --prefi=* | --pref=* | --pre=* | --pr=* | --p=*) + prefix="$ac_optarg" ;; + + -program-prefix | --program-prefix | --program-prefi | --program-pref \ + | --program-pre | --program-pr | --program-p) + ac_prev=program_prefix ;; + -program-prefix=* | --program-prefix=* | --program-prefi=* \ + | --program-pref=* | --program-pre=* | --program-pr=* | --program-p=*) + program_prefix="$ac_optarg" ;; + + -program-suffix | --program-suffix | --program-suffi | --program-suff \ + | --program-suf | --program-su | --program-s) + ac_prev=program_suffix ;; + -program-suffix=* | --program-suffix=* | --program-suffi=* \ + | --program-suff=* | --program-suf=* | --program-su=* | --program-s=*) + program_suffix="$ac_optarg" ;; + + -program-transform-name | --program-transform-name \ + | --program-transform-nam | --program-transform-na \ + | --program-transform-n | --program-transform- \ + | --program-transform | --program-transfor \ + | --program-transfo | --program-transf \ + | --program-trans | --program-tran \ + | --progr-tra | --program-tr | --program-t) + ac_prev=program_transform_name ;; + -program-transform-name=* | --program-transform-name=* \ + | --program-transform-nam=* | --program-transform-na=* \ + | --program-transform-n=* | --program-transform-=* \ + | --program-transform=* | --program-transfor=* \ + | --program-transfo=* | --program-transf=* \ + | --program-trans=* | --program-tran=* \ + | --progr-tra=* | --program-tr=* | --program-t=*) + program_transform_name="$ac_optarg" ;; + + -q | -quiet | --quiet | --quie | --qui | --qu | --q \ + | -silent | --silent | --silen | --sile | --sil) + silent=yes ;; + + -site | --site | --sit) + ac_prev=site ;; + -site=* | --site=* | --sit=*) + site="$ac_optarg" ;; + + -srcdir | --srcdir | --srcdi | --srcd | --src | --sr) + ac_prev=srcdir ;; + -srcdir=* | --srcdir=* | --srcdi=* | --srcd=* | --src=* | --sr=*) + srcdir="$ac_optarg" ;; + + -target | --target | --targe | --targ | --tar | --ta | --t) + ac_prev=target ;; + -target=* | --target=* | --targe=* | --targ=* | --tar=* | --ta=* | --t=*) + target="$ac_optarg" ;; + + -v | -verbose | --verbose | --verbos | --verbo | --verb) + verbose=yes ;; + + -version | --version | --versio | --versi | --vers) + echo "configure generated by autoconf version 2.4" + exit 0 ;; + + -with-* | --with-*) + ac_package=`echo $ac_option|sed -e 's/-*with-//' -e 's/=.*//'` + # Reject names that are not valid shell variable names. + if test -n "`echo $ac_package| sed 's/[-_a-zA-Z0-9]//g'`"; then + { echo "configure: error: $ac_package: invalid package name" 1>&2; exit 1; } + fi + ac_package=`echo $ac_package| sed 's/-/_/g'` + case "$ac_option" in + *=*) ;; + *) ac_optarg=yes ;; + esac + eval "with_${ac_package}='$ac_optarg'" ;; + + -without-* | --without-*) + ac_package=`echo $ac_option|sed -e 's/-*without-//'` + # Reject names that are not valid shell variable names. + if test -n "`echo $ac_package| sed 's/[-a-zA-Z0-9_]//g'`"; then + { echo "configure: error: $ac_package: invalid package name" 1>&2; exit 1; } + fi + ac_package=`echo $ac_package| sed 's/-/_/g'` + eval "with_${ac_package}=no" ;; + + --x) + # Obsolete; use --with-x. + with_x=yes ;; + + -x-includes | --x-includes | --x-include | --x-includ | --x-inclu \ + | --x-incl | --x-inc | --x-in | --x-i) + ac_prev=x_includes ;; + -x-includes=* | --x-includes=* | --x-include=* | --x-includ=* | --x-inclu=* \ + | --x-incl=* | --x-inc=* | --x-in=* | --x-i=*) + x_includes="$ac_optarg" ;; + + -x-libraries | --x-libraries | --x-librarie | --x-librari \ + | --x-librar | --x-libra | --x-libr | --x-lib | --x-li | --x-l) + ac_prev=x_libraries ;; + -x-libraries=* | --x-libraries=* | --x-librarie=* | --x-librari=* \ + | --x-librar=* | --x-libra=* | --x-libr=* | --x-lib=* | --x-li=* | --x-l=*) + x_libraries="$ac_optarg" ;; + + -*) { echo "configure: error: $ac_option: invalid option; use --help to show usage" 1>&2; exit 1; } + ;; + + *) + if test -n "`echo $ac_option| sed 's/[-a-z0-9.]//g'`"; then + echo "configure: warning: $ac_option: invalid host type" 1>&2 + fi + if test "x$nonopt" != xNONE; then + { echo "configure: error: can only configure for one host and one target at a time" 1>&2; exit 1; } + fi + nonopt="$ac_option" + ;; + + esac +done + +if test -n "$ac_prev"; then + { echo "configure: error: missing argument to --`echo $ac_prev | sed 's/_/-/g'`" 1>&2; exit 1; } +fi + +trap 'rm -fr conftest* confdefs* core core.* *.core $ac_clean_files; exit 1' 1 2 15 + +# File descriptor usage: +# 0 standard input +# 1 file creation +# 2 errors and warnings +# 3 some systems may open it to /dev/tty +# 4 used on the Kubota Titan +# 6 checking for... messages and results +# 5 compiler messages saved in config.log +if test "$silent" = yes; then + exec 6>/dev/null +else + exec 6>&1 +fi +exec 5>./config.log + +echo "\ +This file contains any messages produced by compilers while +running configure, to aid debugging if configure makes a mistake. +" 1>&5 + +# Strip out --no-create and --no-recursion so they do not pile up. +# Also quote any args containing shell metacharacters. +ac_configure_args= +for ac_arg +do + case "$ac_arg" in + -no-create | --no-create | --no-creat | --no-crea | --no-cre \ + | --no-cr | --no-c) ;; + -no-recursion | --no-recursion | --no-recursio | --no-recursi \ + | --no-recurs | --no-recur | --no-recu | --no-rec | --no-re | --no-r) ;; + *" "*|*" "*|*[\[\]\~\#\$\^\&\*\(\)\{\}\\\|\;\<\>\?]*) + ac_configure_args="$ac_configure_args '$ac_arg'" ;; + *) ac_configure_args="$ac_configure_args $ac_arg" ;; + esac +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 +if test "${LANG+set}" = set; then LANG=C; export LANG; fi + +# confdefs.h avoids OS command line length limits that DEFS can exceed. +rm -rf conftest* confdefs.h +# AIX cpp loses on an empty file, so make sure it contains at least a newline. +echo > confdefs.h + +# A filename unique to this package, relative to the directory that +# configure is in, which we can look for to find out if srcdir is correct. +ac_unique_file=pkga.c + +# Find the source files, if location was not specified. +if test -z "$srcdir"; then + ac_srcdir_defaulted=yes + # Try the directory containing this script, then its parent. + ac_prog=$0 + ac_confdir=`echo $ac_prog|sed 's%/[^/][^/]*$%%'` + test "x$ac_confdir" = "x$ac_prog" && ac_confdir=. + srcdir=$ac_confdir + if test ! -r $srcdir/$ac_unique_file; then + srcdir=.. + fi +else + ac_srcdir_defaulted=no +fi +if test ! -r $srcdir/$ac_unique_file; then + if test "$ac_srcdir_defaulted" = yes; then + { echo "configure: error: can not find sources in $ac_confdir or .." 1>&2; exit 1; } + else + { echo "configure: error: can not find sources in $srcdir" 1>&2; exit 1; } + fi +fi +srcdir=`echo "${srcdir}" | sed 's%\([^/]\)/*$%\1%'` + +# Prefer explicitly selected file to automatically selected ones. +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 +fi +for ac_site_file in $CONFIG_SITE; do + if test -r "$ac_site_file"; then + echo "loading site script $ac_site_file" + . "$ac_site_file" + fi +done + +if test -r "$cache_file"; then + echo "loading cache $cache_file" + . $cache_file +else + echo "creating cache $cache_file" + > $cache_file +fi + +ac_ext=c +# 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 2>&5' +ac_link='${CC-cc} -o conftest $CFLAGS $CPPFLAGS $LDFLAGS conftest.$ac_ext $LIBS 1>&5 2>&5' + +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 + ac_n= ac_c=' +' ac_t=' ' + else + ac_n=-n ac_c= ac_t= + fi +else + ac_n= ac_c='\c' ac_t= +fi + + +# SCCS: %Z% %M% %I% %E% %U% + +# Recover information that Tcl computed with its configure script. + +. ../tclConfig.sh + +CC=$TCL_CC + +SHLIB_CFLAGS=$TCL_SHLIB_CFLAGS + +SHLIB_LD=$TCL_SHLIB_LD + +SHLIB_LD_LIBS=$TCL_SHLIB_LD_LIBS + +SHLIB_SUFFIX=$TCL_SHLIB_SUFFIX + +SHLIB_VERSION=$TCL_SHLIB_VERSION + + +TCL_LIBS=$TCL_LIBS + +TCL_VERSION=$TCL_VERSION + + +trap '' 1 2 15 +cat > confcache <<\EOF +# This file is a shell script that caches the results of configure +# tests run on this system so they can be shared between configure +# scripts and configure runs. It is not useful on other systems. +# If it contains results you don't want to keep, you may remove or edit it. +# +# By default, configure uses ./config.cache as the cache file, +# creating it if it does not exist already. You can give configure +# the --cache-file=FILE option to use a different cache file; that is +# what configure does when it calls configure scripts in +# subdirectories, so they share the cache. +# Giving --cache-file=/dev/null disables caching, for debugging configure. +# config.status only pays attention to the cache file if you give it the +# --recheck option to rerun configure. +# +EOF +# 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 +if cmp -s $cache_file confcache; then + : +else + if test -w $cache_file; then + echo "updating cache $cache_file" + cat confcache > $cache_file + else + echo "not updating unwritable cache $cache_file" + fi +fi +rm -f confcache + +trap 'rm -fr conftest* confdefs* core core.* *.core $ac_clean_files; exit 1' 1 2 15 + +test "x$prefix" = xNONE && prefix=$ac_default_prefix +# Let make expand exec_prefix. +test "x$exec_prefix" = xNONE && exec_prefix='${prefix}' + +# Any assignment to VPATH causes Sun make to only execute +# the first set of double-colon rules, so remove it if not needed. +# If there is a colon in the path, we need to keep it. +if test "x$srcdir" = x.; then + ac_vpsub='/^[ ]*VPATH[ ]*=[^:]*$/d' +fi + +trap 'rm -f $CONFIG_STATUS conftest*; exit 1' 1 2 15 + +# 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 + + +# Without the "./", some shells look in PATH for config.status. +: ${CONFIG_STATUS=./config.status} + +echo creating $CONFIG_STATUS +rm -f $CONFIG_STATUS +cat > $CONFIG_STATUS <<EOF +#! /bin/sh +# Generated automatically by configure. +# Run this file to recreate the current configuration. +# This directory was configured as follows, +# on host `(hostname || uname -n) 2>/dev/null | sed 1q`: +# +# $0 $ac_configure_args +# +# Compiler output produced by configure, useful for debugging +# configure, is in ./config.log if it exists. + +ac_cs_usage="Usage: $CONFIG_STATUS [--recheck] [--version] [--help]" +for ac_option +do + case "\$ac_option" in + -recheck | --recheck | --rechec | --reche | --rech | --rec | --re | --r) + 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.4" + exit 0 ;; + -help | --help | --hel | --he | --h) + echo "\$ac_cs_usage"; exit 0 ;; + *) echo "\$ac_cs_usage"; exit 1 ;; + esac +done + +ac_given_srcdir=$srcdir + +trap 'rm -fr `echo "Makefile" | sed "s/:[^ ]*//g"` conftest*; exit 1' 1 2 15 + +# Protect against being on the right side of a sed subst in config.status. +sed 's/%@/@@/; s/@%/@@/; s/%g$/@g/; /@g$/s/[\\\\&%]/\\\\&/g; + s/@@/%@/; s/@@/@%/; s/@g$/%g/' > conftest.subs <<\CEOF +$ac_vpsub +$extrasub +s%@CFLAGS@%$CFLAGS%g +s%@CPPFLAGS@%$CPPFLAGS%g +s%@CXXFLAGS@%$CXXFLAGS%g +s%@DEFS@%$DEFS%g +s%@LDFLAGS@%$LDFLAGS%g +s%@LIBS@%$LIBS%g +s%@exec_prefix@%$exec_prefix%g +s%@prefix@%$prefix%g +s%@program_transform_name@%$program_transform_name%g +s%@CC@%$CC%g +s%@SHLIB_CFLAGS@%$SHLIB_CFLAGS%g +s%@SHLIB_LD@%$SHLIB_LD%g +s%@SHLIB_LD_LIBS@%$SHLIB_LD_LIBS%g +s%@SHLIB_SUFFIX@%$SHLIB_SUFFIX%g +s%@SHLIB_VERSION@%$SHLIB_VERSION%g +s%@TCL_BUILD_LIB_SPEC@%$TCL_BUILD_LIB_SPEC%g +s%@TCL_LIBS@%$TCL_LIBS%g +s%@TCL_VERSION@%$TCL_VERSION%g + +CEOF +EOF +cat >> $CONFIG_STATUS <<EOF + +CONFIG_FILES=\${CONFIG_FILES-"Makefile"} +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". + case "$ac_file" in + *:*) 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. + + # Remove last slash and all that follows it. Not all systems have dirname. + ac_dir=`echo $ac_file|sed 's%/[^/][^/]*$%%'` + if test "$ac_dir" != "$ac_file" && test "$ac_dir" != .; then + # The file is in a subdirectory. + test ! -d "$ac_dir" && mkdir "$ac_dir" + ac_dir_suffix="/`echo $ac_dir|sed 's%^\./%%'`" + # A "../" for each directory in $ac_dir_suffix. + ac_dots=`echo $ac_dir_suffix|sed 's%/[^/]*%../%g'` + else + ac_dir_suffix= ac_dots= + fi + + case "$ac_given_srcdir" in + .) srcdir=. + if test -z "$ac_dots"; then top_srcdir=. + else top_srcdir=`echo $ac_dots|sed 's%/$%%'`; fi ;; + /*) srcdir="$ac_given_srcdir$ac_dir_suffix"; top_srcdir="$ac_given_srcdir" ;; + *) # Relative path. + srcdir="$ac_dots$ac_given_srcdir$ac_dir_suffix" + 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." + case "$ac_file" in + *Makefile*) ac_comsub="1i\\ +# $configure_input" ;; + *) ac_comsub= ;; + esac + 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 +fi; done +rm -f conftest.subs + + + +exit 0 +EOF +chmod +x $CONFIG_STATUS +rm -fr confdefs* $ac_clean_files +test "$no_create" = yes || ${CONFIG_SHELL-/bin/sh} $CONFIG_STATUS || exit 1 + diff --git a/contrib/tcl/unix/dltest/configure.in b/contrib/tcl/unix/dltest/configure.in new file mode 100644 index 0000000..29924e9 --- /dev/null +++ b/contrib/tcl/unix/dltest/configure.in @@ -0,0 +1,29 @@ +dnl This file is an input file used by the GNU "autoconf" program to +dnl generate the file "configure", which is run to configure the +dnl Makefile in this directory. +AC_INIT(pkga.c) +# SCCS: @(#) configure.in 1.9 96/04/15 09:50:20 + +# Recover information that Tcl computed with its configure script. + +. ../tclConfig.sh + +CC=$TCL_CC +AC_SUBST(CC) +SHLIB_CFLAGS=$TCL_SHLIB_CFLAGS +AC_SUBST(SHLIB_CFLAGS) +SHLIB_LD=$TCL_SHLIB_LD +AC_SUBST(SHLIB_LD) +SHLIB_LD_LIBS=$TCL_SHLIB_LD_LIBS +AC_SUBST(SHLIB_LD_LIBS) +SHLIB_SUFFIX=$TCL_SHLIB_SUFFIX +AC_SUBST(SHLIB_SUFFIX) +SHLIB_VERSION=$TCL_SHLIB_VERSION +AC_SUBST(SHLIB_VERSION) +AC_SUBST(TCL_BUILD_LIB_SPEC) +TCL_LIBS=$TCL_LIBS +AC_SUBST(TCL_LIBS) +TCL_VERSION=$TCL_VERSION +AC_SUBST(TCL_VERSION) + +AC_OUTPUT(Makefile) diff --git a/contrib/tcl/unix/dltest/pkga.c b/contrib/tcl/unix/dltest/pkga.c new file mode 100644 index 0000000..ab48522 --- /dev/null +++ b/contrib/tcl/unix/dltest/pkga.c @@ -0,0 +1,130 @@ +/* + * pkga.c -- + * + * This file contains a simple Tcl package "pkga" that is intended + * for testing the Tcl dynamic loading facilities. + * + * 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: @(#) pkga.c 1.4 96/02/15 12:30:35 + */ +#include "tcl.h" + +/* + * Prototypes for procedures defined later in this file: + */ + +static int Pkga_EqCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int argc, char **argv)); +static int Pkga_QuoteCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int argc, char **argv)); + +/* + *---------------------------------------------------------------------- + * + * Pkga_EqCmd -- + * + * This procedure is invoked to process the "pkga_eq" Tcl command. + * It expects two arguments and returns 1 if they are the same, + * 0 if they are different. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * See the user documentation. + * + *---------------------------------------------------------------------- + */ + +static int +Pkga_EqCmd(dummy, interp, argc, argv) + ClientData dummy; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ + if (argc != 3) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " string1 string2\"", (char *) NULL); + return TCL_ERROR; + } + + if (strcmp(argv[1], argv[2]) == 0) { + interp->result = "1"; + } else { + interp->result = "0"; + } + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * Pkga_quoteCmd -- + * + * This procedure is invoked to process the "pkga_quote" Tcl command. + * It expects one argument, which it returns as result. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * See the user documentation. + * + *---------------------------------------------------------------------- + */ + +static int +Pkga_QuoteCmd(dummy, interp, argc, argv) + ClientData dummy; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ + if (argc != 2) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " value\"", (char *) NULL); + return TCL_ERROR; + } + strcpy(interp->result, argv[1]); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * Pkga_Init -- + * + * This is a package initialization procedure, which is called + * by Tcl when this package is to be added to an interpreter. + * + * Results: + * None. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +int +Pkga_Init(interp) + Tcl_Interp *interp; /* Interpreter in which the package is + * to be made available. */ +{ + int code; + + code = Tcl_PkgProvide(interp, "Pkga", "1.0"); + if (code != TCL_OK) { + return code; + } + Tcl_CreateCommand(interp, "pkga_eq", Pkga_EqCmd, (ClientData) 0, + (Tcl_CmdDeleteProc *) NULL); + Tcl_CreateCommand(interp, "pkga_quote", Pkga_QuoteCmd, (ClientData) 0, + (Tcl_CmdDeleteProc *) NULL); + return TCL_OK; +} diff --git a/contrib/tcl/unix/dltest/pkgb.c b/contrib/tcl/unix/dltest/pkgb.c new file mode 100644 index 0000000..1da9575 --- /dev/null +++ b/contrib/tcl/unix/dltest/pkgb.c @@ -0,0 +1,153 @@ +/* + * pkgb.c -- + * + * This file contains a simple Tcl package "pkgb" that is intended + * for testing the Tcl dynamic loading facilities. It can be used + * in both safe and unsafe interpreters. + * + * 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: @(#) pkgb.c 1.4 96/02/15 12:30:34 + */ +#include "tcl.h" + +/* + * Prototypes for procedures defined later in this file: + */ + +static int Pkgb_SubCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int argc, char **argv)); +static int Pkgb_UnsafeCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int argc, char **argv)); + +/* + *---------------------------------------------------------------------- + * + * Pkgb_SubCmd -- + * + * This procedure is invoked to process the "pkgb_sub" Tcl command. + * It expects two arguments and returns their difference. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * See the user documentation. + * + *---------------------------------------------------------------------- + */ + +static int +Pkgb_SubCmd(dummy, interp, argc, argv) + ClientData dummy; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ + int first, second; + + if (argc != 3) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " num num\"", (char *) NULL); + return TCL_ERROR; + } + if ((Tcl_GetInt(interp, argv[1], &first) != TCL_OK) + || (Tcl_GetInt(interp, argv[2], &second) != TCL_OK)) { + return TCL_ERROR; + } + sprintf(interp->result, "%d", first - second); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * Pkgb_UnsafeCmd -- + * + * This procedure is invoked to process the "pkgb_unsafe" Tcl command. + * It just returns a constant string. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * See the user documentation. + * + *---------------------------------------------------------------------- + */ + +static int +Pkgb_UnsafeCmd(dummy, interp, argc, argv) + ClientData dummy; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ + interp->result = "unsafe command invoked"; + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * Pkgb_Init -- + * + * This is a package initialization procedure, which is called + * by Tcl when this package is to be added to an interpreter. + * + * Results: + * None. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +int +Pkgb_Init(interp) + Tcl_Interp *interp; /* Interpreter in which the package is + * to be made available. */ +{ + int code; + + code = Tcl_PkgProvide(interp, "Pkgb", "2.3"); + if (code != TCL_OK) { + return code; + } + Tcl_CreateCommand(interp, "pkgb_sub", Pkgb_SubCmd, (ClientData) 0, + (Tcl_CmdDeleteProc *) NULL); + Tcl_CreateCommand(interp, "pkgb_unsafe", Pkgb_UnsafeCmd, (ClientData) 0, + (Tcl_CmdDeleteProc *) NULL); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * Pkgb_SafeInit -- + * + * This is a package initialization procedure, which is called + * by Tcl when this package is to be added to an unsafe interpreter. + * + * Results: + * None. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +int +Pkgb_SafeInit(interp) + Tcl_Interp *interp; /* Interpreter in which the package is + * to be made available. */ +{ + Tcl_CreateCommand(interp, "pkgb_sub", Pkgb_SubCmd, (ClientData) 0, + (Tcl_CmdDeleteProc *) NULL); + return TCL_OK; +} diff --git a/contrib/tcl/unix/dltest/pkgc.c b/contrib/tcl/unix/dltest/pkgc.c new file mode 100644 index 0000000..c35189a --- /dev/null +++ b/contrib/tcl/unix/dltest/pkgc.c @@ -0,0 +1,153 @@ +/* + * pkgc.c -- + * + * This file contains a simple Tcl package "pkgc" that is intended + * for testing the Tcl dynamic loading facilities. It can be used + * in both safe and unsafe interpreters. + * + * 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: @(#) pkgc.c 1.4 96/02/15 12:30:35 + */ +#include "tcl.h" + +/* + * Prototypes for procedures defined later in this file: + */ + +static int Pkgc_SubCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int argc, char **argv)); +static int Pkgc_UnsafeCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int argc, char **argv)); + +/* + *---------------------------------------------------------------------- + * + * Pkgc_SubCmd -- + * + * This procedure is invoked to process the "pkgc_sub" Tcl command. + * It expects two arguments and returns their difference. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * See the user documentation. + * + *---------------------------------------------------------------------- + */ + +static int +Pkgc_SubCmd(dummy, interp, argc, argv) + ClientData dummy; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ + int first, second; + + if (argc != 3) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " num num\"", (char *) NULL); + return TCL_ERROR; + } + if ((Tcl_GetInt(interp, argv[1], &first) != TCL_OK) + || (Tcl_GetInt(interp, argv[2], &second) != TCL_OK)) { + return TCL_ERROR; + } + sprintf(interp->result, "%d", first - second); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * Pkgc_UnsafeCmd -- + * + * This procedure is invoked to process the "pkgc_unsafe" Tcl command. + * It just returns a constant string. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * See the user documentation. + * + *---------------------------------------------------------------------- + */ + +static int +Pkgc_UnsafeCmd(dummy, interp, argc, argv) + ClientData dummy; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ + interp->result = "unsafe command invoked"; + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * Pkgc_Init -- + * + * This is a package initialization procedure, which is called + * by Tcl when this package is to be added to an interpreter. + * + * Results: + * None. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +int +Pkgc_Init(interp) + Tcl_Interp *interp; /* Interpreter in which the package is + * to be made available. */ +{ + int code; + + code = Tcl_PkgProvide(interp, "Pkgc", "1.7.2"); + if (code != TCL_OK) { + return code; + } + Tcl_CreateCommand(interp, "pkgc_sub", Pkgc_SubCmd, (ClientData) 0, + (Tcl_CmdDeleteProc *) NULL); + Tcl_CreateCommand(interp, "pkgc_unsafe", Pkgc_UnsafeCmd, (ClientData) 0, + (Tcl_CmdDeleteProc *) NULL); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * Pkgc_SafeInit -- + * + * This is a package initialization procedure, which is called + * by Tcl when this package is to be added to an unsafe interpreter. + * + * Results: + * None. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +int +Pkgc_SafeInit(interp) + Tcl_Interp *interp; /* Interpreter in which the package is + * to be made available. */ +{ + Tcl_CreateCommand(interp, "pkgc_sub", Pkgc_SubCmd, (ClientData) 0, + (Tcl_CmdDeleteProc *) NULL); + return TCL_OK; +} diff --git a/contrib/tcl/unix/dltest/pkgd.c b/contrib/tcl/unix/dltest/pkgd.c new file mode 100644 index 0000000..56821cc --- /dev/null +++ b/contrib/tcl/unix/dltest/pkgd.c @@ -0,0 +1,154 @@ +/* + * pkgd.c -- + * + * This file contains a simple Tcl package "pkgd" that is intended + * for testing the Tcl dynamic loading facilities. It can be used + * in both safe and unsafe interpreters. + * + * 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: @(#) pkgd.c 1.4 96/02/15 12:30:32 + */ + +#include "tcl.h" + +/* + * Prototypes for procedures defined later in this file: + */ + +static int Pkgd_SubCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int argc, char **argv)); +static int Pkgd_UnsafeCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int argc, char **argv)); + +/* + *---------------------------------------------------------------------- + * + * Pkgd_SubCmd -- + * + * This procedure is invoked to process the "pkgd_sub" Tcl command. + * It expects two arguments and returns their difference. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * See the user documentation. + * + *---------------------------------------------------------------------- + */ + +static int +Pkgd_SubCmd(dummy, interp, argc, argv) + ClientData dummy; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ + int first, second; + + if (argc != 3) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " num num\"", (char *) NULL); + return TCL_ERROR; + } + if ((Tcl_GetInt(interp, argv[1], &first) != TCL_OK) + || (Tcl_GetInt(interp, argv[2], &second) != TCL_OK)) { + return TCL_ERROR; + } + sprintf(interp->result, "%d", first - second); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * Pkgd_UnsafeCmd -- + * + * This procedure is invoked to process the "pkgd_unsafe" Tcl command. + * It just returns a constant string. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * See the user documentation. + * + *---------------------------------------------------------------------- + */ + +static int +Pkgd_UnsafeCmd(dummy, interp, argc, argv) + ClientData dummy; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ + interp->result = "unsafe command invoked"; + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * Pkgd_Init -- + * + * This is a package initialization procedure, which is called + * by Tcl when this package is to be added to an interpreter. + * + * Results: + * None. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +int +Pkgd_Init(interp) + Tcl_Interp *interp; /* Interpreter in which the package is + * to be made available. */ +{ + int code; + + code = Tcl_PkgProvide(interp, "Pkgd", "7.3"); + if (code != TCL_OK) { + return code; + } + Tcl_CreateCommand(interp, "pkgd_sub", Pkgd_SubCmd, (ClientData) 0, + (Tcl_CmdDeleteProc *) NULL); + Tcl_CreateCommand(interp, "pkgd_unsafe", Pkgd_UnsafeCmd, (ClientData) 0, + (Tcl_CmdDeleteProc *) NULL); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * Pkgd_SafeInit -- + * + * This is a package initialization procedure, which is called + * by Tcl when this package is to be added to an unsafe interpreter. + * + * Results: + * None. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +int +Pkgd_SafeInit(interp) + Tcl_Interp *interp; /* Interpreter in which the package is + * to be made available. */ +{ + Tcl_CreateCommand(interp, "pkgd_sub", Pkgd_SubCmd, (ClientData) 0, + (Tcl_CmdDeleteProc *) NULL); + return TCL_OK; +} diff --git a/contrib/tcl/unix/dltest/pkge.c b/contrib/tcl/unix/dltest/pkge.c new file mode 100644 index 0000000..1d585ca --- /dev/null +++ b/contrib/tcl/unix/dltest/pkge.c @@ -0,0 +1,49 @@ +/* + * pkge.c -- + * + * This file contains a simple Tcl package "pkge" that is intended + * for testing the Tcl dynamic loading facilities. Its Init + * procedure returns an error in order to test how this is handled. + * + * 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: @(#) pkge.c 1.5 96/03/07 09:34:27 + */ +#include "tcl.h" + +/* + * Prototypes for procedures defined later in this file: + */ + +static int Pkgd_SubCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int argc, char **argv)); +static int Pkgd_UnsafeCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int argc, char **argv)); + +/* + *---------------------------------------------------------------------- + * + * Pkge_Init -- + * + * This is a package initialization procedure, which is called + * by Tcl when this package is to be added to an interpreter. + * + * Results: + * Returns TCL_ERROR and leaves an error message in interp->result. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +int +Pkge_Init(interp) + Tcl_Interp *interp; /* Interpreter in which the package is + * to be made available. */ +{ + return Tcl_Eval(interp, "if 44 {open non_existent}"); +} diff --git a/contrib/tcl/unix/dltest/pkgf.c b/contrib/tcl/unix/dltest/pkgf.c new file mode 100644 index 0000000..d7c641a --- /dev/null +++ b/contrib/tcl/unix/dltest/pkgf.c @@ -0,0 +1,49 @@ +/* + * pkgf.c -- + * + * This file contains a simple Tcl package "pkgf" that is intended + * for testing the Tcl dynamic loading facilities. Its Init + * procedure returns an error in order to test how this is handled. + * + * 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: @(#) pkgf.c 1.2 96/02/15 12:30:32 + */ +#include "tcl.h" + +/* + * Prototypes for procedures defined later in this file: + */ + +static int Pkgd_SubCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int argc, char **argv)); +static int Pkgd_UnsafeCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int argc, char **argv)); + +/* + *---------------------------------------------------------------------- + * + * Pkgf_Init -- + * + * This is a package initialization procedure, which is called + * by Tcl when this package is to be added to an interpreter. + * + * Results: + * Returns TCL_ERROR and leaves an error message in interp->result. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +int +Pkgf_Init(interp) + Tcl_Interp *interp; /* Interpreter in which the package is + * to be made available. */ +{ + return Tcl_Eval(interp, "if 44 {open non_existent}"); +} diff --git a/contrib/tcl/unix/install-sh b/contrib/tcl/unix/install-sh new file mode 100755 index 0000000..0ff4b6a --- /dev/null +++ b/contrib/tcl/unix/install-sh @@ -0,0 +1,119 @@ +#!/bin/sh + +# +# install - install a program, script, or datafile +# This comes from X11R5; it is not part of GNU. +# +# $XConsortium: install.sh,v 1.2 89/12/18 14:47:22 jim Exp $ +# +# This script is compatible with the BSD install script, but was written +# from scratch. +# + + +# set DOITPROG to echo to test this script + +# Don't use :- since 4.3BSD and earlier shells don't like it. +doit="${DOITPROG-}" + + +# put in absolute paths if you don't have them in your path; or use env. vars. + +mvprog="${MVPROG-mv}" +cpprog="${CPPROG-cp}" +chmodprog="${CHMODPROG-chmod}" +chownprog="${CHOWNPROG-chown}" +chgrpprog="${CHGRPPROG-chgrp}" +stripprog="${STRIPPROG-strip}" +rmprog="${RMPROG-rm}" + +instcmd="$mvprog" +chmodcmd="" +chowncmd="" +chgrpcmd="" +stripcmd="" +rmcmd="$rmprog -f" +mvcmd="$mvprog" +src="" +dst="" + +while [ x"$1" != x ]; do + case $1 in + -c) instcmd="$cpprog" + shift + continue;; + + -m) chmodcmd="$chmodprog $2" + shift + shift + continue;; + + -o) chowncmd="$chownprog $2" + shift + shift + continue;; + + -g) chgrpcmd="$chgrpprog $2" + shift + shift + continue;; + + -s) stripcmd="$stripprog" + shift + continue;; + + *) if [ x"$src" = x ] + then + src=$1 + else + dst=$1 + fi + shift + continue;; + esac +done + +if [ x"$src" = x ] +then + echo "install: no input file specified" + exit 1 +fi + +if [ x"$dst" = x ] +then + echo "install: no destination specified" + exit 1 +fi + + +# If destination is a directory, append the input filename; if your system +# does not like double slashes in filenames, you may need to add some logic + +if [ -d $dst ] +then + dst="$dst"/`basename $src` +fi + +# Make a temp file name in the proper directory. + +dstdir=`dirname $dst` +dsttmp=$dstdir/#inst.$$# + +# Move or copy the file name to the temp name + +$doit $instcmd $src $dsttmp + +# and set any options; do chmod last to preserve setuid bits + +if [ x"$chowncmd" != x ]; then $doit $chowncmd $dsttmp; fi +if [ x"$chgrpcmd" != x ]; then $doit $chgrpcmd $dsttmp; fi +if [ x"$stripcmd" != x ]; then $doit $stripcmd $dsttmp; fi +if [ x"$chmodcmd" != x ]; then $doit $chmodcmd $dsttmp; fi + +# Now rename the file to the real destination. + +$doit $rmcmd $dst +$doit $mvcmd $dsttmp $dst + + +exit 0 diff --git a/contrib/tcl/unix/ldAix b/contrib/tcl/unix/ldAix new file mode 100755 index 0000000..d7f0275 --- /dev/null +++ b/contrib/tcl/unix/ldAix @@ -0,0 +1,72 @@ +#!/bin/sh +# +# ldAix ldCmd ldArg ldArg ... +# +# This shell script provides a wrapper for ld under AIX in order to +# create the .exp file required for linking. Its arguments consist +# of the name and arguments that would normally be provided to the +# ld command. This script extracts the names of the object files +# from the argument list, creates a .exp file describing all of the +# symbols exported by those files, and then invokes "ldCmd" to +# perform the real link. +# +# SCCS: @(#) ldAix 1.7 96/03/27 09:45:03 + +# Extract from the arguments the names of all of the object files. + +args=$* +ofiles="" +for i do + x=`echo $i | grep '[^.].o$'` + if test "$x" != ""; then + ofiles="$ofiles $i" + fi +done + +# Create the export file from all of the object files, using nm followed +# by sed editing. Here are some tricky aspects of this: +# +# 1. Nm produces different output under AIX 4.1 than under AIX 3.2.5; +# 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 +# files (relevant in 4.1 only). +# 4. 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; +# in 3.2.5, these are undefined symbols (address 0). +# 6. 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 +# just cause confusion later. +# 8. Eliminate everything after the first field in a line, so that we're +# left with just the symbol name. + +nmopts="-g" +osver=`uname -v` +if test $osver -eq 3; then + nmopts="-e" +fi +rm -f lib.exp +echo "#! " >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 + +# Extract the name of the object file that we're linking. If it's a .a +# file, then link all the objects together into a single file "shr.o" +# and then put that into the archive. Otherwise link the object files +# directly into the .a file. + +outputFile=`echo $args | sed -e 's/.*-o \([^ ]*\).*/\1/'` +noDotA=`echo $outputFile | sed -e '/\.a$/d'` +echo "noDotA=\"$noDotA\"" +if test "$noDotA" = "" ; then + linkArgs=`echo $args | sed -e 's/-o .*\.a /-o shr.o /'` + echo $linkArgs + eval $linkArgs + echo ar cr $outputFile shr.o + ar cr $outputFile shr.o + rm -f shr.o +else + eval $args +fi diff --git a/contrib/tcl/unix/mkLinks b/contrib/tcl/unix/mkLinks new file mode 100755 index 0000000..149fcba --- /dev/null +++ b/contrib/tcl/unix/mkLinks @@ -0,0 +1,709 @@ +#!/bin/sh +# This script is invoked when installing manual entries. It generates +# additional links to manual entries, corresponding to the procedure +# and command names described by the manual entry. For example, the +# Tcl manual entry Hash.3 describes procedures Tcl_InitHashTable, +# Tcl_CreateHashEntry, and many more. This script will make hard +# links so that Tcl_InitHashTable.3, Tcl_CreateHashEntry.3, and so +# on all refer to Hash.3 in the installed directory. +# +# Because of the length of command and procedure names, this mechanism +# only works on machines that support file names longer than 14 characters. +# This script checks to see if long file names are supported, and it +# doesn't make any links if they are not. +# +# The script takes one argument, which is the name of the directory +# where the manual entries have been installed. + +if test $# != 1; then + echo "Usage: mkLinks dir" + exit 1 +fi + +echo foo > xyzzyTestingAVeryLongFileName.foo +x=`echo xyzzyTe*` +rm xyzzyTe* +if test "$x" != "xyzzyTestingAVeryLongFileName.foo"; then + exit +fi +if test -r $1/AddErrInfo.3; then + rm -f $1/Tcl_AddErrorInfo.3 + ln $1/AddErrInfo.3 $1/Tcl_AddErrorInfo.3 +fi +if test -r $1/AllowExc.3; then + rm -f $1/Tcl_AllowExceptions.3 + ln $1/AllowExc.3 $1/Tcl_AllowExceptions.3 +fi +if test -r $1/AppInit.3; then + rm -f $1/Tcl_AppInit.3 + ln $1/AppInit.3 $1/Tcl_AppInit.3 +fi +if test -r $1/SetResult.3; then + rm -f $1/Tcl_AppendElement.3 + ln $1/SetResult.3 $1/Tcl_AppendElement.3 +fi +if test -r $1/SetResult.3; then + rm -f $1/Tcl_AppendResult.3 + ln $1/SetResult.3 $1/Tcl_AppendResult.3 +fi +if test -r $1/Async.3; then + rm -f $1/Tcl_AsyncCreate.3 + ln $1/Async.3 $1/Tcl_AsyncCreate.3 +fi +if test -r $1/Async.3; then + rm -f $1/Tcl_AsyncDelete.3 + ln $1/Async.3 $1/Tcl_AsyncDelete.3 +fi +if test -r $1/Async.3; then + rm -f $1/Tcl_AsyncInvoke.3 + ln $1/Async.3 $1/Tcl_AsyncInvoke.3 +fi +if test -r $1/Async.3; then + rm -f $1/Tcl_AsyncMark.3 + ln $1/Async.3 $1/Tcl_AsyncMark.3 +fi +if test -r $1/BackgdErr.3; then + rm -f $1/Tcl_BackgroundError.3 + ln $1/BackgdErr.3 $1/Tcl_BackgroundError.3 +fi +if test -r $1/Backslash.3; then + rm -f $1/Tcl_Backslash.3 + ln $1/Backslash.3 $1/Tcl_Backslash.3 +fi +if test -r $1/CallDel.3; then + rm -f $1/Tcl_CallWhenDeleted.3 + ln $1/CallDel.3 $1/Tcl_CallWhenDeleted.3 +fi +if test -r $1/DoWhenIdle.3; then + rm -f $1/Tcl_CancelIdleCall.3 + ln $1/DoWhenIdle.3 $1/Tcl_CancelIdleCall.3 +fi +if test -r $1/OpenFileChnl.3; then + rm -f $1/Tcl_Close.3 + ln $1/OpenFileChnl.3 $1/Tcl_Close.3 +fi +if test -r $1/CmdCmplt.3; then + rm -f $1/Tcl_CommandComplete.3 + ln $1/CmdCmplt.3 $1/Tcl_CommandComplete.3 +fi +if test -r $1/Concat.3; then + rm -f $1/Tcl_Concat.3 + ln $1/Concat.3 $1/Tcl_Concat.3 +fi +if test -r $1/SplitList.3; then + rm -f $1/Tcl_ConvertElement.3 + ln $1/SplitList.3 $1/Tcl_ConvertElement.3 +fi +if test -r $1/CrtSlave.3; then + rm -f $1/Tcl_CreateAlias.3 + ln $1/CrtSlave.3 $1/Tcl_CreateAlias.3 +fi +if test -r $1/CrtChannel.3; then + rm -f $1/Tcl_CreateChannel.3 + ln $1/CrtChannel.3 $1/Tcl_CreateChannel.3 +fi +if test -r $1/CrtChnlHdlr.3; then + rm -f $1/Tcl_CreateChannelHandler.3 + ln $1/CrtChnlHdlr.3 $1/Tcl_CreateChannelHandler.3 +fi +if test -r $1/CrtCloseHdlr.3; then + rm -f $1/Tcl_CreateCloseHandler.3 + ln $1/CrtCloseHdlr.3 $1/Tcl_CreateCloseHandler.3 +fi +if test -r $1/CrtCommand.3; then + rm -f $1/Tcl_CreateCommand.3 + ln $1/CrtCommand.3 $1/Tcl_CreateCommand.3 +fi +if test -r $1/Notifier.3; then + rm -f $1/Tcl_CreateEventSource.3 + ln $1/Notifier.3 $1/Tcl_CreateEventSource.3 +fi +if test -r $1/Exit.3; then + rm -f $1/Tcl_CreateExitHandler.3 + ln $1/Exit.3 $1/Tcl_CreateExitHandler.3 +fi +if test -r $1/CrtFileHdlr.3; then + rm -f $1/Tcl_CreateFileHandler.3 + ln $1/CrtFileHdlr.3 $1/Tcl_CreateFileHandler.3 +fi +if test -r $1/Hash.3; then + rm -f $1/Tcl_CreateHashEntry.3 + ln $1/Hash.3 $1/Tcl_CreateHashEntry.3 +fi +if test -r $1/CrtInterp.3; then + rm -f $1/Tcl_CreateInterp.3 + ln $1/CrtInterp.3 $1/Tcl_CreateInterp.3 +fi +if test -r $1/CrtMathFnc.3; then + rm -f $1/Tcl_CreateMathFunc.3 + ln $1/CrtMathFnc.3 $1/Tcl_CreateMathFunc.3 +fi +if test -r $1/CrtModalTmt.3; then + rm -f $1/Tcl_CreateModalTimeout.3 + ln $1/CrtModalTmt.3 $1/Tcl_CreateModalTimeout.3 +fi +if test -r $1/CrtSlave.3; then + rm -f $1/Tcl_CreateSlave.3 + ln $1/CrtSlave.3 $1/Tcl_CreateSlave.3 +fi +if test -r $1/CrtTimerHdlr.3; then + rm -f $1/Tcl_CreateTimerHandler.3 + ln $1/CrtTimerHdlr.3 $1/Tcl_CreateTimerHandler.3 +fi +if test -r $1/CrtTrace.3; then + rm -f $1/Tcl_CreateTrace.3 + ln $1/CrtTrace.3 $1/Tcl_CreateTrace.3 +fi +if test -r $1/DString.3; then + rm -f $1/Tcl_DStringAppend.3 + ln $1/DString.3 $1/Tcl_DStringAppend.3 +fi +if test -r $1/DString.3; then + rm -f $1/Tcl_DStringAppendElement.3 + ln $1/DString.3 $1/Tcl_DStringAppendElement.3 +fi +if test -r $1/DString.3; then + rm -f $1/Tcl_DStringEndSublist.3 + ln $1/DString.3 $1/Tcl_DStringEndSublist.3 +fi +if test -r $1/DString.3; then + rm -f $1/Tcl_DStringFree.3 + ln $1/DString.3 $1/Tcl_DStringFree.3 +fi +if test -r $1/DString.3; then + rm -f $1/Tcl_DStringGetResult.3 + ln $1/DString.3 $1/Tcl_DStringGetResult.3 +fi +if test -r $1/DString.3; then + rm -f $1/Tcl_DStringInit.3 + ln $1/DString.3 $1/Tcl_DStringInit.3 +fi +if test -r $1/DString.3; then + rm -f $1/Tcl_DStringLength.3 + ln $1/DString.3 $1/Tcl_DStringLength.3 +fi +if test -r $1/DString.3; then + rm -f $1/Tcl_DStringResult.3 + ln $1/DString.3 $1/Tcl_DStringResult.3 +fi +if test -r $1/DString.3; then + rm -f $1/Tcl_DStringSetLength.3 + ln $1/DString.3 $1/Tcl_DStringSetLength.3 +fi +if test -r $1/DString.3; then + rm -f $1/Tcl_DStringStartSublist.3 + ln $1/DString.3 $1/Tcl_DStringStartSublist.3 +fi +if test -r $1/DString.3; then + rm -f $1/Tcl_DStringValue.3 + ln $1/DString.3 $1/Tcl_DStringValue.3 +fi +if test -r $1/AssocData.3; then + rm -f $1/Tcl_DeleteAssocData.3 + ln $1/AssocData.3 $1/Tcl_DeleteAssocData.3 +fi +if test -r $1/CrtChnlHdlr.3; then + rm -f $1/Tcl_DeleteChannelHandler.3 + ln $1/CrtChnlHdlr.3 $1/Tcl_DeleteChannelHandler.3 +fi +if test -r $1/CrtCloseHdlr.3; then + rm -f $1/Tcl_DeleteCloseHandler.3 + ln $1/CrtCloseHdlr.3 $1/Tcl_DeleteCloseHandler.3 +fi +if test -r $1/CrtCommand.3; then + rm -f $1/Tcl_DeleteCommand.3 + ln $1/CrtCommand.3 $1/Tcl_DeleteCommand.3 +fi +if test -r $1/Notifier.3; then + rm -f $1/Tcl_DeleteEventSource.3 + ln $1/Notifier.3 $1/Tcl_DeleteEventSource.3 +fi +if test -r $1/Exit.3; then + rm -f $1/Tcl_DeleteExitHandler.3 + ln $1/Exit.3 $1/Tcl_DeleteExitHandler.3 +fi +if test -r $1/CrtFileHdlr.3; then + rm -f $1/Tcl_DeleteFileHandler.3 + ln $1/CrtFileHdlr.3 $1/Tcl_DeleteFileHandler.3 +fi +if test -r $1/Hash.3; then + rm -f $1/Tcl_DeleteHashEntry.3 + ln $1/Hash.3 $1/Tcl_DeleteHashEntry.3 +fi +if test -r $1/Hash.3; then + rm -f $1/Tcl_DeleteHashTable.3 + ln $1/Hash.3 $1/Tcl_DeleteHashTable.3 +fi +if test -r $1/CrtInterp.3; then + rm -f $1/Tcl_DeleteInterp.3 + ln $1/CrtInterp.3 $1/Tcl_DeleteInterp.3 +fi +if test -r $1/CrtModalTmt.3; then + rm -f $1/Tcl_DeleteModalTimeout.3 + ln $1/CrtModalTmt.3 $1/Tcl_DeleteModalTimeout.3 +fi +if test -r $1/CrtTimerHdlr.3; then + rm -f $1/Tcl_DeleteTimerHandler.3 + ln $1/CrtTimerHdlr.3 $1/Tcl_DeleteTimerHandler.3 +fi +if test -r $1/CrtTrace.3; then + rm -f $1/Tcl_DeleteTrace.3 + ln $1/CrtTrace.3 $1/Tcl_DeleteTrace.3 +fi +if test -r $1/DetachPids.3; then + rm -f $1/Tcl_DetachPids.3 + ln $1/DetachPids.3 $1/Tcl_DetachPids.3 +fi +if test -r $1/DoOneEvent.3; then + rm -f $1/Tcl_DoOneEvent.3 + ln $1/DoOneEvent.3 $1/Tcl_DoOneEvent.3 +fi +if test -r $1/DoWhenIdle.3; then + rm -f $1/Tcl_DoWhenIdle.3 + ln $1/DoWhenIdle.3 $1/Tcl_DoWhenIdle.3 +fi +if test -r $1/CallDel.3; then + rm -f $1/Tcl_DontCallWhenDeleted.3 + ln $1/CallDel.3 $1/Tcl_DontCallWhenDeleted.3 +fi +if test -r $1/OpenFileChnl.3; then + rm -f $1/Tcl_Eof.3 + ln $1/OpenFileChnl.3 $1/Tcl_Eof.3 +fi +if test -r $1/Eval.3; then + rm -f $1/Tcl_Eval.3 + ln $1/Eval.3 $1/Tcl_Eval.3 +fi +if test -r $1/Eval.3; then + rm -f $1/Tcl_EvalFile.3 + ln $1/Eval.3 $1/Tcl_EvalFile.3 +fi +if test -r $1/Preserve.3; then + rm -f $1/Tcl_EventuallyFree.3 + ln $1/Preserve.3 $1/Tcl_EventuallyFree.3 +fi +if test -r $1/Exit.3; then + rm -f $1/Tcl_Exit.3 + ln $1/Exit.3 $1/Tcl_Exit.3 +fi +if test -r $1/ExprLong.3; then + rm -f $1/Tcl_ExprBoolean.3 + ln $1/ExprLong.3 $1/Tcl_ExprBoolean.3 +fi +if test -r $1/ExprLong.3; then + rm -f $1/Tcl_ExprDouble.3 + ln $1/ExprLong.3 $1/Tcl_ExprDouble.3 +fi +if test -r $1/ExprLong.3; then + rm -f $1/Tcl_ExprLong.3 + ln $1/ExprLong.3 $1/Tcl_ExprLong.3 +fi +if test -r $1/ExprLong.3; then + rm -f $1/Tcl_ExprString.3 + ln $1/ExprLong.3 $1/Tcl_ExprString.3 +fi +if test -r $1/Notifier.3; then + rm -f $1/Tcl_FileReady.3 + ln $1/Notifier.3 $1/Tcl_FileReady.3 +fi +if test -r $1/FindExec.3; then + rm -f $1/Tcl_FindExecutable.3 + ln $1/FindExec.3 $1/Tcl_FindExecutable.3 +fi +if test -r $1/Hash.3; then + rm -f $1/Tcl_FindHashEntry.3 + ln $1/Hash.3 $1/Tcl_FindHashEntry.3 +fi +if test -r $1/Hash.3; then + rm -f $1/Tcl_FirstHashEntry.3 + ln $1/Hash.3 $1/Tcl_FirstHashEntry.3 +fi +if test -r $1/OpenFileChnl.3; then + rm -f $1/Tcl_Flush.3 + ln $1/OpenFileChnl.3 $1/Tcl_Flush.3 +fi +if test -r $1/GetFile.3; then + rm -f $1/Tcl_FreeFile.3 + ln $1/GetFile.3 $1/Tcl_FreeFile.3 +fi +if test -r $1/CrtSlave.3; then + rm -f $1/Tcl_GetAlias.3 + ln $1/CrtSlave.3 $1/Tcl_GetAlias.3 +fi +if test -r $1/CrtSlave.3; then + rm -f $1/Tcl_GetAliases.3 + ln $1/CrtSlave.3 $1/Tcl_GetAliases.3 +fi +if test -r $1/AssocData.3; then + rm -f $1/Tcl_GetAssocData.3 + ln $1/AssocData.3 $1/Tcl_GetAssocData.3 +fi +if test -r $1/GetInt.3; then + rm -f $1/Tcl_GetBoolean.3 + ln $1/GetInt.3 $1/Tcl_GetBoolean.3 +fi +if test -r $1/CrtChannel.3; then + rm -f $1/Tcl_GetChannelBufferSize.3 + ln $1/CrtChannel.3 $1/Tcl_GetChannelBufferSize.3 +fi +if test -r $1/CrtChannel.3; then + rm -f $1/Tcl_GetChannelFile.3 + ln $1/CrtChannel.3 $1/Tcl_GetChannelFile.3 +fi +if test -r $1/CrtChannel.3; then + rm -f $1/Tcl_GetChannelInstanceData.3 + ln $1/CrtChannel.3 $1/Tcl_GetChannelInstanceData.3 +fi +if test -r $1/CrtChannel.3; then + rm -f $1/Tcl_GetChannelName.3 + ln $1/CrtChannel.3 $1/Tcl_GetChannelName.3 +fi +if test -r $1/OpenFileChnl.3; then + rm -f $1/Tcl_GetChannelOption.3 + ln $1/OpenFileChnl.3 $1/Tcl_GetChannelOption.3 +fi +if test -r $1/CrtChannel.3; then + rm -f $1/Tcl_GetChannelType.3 + ln $1/CrtChannel.3 $1/Tcl_GetChannelType.3 +fi +if test -r $1/CrtCommand.3; then + rm -f $1/Tcl_GetCommandInfo.3 + ln $1/CrtCommand.3 $1/Tcl_GetCommandInfo.3 +fi +if test -r $1/GetInt.3; then + rm -f $1/Tcl_GetDouble.3 + ln $1/GetInt.3 $1/Tcl_GetDouble.3 +fi +if test -r $1/SetErrno.3; then + rm -f $1/Tcl_GetErrno.3 + ln $1/SetErrno.3 $1/Tcl_GetErrno.3 +fi +if test -r $1/GetFile.3; then + rm -f $1/Tcl_GetFile.3 + ln $1/GetFile.3 $1/Tcl_GetFile.3 +fi +if test -r $1/GetFile.3; then + rm -f $1/Tcl_GetFileInfo.3 + ln $1/GetFile.3 $1/Tcl_GetFileInfo.3 +fi +if test -r $1/Hash.3; then + rm -f $1/Tcl_GetHashKey.3 + ln $1/Hash.3 $1/Tcl_GetHashKey.3 +fi +if test -r $1/Hash.3; then + rm -f $1/Tcl_GetHashValue.3 + ln $1/Hash.3 $1/Tcl_GetHashValue.3 +fi +if test -r $1/GetInt.3; then + rm -f $1/Tcl_GetInt.3 + ln $1/GetInt.3 $1/Tcl_GetInt.3 +fi +if test -r $1/CrtSlave.3; then + rm -f $1/Tcl_GetMaster.3 + ln $1/CrtSlave.3 $1/Tcl_GetMaster.3 +fi +if test -r $1/GetOpnFl.3; then + rm -f $1/Tcl_GetOpenFile.3 + ln $1/GetOpnFl.3 $1/Tcl_GetOpenFile.3 +fi +if test -r $1/CrtSlave.3; then + rm -f $1/Tcl_GetSlave.3 + ln $1/CrtSlave.3 $1/Tcl_GetSlave.3 +fi +if test -r $1/CrtSlave.3; then + rm -f $1/Tcl_GetSlaves.3 + ln $1/CrtSlave.3 $1/Tcl_GetSlaves.3 +fi +if test -r $1/GetStdChan.3; then + rm -f $1/Tcl_GetStdChannel.3 + ln $1/GetStdChan.3 $1/Tcl_GetStdChannel.3 +fi +if test -r $1/SetVar.3; then + rm -f $1/Tcl_GetVar.3 + ln $1/SetVar.3 $1/Tcl_GetVar.3 +fi +if test -r $1/SetVar.3; then + rm -f $1/Tcl_GetVar2.3 + ln $1/SetVar.3 $1/Tcl_GetVar2.3 +fi +if test -r $1/OpenFileChnl.3; then + rm -f $1/Tcl_Gets.3 + ln $1/OpenFileChnl.3 $1/Tcl_Gets.3 +fi +if test -r $1/Eval.3; then + rm -f $1/Tcl_GlobalEval.3 + ln $1/Eval.3 $1/Tcl_GlobalEval.3 +fi +if test -r $1/Hash.3; then + rm -f $1/Tcl_HashStats.3 + ln $1/Hash.3 $1/Tcl_HashStats.3 +fi +if test -r $1/Hash.3; then + rm -f $1/Tcl_InitHashTable.3 + ln $1/Hash.3 $1/Tcl_InitHashTable.3 +fi +if test -r $1/OpenFileChnl.3; then + rm -f $1/Tcl_InputBlocked.3 + ln $1/OpenFileChnl.3 $1/Tcl_InputBlocked.3 +fi +if test -r $1/Interp.3; then + rm -f $1/Tcl_Interp.3 + ln $1/Interp.3 $1/Tcl_Interp.3 +fi +if test -r $1/CrtInterp.3; then + rm -f $1/Tcl_InterpDeleted.3 + ln $1/CrtInterp.3 $1/Tcl_InterpDeleted.3 +fi +if test -r $1/CrtSlave.3; then + rm -f $1/Tcl_IsSafe.3 + ln $1/CrtSlave.3 $1/Tcl_IsSafe.3 +fi +if test -r $1/LinkVar.3; then + rm -f $1/Tcl_LinkVar.3 + ln $1/LinkVar.3 $1/Tcl_LinkVar.3 +fi +if test -r $1/CrtSlave.3; then + rm -f $1/Tcl_MakeSafe.3 + ln $1/CrtSlave.3 $1/Tcl_MakeSafe.3 +fi +if test -r $1/SplitList.3; then + rm -f $1/Tcl_Merge.3 + ln $1/SplitList.3 $1/Tcl_Merge.3 +fi +if test -r $1/Hash.3; then + rm -f $1/Tcl_NextHashEntry.3 + ln $1/Hash.3 $1/Tcl_NextHashEntry.3 +fi +if test -r $1/OpenFileChnl.3; then + rm -f $1/Tcl_OpenCommandChannel.3 + ln $1/OpenFileChnl.3 $1/Tcl_OpenCommandChannel.3 +fi +if test -r $1/OpenFileChnl.3; then + rm -f $1/Tcl_OpenFileChannel.3 + ln $1/OpenFileChnl.3 $1/Tcl_OpenFileChannel.3 +fi +if test -r $1/OpenTcp.3; then + rm -f $1/Tcl_OpenTcpClient.3 + ln $1/OpenTcp.3 $1/Tcl_OpenTcpClient.3 +fi +if test -r $1/OpenTcp.3; then + rm -f $1/Tcl_OpenTcpServer.3 + ln $1/OpenTcp.3 $1/Tcl_OpenTcpServer.3 +fi +if test -r $1/PkgRequire.3; then + rm -f $1/Tcl_PkgProvide.3 + ln $1/PkgRequire.3 $1/Tcl_PkgProvide.3 +fi +if test -r $1/PkgRequire.3; then + rm -f $1/Tcl_PkgRequire.3 + ln $1/PkgRequire.3 $1/Tcl_PkgRequire.3 +fi +if test -r $1/AddErrInfo.3; then + rm -f $1/Tcl_PosixError.3 + ln $1/AddErrInfo.3 $1/Tcl_PosixError.3 +fi +if test -r $1/Preserve.3; then + rm -f $1/Tcl_Preserve.3 + ln $1/Preserve.3 $1/Tcl_Preserve.3 +fi +if test -r $1/PrintDbl.3; then + rm -f $1/Tcl_PrintDouble.3 + ln $1/PrintDbl.3 $1/Tcl_PrintDouble.3 +fi +if test -r $1/Notifier.3; then + rm -f $1/Tcl_QueueEvent.3 + ln $1/Notifier.3 $1/Tcl_QueueEvent.3 +fi +if test -r $1/OpenFileChnl.3; then + rm -f $1/Tcl_Read.3 + ln $1/OpenFileChnl.3 $1/Tcl_Read.3 +fi +if test -r $1/DetachPids.3; then + rm -f $1/Tcl_ReapDetachedProcs.3 + ln $1/DetachPids.3 $1/Tcl_ReapDetachedProcs.3 +fi +if test -r $1/RecordEval.3; then + rm -f $1/Tcl_RecordAndEval.3 + ln $1/RecordEval.3 $1/Tcl_RecordAndEval.3 +fi +if test -r $1/RegExp.3; then + rm -f $1/Tcl_RegExpCompile.3 + ln $1/RegExp.3 $1/Tcl_RegExpCompile.3 +fi +if test -r $1/RegExp.3; then + rm -f $1/Tcl_RegExpExec.3 + ln $1/RegExp.3 $1/Tcl_RegExpExec.3 +fi +if test -r $1/RegExp.3; then + rm -f $1/Tcl_RegExpMatch.3 + ln $1/RegExp.3 $1/Tcl_RegExpMatch.3 +fi +if test -r $1/RegExp.3; then + rm -f $1/Tcl_RegExpRange.3 + ln $1/RegExp.3 $1/Tcl_RegExpRange.3 +fi +if test -r $1/Preserve.3; then + rm -f $1/Tcl_Release.3 + ln $1/Preserve.3 $1/Tcl_Release.3 +fi +if test -r $1/SetResult.3; then + rm -f $1/Tcl_ResetResult.3 + ln $1/SetResult.3 $1/Tcl_ResetResult.3 +fi +if test -r $1/SplitList.3; then + rm -f $1/Tcl_ScanElement.3 + ln $1/SplitList.3 $1/Tcl_ScanElement.3 +fi +if test -r $1/OpenFileChnl.3; then + rm -f $1/Tcl_Seek.3 + ln $1/OpenFileChnl.3 $1/Tcl_Seek.3 +fi +if test -r $1/AssocData.3; then + rm -f $1/Tcl_SetAssocData.3 + ln $1/AssocData.3 $1/Tcl_SetAssocData.3 +fi +if test -r $1/CrtChannel.3; then + rm -f $1/Tcl_SetChannelBufferSize.3 + ln $1/CrtChannel.3 $1/Tcl_SetChannelBufferSize.3 +fi +if test -r $1/OpenFileChnl.3; then + rm -f $1/Tcl_SetChannelOption.3 + ln $1/OpenFileChnl.3 $1/Tcl_SetChannelOption.3 +fi +if test -r $1/CrtCommand.3; then + rm -f $1/Tcl_SetCommandInfo.3 + ln $1/CrtCommand.3 $1/Tcl_SetCommandInfo.3 +fi +if test -r $1/CrtChannel.3; then + rm -f $1/Tcl_SetDefaultTranslation.3 + ln $1/CrtChannel.3 $1/Tcl_SetDefaultTranslation.3 +fi +if test -r $1/SetErrno.3; then + rm -f $1/Tcl_SetErrno.3 + ln $1/SetErrno.3 $1/Tcl_SetErrno.3 +fi +if test -r $1/AddErrInfo.3; then + rm -f $1/Tcl_SetErrorCode.3 + ln $1/AddErrInfo.3 $1/Tcl_SetErrorCode.3 +fi +if test -r $1/Hash.3; then + rm -f $1/Tcl_SetHashValue.3 + ln $1/Hash.3 $1/Tcl_SetHashValue.3 +fi +if test -r $1/Notifier.3; then + rm -f $1/Tcl_SetMaxBlockTime.3 + ln $1/Notifier.3 $1/Tcl_SetMaxBlockTime.3 +fi +if test -r $1/SetRecLmt.3; then + rm -f $1/Tcl_SetRecursionLimit.3 + ln $1/SetRecLmt.3 $1/Tcl_SetRecursionLimit.3 +fi +if test -r $1/SetResult.3; then + rm -f $1/Tcl_SetResult.3 + ln $1/SetResult.3 $1/Tcl_SetResult.3 +fi +if test -r $1/GetStdChan.3; then + rm -f $1/Tcl_SetStdChannel.3 + ln $1/GetStdChan.3 $1/Tcl_SetStdChannel.3 +fi +if test -r $1/SetVar.3; then + rm -f $1/Tcl_SetVar.3 + ln $1/SetVar.3 $1/Tcl_SetVar.3 +fi +if test -r $1/SetVar.3; then + rm -f $1/Tcl_SetVar2.3 + ln $1/SetVar.3 $1/Tcl_SetVar2.3 +fi +if test -r $1/Sleep.3; then + rm -f $1/Tcl_Sleep.3 + ln $1/Sleep.3 $1/Tcl_Sleep.3 +fi +if test -r $1/SplitList.3; then + rm -f $1/Tcl_SplitList.3 + ln $1/SplitList.3 $1/Tcl_SplitList.3 +fi +if test -r $1/StaticPkg.3; then + rm -f $1/Tcl_StaticPackage.3 + ln $1/StaticPkg.3 $1/Tcl_StaticPackage.3 +fi +if test -r $1/StrMatch.3; then + rm -f $1/Tcl_StringMatch.3 + ln $1/StrMatch.3 $1/Tcl_StringMatch.3 +fi +if test -r $1/OpenFileChnl.3; then + rm -f $1/Tcl_Tell.3 + ln $1/OpenFileChnl.3 $1/Tcl_Tell.3 +fi +if test -r $1/TraceVar.3; then + rm -f $1/Tcl_TraceVar.3 + ln $1/TraceVar.3 $1/Tcl_TraceVar.3 +fi +if test -r $1/TraceVar.3; then + rm -f $1/Tcl_TraceVar2.3 + ln $1/TraceVar.3 $1/Tcl_TraceVar2.3 +fi +if test -r $1/Translate.3; then + rm -f $1/Tcl_TranslateFileName.3 + ln $1/Translate.3 $1/Tcl_TranslateFileName.3 +fi +if test -r $1/LinkVar.3; then + rm -f $1/Tcl_UnlinkVar.3 + ln $1/LinkVar.3 $1/Tcl_UnlinkVar.3 +fi +if test -r $1/SetVar.3; then + rm -f $1/Tcl_UnsetVar.3 + ln $1/SetVar.3 $1/Tcl_UnsetVar.3 +fi +if test -r $1/SetVar.3; then + rm -f $1/Tcl_UnsetVar2.3 + ln $1/SetVar.3 $1/Tcl_UnsetVar2.3 +fi +if test -r $1/TraceVar.3; then + rm -f $1/Tcl_UntraceVar.3 + ln $1/TraceVar.3 $1/Tcl_UntraceVar.3 +fi +if test -r $1/TraceVar.3; then + rm -f $1/Tcl_UntraceVar2.3 + ln $1/TraceVar.3 $1/Tcl_UntraceVar2.3 +fi +if test -r $1/UpVar.3; then + rm -f $1/Tcl_UpVar.3 + ln $1/UpVar.3 $1/Tcl_UpVar.3 +fi +if test -r $1/UpVar.3; then + rm -f $1/Tcl_UpVar2.3 + ln $1/UpVar.3 $1/Tcl_UpVar2.3 +fi +if test -r $1/LinkVar.3; then + rm -f $1/Tcl_UpdateLinkedVar.3 + ln $1/LinkVar.3 $1/Tcl_UpdateLinkedVar.3 +fi +if test -r $1/Eval.3; then + rm -f $1/Tcl_VarEval.3 + ln $1/Eval.3 $1/Tcl_VarEval.3 +fi +if test -r $1/TraceVar.3; then + rm -f $1/Tcl_VarTraceInfo.3 + ln $1/TraceVar.3 $1/Tcl_VarTraceInfo.3 +fi +if test -r $1/TraceVar.3; then + rm -f $1/Tcl_VarTraceInfo2.3 + ln $1/TraceVar.3 $1/Tcl_VarTraceInfo2.3 +fi +if test -r $1/Notifier.3; then + rm -f $1/Tcl_WaitForEvent.3 + ln $1/Notifier.3 $1/Tcl_WaitForEvent.3 +fi +if test -r $1/Notifier.3; then + rm -f $1/Tcl_WatchFile.3 + ln $1/Notifier.3 $1/Tcl_WatchFile.3 +fi +if test -r $1/OpenFileChnl.3; then + rm -f $1/Tcl_Write.3 + ln $1/OpenFileChnl.3 $1/Tcl_Write.3 +fi +if test -r $1/pkgMkIndex.n; then + rm -f $1/pkg_mkIndex.n + ln $1/pkgMkIndex.n $1/pkg_mkIndex.n +fi +exit 0 diff --git a/contrib/tcl/unix/porting.notes b/contrib/tcl/unix/porting.notes new file mode 100644 index 0000000..6555a20 --- /dev/null +++ b/contrib/tcl/unix/porting.notes @@ -0,0 +1,357 @@ +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. +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.4.0 +This page provides information about the platforms on which Tcl 7.4 +and Tk 4.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 = SCCS: @(#) porting.notes 1.16 96/04/17 10:32:35 + +-------------------------------------------- +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. + +-------------------------------------------- +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@sco.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@sco.com> diff --git a/contrib/tcl/unix/tclAppInit.c b/contrib/tcl/unix/tclAppInit.c new file mode 100644 index 0000000..a9479b3 --- /dev/null +++ b/contrib/tcl/unix/tclAppInit.c @@ -0,0 +1,116 @@ +/* + * tclAppInit.c -- + * + * Provides a default version of the main program and Tcl_AppInit + * procedure for Tcl applications (without Tk). + * + * Copyright (c) 1993 The Regents of the University of California. + * Copyright (c) 1994-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: @(#) tclAppInit.c 1.17 96/03/26 12:45:29 + */ + +#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 +EXTERN int Tcltest_Init _ANSI_ARGS_((Tcl_Interp *interp)); +#endif /* TCL_TEST */ + +/* + *---------------------------------------------------------------------- + * + * main -- + * + * This is the main program for the application. + * + * Results: + * None: Tcl_Main never returns here, so this procedure never + * returns either. + * + * Side effects: + * Whatever the application does. + * + *---------------------------------------------------------------------- + */ + +int +main(argc, argv) + int argc; /* Number of command-line arguments. */ + char **argv; /* Values of command-line arguments. */ +{ + Tcl_Main(argc, argv, Tcl_AppInit); + return 0; /* Needed only to prevent compiler warning. */ +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_AppInit -- + * + * This procedure performs application-specific initialization. + * Most applications, especially those that incorporate additional + * packages, will have their own version of this procedure. + * + * Results: + * Returns a standard Tcl completion code, and leaves an error + * message in interp->result if an error occurs. + * + * Side effects: + * Depends on the startup script. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_AppInit(interp) + Tcl_Interp *interp; /* Interpreter for application. */ +{ + if (Tcl_Init(interp) == TCL_ERROR) { + return TCL_ERROR; + } + +#ifdef TCL_TEST + if (Tcltest_Init(interp) == TCL_ERROR) { + return TCL_ERROR; + } + Tcl_StaticPackage(interp, "Tcltest", Tcltest_Init, + (Tcl_PackageInitProc *) NULL); +#endif /* TCL_TEST */ + + /* + * Call the init procedures for included packages. Each call should + * look like this: + * + * if (Mod_Init(interp) == TCL_ERROR) { + * return TCL_ERROR; + * } + * + * where "Mod" is the name of the module. + */ + + /* + * Call Tcl_CreateCommand for application-specific commands, if + * they weren't already created by the init procedures called above. + */ + + /* + * Specify a user-specific startup file to invoke if the application + * is run interactively. Typically the startup file is "~/.apprc" + * where "app" is the name of the application. If this line is deleted + * then no user-specific startup file will be run under any conditions. + */ + + Tcl_SetVar(interp, "tcl_rcFileName", "~/.tclshrc", TCL_GLOBAL_ONLY); + return TCL_OK; +} diff --git a/contrib/tcl/unix/tclConfig.sh.in b/contrib/tcl/unix/tclConfig.sh.in new file mode 100644 index 0000000..e6d4b04 --- /dev/null +++ b/contrib/tcl/unix/tclConfig.sh.in @@ -0,0 +1,99 @@ +# tclConfig.sh -- +# +# This shell script (for sh) is generated automatically by Tcl's +# configure script. It will create shell variables for most of +# the configuration options discovered by the configure script. +# This script is intended to be included by the configure scripts +# for Tcl extensions so that they don't have to figure this all +# out for themselves. +# +# The information in this file is specific to a single platform. +# +# SCCS: @(#) tclConfig.sh.in 1.15 96/04/17 10:46:27 + +# Tcl's version number. +TCL_VERSION='@TCL_VERSION@' +TCL_MAJOR_VERSION='@TCL_MAJOR_VERSION@' +TCL_MINOR_VERSION='@TCL_MINOR_VERSION@' + +# C compiler to use for compilation. +TCL_CC='@CC@' + +# -D flags for use with the C compiler. +TCL_DEFS='@DEFS@' + +# The name of the Tcl library (may be either a .a file or a shared library): +TCL_LIB_FILE=@TCL_LIB_FILE@ + +# Additional libraries to use when linking Tcl. +TCL_LIBS='@DL_LIBS@ @LIBS@ @MATH_LIBS@' + +# Top-level directory in which Tcl's platform-independent files are +# installed. +TCL_PREFIX='@prefix@' + +# Top-level directory in which Tcl's platform-specific files (e.g. +# executables) are installed. +TCL_EXEC_PREFIX='@exec_prefix@' + +# Flags to pass to cc when compiling the components of a shared library: +TCL_SHLIB_CFLAGS='@SHLIB_CFLAGS@' + +# Base command to use for combining object files into a shared library: +TCL_SHLIB_LD='@SHLIB_LD@' + +# Either '$LIBS' (if dependent libraries should be included when linking +# shared libraries) or an empty string. See Tcl's configure.in for more +# explanation. +TCL_SHLIB_LD_LIBS='@SHLIB_LD_LIBS@' + +# 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. +TCL_DL_LIBS='@DL_LIBS@' + +# Flags to pass to the compiler when linking object files into +# an executable tclsh or tcltest binary. +TCL_LD_FLAGS='@LD_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. Used when linking applications. Only works if there +# is a variable "LIB_INSTALL_DIR" defined in the Makefile. +TCL_LD_SEARCH_FLAGS='@TCL_LD_SEARCH_FLAGS@' + +# Additional object files linked with Tcl to provide compatibility +# with standard facilities from ANSI C or POSIX. +TCL_COMPAT_OBJS='@LIBOBJS@' + +# Name of the ranlib program to use. +TCL_RANLIB='@RANLIB@' + +# String to pass to linker to pick up the Tcl library from its +# build directory. +TCL_BUILD_LIB_SPEC='@TCL_BUILD_LIB_SPEC@' + +# String to pass to linker to pick up the Tcl library from its +# installed directory. +TCL_LIB_SPEC='@TCL_LIB_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 +# example. +TCL_LIB_VERSIONS_OK='@TCL_LIB_VERSIONS_OK@' + +# String that can be evaluated to generate the part of a shared library +# name that comes after the "libxxx" (includes version number, if any, +# extension, and anything else needed). May depend on the variables +# VERSION and SHLIB_SUFFIX. On most UNIX systems this is +# ${VERSION}${SHLIB_SUFFIX}. +TCL_SHARED_LIB_SUFFIX='@TCL_SHARED_LIB_SUFFIX@' + +# String that can be evaluated to generate the part of an unshared library +# name that comes after the "libxxx" (includes version number, if any, +# extension, and anything else needed). May depend on the variable +# VERSION. On most UNIX systems this is ${VERSION}.a. +TCL_UNSHARED_LIB_SUFFIX='@TCL_UNSHARED_LIB_SUFFIX@' diff --git a/contrib/tcl/unix/tclLoadAix.c b/contrib/tcl/unix/tclLoadAix.c new file mode 100644 index 0000000..a940ca3 --- /dev/null +++ b/contrib/tcl/unix/tclLoadAix.c @@ -0,0 +1,549 @@ +/* + * tclLoadAix.c -- + * + * This file implements the dlopen and dlsym APIs under the + * AIX operating system, to enable the Tcl "load" command to + * work. This code was provided by Jens-Uwe Mager. + * + * This file is subject to the following copyright notice, which is + * different from the notice used elsewhere in Tcl. The file has + * been modified to incorporate the file dlfcn.h in-line. + * + * Copyright (c) 1992,1993,1995,1996, Jens-Uwe Mager, Helios Software GmbH + * Not derived from licensed software. + + * Permission is granted to freely use, copy, modify, and redistribute + * this software, provided that the author is not construed to be liable + * for any results of using the software, alterations are clearly marked + * as such, and this notice is not modified. + * + * SCCS: @(#) tclLoadAix.c 1.10 96/03/26 13:18:21 + * + * Note: this file has been altered from the original in a few + * ways in order to work properly with Tcl. + */ + +/* + * @(#)dlfcn.c 1.7 revision of 95/08/14 19:08:38 + * This is an unpublished work copyright (c) 1992 HELIOS Software GmbH + * 30159 Hannover, Germany + */ + +#include <stdio.h> +#include <errno.h> +#include <string.h> +#include <stdlib.h> +#include <sys/types.h> +#include <sys/ldr.h> +#include <a.out.h> +#include <ldfcn.h> +#include "../compat/dlfcn.h" + +/* + * We simulate dlopen() et al. through a call to load. Because AIX has + * no call to find an exported symbol we read the loader section of the + * loaded module and build a list of exported symbols and their virtual + * address. + */ + +typedef struct { + char *name; /* the symbols's name */ + void *addr; /* its relocated virtual address */ +} Export, *ExportPtr; + +/* + * xlC uses the following structure to list its constructors and + * destructors. This is gleaned from the output of munch. + */ +typedef struct { + void (*init)(void); /* call static constructors */ + void (*term)(void); /* call static destructors */ +} Cdtor, *CdtorPtr; + +/* + * The void * handle returned from dlopen is actually a ModulePtr. + */ +typedef struct Module { + struct Module *next; + char *name; /* module name for refcounting */ + int refCnt; /* the number of references */ + void *entry; /* entry point from load */ + struct dl_info *info; /* optional init/terminate functions */ + CdtorPtr cdtors; /* optional C++ constructors */ + int nExports; /* the number of exports found */ + ExportPtr exports; /* the array of exports */ +} Module, *ModulePtr; + +/* + * We keep a list of all loaded modules to be able to call the fini + * handlers and destructors at atexit() time. + */ +static ModulePtr modList; + +/* + * The last error from one of the dl* routines is kept in static + * variables here. Each error is returned only once to the caller. + */ +static char errbuf[BUFSIZ]; +static int errvalid; + +static void caterr(char *); +static int readExports(ModulePtr); +static void terminate(void); +static void *findMain(void); + +void *dlopen(const char *path, int mode) +{ + register ModulePtr mp; + static void *mainModule; + + /* + * Upon the first call register a terminate handler that will + * close all libraries. Also get a reference to the main module + * for use with loadbind. + */ + if (!mainModule) { + if ((mainModule = findMain()) == NULL) + return NULL; + atexit(terminate); + } + /* + * Scan the list of modules if we have the module already loaded. + */ + for (mp = modList; mp; mp = mp->next) + if (strcmp(mp->name, path) == 0) { + mp->refCnt++; + return mp; + } + if ((mp = (ModulePtr)calloc(1, sizeof(*mp))) == NULL) { + errvalid++; + strcpy(errbuf, "calloc: "); + strcat(errbuf, strerror(errno)); + return NULL; + } + mp->name = malloc((unsigned) (strlen(path) + 1)); + strcpy(mp->name, path); + /* + * load should be declared load(const char *...). Thus we + * cast the path to a normal char *. Ugly. + */ + if ((mp->entry = (void *)load((char *)path, L_NOAUTODEFER, NULL)) == NULL) { + free(mp->name); + free(mp); + errvalid++; + strcpy(errbuf, "dlopen: "); + strcat(errbuf, path); + strcat(errbuf, ": "); + /* + * If AIX says the file is not executable, the error + * can be further described by querying the loader about + * the last error. + */ + if (errno == ENOEXEC) { + char *tmp[BUFSIZ/sizeof(char *)]; + if (loadquery(L_GETMESSAGES, tmp, sizeof(tmp)) == -1) + strcpy(errbuf, strerror(errno)); + else { + char **p; + for (p = tmp; *p; p++) + caterr(*p); + } + } else + strcat(errbuf, strerror(errno)); + return NULL; + } + mp->refCnt = 1; + mp->next = modList; + modList = mp; + if (loadbind(0, mainModule, mp->entry) == -1) { + dlclose(mp); + errvalid++; + strcpy(errbuf, "loadbind: "); + strcat(errbuf, strerror(errno)); + return NULL; + } + /* + * If the user wants global binding, loadbind against all other + * loaded modules. + */ + if (mode & RTLD_GLOBAL) { + register ModulePtr mp1; + for (mp1 = mp->next; mp1; mp1 = mp1->next) + if (loadbind(0, mp1->entry, mp->entry) == -1) { + dlclose(mp); + errvalid++; + strcpy(errbuf, "loadbind: "); + strcat(errbuf, strerror(errno)); + return NULL; + } + } + if (readExports(mp) == -1) { + dlclose(mp); + return NULL; + } + /* + * If there is a dl_info structure, call the init function. + */ + if (mp->info = (struct dl_info *)dlsym(mp, "dl_info")) { + if (mp->info->init) + (*mp->info->init)(); + } else + errvalid = 0; + /* + * If the shared object was compiled using xlC we will need + * to call static constructors (and later on dlclose destructors). + */ + if (mp->cdtors = (CdtorPtr)dlsym(mp, "__cdtors")) { + while (mp->cdtors->init) { + (*mp->cdtors->init)(); + mp->cdtors++; + } + } else + errvalid = 0; + return mp; +} + +/* + * Attempt to decipher an AIX loader error message and append it + * to our static error message buffer. + */ +static void caterr(char *s) +{ + register char *p = s; + + while (*p >= '0' && *p <= '9') + p++; + switch(atoi(s)) { + case L_ERROR_TOOMANY: + strcat(errbuf, "to many errors"); + break; + case L_ERROR_NOLIB: + strcat(errbuf, "can't load library"); + strcat(errbuf, p); + break; + case L_ERROR_UNDEF: + strcat(errbuf, "can't find symbol"); + strcat(errbuf, p); + break; + case L_ERROR_RLDBAD: + strcat(errbuf, "bad RLD"); + strcat(errbuf, p); + break; + case L_ERROR_FORMAT: + strcat(errbuf, "bad exec format in"); + strcat(errbuf, p); + break; + case L_ERROR_ERRNO: + strcat(errbuf, strerror(atoi(++p))); + break; + default: + strcat(errbuf, s); + break; + } +} + +void *dlsym(void *handle, const char *symbol) +{ + register ModulePtr mp = (ModulePtr)handle; + register ExportPtr ep; + register int i; + + /* + * Could speed up the search, but I assume that one assigns + * the result to function pointers anyways. + */ + for (ep = mp->exports, i = mp->nExports; i; i--, ep++) + if (strcmp(ep->name, symbol) == 0) + return ep->addr; + errvalid++; + strcpy(errbuf, "dlsym: undefined symbol "); + strcat(errbuf, symbol); + return NULL; +} + +char *dlerror(void) +{ + if (errvalid) { + errvalid = 0; + return errbuf; + } + return NULL; +} + +int dlclose(void *handle) +{ + register ModulePtr mp = (ModulePtr)handle; + int result; + register ModulePtr mp1; + + if (--mp->refCnt > 0) + return 0; + if (mp->info && mp->info->fini) + (*mp->info->fini)(); + if (mp->cdtors) + while (mp->cdtors->term) { + (*mp->cdtors->term)(); + mp->cdtors++; + } + result = unload(mp->entry); + if (result == -1) { + errvalid++; + strcpy(errbuf, strerror(errno)); + } + if (mp->exports) { + register ExportPtr ep; + register int i; + for (ep = mp->exports, i = mp->nExports; i; i--, ep++) + if (ep->name) + free(ep->name); + free(mp->exports); + } + if (mp == modList) + modList = mp->next; + else { + for (mp1 = modList; mp1; mp1 = mp1->next) + if (mp1->next == mp) { + mp1->next = mp->next; + break; + } + } + free(mp->name); + free(mp); + return result; +} + +static void terminate(void) +{ + while (modList) + dlclose(modList); +} + +/* + * Build the export table from the XCOFF .loader section. + */ +static int readExports(ModulePtr mp) +{ + LDFILE *ldp = NULL; + SCNHDR sh, shdata; + LDHDR *lhp; + char *ldbuf; + LDSYM *ls; + int i; + ExportPtr ep; + + if ((ldp = ldopen(mp->name, ldp)) == NULL) { + struct ld_info *lp; + char *buf; + int size = 4*1024; + if (errno != ENOENT) { + errvalid++; + strcpy(errbuf, "readExports: "); + strcat(errbuf, strerror(errno)); + return -1; + } + /* + * The module might be loaded due to the LIBPATH + * environment variable. Search for the loaded + * module using L_GETINFO. + */ + if ((buf = malloc(size)) == NULL) { + errvalid++; + strcpy(errbuf, "readExports: "); + strcat(errbuf, strerror(errno)); + return -1; + } + while ((i = loadquery(L_GETINFO, buf, size)) == -1 && errno == ENOMEM) { + free(buf); + size += 4*1024; + if ((buf = malloc(size)) == NULL) { + errvalid++; + strcpy(errbuf, "readExports: "); + strcat(errbuf, strerror(errno)); + return -1; + } + } + if (i == -1) { + errvalid++; + strcpy(errbuf, "readExports: "); + strcat(errbuf, strerror(errno)); + free(buf); + return -1; + } + /* + * Traverse the list of loaded modules. The entry point + * returned by load() does actually point to the data + * segment origin. + */ + lp = (struct ld_info *)buf; + while (lp) { + if (lp->ldinfo_dataorg == mp->entry) { + ldp = ldopen(lp->ldinfo_filename, ldp); + break; + } + if (lp->ldinfo_next == 0) + lp = NULL; + else + lp = (struct ld_info *)((char *)lp + lp->ldinfo_next); + } + free(buf); + if (!ldp) { + errvalid++; + strcpy(errbuf, "readExports: "); + strcat(errbuf, strerror(errno)); + return -1; + } + } + if (TYPE(ldp) != U802TOCMAGIC) { + errvalid++; + strcpy(errbuf, "readExports: bad magic"); + while(ldclose(ldp) == FAILURE) + ; + return -1; + } + /* + * Get the padding for the data section. This is needed for + * AIX 4.1 compilers. This is used when building the final + * function pointer to the exported symbol. + */ + if (ldnshread(ldp, _DATA, &shdata) != SUCCESS) { + errvalid++; + strcpy(errbuf, "readExports: cannot read data section header"); + while(ldclose(ldp) == FAILURE) + ; + return -1; + } + if (ldnshread(ldp, _LOADER, &sh) != SUCCESS) { + errvalid++; + strcpy(errbuf, "readExports: cannot read loader section header"); + while(ldclose(ldp) == FAILURE) + ; + return -1; + } + /* + * We read the complete loader section in one chunk, this makes + * finding long symbol names residing in the string table easier. + */ + if ((ldbuf = (char *)malloc(sh.s_size)) == NULL) { + errvalid++; + strcpy(errbuf, "readExports: "); + strcat(errbuf, strerror(errno)); + while(ldclose(ldp) == FAILURE) + ; + return -1; + } + if (FSEEK(ldp, sh.s_scnptr, BEGINNING) != OKFSEEK) { + errvalid++; + strcpy(errbuf, "readExports: cannot seek to loader section"); + free(ldbuf); + while(ldclose(ldp) == FAILURE) + ; + return -1; + } + if (FREAD(ldbuf, sh.s_size, 1, ldp) != 1) { + errvalid++; + strcpy(errbuf, "readExports: cannot read loader section"); + free(ldbuf); + while(ldclose(ldp) == FAILURE) + ; + return -1; + } + lhp = (LDHDR *)ldbuf; + ls = (LDSYM *)(ldbuf+LDHDRSZ); + /* + * Count the number of exports to include in our export table. + */ + for (i = lhp->l_nsyms; i; i--, ls++) { + if (!LDR_EXPORT(*ls)) + continue; + mp->nExports++; + } + if ((mp->exports = (ExportPtr)calloc(mp->nExports, sizeof(*mp->exports))) == NULL) { + errvalid++; + strcpy(errbuf, "readExports: "); + strcat(errbuf, strerror(errno)); + free(ldbuf); + while(ldclose(ldp) == FAILURE) + ; + return -1; + } + /* + * Fill in the export table. All entries are relative to + * the entry point we got from load. + */ + ep = mp->exports; + ls = (LDSYM *)(ldbuf+LDHDRSZ); + for (i = lhp->l_nsyms; i; i--, ls++) { + char *symname; + char tmpsym[SYMNMLEN+1]; + if (!LDR_EXPORT(*ls)) + continue; + if (ls->l_zeroes == 0) + symname = ls->l_offset+lhp->l_stoff+ldbuf; + else { + /* + * The l_name member is not zero terminated, we + * must copy the first SYMNMLEN chars and make + * sure we have a zero byte at the end. + */ + strncpy(tmpsym, ls->l_name, SYMNMLEN); + tmpsym[SYMNMLEN] = '\0'; + symname = tmpsym; + } + ep->name = malloc((unsigned) (strlen(symname) + 1)); + strcpy(ep->name, symname); + ep->addr = (void *)((unsigned long)mp->entry + + ls->l_value - shdata.s_vaddr); + ep++; + } + free(ldbuf); + while(ldclose(ldp) == FAILURE) + ; + return 0; +} + +/* + * Find the main modules entry point. This is used as export pointer + * for loadbind() to be able to resolve references to the main part. + */ +static void * findMain(void) +{ + struct ld_info *lp; + char *buf; + int size = 4*1024; + int i; + void *ret; + + if ((buf = malloc(size)) == NULL) { + errvalid++; + strcpy(errbuf, "findMain: "); + strcat(errbuf, strerror(errno)); + return NULL; + } + while ((i = loadquery(L_GETINFO, buf, size)) == -1 && errno == ENOMEM) { + free(buf); + size += 4*1024; + if ((buf = malloc(size)) == NULL) { + errvalid++; + strcpy(errbuf, "findMain: "); + strcat(errbuf, strerror(errno)); + return NULL; + } + } + if (i == -1) { + errvalid++; + strcpy(errbuf, "findMain: "); + strcat(errbuf, strerror(errno)); + free(buf); + return NULL; + } + /* + * The first entry is the main module. The entry point + * returned by load() does actually point to the data + * segment origin. + */ + lp = (struct ld_info *)buf; + ret = lp->ldinfo_dataorg; + free(buf); + return ret; +} + diff --git a/contrib/tcl/unix/tclLoadAout.c b/contrib/tcl/unix/tclLoadAout.c new file mode 100644 index 0000000..29859a0 --- /dev/null +++ b/contrib/tcl/unix/tclLoadAout.c @@ -0,0 +1,433 @@ +/* + * tclLoadAout.c -- + * + * This procedure provides a version of the TclLoadFile that + * provides pseudo-static linking using version-7 compatible + * a.out files described in either sys/exec.h or sys/a.out.h. + * + * Copyright (c) 1995, by General Electric Company. 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 work was supported in part by the ARPA Manufacturing Automation + * and Design Engineering (MADE) Initiative through ARPA contract + * F33615-94-C-4400. + * + * SCCS: @(#) tclLoadAout.c 1.7 96/02/15 11:58:53 + */ + +#include "tclInt.h" +#include <fcntl.h> +#ifdef HAVE_EXEC_AOUT_H +# include <sys/exec_aout.h> +#endif + +/* + * Some systems describe the a.out header in sys/exec.h, and some in + * a.out.h. + */ + +#ifdef USE_SYS_EXEC_H +#include <sys/exec.h> +#endif +#ifdef USE_A_OUT_H +#include <a.out.h> +#endif +#ifdef USE_SYS_EXEC_AOUT_H +#include <sys/exec_aout.h> +#define a_magic a_midmag +#endif + +/* + * TCL_LOADSHIM is the amount by which to shim the break when loading + */ + +#ifndef TCL_LOADSHIM +#define TCL_LOADSHIM 0x4000L +#endif + +/* + * TCL_LOADALIGN must be a power of 2, and is the alignment to which + * to force the origin of load modules + */ + +#ifndef TCL_LOADALIGN +#define TCL_LOADALIGN 0x4000L +#endif + +/* + * TCL_LOADMAX is the maximum size of a load module, and is used as + * a sanity check when loading + */ + +#ifndef TCL_LOADMAX +#define TCL_LOADMAX 2000000L +#endif + +/* + * Kernel calls that appear to be missing from the system .h files: + */ + +extern char * brk _ANSI_ARGS_((char *)); +extern char * sbrk _ANSI_ARGS_((size_t)); + +/* + * The static variable SymbolTableFile contains the file name where the + * result of the last link was stored. The file is kept because doing so + * allows one load module to use the symbols defined in another. + */ + +static char * SymbolTableFile = NULL; + +/* + * Type of the dictionary function that begins each load module. + */ + +typedef Tcl_PackageInitProc * (* DictFn) _ANSI_ARGS_ ((char * symbol)); + +/* + * Prototypes for procedures referenced only in this file: + */ + +static int FindLibraries _ANSI_ARGS_((Tcl_Interp * interp, char * fileName, + Tcl_DString * buf)); +static void UnlinkSymbolTable _ANSI_ARGS_((void)); + +/* + *---------------------------------------------------------------------- + * + * 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. + * + * + * Bugs: + * This function does not attempt to handle the case where the + * BSS segment is not executable. It will therefore fail on + * Encore Multimax, Pyramid 90x, and similar machines. The + * reason is that the mprotect() kernel call, which would + * otherwise be employed to mark the newly-loaded text segment + * executable, results in a system crash on BSD/386. + * + * In an effort to make it fast, this function eschews the + * technique of linking the load module once, reading its header + * to determine its size, allocating memory for it, and linking + * it again. Instead, it `shims out' memory allocation by + * placing the module TCL_LOADSHIM bytes beyond the break, + * and assuming that any malloc() calls required to run the + * linker will not advance the break beyond that point. If + * the break is advanced beyonnd that point, the load will + * fail with an `inconsistent memory allocation' error. + * It perhaps ought to retry the link, but the failure has + * not been observed in two years of daily use of this function. + *---------------------------------------------------------------------- + */ + +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. */ +{ + char * inputSymbolTable; /* Name of the file containing the + * symbol table from the last link. */ + Tcl_DString linkCommandBuf; /* Command to do the run-time relocation + * of the module.*/ + 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 + * 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; + + /* 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); +#endif + 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_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 defined(__mips) || defined(mips) + status = lseek (relocatedFd, + N_TXTOFF (relocatedHead.ex_f, relocatedHead.ex_o), + SEEK_SET); +#else + status = lseek (relocatedFd, 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; +} + +/* + *------------------------------------------------------------------------ + * + * FindLibraries -- + * + * Find the libraries needed to link a load module at run time. + * + * Results: + * A standard Tcl completion code. If an error occurs, + * an error message is left in interp->result. The -l and -L flags + * are concatenated onto the dynamic string `buf'. + * + *------------------------------------------------------------------------ + */ + +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 */ +{ + FILE * f; /* The load module */ + int c; /* Byte from the load module */ + char * p; + + /* Open the load module */ + + if ((f = fopen (fileName, "rb")) == 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; + } + 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); + } + (void) fclose (f); + + if (c == EOF) { + Tcl_AppendResult (interp, "Library directory in \"", fileName, + "\" ends prematurely.", (char *) NULL); + return TCL_ERROR; + } + + return TCL_OK; +} + +/* + *------------------------------------------------------------------------ + * + * UnlinkSymbolTable -- + * + * Remove the symbol table file from the last dynamic link. + * + * Results: + * None. + * + * Side effects: + * The symbol table file from the last dynamic link is removed. + * This function is called when (a) a new symbol table is present + * because another dynamic link is complete, or (b) the process + * is exiting. + *------------------------------------------------------------------------ + */ + +static void +UnlinkSymbolTable () +{ + (void) unlink (SymbolTableFile); + ckfree (SymbolTableFile); + SymbolTableFile = NULL; +} + +/* + *---------------------------------------------------------------------- + * + * 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; +} diff --git a/contrib/tcl/unix/tclLoadDl.c b/contrib/tcl/unix/tclLoadDl.c new file mode 100644 index 0000000..4f07363 --- /dev/null +++ b/contrib/tcl/unix/tclLoadDl.c @@ -0,0 +1,111 @@ +/* + * tclLoadDl.c -- + * + * This procedure provides a version of the TclLoadFile that + * works with the "dlopen" and "dlsym" library procedures for + * dynamic loading. + * + * 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: @(#) tclLoadDl.c 1.7 96/03/14 09:03:33 + */ + +#include "tclInt.h" +#ifdef NO_DLFCN_H +# include "../compat/dlfcn.h" +#else +# include <dlfcn.h> +#endif + +/* + * In some systems, like SunOS 4.1.3, the RTLD_NOW flag isn't defined + * and this argument to dlopen must always be 1. The RTLD_GLOBAL + * flag is needed on some systems (e.g. SCO and UnixWare) but doesn't + * exist on others; if it doesn't exist, set it to 0 so it has no effect. + */ + +#ifndef RTLD_NOW +# define RTLD_NOW 1 +#endif + +#ifndef RTLD_GLOBAL +# define RTLD_GLOBAL 0 +#endif + +/* + *---------------------------------------------------------------------- + * + * 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; + + handle = dlopen(fileName, RTLD_NOW | RTLD_GLOBAL); + if (handle == NULL) { + Tcl_AppendResult(interp, "couldn't load file \"", fileName, + "\": ", dlerror(), (char *) NULL); + return TCL_ERROR; + } + *proc1Ptr = (Tcl_PackageInitProc *) dlsym(handle, sym1); + *proc2Ptr = (Tcl_PackageInitProc *) dlsym(handle, sym2); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * 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; +} diff --git a/contrib/tcl/unix/tclLoadDl2.c b/contrib/tcl/unix/tclLoadDl2.c new file mode 100644 index 0000000..ad18537 --- /dev/null +++ b/contrib/tcl/unix/tclLoadDl2.c @@ -0,0 +1,113 @@ +/* + * 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 + +/* + *---------------------------------------------------------------------- + * + * 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; +} + +/* + *---------------------------------------------------------------------- + * + * 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; +} diff --git a/contrib/tcl/unix/tclLoadDld.c b/contrib/tcl/unix/tclLoadDld.c new file mode 100644 index 0000000..f2f949e --- /dev/null +++ b/contrib/tcl/unix/tclLoadDld.c @@ -0,0 +1,123 @@ +/* + * tclLoadDld.c -- + * + * This procedure provides a version of the TclLoadFile that + * works with the "dld_link" and "dld_get_func" library procedures + * for dynamic loading. It has been tested on Linux 1.1.95 and + * dld-3.2.7. This file probably isn't needed anymore, since it + * makes more sense to use "dl_open" etc. + * + * 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: @(#) tclLoadDld.c 1.4 96/02/15 11:58:46 + */ + +#include "tclInt.h" +#include "dld.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 + +/* + *---------------------------------------------------------------------- + * + * 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. */ +{ + static int firstTime = 1; + int returnCode; + + /* + * The dld package needs to know the pathname to the tcl binary. + * If that's not know, return an error. + */ + + if (firstTime) { + if (tclExecutableName == NULL) { + interp->result = "don't know name of application binary file, so can't initialize dynamic loader"; + return TCL_ERROR; + } + returnCode = dld_init(tclExecutableName); + if (returnCode != 0) { + Tcl_AppendResult(interp, + "initialization failed for dynamic loader: ", + dld_strerror(returnCode), (char *) NULL); + return TCL_ERROR; + } + firstTime = 0; + } + + if ((returnCode = dld_link(fileName)) != 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); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * 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; +} diff --git a/contrib/tcl/unix/tclLoadNext.c b/contrib/tcl/unix/tclLoadNext.c new file mode 100644 index 0000000..ed4b823 --- /dev/null +++ b/contrib/tcl/unix/tclLoadNext.c @@ -0,0 +1,111 @@ +/* + * tclLoadNext.c -- + * + * This procedure provides a version of the TclLoadFile that + * works with NeXTs rld_* dynamic loading. This file provided + * by Pedja Bogdanovich. + * + * 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: @(#) tclLoadNext.c 1.4 96/02/15 11:58:55 + */ + +#include "tclInt.h" +#include <mach-o/rld.h> +#include <streams/streams.h> + +/* + *---------------------------------------------------------------------- + * + * 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. */ +{ + struct mach_header *header; + char *data; + int len, maxlen; + 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); + return TCL_ERROR; + } + NXCloseMemory(errorStream,NX_FREEBUFFER); + + *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); + } + + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * 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; +} diff --git a/contrib/tcl/unix/tclLoadOSF.c b/contrib/tcl/unix/tclLoadOSF.c new file mode 100644 index 0000000..ca8c8fc --- /dev/null +++ b/contrib/tcl/unix/tclLoadOSF.c @@ -0,0 +1,128 @@ +/* + * tclLoadOSF.c -- + * + * This procedure provides a version of the TclLoadFile that works + * under OSF/1 1.0/1.1/1.2 and related systems, utilizing the old OSF/1 + * /sbin/loader and /usr/include/loader.h. OSF/1 versions from 1.3 and + * on use ELF, rtld, and dlopen()[/usr/include/ldfcn.h]. + * + * This is useful for: + * OSF/1 1.0, 1.1, 1.2 (from OSF) + * includes: MK4 and AD1 (from OSF RI) + * OSF/1 1.3 (from OSF) using ROSE + * HP OSF/1 1.0 ("Acorn") using COFF + * + * This is likely to be useful for: + * Paragon OSF/1 (from Intel) + * HI-OSF/1 (from Hitachi) + * + * This is NOT to be used on: + * Digitial Alpha OSF/1 systems + * OSF/1 1.3 or later (from OSF) using ELF + * includes: MK6, MK7, AD2, AD3 (from OSF RI) + * + * This approach to things was utter @&^#; thankfully, + * OSF/1 eventually supported dlopen(). + * + * John Robert LoVerso <loverso@freebsd.osf.org> + * + * 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: @(#) tclLoadOSF.c 1.2 96/02/15 11:58:40 + */ + +#include "tclInt.h" +#include <sys/types.h> +#include <loader.h> + +/* + *---------------------------------------------------------------------- + * + * 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. */ +{ + ldr_module_t lm; + char *pkg; + + lm = (Tcl_PackageInitProc *) load(fileName, LDR_NOFLAGS); + if (lm == LDR_NULL_MODULE) { + Tcl_AppendResult(interp, "couldn't load file \"", fileName, + "\": ", Tcl_PosixError (interp), (char *) NULL); + return TCL_ERROR; + } + + /* + * My convention is to use a [OSF loader] package name the same as shlib, + * since the idiots never implemented ldr_lookup() and it is otherwise + * impossible to get a package name given a module. + * + * I build loadable modules with a makefile rule like + * ld ... -export $@: -o $@ $(OBJS) + */ + if ((pkg = strrchr(fileName, '/')) == NULL) + pkg = fileName; + else + pkg++; + *proc1Ptr = ldr_lookup_package(pkg, sym1); + *proc2Ptr = ldr_lookup_package(pkg, sym2); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * 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; +} diff --git a/contrib/tcl/unix/tclLoadShl.c b/contrib/tcl/unix/tclLoadShl.c new file mode 100644 index 0000000..2f290ab --- /dev/null +++ b/contrib/tcl/unix/tclLoadShl.c @@ -0,0 +1,129 @@ +/* + * tclLoadShl.c -- + * + * This procedure provides a version of the TclLoadFile that works + * with the "shl_load" and "shl_findsym" library procedures for + * dynamic loading (e.g. for HP machines). + * + * Copyright (c) 1995-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: @(#) tclLoadShl.c 1.5 96/03/15 15:01:44 + */ + +#include <dl.h> + +/* + * On some HP machines, dl.h defines EXTERN; remove that definition. + */ + +#ifdef EXTERN +# undef EXTERN +#endif + +#include "tcl.h" + +/* + *---------------------------------------------------------------------- + * + * 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. */ +{ + shl_t handle; + Tcl_DString newName; + + handle = shl_load(fileName, BIND_IMMEDIATE, 0L); + if (handle == NULL) { + Tcl_AppendResult(interp, "couldn't load file \"", fileName, + "\": ", Tcl_PosixError(interp), (char *) NULL); + return TCL_ERROR; + } + + /* + * 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) + != 0) { + Tcl_DStringInit(&newName); + Tcl_DStringAppend(&newName, "_", 1); + Tcl_DStringAppend(&newName, sym1, -1); + if (shl_findsym(&handle, Tcl_DStringValue(&newName), + (short) TYPE_PROCEDURE, (void *) proc1Ptr) != 0) { + *proc1Ptr = 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; +} + +/* + *---------------------------------------------------------------------- + * + * 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; +} diff --git a/contrib/tcl/unix/tclMtherr.c b/contrib/tcl/unix/tclMtherr.c new file mode 100644 index 0000000..2f56e00 --- /dev/null +++ b/contrib/tcl/unix/tclMtherr.c @@ -0,0 +1,86 @@ +/* + * 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. + * + * SCCS: @(#) tclMtherr.c 1.11 96/02/15 11:58:36 + */ + +#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 tclExpr.c. */ +#define EDOM 33 +#define ERANGE 34 +#endif + +/* + * The following variable is secretly shared with Tcl so we can + * tell if expression evaluation is in progress. If not, matherr + * just emulates the default behavior, which includes printing + * a message. + */ + +extern int tcl_MathInProgress; + +/* + * 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 + +/* + *---------------------------------------------------------------------- + * + * 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 (!tcl_MathInProgress) { + return 0; + } + if ((xPtr->type == DOMAIN) || (xPtr->type == SING)) { + errno = EDOM; + } else { + errno = ERANGE; + } + return 1; +} diff --git a/contrib/tcl/unix/tclUnixChan.c b/contrib/tcl/unix/tclUnixChan.c new file mode 100644 index 0000000..aa16fe3 --- /dev/null +++ b/contrib/tcl/unix/tclUnixChan.c @@ -0,0 +1,1829 @@ +/* + * tclUnixChan.c + * + * Common channel driver for Unix channels based on files, command + * pipes and TCP sockets. + * + * Copyright (c) 1995-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: @(#) tclUnixChan.c 1.161 96/04/18 08:28:54 + */ + +#include "tclInt.h" /* Internal definitions for Tcl. */ +#include "tclPort.h" /* Portability features for Tcl. */ + +/* + * This structure describes per-instance state of a pipe based channel. + */ + +typedef struct PipeState { + Tcl_File readFile; /* Output from pipe. */ + Tcl_File writeFile; /* Input to pipe. */ + Tcl_File errorFile; /* Error output from pipe. */ + int numPids; /* How many processes are attached to this pipe? */ + int *pidPtr; /* The process IDs themselves. Allocated by + * the creator of the pipe. */ +} PipeState; + +/* + * This structure describes per-instance state of a tcp based channel. + */ + +typedef struct TcpState { + int flags; /* ORed combination of the + * bitfields defined below. */ + Tcl_File sock; /* The socket itself. */ + Tcl_TcpAcceptProc *acceptProc; /* Proc to call on accept. */ + ClientData acceptProcData; /* The data for the accept proc. */ +} TcpState; + +/* + * These bits may be ORed together into the "flags" field of a TcpState + * structure. + */ + +#define TCP_ASYNC_SOCKET (1<<0) /* Asynchronous socket. */ +#define TCP_ASYNC_CONNECT (1<<1) /* Async connect in progress. */ + +/* + * The following defines how much buffer space the kernel should maintain + * for a socket. + */ + +#define SOCKET_BUFSIZE 4096 + +/* + * Static routines for this file: + */ + +static int CommonBlockModeProc _ANSI_ARGS_(( + ClientData instanceData, Tcl_File inFile, + Tcl_File outFile, int mode)); +static TcpState * CreateSocket _ANSI_ARGS_((Tcl_Interp *interp, + int port, char *host, int server, + char *myaddr, int myport, int async)); +static int CreateSocketAddress _ANSI_ARGS_( + (struct sockaddr_in *sockaddrPtr, + char *host, int port)); +static int FileCloseProc _ANSI_ARGS_((ClientData instanceData, + Tcl_Interp *interp, Tcl_File inFile, + Tcl_File outFile)); +static int FilePipeInputProc _ANSI_ARGS_((ClientData instanceData, + Tcl_File inFile, char *buf, int toRead, + int *errorCode)); +static int FilePipeOutputProc _ANSI_ARGS_(( + ClientData instanceData, Tcl_File outFile, + char *buf, int toWrite, int *errorCode)); +static int FileSeekProc _ANSI_ARGS_((ClientData instanceData, + Tcl_File inFile, Tcl_File outFile, long offset, + int mode, int *errorCode)); +static int PipeCloseProc _ANSI_ARGS_((ClientData instanceData, + Tcl_Interp *interp, Tcl_File inFile, + Tcl_File outFile)); +static void TcpAccept _ANSI_ARGS_((ClientData data, int mask)); +static int TcpBlockModeProc _ANSI_ARGS_((ClientData data, + Tcl_File inFile, Tcl_File outFile, int mode)); +static int TcpCloseProc _ANSI_ARGS_((ClientData instanceData, + Tcl_Interp *interp, Tcl_File inFile, + Tcl_File outFile)); +static int TcpGetOptionProc _ANSI_ARGS_((ClientData instanceData, + char *optionName, Tcl_DString *dsPtr)); +static int TcpInputProc _ANSI_ARGS_((ClientData instanceData, + Tcl_File infile, char *buf, int toRead, + int *errorCode)); +static int TcpOutputProc _ANSI_ARGS_((ClientData instanceData, + Tcl_File outFile, char *buf, int toWrite, + int *errorCode)); +static int WaitForConnect _ANSI_ARGS_((TcpState *statePtr, + Tcl_File fileToWaitFor, int *errorCodePtr)); + +/* + * This structure describes the channel type structure for file based IO: + */ + +static Tcl_ChannelType fileChannelType = { + "file", /* Type name. */ + CommonBlockModeProc, /* Set blocking/nonblocking mode.*/ + FileCloseProc, /* Close proc. */ + FilePipeInputProc, /* Input proc. */ + FilePipeOutputProc, /* Output proc. */ + FileSeekProc, /* Seek proc. */ + NULL, /* Set option proc. */ + NULL, /* Get option proc. */ +}; + +/* + * This structure describes the channel type structure for command pipe + * based IO: + */ + +static Tcl_ChannelType pipeChannelType = { + "pipe", /* Type name. */ + CommonBlockModeProc, /* Set blocking/nonblocking mode.*/ + PipeCloseProc, /* Close proc. */ + FilePipeInputProc, /* Input proc. */ + FilePipeOutputProc, /* Output proc. */ + NULL, /* Seek proc. */ + NULL, /* Set option proc. */ + NULL, /* Get option proc. */ +}; + +/* + * This structure describes the channel type structure for TCP socket + * based IO: + */ + +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. */ +}; + +/* + *---------------------------------------------------------------------- + * + * CommonBlockModeProc -- + * + * Helper procedure to set blocking and nonblocking modes on a + * channel. Invoked either by generic IO level code or by other + * channel drivers after doing channel-type-specific inialization. + * + * Results: + * 0 if successful, errno when failed. + * + * Side effects: + * Sets the device into blocking or non-blocking mode. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +static int +CommonBlockModeProc(instanceData, inFile, outFile, mode) + ClientData instanceData; /* Unused. */ + Tcl_File inFile, outFile; /* Input, output files for channel. */ + int mode; /* The mode to set. Can be one of + * TCL_MODE_BLOCKING or + * TCL_MODE_NONBLOCKING. */ +{ + int curStatus; + int fd; + + if (inFile != NULL) { + fd = (int) Tcl_GetFileInfo(inFile, NULL); + curStatus = fcntl(fd, F_GETFL); + if (mode == TCL_MODE_BLOCKING) { + curStatus &= (~(O_NONBLOCK)); + } else { + curStatus |= O_NONBLOCK; + } + if (fcntl(fd, F_SETFL, curStatus) < 0) { + return errno; + } + curStatus = fcntl(fd, F_GETFL); + } + if (outFile != NULL) { + fd = (int) Tcl_GetFileInfo(outFile, NULL); + curStatus = fcntl(fd, F_GETFL); + if (mode == TCL_MODE_BLOCKING) { + curStatus &= (~(O_NONBLOCK)); + } else { + curStatus |= O_NONBLOCK; + } + if (fcntl(fd, F_SETFL, curStatus) < 0) { + return errno; + } + } + + return 0; +} + +/* + *---------------------------------------------------------------------- + * + * FilePipeInputProc -- + * + * This procedure is invoked from the generic IO level to read + * input from a file or command pipeline channel. + * + * Results: + * The number of bytes read is returned or -1 on error. An output + * argument contains a POSIX error code if an error occurs, or zero. + * + * Side effects: + * Reads input from the input device of the channel. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +static int +FilePipeInputProc(instanceData, inFile, buf, toRead, errorCodePtr) + ClientData instanceData; /* Unused. */ + Tcl_File inFile; /* Input device for channel. */ + char *buf; /* Where to store data read. */ + int toRead; /* How much space is available + * in the buffer? */ + int *errorCodePtr; /* Where to store error code. */ +{ + int fd; /* The OS handle for reading. */ + int bytesRead; /* How many bytes were actually + * read from the input device? */ + + *errorCodePtr = 0; + fd = (int) Tcl_GetFileInfo(inFile, NULL); + + /* + * Assume there is always enough input available. This will block + * 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. + */ + + bytesRead = read(fd, buf, (size_t) toRead); + if (bytesRead > -1) { + return bytesRead; + } + *errorCodePtr = errno; + return -1; +} + +/* + *---------------------------------------------------------------------- + * + * FilePipeOutputProc-- + * + * This procedure is invoked from the generic IO level to write + * output to a file or command pipeline 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. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +static int +FilePipeOutputProc(instanceData, outFile, buf, toWrite, errorCodePtr) + ClientData instanceData; /* Unused. */ + Tcl_File outFile; /* Output device for channel. */ + char *buf; /* The data buffer. */ + int toWrite; /* How many bytes to write? */ + int *errorCodePtr; /* Where to store error code. */ +{ + int written; + int fd; + + *errorCodePtr = 0; + fd = (int) Tcl_GetFileInfo(outFile, NULL); + written = write(fd, buf, (size_t) toWrite); + if (written > -1) { + return written; + } + *errorCodePtr = errno; + return -1; +} + +/* + *---------------------------------------------------------------------- + * + * FileCloseProc -- + * + * This procedure is called from the generic IO level to perform + * channel-type-specific cleanup when a file based channel is closed. + * + * Results: + * 0 if successful, errno if failed. + * + * Side effects: + * Closes the device of the channel. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +static int +FileCloseProc(instanceData, interp, inFile, outFile) + ClientData instanceData; /* Unused. */ + Tcl_Interp *interp; /* For error reporting - unused. */ + Tcl_File inFile; /* Input file to close. */ + Tcl_File outFile; /* Output file to close. */ +{ + int fd, errorCode = 0; + + if (inFile != NULL) { + + /* + * Check for read/write file so we only close it once. + */ + + if (inFile == outFile) { + outFile = NULL; + } + fd = (int) Tcl_GetFileInfo(inFile, NULL); + Tcl_FreeFile(inFile); + + if (close(fd) < 0) { + errorCode = errno; + } + } + + if (outFile != NULL) { + fd = (int) Tcl_GetFileInfo(outFile, NULL); + Tcl_FreeFile(outFile); + if ((close(fd) < 0) && (errorCode == 0)) { + errorCode = errno; + } + } + return errorCode; +} + +/* + *---------------------------------------------------------------------- + * + * FileSeekProc -- + * + * This procedure is called by the generic IO level to move the + * access point in a file based channel. + * + * 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. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +static int +FileSeekProc(instanceData, inFile, outFile, offset, mode, errorCodePtr) + ClientData instanceData; /* Unused. */ + Tcl_File inFile, outFile; /* Input and output + * files for channel. */ + 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. */ +{ + int newLoc; + int fd; + + *errorCodePtr = 0; + if (inFile != (Tcl_File) NULL) { + fd = (int) Tcl_GetFileInfo(inFile, NULL); + } else if (outFile != (Tcl_File) NULL) { + fd = (int) Tcl_GetFileInfo(outFile, NULL); + } else { + *errorCodePtr = EFAULT; + return -1; + } + newLoc = lseek(fd, offset, mode); + if (newLoc > -1) { + return newLoc; + } + *errorCodePtr = errno; + return -1; +} + +/* + *---------------------------------------------------------------------- + * + * TclGetAndDetachPids -- + * + * This procedure is invoked in the generic implementation of a + * background "exec" (An exec when invoked with a terminating "&") + * to store a list of the PIDs for processes in a command pipeline + * in interp->result and to detach the processes. + * + * Results: + * None. + * + * Side effects: + * Modifies interp->result. Detaches processes. + * + *---------------------------------------------------------------------- + */ + +void +TclGetAndDetachPids(interp, chan) + Tcl_Interp *interp; + Tcl_Channel chan; +{ + PipeState *pipePtr; + Tcl_ChannelType *chanTypePtr; + int i; + char buf[20]; + + /* + * Punt if the channel is not a command channel. + */ + + chanTypePtr = Tcl_GetChannelType(chan); + if (chanTypePtr != &pipeChannelType) { + return; + } + + pipePtr = (PipeState *) Tcl_GetChannelInstanceData(chan); + for (i = 0; i < pipePtr->numPids; i++) { + sprintf(buf, "%d", pipePtr->pidPtr[i]); + Tcl_AppendElement(interp, buf); + Tcl_DetachPids(1, &(pipePtr->pidPtr[i])); + } + if (pipePtr->numPids > 0) { + ckfree((char *) pipePtr->pidPtr); + pipePtr->numPids = 0; + } +} + +/* + *---------------------------------------------------------------------- + * + * PipeCloseProc -- + * + * This procedure is invoked by the generic IO level to perform + * channel-type-specific cleanup when a command pipeline channel + * is closed. + * + * Results: + * 0 on success, errno otherwise. + * + * Side effects: + * Closes the command pipeline channel. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +static int +PipeCloseProc(instanceData, interp, inFile, outFile) + ClientData instanceData; /* The pipe to close. */ + Tcl_Interp *interp; /* For error reporting. */ + Tcl_File inFile, outFile; /* Unused. */ +{ + PipeState *pipePtr; + Tcl_Channel errChan; + int fd, errorCode, result; + + errorCode = 0; + pipePtr = (PipeState *) instanceData; + if (pipePtr->readFile != NULL) { + fd = (int) Tcl_GetFileInfo(pipePtr->readFile, NULL); + Tcl_FreeFile(pipePtr->readFile); + if (close(fd) < 0) { + errorCode = errno; + } + } + if (pipePtr->writeFile != NULL) { + fd = (int) Tcl_GetFileInfo(pipePtr->writeFile, NULL); + Tcl_FreeFile(pipePtr->writeFile); + if ((close(fd) < 0) && (errorCode == 0)) { + errorCode = errno; + } + } + + /* + * Wrap the error file into a channel and give it to the cleanup + * routine. + */ + + if (pipePtr->errorFile != NULL) { + errChan = Tcl_CreateChannel(&fileChannelType, "pipeError", + pipePtr->errorFile, NULL, NULL); + } else { + errChan = NULL; + } + result = TclCleanupChildren(interp, pipePtr->numPids, pipePtr->pidPtr, + errChan); + if (pipePtr->numPids != 0) { + ckfree((char *) pipePtr->pidPtr); + } + ckfree((char *) pipePtr); + if (errorCode == 0) { + return result; + } + return errorCode; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_OpenFileChannel -- + * + * Open an file based channel on Unix systems. + * + * Results: + * The new channel or NULL. If NULL, the output argument + * errorCodePtr is set to a POSIX error and an error message is + * left in interp->result if interp is not NULL. + * + * Side effects: + * May open the channel and may cause creation of a file on the + * file system. + * + *---------------------------------------------------------------------- + */ + +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 fd, seekFlag, mode, channelPermissions; + Tcl_File file; + Tcl_Channel chan; + char *nativeName, channelName[20]; + Tcl_DString buffer; + + mode = TclGetOpenMode(interp, modeString, &seekFlag); + if (mode == -1) { + return NULL; + } + switch (mode & (O_RDONLY | O_WRONLY | O_RDWR)) { + case O_RDONLY: + channelPermissions = TCL_READABLE; + break; + case O_WRONLY: + channelPermissions = TCL_WRITABLE; + break; + case O_RDWR: + channelPermissions = (TCL_READABLE | TCL_WRITABLE); + break; + default: + /* + * This may occurr if modeString was "", for example. + */ + panic("Tcl_OpenFileChannel: invalid mode value"); + return NULL; + } + + nativeName = Tcl_TranslateFileName(interp, fileName, &buffer); + if (nativeName == NULL) { + return NULL; + } + fd = open(nativeName, mode, permissions); + + /* + * If nativeName is not NULL, the buffer is valid and we must free + * the storage. + */ + + Tcl_DStringFree(&buffer); + + if (fd < 0) { + if (interp != (Tcl_Interp *) NULL) { + Tcl_AppendResult(interp, "couldn't open \"", fileName, "\": ", + Tcl_PosixError(interp), (char *) NULL); + } + return NULL; + } + + sprintf(channelName, "file%d", fd); + file = Tcl_GetFile((ClientData) fd, TCL_UNIX_FD); + + chan = Tcl_CreateChannel(&fileChannelType, channelName, + (channelPermissions & TCL_READABLE) ? file : NULL, + (channelPermissions & TCL_WRITABLE) ? file : NULL, + (ClientData) NULL); + + /* + * The channel may not be open now, for example if we tried to + * open a file with permissions that cannot be satisfied. + */ + + if (chan == (Tcl_Channel) NULL) { + if (interp != (Tcl_Interp *) NULL) { + Tcl_AppendResult(interp, "couldn't create channel \"", + channelName, "\": ", Tcl_PosixError(interp), + (char *) NULL); + } + Tcl_FreeFile(file); + close(fd); + return NULL; + } + + if (seekFlag) { + if (Tcl_Seek(chan, 0, SEEK_END) < 0) { + if (interp != (Tcl_Interp *) NULL) { + Tcl_AppendResult(interp, "couldn't seek to end of file on \"", + channelName, "\": ", Tcl_PosixError(interp), + (char *) NULL); + } + Tcl_Close(NULL, chan); + return NULL; + } + } + return chan; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_MakeFileChannel -- + * + * Makes a Tcl_Channel from an existing OS level file handle. + * + * Results: + * The Tcl_Channel created around the preexisting OS level file handle. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +Tcl_Channel +Tcl_MakeFileChannel(inFd, outFd, mode) + ClientData inFd; /* OS level handle used for input. */ + ClientData outFd; /* OS level handle used for output. */ + int mode; /* ORed combination of TCL_READABLE and + * TCL_WRITABLE to indicate whether inFile + * and/or outFile are valid. */ +{ + Tcl_File inFile, outFile; + char channelName[20]; + + if (mode == 0) { + return (Tcl_Channel) NULL; + } + + inFile = (Tcl_File) NULL; + outFile = (Tcl_File) NULL; + + if (mode & TCL_READABLE) { + sprintf(channelName, "file%d", (int) inFd); + inFile = Tcl_GetFile(inFd, TCL_UNIX_FD); + } + + if (mode & TCL_WRITABLE) { + sprintf(channelName, "file%d", (int) outFd); + outFile = Tcl_GetFile(outFd, TCL_UNIX_FD); + } + + return Tcl_CreateChannel(&fileChannelType, channelName, inFile, outFile, + (ClientData) NULL); +} + +/* + *---------------------------------------------------------------------- + * + * TclCreateCommandChannel -- + * + * This function is called by the generic IO level to perform + * the platform specific channel initialization for a command + * channel. + * + * Results: + * Returns a new channel or NULL on failure. + * + * Side effects: + * Allocates a new channel. + * + *---------------------------------------------------------------------- + */ + +Tcl_Channel +TclCreateCommandChannel(readFile, writeFile, errorFile, numPids, pidPtr) + Tcl_File readFile; /* If non-null, gives the file for reading. */ + Tcl_File writeFile; /* If non-null, gives the file for writing. */ + Tcl_File errorFile; /* If non-null, gives the file where errors + * can be read. */ + int numPids; /* The number of pids in the pid array. */ + int *pidPtr; /* An array of process identifiers. + * Allocated by the caller, freed when + * the channel is closed or the processes + * are detached (in a background exec). */ +{ + Tcl_Channel channel; + char channelName[20]; + int channelId; + PipeState *statePtr = (PipeState *) ckalloc((unsigned) sizeof(PipeState)); + + statePtr->readFile = readFile; + statePtr->writeFile = writeFile; + statePtr->errorFile = errorFile; + statePtr->numPids = numPids; + statePtr->pidPtr = pidPtr; + + /* + * Use one of the fds associated with the channel as the + * channel id. + */ + + if (readFile) { + channelId = (int) Tcl_GetFileInfo(readFile, NULL); + } else if (writeFile) { + channelId = (int) Tcl_GetFileInfo(writeFile, NULL); + } else if (errorFile) { + channelId = (int) Tcl_GetFileInfo(errorFile, NULL); + } else { + channelId = 0; + } + + /* + * For backward compatibility with previous versions of Tcl, we + * use "file%d" as the base name for pipes even though it would + * be more natural to use "pipe%d". + */ + + sprintf(channelName, "file%d", channelId); + channel = Tcl_CreateChannel(&pipeChannelType, channelName, readFile, + writeFile, (ClientData) statePtr); + + if (channel == NULL) { + + /* + * pidPtr will be freed by the caller if the return value is NULL. + */ + + ckfree((char *)statePtr); + } + return channel; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_PidCmd -- + * + * This procedure is invoked to process the "pid" Tcl command. + * See the user documentation for details on what it does. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * See the user documentation. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +int +Tcl_PidCmd(dummy, interp, argc, argv) + ClientData dummy; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ + Tcl_Channel chan; /* The channel to get pids for. */ + Tcl_ChannelType *chanTypePtr; /* The type of that channel. */ + PipeState *pipePtr; /* The pipe state. */ + int i; /* Loops over PIDs attached to the + * pipe. */ + char string[50]; /* Temp buffer for string rep. of + * PIDs attached to the pipe. */ + + if (argc > 2) { + Tcl_AppendResult(interp, "wrong # args: should be \"", + argv[0], " ?channelId?\"", (char *) NULL); + return TCL_ERROR; + } + if (argc == 1) { + sprintf(interp->result, "%ld", (long) getpid()); + } else { + chan = Tcl_GetChannel(interp, argv[1], NULL); + if (chan == (Tcl_Channel) NULL) { + return TCL_ERROR; + } + chanTypePtr = Tcl_GetChannelType(chan); + if (chanTypePtr != &pipeChannelType) { + return TCL_OK; + } + pipePtr = (PipeState *) Tcl_GetChannelInstanceData(chan); + for (i = 0; i < pipePtr->numPids; i++) { + sprintf(string, "%d", pipePtr->pidPtr[i]); + Tcl_AppendElement(interp, string); + } + } + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * TcpBlockModeProc -- + * + * This procedure is invoked by the generic IO level to set blocking + * and nonblocking mode on a TCP socket based channel. + * + * Results: + * 0 if successful, errno when failed. + * + * Side effects: + * Sets the device into blocking or nonblocking mode. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +static int +TcpBlockModeProc(instanceData, inFile, outFile, mode) + ClientData instanceData; /* Socket state. */ + Tcl_File inFile, outFile; /* Input, output files for channel. */ + int mode; /* The mode to set. Can be one of + * TCL_MODE_BLOCKING or + * TCL_MODE_NONBLOCKING. */ +{ + TcpState *statePtr; + + statePtr = (TcpState *) instanceData; + if (mode == TCL_MODE_BLOCKING) { + statePtr->flags &= (~(TCP_ASYNC_SOCKET)); + } else { + statePtr->flags |= TCP_ASYNC_SOCKET; + } + return CommonBlockModeProc(instanceData, inFile, outFile, mode); +} + +/* + *---------------------------------------------------------------------- + * + * WaitForConnect -- + * + * Waits for a connection on an asynchronously opened socket to + * be completed. + * + * Results: + * None. + * + * Side effects: + * The socket is connected after this function returns. + * + *---------------------------------------------------------------------- + */ + +static int +WaitForConnect(statePtr, fileToWaitFor, errorCodePtr) + TcpState *statePtr; /* State of the socket. */ + Tcl_File fileToWaitFor; /* File to wait on to become connected. */ + int *errorCodePtr; /* Where to store errors? */ +{ + int sock; /* The socket itself. */ + int timeOut; /* How long to wait. */ + int state; /* Of calling TclWaitForFile. */ + int flags; /* fcntl flags for the socket. */ + + /* + * 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 = TclWaitForFile(fileToWaitFor, TCL_WRITABLE | TCL_EXCEPTION, + timeOut); + if (!(statePtr->flags & TCP_ASYNC_SOCKET)) { + sock = (int) Tcl_GetFileInfo(statePtr->sock, NULL); + flags = fcntl(sock, F_GETFL); + flags &= (~(O_NONBLOCK)); + (void) fcntl(sock, F_SETFL, flags); + } + 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; +} + +/* + *---------------------------------------------------------------------- + * + * TcpInputProc -- + * + * This procedure is invoked by the generic IO level to read input + * from a TCP socket based channel. + * + * NOTE: We cannot share code with FilePipeInputProc because here + * we must use recv to obtain the input from the channel, not read. + * + * Results: + * The number of bytes read is returned or -1 on error. An output + * argument contains the POSIX error code on error, or zero if no + * error occurred. + * + * Side effects: + * Reads input from the input device of the channel. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +static int +TcpInputProc(instanceData, inFile, buf, bufSize, errorCodePtr) + ClientData instanceData; /* Socket state. */ + Tcl_File inFile; /* Input device for channel. */ + char *buf; /* Where to store data read. */ + int bufSize; /* How much space is available + * in the buffer? */ + int *errorCodePtr; /* Where to store error code. */ +{ + TcpState *statePtr; /* The state of the socket. */ + int sock; /* The OS handle. */ + int bytesRead; /* How many bytes were read? */ + int state; /* Of waiting for connection. */ + + *errorCodePtr = 0; + sock = (int) Tcl_GetFileInfo(inFile, NULL); + statePtr = (TcpState *) instanceData; + + state = WaitForConnect(statePtr, inFile, errorCodePtr); + if (state != 0) { + return -1; + } + bytesRead = recv(sock, buf, bufSize, 0); + if (bytesRead > -1) { + return bytesRead; + } + if (errno == ECONNRESET) { + + /* + * Turn ECONNRESET into a soft EOF condition. + */ + + return 0; + } + *errorCodePtr = errno; + return -1; +} + +/* + *---------------------------------------------------------------------- + * + * TcpOutputProc -- + * + * This procedure is invoked by the generic IO level to write output + * to a TCP socket based channel. + * + * NOTE: We cannot share code with FilePipeOutputProc because here + * we must use send, not write, to get reliable error reporting. + * + * Results: + * The number of bytes written is returned. An output argument is + * set to a POSIX error code if an error occurred, or zero. + * + * Side effects: + * Writes output on the output device of the channel. + * + *---------------------------------------------------------------------- + */ + +static int +TcpOutputProc(instanceData, outFile, buf, toWrite, errorCodePtr) + ClientData instanceData; /* Socket state. */ + Tcl_File outFile; /* Output device for channel. */ + char *buf; /* The data buffer. */ + int toWrite; /* How many bytes to write? */ + int *errorCodePtr; /* Where to store error code. */ +{ + TcpState *statePtr; + int written; + int sock; /* OS level socket. */ + int state; /* Of waiting for connection. */ + + *errorCodePtr = 0; + sock = (int) Tcl_GetFileInfo(outFile, NULL); + statePtr = (TcpState *) instanceData; + state = WaitForConnect(statePtr, outFile, errorCodePtr); + if (state != 0) { + return -1; + } + written = send(sock, buf, toWrite, 0); + if (written > -1) { + return written; + } + *errorCodePtr = errno; + return -1; +} + +/* + *---------------------------------------------------------------------- + * + * TcpCloseProc -- + * + * This procedure is invoked by the generic IO level to perform + * channel-type-specific cleanup when a TCP socket based channel + * is closed. + * + * Results: + * 0 if successful, the value of errno if failed. + * + * Side effects: + * Closes the socket of the channel. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +static int +TcpCloseProc(instanceData, interp, inFile, outFile) + ClientData instanceData; /* The socket to close. */ + Tcl_Interp *interp; /* For error reporting - unused. */ + Tcl_File inFile, outFile; /* Unused. */ +{ + TcpState *statePtr; + Tcl_File sockFile; + int sock; + int errorCode = 0; + + statePtr = (TcpState *) instanceData; + sockFile = statePtr->sock; + sock = (int) Tcl_GetFileInfo(sockFile, NULL); + + /* + * Delete a file handler that may be active for this socket if this + * is a server socket - the file handler was created automatically + * by Tcl as part of the mechanism to accept new client connections. + * Channel handlers are already deleted in the generic IO channel + * closing code that called this function, so we do not have to + * delete them here. + */ + + Tcl_DeleteFileHandler(sockFile); + + ckfree((char *) statePtr); + + /* + * We assume that inFile==outFile==sockFile and so + * we only clean up sockFile. + */ + + Tcl_FreeFile(sockFile); + + if (close(sock) < 0) { + errorCode = errno; + } + + return errorCode; +} + +/* + *---------------------------------------------------------------------- + * + * TcpGetOptionProc -- + * + * Computes an option value for a TCP socket based channel, or a + * list of all options and their values. + * + * Note: This code is based on code contributed by John Haxby. + * + * Results: + * A standard Tcl result. The value of the specified option or a + * list of all options and their values is returned in the + * supplied DString. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static int +TcpGetOptionProc(instanceData, optionName, dsPtr) + ClientData instanceData; /* Socket state. */ + 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 + * value; initialized by caller. */ +{ + TcpState *statePtr; + struct sockaddr_in sockname; + struct sockaddr_in peername; + struct hostent *hostEntPtr; + int sock; + int size = sizeof(struct sockaddr_in); + size_t len = 0; + char buf[128]; + + statePtr = (TcpState *) instanceData; + sock = (int) Tcl_GetFileInfo(statePtr->sock, NULL); + if (optionName != (char *) NULL) { + len = strlen(optionName); + } + + if ((len == 0) || + ((len > 1) && (optionName[1] == 'p') && + (strncmp(optionName, "-peername", len) == 0))) { + if (getpeername(sock, (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((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, inet_ntoa(peername.sin_addr)); + } + sprintf(buf, "%d", ntohs(peername.sin_port)); + Tcl_DStringAppendElement(dsPtr, buf); + if (len == 0) { + Tcl_DStringEndSublist(dsPtr); + } else { + return TCL_OK; + } + } + } + + if ((len == 0) || + ((len > 1) && (optionName[1] == 's') && + (strncmp(optionName, "-sockname", len) == 0))) { + if (getsockname(sock, (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((char *) &(sockname.sin_addr), + sizeof(peername.sin_addr), AF_INET); + if (hostEntPtr != (struct hostent *) NULL) { + Tcl_DStringAppendElement(dsPtr, hostEntPtr->h_name); + } else { + Tcl_DStringAppendElement(dsPtr, inet_ntoa(sockname.sin_addr)); + } + sprintf(buf, "%d", ntohs(sockname.sin_port)); + Tcl_DStringAppendElement(dsPtr, buf); + if (len == 0) { + Tcl_DStringEndSublist(dsPtr); + } else { + return TCL_OK; + } + } + } + + if (len > 0) { + Tcl_SetErrno(EINVAL); + return TCL_ERROR; + } + + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * CreateSocket -- + * + * This function opens a new socket in client or server mode + * and initializes the TcpState structure. + * + * Results: + * Returns a new TcpState, or NULL with an error in interp->result, + * if interp is not NULL. + * + * Side effects: + * Opens a socket. + * + *---------------------------------------------------------------------- + */ + +static TcpState * +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. + * 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 */ + 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. */ +{ + int status, sock, asyncConnect, curState, origState; + struct sockaddr_in sockaddr; /* socket address */ + struct sockaddr_in mysockaddr; /* Socket address for client */ + TcpState *statePtr; + + sock = -1; + origState = 0; + if (! CreateSocketAddress(&sockaddr, host, port)) { + goto addressError; + } + if ((myaddr != NULL || myport != 0) && + ! CreateSocketAddress(&mysockaddr, myaddr, myport)) { + goto addressError; + } + + sock = socket(AF_INET, SOCK_STREAM, 0); + if (sock < 0) { + goto addressError; + } + + /* + * Set kernel space buffering + */ + + TclSockMinimumBuffers(sock, SOCKET_BUFSIZE); + + 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)); + if (status != -1) { + status = listen(sock, 5); + } + } else { + if (myaddr != NULL || myport != 0) { + status = 1; + (void) setsockopt(sock, SOL_SOCKET, SO_REUSEADDR, (char *) &status, + sizeof(status)); + status = bind(sock, (struct sockaddr *) &mysockaddr, + sizeof(struct sockaddr)); + if (status < 0) { + goto bindError; + } + } + + /* + * Attempt to connect. The connect may fail at present with an + * EINPROGRESS but at a later time it will complete. The caller + * will set up a file handler on the socket if she is interested in + * being informed when the connect completes. + */ + + if (async) { + origState = fcntl(sock, F_GETFL); + curState = origState | O_NONBLOCK; + status = fcntl(sock, F_SETFL, curState); + } else { + status = 0; + } + if (status > -1) { + status = connect(sock, (struct sockaddr *) &sockaddr, + sizeof(sockaddr)); + if (status < 0) { + if (errno == EINPROGRESS) { + asyncConnect = 1; + status = 0; + } + } + } + } + +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; + } + + /* + * Allocate a new TcpState for this socket. + */ + + statePtr = (TcpState *) ckalloc((unsigned) sizeof(TcpState)); + statePtr->flags = 0; + if (asyncConnect) { + statePtr->flags = TCP_ASYNC_CONNECT; + } + statePtr->sock = Tcl_GetFile((ClientData) sock, TCL_UNIX_FD); + + return statePtr; + +addressError: + if (sock != -1) { + close(sock); + } + if (interp != NULL) { + Tcl_AppendResult(interp, "couldn't open socket: ", + Tcl_PosixError(interp), (char *) NULL); + } + return NULL; +} + +/* + *---------------------------------------------------------------------- + * + * CreateSocketAddress -- + * + * This function initializes a sockaddr structure for a host and port. + * + * Results: + * 1 if the host was valid, 0 if the host could not be converted to + * an IP address. + * + * Side effects: + * Fills in the *sockaddrPtr structure. + * + *---------------------------------------------------------------------- + */ + +static int +CreateSocketAddress(sockaddrPtr, host, port) + struct sockaddr_in *sockaddrPtr; /* Socket address */ + char *host; /* Host. NULL implies INADDR_ANY */ + int port; /* Port number */ +{ + struct hostent *hostent; /* Host database entry */ + struct in_addr addr; /* For 64/32 bit madness */ + + (void) memset((VOID *) sockaddrPtr, '\0', sizeof(struct sockaddr_in)); + sockaddrPtr->sin_family = AF_INET; + sockaddrPtr->sin_port = htons((unsigned short) (port & 0xFFFF)); + if (host == NULL) { + addr.s_addr = INADDR_ANY; + } else { + addr.s_addr = inet_addr(host); + if (addr.s_addr == (unsigned long) -1) { + hostent = gethostbyname(host); + if (hostent != NULL) { + memcpy((VOID *) &addr, + (VOID *) hostent->h_addr_list[0], + (size_t) hostent->h_length); + } else { +#ifdef EHOSTUNREACH + errno = EHOSTUNREACH; +#else +#ifdef ENXIO + errno = ENXIO; +#endif +#endif + return 0; /* error */ + } + } + } + + /* + * NOTE: On 64 bit machines the assignment below is rumored to not + * do the right thing. Please report errors related to this if you + * observe incorrect behavior on 64 bit machines such as DEC Alphas. + * Should we modify this code to do an explicit memcpy? + */ + + sockaddrPtr->sin_addr.s_addr = addr.s_addr; + return 1; /* Success. */ +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_OpenTcpClient -- + * + * Opens a TCP client socket and creates a channel around it. + * + * Results: + * The channel or NULL if failed. An error message is returned + * in the interpreter on failure. + * + * Side effects: + * Opens a client socket and creates a new channel. + * + *---------------------------------------------------------------------- + */ + +Tcl_Channel +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 */ + int myport; /* Client-side port */ + int async; /* If nonzero, attempt to do an + * asynchronous connect. Otherwise + * we do a blocking connect. */ +{ + Tcl_Channel chan; + TcpState *statePtr; + char channelName[20]; + + /* + * Create a new client socket and wrap it in a channel. + */ + + statePtr = CreateSocket(interp, port, host, 0, myaddr, myport, async); + if (statePtr == NULL) { + return NULL; + } + + statePtr->acceptProc = NULL; + statePtr->acceptProcData = (ClientData) NULL; + + sprintf(channelName, "sock%d", + (int) Tcl_GetFileInfo(statePtr->sock, NULL)); + + chan = Tcl_CreateChannel(&tcpChannelType, channelName, statePtr->sock, + statePtr->sock, (ClientData) statePtr); + if (Tcl_SetChannelOption(interp, chan, "-translation", "auto crlf") == + TCL_ERROR) { + Tcl_Close((Tcl_Interp *) NULL, chan); + return NULL; + } + return chan; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_MakeTcpClientChannel -- + * + * Creates a Tcl_Channel from an existing client TCP socket. + * + * Results: + * The Tcl_Channel wrapped around the preexisting TCP socket. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +Tcl_Channel +Tcl_MakeTcpClientChannel(sock) + ClientData sock; /* The socket to wrap up into a channel. */ +{ + TcpState *statePtr; + Tcl_File sockFile; + char channelName[20]; + Tcl_Channel chan; + + sockFile = Tcl_GetFile(sock, TCL_UNIX_FD); + statePtr = (TcpState *) ckalloc((unsigned) sizeof(TcpState)); + statePtr->sock = sockFile; + statePtr->acceptProc = NULL; + statePtr->acceptProcData = (ClientData) NULL; + + sprintf(channelName, "sock%d", (int) sock); + + chan = Tcl_CreateChannel(&tcpChannelType, channelName, sockFile, sockFile, + (ClientData) statePtr); + if (Tcl_SetChannelOption((Tcl_Interp *) NULL, chan, "-translation", + "auto crlf") == TCL_ERROR) { + Tcl_Close((Tcl_Interp *) NULL, chan); + return NULL; + } + return chan; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_OpenTcpServer -- + * + * Opens a TCP server socket and creates a channel around it. + * + * Results: + * The channel or NULL if failed. If an error occurred, an + * error message is left in interp->result if interp is + * not NULL. + * + * Side effects: + * Opens a server socket and creates a new channel. + * + *---------------------------------------------------------------------- + */ + +Tcl_Channel +Tcl_OpenTcpServer(interp, port, myHost, acceptProc, acceptProcData) + Tcl_Interp *interp; /* For error reporting - may be + * NULL. */ + int port; /* Port number to open. */ + char *myHost; /* Name of local host. */ + Tcl_TcpAcceptProc *acceptProc; /* Callback for accepting connections + * from new clients. */ + ClientData acceptProcData; /* Data for the callback. */ +{ + Tcl_Channel chan; + TcpState *statePtr; + char channelName[20]; + + /* + * Create a new client socket and wrap it in a channel. + */ + + statePtr = CreateSocket(interp, port, myHost, 1, NULL, 0, 0); + if (statePtr == NULL) { + return NULL; + } + + statePtr->acceptProc = acceptProc; + statePtr->acceptProcData = acceptProcData; + + /* + * Set up the callback mechanism for accepting connections + * from new clients. + */ + + Tcl_CreateFileHandler(statePtr->sock, TCL_READABLE, TcpAccept, + (ClientData) statePtr); + sprintf(channelName, "sock%d", + (int) Tcl_GetFileInfo(statePtr->sock, NULL)); + chan = Tcl_CreateChannel(&tcpChannelType, channelName, NULL, NULL, + (ClientData) statePtr); + return chan; +} + +/* + *---------------------------------------------------------------------- + * + * TcpAccept -- + * Accept a TCP socket connection. This is called by the event loop. + * + * Results: + * None. + * + * Side effects: + * Creates a new connection socket. Calls the registered callback + * for the connection acceptance mechanism. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +static void +TcpAccept(data, mask) + ClientData data; /* Callback token. */ + int mask; /* Not used. */ +{ + TcpState *sockState; /* Client data of server socket. */ + int newsock; /* The new client socket */ + Tcl_File newFile; /* Its file. */ + TcpState *newSockState; /* State for new socket. */ + struct sockaddr_in addr; /* The remote address */ + int len; /* For accept interface */ + Tcl_Channel chan; /* Channel instance created. */ + char channelName[20]; + + sockState = (TcpState *) data; + + len = sizeof(struct sockaddr_in); + newsock = accept((int) Tcl_GetFileInfo(sockState->sock, NULL), + (struct sockaddr *)&addr, &len); + if (newsock < 0) { + return; + } + + newFile = Tcl_GetFile((ClientData) newsock, TCL_UNIX_FD); + if (newFile) { + newSockState = (TcpState *) ckalloc((unsigned) sizeof(TcpState)); + + newSockState->flags = 0; + newSockState->sock = newFile; + newSockState->acceptProc = (Tcl_TcpAcceptProc *) NULL; + newSockState->acceptProcData = (ClientData) NULL; + + sprintf(channelName, "sock%d", (int) newsock); + chan = Tcl_CreateChannel(&tcpChannelType, channelName, newFile, + newFile, (ClientData) newSockState); + if (chan == (Tcl_Channel) NULL) { + ckfree((char *) newSockState); + close(newsock); + Tcl_FreeFile(newFile); + } else { + if (Tcl_SetChannelOption((Tcl_Interp *) NULL, chan, "-translation", + "auto crlf") == TCL_ERROR) { + Tcl_Close((Tcl_Interp *) NULL, chan); + } + if (sockState->acceptProc != (Tcl_TcpAcceptProc *) NULL) { + (sockState->acceptProc) (sockState->acceptProcData, chan, + inet_ntoa(addr.sin_addr), ntohs(addr.sin_port)); + } + } + } +} + +/* + *---------------------------------------------------------------------- + * + * TclGetDefaultStdChannel -- + * + * Creates channels for standard input, standard output or standard + * error output if they do not already exist. + * + * Results: + * Returns the specified default standard channel, or NULL. + * + * Side effects: + * May cause the creation of a standard channel and the underlying + * file. + * + *---------------------------------------------------------------------- + */ + +Tcl_Channel +TclGetDefaultStdChannel(type) + int type; /* One of TCL_STDIN, TCL_STDOUT, TCL_STDERR. */ +{ + Tcl_Channel channel = NULL; + int fd = 0; /* Initializations needed to prevent */ + int mode = 0; /* compiler warning (used before set). */ + char *bufMode = NULL; + + /* + * If the channels were not created yet, create them now and + * store them in the static variables. + */ + + switch (type) { + case TCL_STDIN: + fd = 0; + mode = TCL_READABLE; + bufMode = "line"; + break; + case TCL_STDOUT: + fd = 1; + mode = TCL_WRITABLE; + bufMode = "line"; + break; + case TCL_STDERR: + fd = 2; + mode = TCL_WRITABLE; + bufMode = "none"; + break; + default: + panic("TclGetDefaultStdChannel: Unexpected channel type"); + break; + } + + channel = Tcl_MakeFileChannel((ClientData) fd, (ClientData) fd, mode); + + /* + * Set up the normal channel options for stdio handles. + */ + + if (Tcl_SetChannelOption(NULL, channel, "-translation", "auto") == + TCL_ERROR) { + Tcl_Close((Tcl_Interp *) NULL, channel); + return NULL; + } + if (Tcl_SetChannelOption(NULL, channel, "-buffering", bufMode) == + TCL_ERROR) { + Tcl_Close((Tcl_Interp *) NULL, channel); + return NULL; + } + return channel; +} + +/* + *---------------------------------------------------------------------- + * + * TclClosePipeFile -- + * + * This function is a simple wrapper for close on a file or + * pipe handle. Called in the generic command pipeline cleanup + * code to do platform specific closing of the files associated + * with the command channel. + * + * Results: + * None. + * + * Side effects: + * Closes the fd and frees the Tcl_File. + * + *---------------------------------------------------------------------- + */ + +void +TclClosePipeFile(file) + Tcl_File file; +{ + int fd = (int) Tcl_GetFileInfo(file, NULL); + close(fd); + Tcl_FreeFile(file); +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_GetOpenFile -- + * + * Given a name of a channel registered in the given interpreter, + * returns a FILE * for it. + * + * Results: + * A standard Tcl result. If the channel is registered in the given + * interpreter and it is managed by the "file" channel driver, and + * it is open for the requested mode, then the output parameter + * filePtr is set to a FILE * for the underlying file. On error, the + * filePtr is not set, TCL_ERROR is returned and an error message is + * left in interp->result. + * + * Side effects: + * May invoke fdopen to create the FILE * for the requested file. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_GetOpenFile(interp, string, forWriting, checkUsage, filePtr) + Tcl_Interp *interp; /* Interpreter in which to find file. */ + 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. */ + ClientData *filePtr; /* Store pointer to FILE structure here. */ +{ + Tcl_Channel chan; + int chanMode; + Tcl_ChannelType *chanTypePtr; + Tcl_File tf; + int fd; + FILE *f; + + chan = Tcl_GetChannel(interp, string, &chanMode); + if (chan == (Tcl_Channel) NULL) { + return TCL_ERROR; + } + if ((forWriting) && ((chanMode & TCL_WRITABLE) == 0)) { + 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; + } + + /* + * We allow creating a FILE * out of file based, pipe based and socket + * based channels. We currently do not allow any other channel types, + * because it is likely that stdio will not know what to do with them. + */ + + chanTypePtr = Tcl_GetChannelType(chan); + if ((chanTypePtr == &fileChannelType) || (chanTypePtr == &pipeChannelType) + || (chanTypePtr == &tcpChannelType)) { + tf = Tcl_GetChannelFile(chan, + (forWriting ? TCL_WRITABLE : TCL_READABLE)); + fd = (int) Tcl_GetFileInfo(tf, NULL); + + /* + * The call to fdopen below is probably dangerous, since it will + * 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, + "\"", (char *) NULL); + return TCL_ERROR; + } + *filePtr = (ClientData) f; + return TCL_OK; + } + + Tcl_AppendResult(interp, "\"", string, + "\" cannot be used to get a FILE * - unsupported type", + (char *) NULL); + return TCL_ERROR; +} diff --git a/contrib/tcl/unix/tclUnixFile.c b/contrib/tcl/unix/tclUnixFile.c new file mode 100644 index 0000000..cebd43b --- /dev/null +++ b/contrib/tcl/unix/tclUnixFile.c @@ -0,0 +1,762 @@ +/* + * tclUnixFile.c -- + * + * This file contains wrappers around UNIX file handling functions. + * These wrappers mask differences between Windows and UNIX. + * + * 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: @(#) tclUnixFile.c 1.38 96/04/18 08:43:51 + */ + +#include "tclInt.h" +#include "tclPort.h" + +/* + * The variable below caches the name of the current working directory + * in order to avoid repeated calls to getcwd. The string is malloc-ed. + * NULL means the cache needs to be refreshed. + */ + +static char *currentDir = NULL; +static int currentDirExitHandlerSet = 0; + +/* + * The variable below is set if the exit routine for deleting the string + * containing the executable name has been registered. + */ + +static int executableNameExitHandlerSet = 0; + +extern pid_t waitpid _ANSI_ARGS_((pid_t pid, int *stat_loc, int options)); + +/* + * Static routines for this file: + */ + +static void FreeCurrentDir _ANSI_ARGS_((ClientData clientData)); +static void FreeExecutableName _ANSI_ARGS_((ClientData clientData)); + +/* + *---------------------------------------------------------------------- + * + * Tcl_WaitPid -- + * + * Implements the waitpid system call on Unix systems. + * + * Results: + * Result of calling waitpid. + * + * Side effects: + * Waits for a process to terminate. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_WaitPid(pid, statPtr, options) + int pid; + int *statPtr; + int options; +{ + int result; + pid_t real_pid; + + real_pid = (pid_t) pid; + while (1) { + result = (int) waitpid(real_pid, statPtr, options); + if ((result != -1) || (errno != EINTR)) { + return result; + } + } +} + +/* + *---------------------------------------------------------------------- + * + * FreeCurrentDir -- + * + * Frees the string stored in the currentDir variable. This routine + * is registered as an exit handler and will be called during shutdown. + * + * Results: + * None. + * + * Side effects: + * Frees the memory occuppied by the currentDir value. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +static void +FreeCurrentDir(clientData) + ClientData clientData; /* Not used. */ +{ + if (currentDir != (char *) NULL) { + ckfree(currentDir); + currentDir = (char *) NULL; + } +} + +/* + *---------------------------------------------------------------------- + * + * FreeExecutableName -- + * + * Frees the string stored in the tclExecutableName variable. This + * routine is registered as an exit handler and will be called + * during shutdown. + * + * Results: + * None. + * + * Side effects: + * Frees the memory occuppied by the tclExecutableName value. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +static void +FreeExecutableName(clientData) + ClientData clientData; /* Not used. */ +{ + if (tclExecutableName != (char *) NULL) { + ckfree(tclExecutableName); + tclExecutableName = (char *) NULL; + } +} + +/* + *---------------------------------------------------------------------- + * + * TclChdir -- + * + * Change the current working directory. + * + * Results: + * The result is a standard Tcl result. If an error occurs and + * interp isn't NULL, an error message is left in interp->result. + * + * Side effects: + * The working directory for this application is changed. Also + * the cache maintained used by TclGetCwd is deallocated and + * set to NULL. + * + *---------------------------------------------------------------------- + */ + +int +TclChdir(interp, dirName) + Tcl_Interp *interp; /* If non NULL, used for error reporting. */ + char *dirName; /* Path to new working directory. */ +{ + if (currentDir != NULL) { + ckfree(currentDir); + currentDir = NULL; + } + if (chdir(dirName) != 0) { + if (interp != NULL) { + Tcl_AppendResult(interp, "couldn't change working directory to \"", + dirName, "\": ", Tcl_PosixError(interp), (char *) NULL); + } + return TCL_ERROR; + } + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * TclGetCwd -- + * + * Return the path name of the current working directory. + * + * Results: + * The result is the full path name of the current working + * directory, or NULL if an error occurred while figuring it out. + * The returned string is owned by the TclGetCwd routine and must + * not be freed by the caller. If an error occurs and interp + * isn't NULL, an error message is left in interp->result. + * + * Side effects: + * The path name is cached to avoid having to recompute it + * on future calls; if it is already cached, the cached + * value is returned. + * + *---------------------------------------------------------------------- + */ + +char * +TclGetCwd(interp) + Tcl_Interp *interp; /* If non NULL, used for error reporting. */ +{ + char buffer[MAXPATHLEN+1]; + + if (currentDir == NULL) { + if (!currentDirExitHandlerSet) { + currentDirExitHandlerSet = 1; + Tcl_CreateExitHandler(FreeCurrentDir, (ClientData) NULL); + } + if (getcwd(buffer, MAXPATHLEN+1) == NULL) { + if (interp != NULL) { + if (errno == ERANGE) { + interp->result = "working directory name is too long"; + } else { + Tcl_AppendResult(interp, + "error getting working directory name: ", + Tcl_PosixError(interp), (char *) NULL); + } + } + return NULL; + } + currentDir = (char *) ckalloc((unsigned) (strlen(buffer) + 1)); + strcpy(currentDir, buffer); + } + return currentDir; +} + +/* + *---------------------------------------------------------------------- + * + * TclOpenFile -- + * + * Implements a mechanism to open files on Unix systems. + * + * Results: + * The opened file. + * + * Side effects: + * May cause a file to be created on the file system. + * + *---------------------------------------------------------------------- + */ + +Tcl_File +TclOpenFile(fname, mode) + char *fname; /* The name of the file to open. */ + int mode; /* In what mode to open the file? */ +{ + int fd; + + fd = open(fname, mode, 0600); + if (fd != -1) { + fcntl(fd, F_SETFD, FD_CLOEXEC); + return Tcl_GetFile((ClientData)fd, TCL_UNIX_FD); + } + return NULL; +} + +/* + *---------------------------------------------------------------------- + * + * TclCloseFile -- + * + * Implements a mechanism to close a UNIX file. + * + * Results: + * Returns 0 on success, or -1 on error, setting errno. + * + * Side effects: + * The file is closed. + * + *---------------------------------------------------------------------- + */ + +int +TclCloseFile(file) + Tcl_File file; /* The file to close. */ +{ + int type; + int fd; + int result; + + fd = (int) Tcl_GetFileInfo(file, &type); + if (type != TCL_UNIX_FD) { + panic("Tcl_CloseFile: unexpected file type"); + } + + /* + * Refuse to close the fds for stdin, stdout and stderr. + */ + + if ((fd == 0) || (fd == 1) || (fd == 2)) { + return 0; + } + + result = close(fd); + Tcl_DeleteFileHandler(file); + Tcl_FreeFile(file); + return result; +} + +/* + *---------------------------------------------------------------------- + * + * TclReadFile -- + * + * Implements a mechanism to read from files on Unix systems. Also + * simulates blocking behavior on non-blocking files when asked to. + * + * Results: + * The number of characters read from the specified file. + * + * Side effects: + * May consume characters from the file. + * + *---------------------------------------------------------------------- + */ + /* ARGSUSED */ +int +TclReadFile(file, shouldBlock, buf, toRead) + Tcl_File file; /* The file to read from. */ + int shouldBlock; /* Not used. */ + char *buf; /* The buffer to store input in. */ + int toRead; /* Number of characters to read. */ +{ + int type, fd; + + fd = (int) Tcl_GetFileInfo(file, &type); + if (type != TCL_UNIX_FD) { + panic("Tcl_ReadFile: unexpected file type"); + } + + return read(fd, buf, (size_t) toRead); +} + +/* + *---------------------------------------------------------------------- + * + * TclWriteFile -- + * + * Implements a mechanism to write to files on Unix systems. + * + * Results: + * The number of characters written to the specified file. + * + * Side effects: + * May produce characters on the file. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +int +TclWriteFile(file, shouldBlock, buf, toWrite) + Tcl_File file; /* The file to write to. */ + int shouldBlock; /* Not used. */ + char *buf; /* Where output is stored. */ + int toWrite; /* Number of characters to write. */ +{ + int type, fd; + + fd = (int) Tcl_GetFileInfo(file, &type); + if (type != TCL_UNIX_FD) { + panic("Tcl_WriteFile: unexpected file type"); + } + return write(fd, buf, (size_t) toWrite); +} + +/* + *---------------------------------------------------------------------- + * + * TclSeekFile -- + * + * Sets the file pointer on the indicated UNIX file. + * + * Results: + * The new position at which the file will be accessed, or -1 on + * failure. + * + * Side effects: + * May change the position at which subsequent operations access the + * file designated by the file. + * + *---------------------------------------------------------------------- + */ + +int +TclSeekFile(file, offset, whence) + Tcl_File file; /* The file to seek on. */ + int offset; /* How far to seek? */ + int whence; /* And from where to seek? */ +{ + int type, fd; + + fd = (int) Tcl_GetFileInfo(file, &type); + if (type != TCL_UNIX_FD) { + panic("Tcl_SeekFile: unexpected file type"); + } + + return lseek(fd, offset, whence); +} + +/* + *---------------------------------------------------------------------- + * + * TclCreateTempFile -- + * + * This function creates a temporary file initialized with an + * optional string, and returns a file handle with the file pointer + * at the beginning of the file. + * + * Results: + * A handle to a file. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +Tcl_File +TclCreateTempFile(contents) + char *contents; /* String to write into temp file, or NULL. */ +{ + char fileName[L_tmpnam]; + Tcl_File file; + size_t length = (contents == NULL) ? 0 : strlen(contents); + + tmpnam(fileName); + file = TclOpenFile(fileName, O_RDWR|O_CREAT|O_TRUNC); + unlink(fileName); + + if ((file != NULL) && (length > 0)) { + int fd = (int)Tcl_GetFileInfo(file, NULL); + while (1) { + if (write(fd, contents, length) != -1) { + break; + } else if (errno != EINTR) { + close(fd); + Tcl_FreeFile(file); + return NULL; + } + } + lseek(fd, 0, SEEK_SET); + } + return file; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_FindExecutable -- + * + * This procedure computes the absolute path name of the current + * application, given its argv[0] value. + * + * Results: + * None. + * + * Side effects: + * The variable tclExecutableName gets filled in with the file + * name for the application, if we figured it out. If we couldn't + * figure it out, Tcl_FindExecutable is set to NULL. + * + *---------------------------------------------------------------------- + */ + +void +Tcl_FindExecutable(argv0) + char *argv0; /* The value of the application's argv[0]. */ +{ + char *name, *p, *cwd; + Tcl_DString buffer; + int length; + + Tcl_DStringInit(&buffer); + if (tclExecutableName != NULL) { + ckfree(tclExecutableName); + tclExecutableName = NULL; + } + + name = argv0; + for (p = name; *p != 0; p++) { + if (*p == '/') { + /* + * The name contains a slash, so use the name directly + * without doing a path search. + */ + + goto gotName; + } + } + + p = getenv("PATH"); + if (p == NULL) { + /* + * There's no PATH environment variable; use the default that + * is used by sh. + */ + + p = ":/bin:/usr/bin"; + } + + /* + * Search through all the directories named in the PATH variable + * to see if argv[0] is in one of them. If so, use that file + * name. + */ + + while (*p != 0) { + while (isspace(UCHAR(*p))) { + p++; + } + name = p; + while ((*p != ':') && (*p != 0)) { + p++; + } + Tcl_DStringSetLength(&buffer, 0); + if (p != name) { + Tcl_DStringAppend(&buffer, name, p-name); + if (p[-1] != '/') { + Tcl_DStringAppend(&buffer, "/", 1); + } + } + Tcl_DStringAppend(&buffer, argv0, -1); + if (access(Tcl_DStringValue(&buffer), X_OK) == 0) { + name = Tcl_DStringValue(&buffer); + goto gotName; + } + p++; + } + goto done; + + /* + * If the name starts with "/" then just copy it to tclExecutableName. + */ + + gotName: + if (name[0] == '/') { + tclExecutableName = (char *) ckalloc((unsigned) (strlen(name) + 1)); + strcpy(tclExecutableName, name); + goto done; + } + + /* + * The name is relative to the current working directory. First + * strip off a leading "./", if any, then add the full path name of + * the current working directory. + */ + + if ((name[0] == '.') && (name[1] == '/')) { + name += 2; + } + cwd = TclGetCwd((Tcl_Interp *) NULL); + if (cwd == NULL) { + tclExecutableName = NULL; + goto done; + } + length = strlen(cwd); + tclExecutableName = (char *) ckalloc((unsigned) + (length + strlen(name) + 2)); + strcpy(tclExecutableName, cwd); + tclExecutableName[length] = '/'; + strcpy(tclExecutableName + length + 1, name); + + done: + Tcl_DStringFree(&buffer); + + if (!executableNameExitHandlerSet) { + executableNameExitHandlerSet = 1; + Tcl_CreateExitHandler(FreeExecutableName, (ClientData) NULL); + } +} + +/* + *---------------------------------------------------------------------- + * + * TclGetUserHome -- + * + * This function takes the passed in user name and finds the + * corresponding home directory specified in the password file. + * + * Results: + * The result is a pointer to a static string containing + * the new name. If there was an error in processing the + * user name then the return value is NULL. Otherwise the + * result is stored in bufferPtr, and the caller must call + * Tcl_DStringFree(bufferPtr) to free the result. + * + * Side effects: + * Information may be left in bufferPtr. + * + *---------------------------------------------------------------------- + */ + +char * +TclGetUserHome(name, bufferPtr) + char *name; /* User name to use to find home directory. */ + Tcl_DString *bufferPtr; /* May be used to hold result. Must not hold + * anything at the time of the call, and need + * not even be initialized. */ +{ + struct passwd *pwPtr; + + pwPtr = getpwnam(name); + if (pwPtr == NULL) { + endpwent(); + return NULL; + } + Tcl_DStringInit(bufferPtr); + Tcl_DStringAppend(bufferPtr, pwPtr->pw_dir, -1); + endpwent(); + return bufferPtr->string; +} + +/* + *---------------------------------------------------------------------- + * + * TclMatchFiles -- + * + * 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 interp->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. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- */ + +int +TclMatchFiles(interp, separators, dirPtr, pattern, tail) + Tcl_Interp *interp; /* Interpreter to receive results. */ + char *separators; /* Path 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. */ +{ + char *dirName, *patternEnd = tail; + char savedChar = 0; /* Initialization needed only to prevent + * compiler warning from gcc. */ + DIR *d; + struct stat statBuf; + struct dirent *entryPtr; + int matchHidden; + int result = TCL_OK; + int baseLength = Tcl_DStringLength(dirPtr); + + /* + * 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 (dirPtr->string[0] == '\0') { + dirName = "."; + } else { + dirName = dirPtr->string; + } + if ((stat(dirName, &statBuf) != 0) || !S_ISDIR(statBuf.st_mode)) { + 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. + */ + + d = opendir(dirName); + if (d == NULL) { + Tcl_ResetResult(interp); + + /* + * Strip off a trailing '/' if necessary, before reporting the error. + */ + + if (baseLength > 0) { + savedChar = dirPtr->string[baseLength-1]; + if (savedChar == '/') { + dirPtr->string[baseLength-1] = '\0'; + } + } + Tcl_AppendResult(interp, "couldn't read directory \"", + dirPtr->string, "\": ", Tcl_PosixError(interp), (char *) NULL); + if (baseLength > 0) { + dirPtr->string[baseLength-1] = savedChar; + } + 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. + */ + + if (*tail == '\\') { + tail++; + } + if (*tail == '\0') { + tail = NULL; + } else { + tail++; + } + savedChar = *patternEnd; + *patternEnd = '\0'; + + while (1) { + entryPtr = readdir(d); + if (entryPtr == NULL) { + break; + } + + /* + * Don't match names starting with "." unless the "." is + * present in the pattern. + */ + + if (!matchHidden && (*entryPtr->d_name == '.')) { + continue; + } + + /* + * 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. + */ + + if (Tcl_StringMatch(entryPtr->d_name, pattern)) { + Tcl_DStringSetLength(dirPtr, baseLength); + Tcl_DStringAppend(dirPtr, entryPtr->d_name, -1); + if (tail == NULL) { + Tcl_AppendElement(interp, dirPtr->string); + } else if ((stat(dirPtr->string, &statBuf) == 0) + && S_ISDIR(statBuf.st_mode)) { + Tcl_DStringAppend(dirPtr, "/", 1); + result = TclDoGlob(interp, separators, dirPtr, tail); + if (result != TCL_OK) { + break; + } + } + } + } + *patternEnd = savedChar; + + closedir(d); + return result; +} diff --git a/contrib/tcl/unix/tclUnixInit.c b/contrib/tcl/unix/tclUnixInit.c new file mode 100644 index 0000000..639ae6a --- /dev/null +++ b/contrib/tcl/unix/tclUnixInit.c @@ -0,0 +1,163 @@ +/* + * tclUnixInit.c -- + * + * Contains the Unix-specific interpreter initialization functions. + * + * Copyright (c) 1995-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: @(#) tclUnixInit.c 1.10 96/03/12 09:05:59 + */ + +#include "tclInt.h" +#include "tclPort.h" +#ifndef NO_UNAME +# include <sys/utsname.h> +#endif +#if defined(__FreeBSD__) +#include <floatingpoint.h> +#endif + +/* + * Default directory in which to look for libraries: + */ + +static char defaultLibraryDir[200] = TCL_LIBRARY; + +/* + * The following string is the startup script executed in new + * interpreters. It looks on disk in several different directories + * for a script "init.tcl" that is compatible with this version + * of Tcl. The init.tcl script does all of the real work of + * initialization. + */ + +static char *initScript = +"proc init {} {\n\ + global tcl_library tcl_version tcl_patchLevel env\n\ + rename init {}\n\ + set dirs {}\n\ + if [info exists env(TCL_LIBRARY)] {\n\ + lappend dirs $env(TCL_LIBRARY)\n\ + }\n\ + lappend dirs [info library]\n\ + lappend dirs [file dirname [file dirname [info nameofexecutable]]]/lib/tcl$tcl_version\n\ + if [string match {*[ab]*} $tcl_patchLevel] {\n\ + set lib tcl$tcl_patchLevel\n\ + } else {\n\ + set lib tcl$tcl_version\n\ + }\n\ + lappend dirs [file dirname [file dirname [pwd]]]/$lib/library\n\ + lappend dirs [file dirname [pwd]]/library\n\ + foreach i $dirs {\n\ + set tcl_library $i\n\ + if ![catch {uplevel #0 source $i/init.tcl}] {\n\ + return\n\ + }\n\ + }\n\ + set msg \"Can't find a usable init.tcl in the following directories: \n\"\n\ + append msg \" $dirs\n\"\n\ + append msg \"This probably means that Tcl wasn't installed properly.\n\"\n\ + error $msg\n\ +}\n\ +init"; + +/* + *---------------------------------------------------------------------- + * + * TclPlatformInit -- + * + * Performs Unix-specific interpreter initialization related to the + * tcl_library and tcl_platform variables, and other platform- + * specific things. + * + * Results: + * None. + * + * Side effects: + * Sets "tcl_library" and "tcl_platform" Tcl variables. + * + *---------------------------------------------------------------------- + */ + +void +TclPlatformInit(interp) + Tcl_Interp *interp; +{ +#ifndef NO_UNAME + struct utsname name; +#endif + int unameOK; + static int initialized = 0; + + tclPlatform = TCL_PLATFORM_UNIX; + Tcl_SetVar(interp, "tcl_library", defaultLibraryDir, TCL_GLOBAL_ONLY); + Tcl_SetVar2(interp, "tcl_platform", "platform", "unix", TCL_GLOBAL_ONLY); + unameOK = 0; +#ifndef NO_UNAME + if (uname(&name) >= 0) { + unameOK = 1; + Tcl_SetVar2(interp, "tcl_platform", "os", name.sysname, + TCL_GLOBAL_ONLY); + Tcl_SetVar2(interp, "tcl_platform", "osVersion", name.release, + TCL_GLOBAL_ONLY); + Tcl_SetVar2(interp, "tcl_platform", "machine", name.machine, + TCL_GLOBAL_ONLY); + } +#endif + if (!unameOK) { + Tcl_SetVar2(interp, "tcl_platform", "os", "", TCL_GLOBAL_ONLY); + Tcl_SetVar2(interp, "tcl_platform", "osVersion", "", TCL_GLOBAL_ONLY); + Tcl_SetVar2(interp, "tcl_platform", "machine", "", TCL_GLOBAL_ONLY); + } + + if (!initialized) { + /* + * The code below causes SIGPIPE (broken pipe) errors to + * be ignored. This is needed so that Tcl processes don't + * die if they create child processes (e.g. using "exec" or + * "open") that terminate prematurely. The signal handler + * is only set up when the first interpreter is created; + * after this the application can override the handler with + * a different one of its own, if it wants. + */ + +#ifdef SIGPIPE + (void) signal(SIGPIPE, SIG_IGN); +#endif /* SIGPIPE */ + +#ifdef __FreeBSD__ + fpsetround(FP_RN); + fpsetmask(0L); +#endif + initialized = 1; + } +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_Init -- + * + * This procedure is typically invoked by Tcl_AppInit procedures + * to perform additional initialization for a Tcl interpreter, + * such as sourcing the "init.tcl" script. + * + * Results: + * Returns a standard Tcl completion code and sets interp->result + * if there is an error. + * + * Side effects: + * Depends on what's in the init.tcl script. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_Init(interp) + Tcl_Interp *interp; /* Interpreter to initialize. */ +{ + return Tcl_Eval(interp, initScript); +} diff --git a/contrib/tcl/unix/tclUnixNotfy.c b/contrib/tcl/unix/tclUnixNotfy.c new file mode 100644 index 0000000..e03d186 --- /dev/null +++ b/contrib/tcl/unix/tclUnixNotfy.c @@ -0,0 +1,322 @@ +/* + * tclUnixNotify.c -- + * + * This file contains Unix-specific procedures for the notifier, + * which is the lowest-level part of the Tcl event loop. This file + * works together with ../generic/tclNotify.c. + * + * 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: @(#) tclUnixNotfy.c 1.30 96/03/22 12:45:31 + */ + +#include "tclInt.h" +#include "tclPort.h" +#include <signal.h> + +/* + * The information below is used to provide read, write, and + * exception masks to select during calls to Tcl_DoOneEvent. + */ + +static fd_mask checkMasks[3*MASK_SIZE]; + /* This array is used to build up the masks + * to be used in the next call to select. + * Bits are set in response to calls to + * Tcl_WatchFile. */ +static fd_mask readyMasks[3*MASK_SIZE]; + /* This array reflects the readable/writable + * conditions that were found to exist by the + * last call to select. */ +static int numFdBits; /* Number of valid bits in checkMasks + * (one more than highest fd for which + * Tcl_WatchFile has been called). */ + +/* + * Static routines in this file: + */ + +static int MaskEmpty _ANSI_ARGS_((long *maskPtr)); + +/* + *---------------------------------------------------------------------- + * + * Tcl_WatchFile -- + * + * Arrange for Tcl_DoOneEvent to include this file in the masks + * for the next call to select. This procedure is invoked by + * event sources, which are in turn invoked by Tcl_DoOneEvent + * before it invokes select. + * + * Results: + * None. + * + * Side effects: + * + * The notifier will generate a file event when the I/O channel + * given by fd next becomes ready in the way indicated by mask. + * If fd is already registered then the old mask will be replaced + * with the new one. Once the event is sent, the notifier will + * not send any more events about the fd until the next call to + * Tcl_NotifyFile. + * + *---------------------------------------------------------------------- + */ + +void +Tcl_WatchFile(file, mask) + Tcl_File file; /* Generic file handle for a stream. */ + int mask; /* OR'ed combination of TCL_READABLE, + * TCL_WRITABLE, and TCL_EXCEPTION: + * indicates conditions to wait for + * in select. */ +{ + int fd, type, index; + fd_mask bit; + + fd = (int) Tcl_GetFileInfo(file, &type); + + if (type != TCL_UNIX_FD) { + panic("Tcl_WatchFile: unexpected file type"); + } + + if (fd >= FD_SETSIZE) { + panic("Tcl_WatchFile can't handle file id %d", fd); + } + + index = fd/(NBBY*sizeof(fd_mask)); + bit = 1 << (fd%(NBBY*sizeof(fd_mask))); + if (mask & TCL_READABLE) { + checkMasks[index] |= bit; + } + if (mask & TCL_WRITABLE) { + (checkMasks+MASK_SIZE)[index] |= bit; + } + if (mask & TCL_EXCEPTION) { + (checkMasks+2*(MASK_SIZE))[index] |= bit; + } + if (numFdBits <= fd) { + numFdBits = fd+1; + } +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_FileReady -- + * + * Indicates what conditions (readable, writable, etc.) were + * present on a file the last time the notifier invoked select. + * This procedure is typically invoked by event sources to see + * if they should queue events. + * + * Results: + * The return value is 0 if none of the conditions specified by mask + * was true for fd the last time the system checked. If any of the + * conditions were true, then the return value is a mask of those + * that were true. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_FileReady(file, mask) + Tcl_File file; /* Generic file handle for a stream. */ + int mask; /* OR'ed combination of TCL_READABLE, + * TCL_WRITABLE, and TCL_EXCEPTION: + * indicates conditions caller cares about. */ +{ + int index, result, type, fd; + fd_mask bit; + + fd = (int) Tcl_GetFileInfo(file, &type); + if (type != TCL_UNIX_FD) { + panic("Tcl_FileReady: unexpected file type"); + } + + index = fd/(NBBY*sizeof(fd_mask)); + bit = 1 << (fd%(NBBY*sizeof(fd_mask))); + result = 0; + if ((mask & TCL_READABLE) && (readyMasks[index] & bit)) { + result |= TCL_READABLE; + } + if ((mask & TCL_WRITABLE) && ((readyMasks+MASK_SIZE)[index] & bit)) { + result |= TCL_WRITABLE; + } + if ((mask & TCL_EXCEPTION) && ((readyMasks+(2*MASK_SIZE))[index] & bit)) { + result |= TCL_EXCEPTION; + } + return result; +} + +/* + *---------------------------------------------------------------------- + * + * MaskEmpty -- + * + * Returns nonzero if mask is empty (has no bits set). + * + * Results: + * Nonzero if the mask is empty, zero otherwise. + * + * Side effects: + * None + * + *---------------------------------------------------------------------- + */ + +static int +MaskEmpty(maskPtr) + long *maskPtr; +{ + long *runPtr, *tailPtr; + int found, sz; + + sz = 3 * ((MASK_SIZE) / sizeof(long)) * sizeof(fd_mask); + for (runPtr = maskPtr, tailPtr = maskPtr + sz, found = 0; + runPtr < tailPtr; + runPtr++) { + if (*runPtr != 0) { + found = 1; + break; + } + } + return !found; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_WaitForEvent -- + * + * This procedure does the lowest level wait for events in a + * platform-specific manner. It uses information provided by + * previous calls to Tcl_WatchFile, plus the timePtr argument, + * to determine what to wait for and how long to wait. + * + * Results: + * The return value is normally TCL_OK. However, if there are + * no events to wait for (e.g. no files and no timers) so that + * the procedure would block forever, then it returns TCL_ERROR. + * + * Side effects: + * May put the process to sleep for a while, depending on timePtr. + * When this procedure returns, an event of interest to the application + * has probably, but not necessarily, occurred. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_WaitForEvent(timePtr) + Tcl_Time *timePtr; /* Specifies the maximum amount of time + * that this procedure should block before + * returning. The time is given as an + * interval, not an absolute wakeup time. + * NULL means block forever. */ +{ + struct timeval timeout, *timeoutPtr; + int numFound; + + memcpy((VOID *) readyMasks, (VOID *) checkMasks, + 3*MASK_SIZE*sizeof(fd_mask)); + if (timePtr == NULL) { + if ((numFdBits == 0) || (MaskEmpty((long *) readyMasks))) { + return TCL_ERROR; + } + timeoutPtr = NULL; + } else { + timeoutPtr = &timeout; + timeout.tv_sec = timePtr->sec; + timeout.tv_usec = timePtr->usec; + } + numFound = select(numFdBits, (SELECT_MASK *) &readyMasks[0], + (SELECT_MASK *) &readyMasks[MASK_SIZE], + (SELECT_MASK *) &readyMasks[2*MASK_SIZE], timeoutPtr); + + /* + * Some systems don't clear the masks after an error, so + * we have to do it here. + */ + + if (numFound == -1) { + memset((VOID *) readyMasks, 0, 3*MASK_SIZE*sizeof(fd_mask)); + } + + /* + * Reset the check masks in preparation for the next call to + * select. + */ + + numFdBits = 0; + memset((VOID *) checkMasks, 0, 3*MASK_SIZE*sizeof(fd_mask)); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_Sleep -- + * + * Delay execution for the specified number of milliseconds. + * + * Results: + * None. + * + * Side effects: + * Time passes. + * + *---------------------------------------------------------------------- + */ + +void +Tcl_Sleep(ms) + int ms; /* Number of milliseconds to sleep. */ +{ + static struct timeval delay; + Tcl_Time before, after; + + /* + * The only trick here is that select appears to return early + * under some conditions, so we have to check to make sure that + * the right amount of time really has elapsed. If it's too + * early, go back to sleep again. + */ + + TclGetTime(&before); + after = before; + after.sec += ms/1000; + after.usec += (ms%1000)*1000; + if (after.usec > 1000000) { + after.usec -= 1000000; + after.sec += 1; + } + while (1) { + delay.tv_sec = after.sec - before.sec; + delay.tv_usec = after.usec - before.usec; + if (delay.tv_usec < 0) { + delay.tv_usec += 1000000; + delay.tv_sec -= 1; + } + + /* + * Special note: must convert delay.tv_sec to int before comparing + * to zero, since delay.tv_usec is unsigned on some platforms. + */ + + if ((((int) delay.tv_sec) < 0) + || ((delay.tv_usec == 0) && (delay.tv_sec == 0))) { + break; + } + (void) select(0, (SELECT_MASK *) 0, (SELECT_MASK *) 0, + (SELECT_MASK *) 0, &delay); + TclGetTime(&before); + } +} + diff --git a/contrib/tcl/unix/tclUnixPipe.c b/contrib/tcl/unix/tclUnixPipe.c new file mode 100644 index 0000000..a7ff1b3 --- /dev/null +++ b/contrib/tcl/unix/tclUnixPipe.c @@ -0,0 +1,496 @@ +/* + * tclUnixPipe.c -- This file implements the UNIX-specific exec pipeline + * functions. + * + * Copyright (c) 1991-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: @(#) tclUnixPipe.c 1.29 96/04/18 15:56:26 + */ + +#include "tclInt.h" +#include "tclPort.h" + +/* + * Declarations for local procedures defined in this file: + */ + +static void RestoreSignals _ANSI_ARGS_((void)); +static int SetupStdFile _ANSI_ARGS_((Tcl_File file, int type)); + +/* + *---------------------------------------------------------------------- + * + * RestoreSignals -- + * + * This procedure is invoked in a forked child process just before + * exec-ing a new program to restore all signals to their default + * settings. + * + * Results: + * None. + * + * Side effects: + * Signal settings get changed. + * + *---------------------------------------------------------------------- + */ + +static void +RestoreSignals() +{ +#ifdef SIGABRT + signal(SIGABRT, SIG_DFL); +#endif +#ifdef SIGALRM + signal(SIGALRM, SIG_DFL); +#endif +#ifdef SIGFPE + signal(SIGFPE, SIG_DFL); +#endif +#ifdef SIGHUP + signal(SIGHUP, SIG_DFL); +#endif +#ifdef SIGILL + signal(SIGILL, SIG_DFL); +#endif +#ifdef SIGINT + signal(SIGINT, SIG_DFL); +#endif +#ifdef SIGPIPE + signal(SIGPIPE, SIG_DFL); +#endif +#ifdef SIGQUIT + signal(SIGQUIT, SIG_DFL); +#endif +#ifdef SIGSEGV + signal(SIGSEGV, SIG_DFL); +#endif +#ifdef SIGTERM + signal(SIGTERM, SIG_DFL); +#endif +#ifdef SIGUSR1 + signal(SIGUSR1, SIG_DFL); +#endif +#ifdef SIGUSR2 + signal(SIGUSR2, SIG_DFL); +#endif +#ifdef SIGCHLD + signal(SIGCHLD, SIG_DFL); +#endif +#ifdef SIGCONT + signal(SIGCONT, SIG_DFL); +#endif +#ifdef SIGTSTP + signal(SIGTSTP, SIG_DFL); +#endif +#ifdef SIGTTIN + signal(SIGTTIN, SIG_DFL); +#endif +#ifdef SIGTTOU + signal(SIGTTOU, SIG_DFL); +#endif +} + +/* + *---------------------------------------------------------------------- + * + * SetupStdFile -- + * + * Set up stdio file handles for the child process, using the + * current standard channels if no other files are specified. + * If no standard channel is defined, or if no file is associated + * with the channel, then the corresponding standard fd is closed. + * + * Results: + * Returns 1 on success, or 0 on failure. + * + * Side effects: + * Replaces stdio fds. + * + *---------------------------------------------------------------------- + */ + +static int +SetupStdFile(file, type) + Tcl_File file; /* File to dup, or NULL. */ + int type; /* One of TCL_STDIN, TCL_STDOUT, TCL_STDERR */ +{ + Tcl_Channel channel; + int fd; + int targetFd = 0; /* Initializations here needed only to */ + int direction = 0; /* prevent warnings about using uninitialized + * variables. */ + + switch (type) { + case TCL_STDIN: + targetFd = 0; + direction = TCL_READABLE; + break; + case TCL_STDOUT: + targetFd = 1; + direction = TCL_WRITABLE; + break; + case TCL_STDERR: + targetFd = 2; + direction = TCL_WRITABLE; + break; + } + + if (!file) { + channel = Tcl_GetStdChannel(type); + if (channel) { + file = Tcl_GetChannelFile(channel, direction); + } + } + if (file) { + fd = (int)Tcl_GetFileInfo(file, NULL); + if (fd != targetFd) { + if (dup2(fd, targetFd) == -1) { + return 0; + } + + /* + * Must clear the close-on-exec flag for the target FD, since + * some systems (e.g. Ultrix) do not clear the CLOEXEC flag on + * the target FD. + */ + + fcntl(targetFd, F_SETFD, 0); + } else { + int result; + + /* + * Since we aren't dup'ing the file, we need to explicitly clear + * the close-on-exec flag. + */ + + result = fcntl(fd, F_SETFD, 0); + } + } else { + close(targetFd); + } + return 1; +} + +/* + *---------------------------------------------------------------------- + * + * TclSpawnPipeline -- + * + * Given an argc/argv array, instantiate a pipeline of processes + * as described by the argv. + * + * Results: + * The return value is 1 on success, 0 on error + * + * Side effects: + * Processes and pipes are created. + * + *---------------------------------------------------------------------- + */ +int +TclSpawnPipeline(interp, pidPtr, numPids, argc, argv, inputFile, + outputFile, errorFile, intIn, finalOut) + Tcl_Interp *interp; /* Interpreter in which to process pipeline. */ + int *pidPtr; /* Array of pids which are created. */ + int *numPids; /* Number of pids created. */ + int argc; /* Number of entries in argv. */ + char **argv; /* Array of strings describing commands in + * pipeline plus I/O redirection with <, + * <<, >, etc. argv[argc] must be NULL. */ + Tcl_File inputFile; /* If >=0, gives file id to use as input for + * first process in pipeline (specified via < + * or <@). */ + Tcl_File outputFile; /* Writable file id for output from last + * command in pipeline (could be file or + * pipe). NULL means use stdout. */ + Tcl_File errorFile; /* Writable file id for error output from all + * commands in the pipeline. NULL means use + * stderr */ + char *intIn; /* File name for initial input (for Win32s). */ + char *finalOut; /* File name for final output (for Win32s). */ +{ + int firstArg, lastArg; + int pid, count; + Tcl_DString buffer; + char *execName; + char errSpace[200]; + Tcl_File pipeIn, errPipeIn, errPipeOut; + int joinThisError; + Tcl_File curOutFile = NULL, curInFile; + + Tcl_DStringInit(&buffer); + pipeIn = errPipeIn = errPipeOut = NULL; + + curInFile = inputFile; + + for (firstArg = 0; firstArg < argc; firstArg = lastArg+1) { + + /* + * Convert the program name into native form. + */ + + Tcl_DStringFree(&buffer); + execName = Tcl_TranslateFileName(interp, argv[firstArg], &buffer); + if (execName == NULL) { + goto error; + } + + /* + * Find the end of the current segment of the pipeline. + */ + + joinThisError = 0; + for (lastArg = firstArg; lastArg < argc; lastArg++) { + if (argv[lastArg][0] == '|') { + if (argv[lastArg][1] == 0) { + break; + } + if ((argv[lastArg][1] == '&') && (argv[lastArg][2] == 0)) { + joinThisError = 1; + break; + } + } + } + argv[lastArg] = NULL; + + /* + * If this is the last segment, use the specified outputFile. + * Otherwise create an intermediate pipe. + */ + + if (lastArg == argc) { + curOutFile = outputFile; + } else { + if (TclCreatePipe(&pipeIn, &curOutFile) == 0) { + Tcl_AppendResult(interp, "couldn't create pipe: ", + Tcl_PosixError(interp), (char *) NULL); + goto error; + } + } + + /* + * Create a pipe that the child can use to return error + * information if anything goes wrong. + */ + + if (TclCreatePipe(&errPipeIn, &errPipeOut) == 0) { + Tcl_AppendResult(interp, "couldn't create pipe: ", + Tcl_PosixError(interp), (char *) NULL); + goto error; + } + + pid = vfork(); + if (pid == 0) { + + /* + * Set up stdio file handles for the child process. + */ + + if (!SetupStdFile(curInFile, TCL_STDIN) + || !SetupStdFile(curOutFile, TCL_STDOUT) + || (!joinThisError && !SetupStdFile(errorFile, TCL_STDERR)) + || (joinThisError && + ((dup2(1,2) == -1) || + (fcntl(2, F_SETFD, 0) != 0)))) { + sprintf(errSpace, + "%dforked process couldn't set up input/output: ", + errno); + TclWriteFile(errPipeOut, 1, errSpace, (int) strlen(errSpace)); + _exit(1); + } + + /* + * Close the input side of the error pipe. + */ + + RestoreSignals(); + execvp(execName, &argv[firstArg]); + sprintf(errSpace, "%dcouldn't execute \"%.150s\": ", errno, + argv[firstArg]); + TclWriteFile(errPipeOut, 1, errSpace, (int) strlen(errSpace)); + _exit(1); + } + Tcl_DStringFree(&buffer); + if (pid == -1) { + Tcl_AppendResult(interp, "couldn't fork child process: ", + Tcl_PosixError(interp), (char *) NULL); + goto error; + } + + /* + * Add the child process to the list of those to be reaped. + * Note: must do it now, so that the process will be reaped even if + * an error occurs during its startup. + */ + + pidPtr[*numPids] = pid; + (*numPids)++; + + /* + * Read back from the error pipe to see if the child startup + * up OK. The info in the pipe (if any) consists of a decimal + * errno value followed by an error message. + */ + + TclCloseFile(errPipeOut); + errPipeOut = NULL; + + count = TclReadFile(errPipeIn, 1, errSpace, + (size_t) (sizeof(errSpace) - 1)); + if (count > 0) { + char *end; + errSpace[count] = 0; + errno = strtol(errSpace, &end, 10); + Tcl_AppendResult(interp, end, Tcl_PosixError(interp), + (char *) NULL); + goto error; + } + TclCloseFile(errPipeIn); + errPipeIn = NULL; + + /* + * Close off our copies of file descriptors that were set up for + * this child, then set up the input for the next child. + */ + + if (curInFile && (curInFile != inputFile)) { + TclCloseFile(curInFile); + } + curInFile = pipeIn; + pipeIn = NULL; + + if (curOutFile && (curOutFile != outputFile)) { + TclCloseFile(curOutFile); + } + curOutFile = NULL; + } + return 1; + + /* + * An error occured, so we need to clean up any open pipes. + */ + +error: + Tcl_DStringFree(&buffer); + if (errPipeIn) { + TclCloseFile(errPipeIn); + } + if (errPipeOut) { + TclCloseFile(errPipeOut); + } + if (pipeIn) { + TclCloseFile(pipeIn); + } + if (curOutFile && (curOutFile != outputFile)) { + TclCloseFile(curOutFile); + } + if (curInFile && (curInFile != inputFile)) { + TclCloseFile(curInFile); + } + return 0; +} + +/* + *---------------------------------------------------------------------- + * + * TclCreatePipe -- + * + * Creates a pipe - simply calls the pipe() function. + * + * Results: + * Returns 1 on success, 0 on failure. + * + * Side effects: + * Creates a pipe. + * + *---------------------------------------------------------------------- + */ +int +TclCreatePipe(readPipe, writePipe) + Tcl_File *readPipe; /* Location to store file handle for + * read side of pipe. */ + Tcl_File *writePipe; /* Location to store file handle for + * write side of pipe. */ +{ + int pipeIds[2]; + + if (pipe(pipeIds) != 0) { + return 0; + } + + fcntl(pipeIds[0], F_SETFD, FD_CLOEXEC); + fcntl(pipeIds[1], F_SETFD, FD_CLOEXEC); + + *readPipe = Tcl_GetFile((ClientData)pipeIds[0], TCL_UNIX_FD); + *writePipe = Tcl_GetFile((ClientData)pipeIds[1], TCL_UNIX_FD); + return 1; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_CreatePipeline -- + * + * This function is a compatibility wrapper for TclCreatePipeline. + * It is only available under Unix, and may be removed from later + * versions. + * + * Results: + * Same as TclCreatePipeline. + * + * Side effects: + * Same as TclCreatePipeline. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_CreatePipeline(interp, argc, argv, pidArrayPtr, inPipePtr, + outPipePtr, errFilePtr) + Tcl_Interp *interp; + int argc; + char **argv; + int **pidArrayPtr; + int *inPipePtr; + int *outPipePtr; + int *errFilePtr; +{ + Tcl_File inFile, outFile, errFile; + int result; + + result = TclCreatePipeline(interp, argc, argv, pidArrayPtr, + (inPipePtr ? &inFile : NULL), + (outPipePtr ? &outFile : NULL), + (errFilePtr ? &errFile : NULL)); + + if (inPipePtr) { + if (inFile) { + *inPipePtr = (int) Tcl_GetFileInfo(inFile, NULL); + Tcl_FreeFile(inFile); + } else { + *inPipePtr = -1; + } + } + if (outPipePtr) { + if (outFile) { + *outPipePtr = (int) Tcl_GetFileInfo(outFile, NULL); + Tcl_FreeFile(outFile); + } else { + *outPipePtr = -1; + } + } + if (errFilePtr) { + if (errFile) { + *errFilePtr = (int) Tcl_GetFileInfo(errFile, NULL); + Tcl_FreeFile(errFile); + } else { + *errFilePtr = -1; + } + } + return result; +} diff --git a/contrib/tcl/unix/tclUnixPort.h b/contrib/tcl/unix/tclUnixPort.h new file mode 100644 index 0000000..1b78021 --- /dev/null +++ b/contrib/tcl/unix/tclUnixPort.h @@ -0,0 +1,413 @@ +/* + * tclUnixPort.h -- + * + * This header file handles porting issues that occur because + * of differences between systems. It reads in UNIX-related + * header files and sets up UNIX-related macros for Tcl's UNIX + * core. It should be the only file that contains #ifdefs to + * handle different flavors of UNIX. This file sets up the + * union of all UNIX-related things needed by any of the Tcl + * core files. This file depends on configuration #defines such + * as NO_DIRENT_H that are set up by the "configure" script. + * + * Much of the material in this file was originally contributed + * by Karl Lehenbauer, Mark Diekhans and Peter da Silva. + * + * Copyright (c) 1991-1994 The Regents of the University of California. + * Copyright (c) 1994-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: @(#) tclUnixPort.h 1.33 96/03/25 17:15:21 + */ + +#ifndef _TCLUNIXPORT +#define _TCLUNIXPORT + +#ifndef _TCLINT +# include "tclInt.h" +#endif +#include <errno.h> +#include <fcntl.h> +#ifdef HAVE_NET_ERRNO_H +# include <net/errno.h> +#endif +#include <pwd.h> +#include <signal.h> +#include <sys/param.h> +#include <sys/types.h> +#ifdef USE_DIRENT2_H +# include "../compat/dirent2.h" +#else +# ifdef NO_DIRENT_H +# include "../compat/dirent.h" +# else +# include <dirent.h> +# endif +#endif +#include <sys/file.h> +#ifdef HAVE_SYS_SELECT_H +# include <sys/select.h> +#endif +#include <sys/stat.h> +#if TIME_WITH_SYS_TIME +# include <sys/time.h> +# include <time.h> +#else +# if HAVE_SYS_TIME_H +# include <sys/time.h> +# else +# include <time.h> +# endif +#endif +#ifndef NO_SYS_WAIT_H +# include <sys/wait.h> +#endif +#ifdef HAVE_UNISTD_H +# include <unistd.h> +#else +# include "../compat/unistd.h" +#endif + +/* + * Socket support stuff: This likely needs more work to parameterize for + * each system. + */ + +#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() */ + +/* + * NeXT doesn't define O_NONBLOCK, so #define it here if necessary. + */ + +#ifndef O_NONBLOCK +# define O_NONBLOCK 0x80 +#endif + +/* + * HPUX needs the flag O_NONBLOCK to get the right non-blocking I/O + * semantics, while most other systems need O_NDELAY. Define the + * constant NBIO_FLAG to be one of these + */ + +#ifdef HPUX +# define NBIO_FLAG O_NONBLOCK +#else +# define NBIO_FLAG O_NDELAY +#endif + +/* + * The default platform eol translation on Unix is TCL_TRANSLATE_LF: + */ + +#define TCL_PLATFORM_TRANSLATION TCL_TRANSLATE_LF + +/* + * Not all systems declare the errno variable in errno.h. so this + * file does it explicitly. The list of system error messages also + * isn't generally declared in a header file anywhere. + */ + +extern int errno; + +/* + * The type of the status returned by wait varies from UNIX system + * to UNIX system. The macro below defines it: + */ + +#ifdef _AIX +# define WAIT_STATUS_TYPE pid_t +#else +#ifndef NO_UNION_WAIT +# define WAIT_STATUS_TYPE union wait +#else +# define WAIT_STATUS_TYPE int +#endif +#endif + +/* + * Supply definitions for macros to query wait status, if not already + * defined in header files above. + */ + +#ifndef WIFEXITED +# define WIFEXITED(stat) (((*((int *) &(stat))) & 0xff) == 0) +#endif + +#ifndef WEXITSTATUS +# define WEXITSTATUS(stat) (((*((int *) &(stat))) >> 8) & 0xff) +#endif + +#ifndef WIFSIGNALED +# define WIFSIGNALED(stat) (((*((int *) &(stat)))) && ((*((int *) &(stat))) == ((*((int *) &(stat))) & 0x00ff))) +#endif + +#ifndef WTERMSIG +# define WTERMSIG(stat) ((*((int *) &(stat))) & 0x7f) +#endif + +#ifndef WIFSTOPPED +# define WIFSTOPPED(stat) (((*((int *) &(stat))) & 0xff) == 0177) +#endif + +#ifndef WSTOPSIG +# define WSTOPSIG(stat) (((*((int *) &(stat))) >> 8) & 0xff) +#endif + +/* + * Define constants for waitpid() system call if they aren't defined + * by a system header file. + */ + +#ifndef WNOHANG +# define WNOHANG 1 +#endif +#ifndef WUNTRACED +# define WUNTRACED 2 +#endif + +/* + * Supply macros for seek offsets, if they're not already provided by + * an include file. + */ + +#ifndef SEEK_SET +# define SEEK_SET 0 +#endif + +#ifndef SEEK_CUR +# define SEEK_CUR 1 +#endif + +#ifndef SEEK_END +# define SEEK_END 2 +#endif + +/* + * The stuff below is needed by the "time" command. If this + * system has no gettimeofday call, then must use times and the + * CLK_TCK #define (from sys/param.h) to compute elapsed time. + * Unfortunately, some systems only have HZ and no CLK_TCK, and + * some might not even have HZ. + */ + +#ifdef NO_GETTOD +# include <sys/times.h> +# include <sys/param.h> +# ifndef CLK_TCK +# ifdef HZ +# define CLK_TCK HZ +# else +# define CLK_TCK 60 +# endif +# endif +#else +# ifdef HAVE_BSDGETTIMEOFDAY +# define gettimeofday BSDgettimeofday +# endif +#endif + +#ifdef GETTOD_NOT_DECLARED +EXTERN int gettimeofday _ANSI_ARGS_((struct timeval *tp, + struct timezone *tzp)); +#endif + +/* + * Define access mode constants if they aren't already defined. + */ + +#ifndef F_OK +# define F_OK 00 +#endif +#ifndef X_OK +# define X_OK 01 +#endif +#ifndef W_OK +# define W_OK 02 +#endif +#ifndef R_OK +# define R_OK 04 +#endif + +/* + * Define FD_CLOEEXEC (the close-on-exec flag bit) if it isn't + * already defined. + */ + +#ifndef FD_CLOEXEC +# define FD_CLOEXEC 1 +#endif + +/* + * On systems without symbolic links (i.e. S_IFLNK isn't defined) + * define "lstat" to use "stat" instead. + */ + +#ifndef S_IFLNK +# define lstat stat +#endif + +/* + * Define macros to query file type bits, if they're not already + * defined. + */ + +#ifndef S_ISREG +# ifdef S_IFREG +# define S_ISREG(m) (((m) & S_IFMT) == S_IFREG) +# else +# define S_ISREG(m) 0 +# endif +# endif +#ifndef S_ISDIR +# ifdef S_IFDIR +# define S_ISDIR(m) (((m) & S_IFMT) == S_IFDIR) +# else +# define S_ISDIR(m) 0 +# endif +# endif +#ifndef S_ISCHR +# ifdef S_IFCHR +# define S_ISCHR(m) (((m) & S_IFMT) == S_IFCHR) +# else +# define S_ISCHR(m) 0 +# endif +# endif +#ifndef S_ISBLK +# ifdef S_IFBLK +# define S_ISBLK(m) (((m) & S_IFMT) == S_IFBLK) +# else +# define S_ISBLK(m) 0 +# endif +# endif +#ifndef S_ISFIFO +# ifdef S_IFIFO +# define S_ISFIFO(m) (((m) & S_IFMT) == S_IFIFO) +# else +# define S_ISFIFO(m) 0 +# endif +# endif +#ifndef S_ISLNK +# ifdef S_IFLNK +# define S_ISLNK(m) (((m) & S_IFMT) == S_IFLNK) +# else +# define S_ISLNK(m) 0 +# endif +# endif +#ifndef S_ISSOCK +# ifdef S_IFSOCK +# define S_ISSOCK(m) (((m) & S_IFMT) == S_IFSOCK) +# else +# define S_ISSOCK(m) 0 +# endif +# endif + +/* + * Make sure that MAXPATHLEN is defined. + */ + +#ifndef MAXPATHLEN +# ifdef PATH_MAX +# define MAXPATHLEN PATH_MAX +# else +# define MAXPATHLEN 2048 +# endif +#endif + +/* + * Make sure that L_tmpnam is defined. + */ + +#ifndef L_tmpnam +# define L_tmpnam 100 +#endif + +/* + * The following macro defines the type of the mask arguments to + * select: + */ + +#ifndef NO_FD_SET +# define SELECT_MASK fd_set +#else +# ifndef _AIX + typedef long fd_mask; +# endif +# if defined(_IBMR2) +# define SELECT_MASK void +# else +# define SELECT_MASK int +# endif +#endif + +/* + * Define "NBBY" (number of bits per byte) if it's not already defined. + */ + +#ifndef NBBY +# define NBBY 8 +#endif + +/* + * The following macro defines the number of fd_masks in an fd_set: + */ + +#ifndef FD_SETSIZE +# ifdef OPEN_MAX +# define FD_SETSIZE OPEN_MAX +# else +# define FD_SETSIZE 256 +# endif +#endif +#if !defined(howmany) +# define howmany(x, y) (((x)+((y)-1))/(y)) +#endif +#ifndef NFDBITS +# define NFDBITS NBBY*sizeof(fd_mask) +#endif +#define MASK_SIZE howmany(FD_SETSIZE, NFDBITS) + +/* + * The following function is declared in tclInt.h but doesn't do anything + * on Unix systems. + */ + +#define TclSetSystemEnv(a,b) + +/* + * The following implements the Unix method for exiting the process. + */ +#define TclPlatformExit(status) exit(status) + +/* + * The following functions always succeeds under Unix. + */ + +#define TclHasSockets(interp) (TCL_OK) +#define TclHasPipes() (1) + +/* + * Variables provided by the C library: + */ + +#if defined(_sgi) || defined(__sgi) +#define environ _environ +#endif +extern char **environ; + +/* + * At present (12/91) not all stdlib.h implementations declare strtod. + * The declaration below is here to ensure that it's declared, so that + * the compiler won't take the default approach of assuming it returns + * an int. There's no ANSI prototype for it because there would end + * up being too many conflicts with slightly-different prototypes. + */ + +extern double strtod(); + +#endif /* _TCLUNIXPORT */ diff --git a/contrib/tcl/unix/tclUnixSock.c b/contrib/tcl/unix/tclUnixSock.c new file mode 100644 index 0000000..e5d293b --- /dev/null +++ b/contrib/tcl/unix/tclUnixSock.c @@ -0,0 +1,65 @@ +/* + * tclUnixSock.c -- + * + * This file contains Unix-specific socket related code. + * + * 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: @(#) tclUnixSock.c 1.5 96/04/04 15:28:39 + */ + +#include "tcl.h" +#include "tclPort.h" + +/* + * The following variable holds the network name of this host. + */ + +#ifndef SYS_NMLN +# define SYS_NMLN 100 +#endif + +static char hostname[SYS_NMLN + 1]; +static int hostnameInited = 0; + +/* + *---------------------------------------------------------------------- + * + * Tcl_GetHostName -- + * + * Get the network name for this machine, in a system dependent way. + * + * Results: + * A string containing the network name for this machine. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +char * +Tcl_GetHostName() +{ + struct utsname u; + struct hostent *hp; + + if (hostnameInited) { + return hostname; + } + + if (uname(&u) > -1) { + hp = gethostbyname(u.nodename); + if (hp != NULL) { + strcpy(hostname, hp->h_name); + } else { + strcpy(hostname, u.nodename); + } + hostnameInited = 1; + return hostname; + } + return (char *) NULL; +} diff --git a/contrib/tcl/unix/tclUnixTest.c b/contrib/tcl/unix/tclUnixTest.c new file mode 100644 index 0000000..1fc95e6 --- /dev/null +++ b/contrib/tcl/unix/tclUnixTest.c @@ -0,0 +1,378 @@ +/* + * tclUnixTest.c -- + * + * Contains platform specific test commands for the Unix platform. + * + * Copyright (c) 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: @(#) tclUnixTest.c 1.1 96/03/26 12:44:30 + */ + +#include "tclInt.h" +#include "tclPort.h" + +/* + * The stuff below is used to keep track of file handlers created and + * exercised by the "testfilehandler" command. + */ + +typedef struct Pipe { + Tcl_File readFile; /* File handle for reading from the + * pipe. NULL means pipe doesn't exist yet. */ + Tcl_File writeFile; /* File handle for writing from the + * pipe. */ + int readCount; /* Number of times the file handler for + * this file has triggered and the file + * was readable. */ + int writeCount; /* Number of times the file handler for + * this file has triggered and the file + * was writable. */ +} Pipe; + +#define MAX_PIPES 10 +static Pipe testPipes[MAX_PIPES]; + +/* + * Forward declarations of procedures defined later in this file: + */ + +static void TestFileHandlerProc _ANSI_ARGS_((ClientData clientData, + int mask)); +static int TestfilehandlerCmd _ANSI_ARGS_((ClientData dummy, + Tcl_Interp *interp, int argc, char **argv)); +static int TestgetopenfileCmd _ANSI_ARGS_((ClientData dummy, + Tcl_Interp *interp, int argc, char **argv)); +int TclplatformtestInit _ANSI_ARGS_((Tcl_Interp *interp)); + +/* + *---------------------------------------------------------------------- + * + * TclplatformtestInit -- + * + * Defines commands that test platform specific functionality for + * Unix platforms. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * Defines new commands. + * + *---------------------------------------------------------------------- + */ + +int +TclplatformtestInit(interp) + Tcl_Interp *interp; /* Interpreter to add commands to. */ +{ + Tcl_CreateCommand(interp, "testfilehandler", TestfilehandlerCmd, + (ClientData) 0, (Tcl_CmdDeleteProc *) NULL); + Tcl_CreateCommand(interp, "testgetopenfile", TestgetopenfileCmd, + (ClientData) 0, (Tcl_CmdDeleteProc *) NULL); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * TestfilehandlerCmd -- + * + * This procedure implements the "testfilehandler" command. It is + * used to test Tcl_CreateFileHandler, Tcl_DeleteFileHandler, and + * TclWaitForFile. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static int +TestfilehandlerCmd(clientData, interp, argc, argv) + ClientData clientData; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ + Pipe *pipePtr; + int i, mask, timeout; + static int initialized = 0; + char buffer[4000]; + Tcl_File file; + + /* + * NOTE: When we make this code work on Windows also, the following + * variable needs to be made Unix-only. + */ + + int fd; + + if (!initialized) { + for (i = 0; i < MAX_PIPES; i++) { + testPipes[i].readFile = NULL; + } + initialized = 1; + } + + if (argc < 2) { + Tcl_AppendResult(interp, "wrong # arguments: should be \"", argv[0], + " option ... \"", (char *) NULL); + return TCL_ERROR; + } + pipePtr = NULL; + if (argc >= 3) { + if (Tcl_GetInt(interp, argv[2], &i) != TCL_OK) { + return TCL_ERROR; + } + if (i >= MAX_PIPES) { + Tcl_AppendResult(interp, "bad index ", argv[2], (char *) NULL); + return TCL_ERROR; + } + pipePtr = &testPipes[i]; + } + + if (strcmp(argv[1], "close") == 0) { + for (i = 0; i < MAX_PIPES; i++) { + if (testPipes[i].readFile != NULL) { + Tcl_DeleteFileHandler(testPipes[i].readFile); + + /* + * NOTE: Unix specific code below. + */ + + fd = (int) Tcl_GetFileInfo(testPipes[i].readFile, NULL); + close(fd); + Tcl_FreeFile(testPipes[i].readFile); + + testPipes[i].readFile = NULL; + Tcl_DeleteFileHandler(testPipes[i].writeFile); + + /* + * NOTE: Unix specific code below. + */ + + fd = (int) Tcl_GetFileInfo(testPipes[i].writeFile, NULL); + Tcl_FreeFile(testPipes[i].writeFile); + close(fd); + } + } + } else if (strcmp(argv[1], "clear") == 0) { + if (argc != 3) { + Tcl_AppendResult(interp, "wrong # arguments: should be \"", + argv[0], " clear index\"", (char *) NULL); + return TCL_ERROR; + } + pipePtr->readCount = pipePtr->writeCount = 0; + } else if (strcmp(argv[1], "counts") == 0) { + if (argc != 3) { + Tcl_AppendResult(interp, "wrong # arguments: should be \"", + argv[0], " counts index\"", (char *) NULL); + return TCL_ERROR; + } + sprintf(interp->result, "%d %d", pipePtr->readCount, + pipePtr->writeCount); + } else if (strcmp(argv[1], "create") == 0) { + if (argc != 5) { + Tcl_AppendResult(interp, "wrong # arguments: should be \"", + argv[0], " create index readMode writeMode\"", + (char *) NULL); + return TCL_ERROR; + } + if (pipePtr->readFile == NULL) { + if (!TclCreatePipe(&pipePtr->readFile, &pipePtr->writeFile)) { + Tcl_AppendResult(interp, "couldn't open pipe: ", + Tcl_PosixError(interp), (char *) NULL); + return TCL_ERROR; + } +#ifdef O_NONBLOCK + fcntl((int)Tcl_GetFileInfo(pipePtr->readFile, NULL), + F_SETFL, O_NONBLOCK); + fcntl((int)Tcl_GetFileInfo(pipePtr->writeFile, NULL), + F_SETFL, O_NONBLOCK); +#else + interp->result = "can't make pipes non-blocking"; + return TCL_ERROR; +#endif + } + pipePtr->readCount = 0; + pipePtr->writeCount = 0; + + if (strcmp(argv[3], "readable") == 0) { + Tcl_CreateFileHandler(pipePtr->readFile, TCL_READABLE, + TestFileHandlerProc, (ClientData) pipePtr); + } else if (strcmp(argv[3], "off") == 0) { + Tcl_DeleteFileHandler(pipePtr->readFile); + } else if (strcmp(argv[3], "disabled") == 0) { + Tcl_CreateFileHandler(pipePtr->readFile, 0, + TestFileHandlerProc, (ClientData) pipePtr); + } else { + Tcl_AppendResult(interp, "bad read mode \"", argv[3], "\"", + (char *) NULL); + return TCL_ERROR; + } + if (strcmp(argv[4], "writable") == 0) { + Tcl_CreateFileHandler(pipePtr->writeFile, TCL_WRITABLE, + TestFileHandlerProc, (ClientData) pipePtr); + } else if (strcmp(argv[4], "off") == 0) { + Tcl_DeleteFileHandler(pipePtr->writeFile); + } else if (strcmp(argv[4], "disabled") == 0) { + Tcl_CreateFileHandler(pipePtr->writeFile, 0, + TestFileHandlerProc, (ClientData) pipePtr); + } else { + Tcl_AppendResult(interp, "bad read mode \"", argv[4], "\"", + (char *) NULL); + return TCL_ERROR; + } + } else if (strcmp(argv[1], "empty") == 0) { + if (argc != 3) { + Tcl_AppendResult(interp, "wrong # arguments: should be \"", + argv[0], " empty index\"", (char *) NULL); + return TCL_ERROR; + } + + /* + * NOTE: Unix specific code below. + */ + + fd = (int) Tcl_GetFileInfo(pipePtr->readFile, NULL); + while (read(fd, buffer, 4000) > 0) { + /* Empty loop body. */ + } + } else if (strcmp(argv[1], "fill") == 0) { + if (argc != 3) { + Tcl_AppendResult(interp, "wrong # arguments: should be \"", + argv[0], " empty index\"", (char *) NULL); + return TCL_ERROR; + } + + /* + * NOTE: Unix specific code below. + */ + + fd = (int) Tcl_GetFileInfo(pipePtr->writeFile, NULL); + memset((VOID *) buffer, 'a', 4000); + while (write(fd, buffer, 4000) > 0) { + /* Empty loop body. */ + } + } else if (strcmp(argv[1], "fillpartial") == 0) { + if (argc != 3) { + Tcl_AppendResult(interp, "wrong # arguments: should be \"", + argv[0], " empty index\"", (char *) NULL); + return TCL_ERROR; + } + + /* + * NOTE: Unix specific code below. + */ + + fd = (int) Tcl_GetFileInfo(pipePtr->writeFile, NULL); + memset((VOID *) buffer, 'b', 10); + sprintf(interp->result, "%d", write(fd, buffer, 10)); + } else if (strcmp(argv[1], "oneevent") == 0) { + Tcl_DoOneEvent(TCL_FILE_EVENTS|TCL_DONT_WAIT); + } else if (strcmp(argv[1], "wait") == 0) { + if (argc != 5) { + Tcl_AppendResult(interp, "wrong # arguments: should be \"", + argv[0], " wait index readable/writable timeout\"", + (char *) NULL); + return TCL_ERROR; + } + if (pipePtr->readFile == NULL) { + Tcl_AppendResult(interp, "pipe ", argv[2], " doesn't exist", + (char *) NULL); + return TCL_ERROR; + } + if (strcmp(argv[3], "readable") == 0) { + mask = TCL_READABLE; + file = pipePtr->readFile; + } else { + mask = TCL_WRITABLE; + file = pipePtr->writeFile; + } + if (Tcl_GetInt(interp, argv[4], &timeout) != TCL_OK) { + return TCL_ERROR; + } + i = TclWaitForFile(file, mask, timeout); + if (i & TCL_READABLE) { + Tcl_AppendElement(interp, "readable"); + } + if (i & TCL_WRITABLE) { + Tcl_AppendElement(interp, "writable"); + } + } else if (strcmp(argv[1], "windowevent") == 0) { + Tcl_DoOneEvent(TCL_WINDOW_EVENTS|TCL_DONT_WAIT); + } else { + Tcl_AppendResult(interp, "bad option \"", argv[1], + "\": must be close, clear, counts, create, empty, fill, ", + "fillpartial, oneevent, wait, or windowevent", + (char *) NULL); + return TCL_ERROR; + } + return TCL_OK; +} + +static void TestFileHandlerProc(clientData, mask) + ClientData clientData; /* Points to a Pipe structure. */ + int mask; /* Indicates which events happened: + * TCL_READABLE or TCL_WRITABLE. */ +{ + Pipe *pipePtr = (Pipe *) clientData; + + if (mask & TCL_READABLE) { + pipePtr->readCount++; + } + if (mask & TCL_WRITABLE) { + pipePtr->writeCount++; + } +} + +/* + *---------------------------------------------------------------------- + * + * TestgetopenfileCmd -- + * + * This procedure implements the "testgetopenfile" command. It is + * used to get a FILE * value from a registered channel. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static int +TestgetopenfileCmd(clientData, interp, argc, argv) + ClientData clientData; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ + ClientData filePtr; + + if (argc != 3) { + Tcl_AppendResult(interp, + "wrong # args: should be \"", argv[0], + " channelName forWriting\"", + (char *) NULL); + return TCL_ERROR; + } + if (Tcl_GetOpenFile(interp, argv[1], atoi(argv[2]), 1, &filePtr) + == TCL_ERROR) { + return TCL_ERROR; + } + if (filePtr == (ClientData) NULL) { + Tcl_AppendResult(interp, + "Tcl_GetOpenFile succeeded but FILE * NULL!", (char *) NULL); + return TCL_ERROR; + } + return TCL_OK; +} diff --git a/contrib/tcl/unix/tclUnixTime.c b/contrib/tcl/unix/tclUnixTime.c new file mode 100644 index 0000000..96d29bf --- /dev/null +++ b/contrib/tcl/unix/tclUnixTime.c @@ -0,0 +1,217 @@ +/* + * tclUnixTime.c -- + * + * Contains Unix specific versions of Tcl functions that + * obtain time values from the operating system. + * + * 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: @(#) tclUnixTime.c 1.10 96/02/15 11:58:41 + */ + +#include "tclInt.h" +#include "tclPort.h" + +/* + *----------------------------------------------------------------------------- + * + * TclGetSeconds -- + * + * This procedure returns the number of seconds from the epoch. On + * most Unix systems the epoch is Midnight Jan 1, 1970 GMT. + * + * Results: + * Number of seconds from the epoch. + * + * Side effects: + * None. + * + *----------------------------------------------------------------------------- + */ + +unsigned long +TclGetSeconds() +{ + return time((time_t *) NULL); +} + +/* + *----------------------------------------------------------------------------- + * + * TclGetClicks -- + * + * This procedure returns a value that represents the highest resolution + * clock available on the system. There are no garantees on what the + * resolution will be. In Tcl we will call this value a "click". The + * start time is also system dependant. + * + * Results: + * Number of clicks from some start time. + * + * Side effects: + * None. + * + *----------------------------------------------------------------------------- + */ + +unsigned long +TclGetClicks() +{ + unsigned long now; +#ifdef NO_GETTOD + struct tms dummy; +#else + struct timeval date; + struct timezone tz; +#endif + +#ifdef NO_GETTOD + now = (unsigned long) times(&dummy); +#else + gettimeofday(&date, &tz); + now = date.tv_sec*1000000 + date.tv_usec; +#endif + + return now; +} + +/* + *---------------------------------------------------------------------- + * + * TclGetTimeZone -- + * + * Determines the current timezone. The method varies wildly + * between different platform implementations, so its hidden in + * this function. + * + * Results: + * Hours east of GMT. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +int +TclGetTimeZone (currentTime) + unsigned long currentTime; +{ + /* + * Determine how a timezone is obtained from "struct tm". If there is no + * time zone in this struct (very lame) then use the timezone variable. + * This is done in a way to make the timezone variable the method of last + * resort, as some systems have it in addition to a field in "struct tm". + * The gettimeofday system call can also be used to determine the time + * zone. + */ + +#if defined(HAVE_TM_TZADJ) +# define TCL_GOT_TIMEZONE + time_t curTime = (time_t) currentTime; + struct tm *timeDataPtr = localtime(&curTime); + int timeZone; + + timeZone = timeDataPtr->tm_tzadj / 60; + if (timeDataPtr->tm_isdst) { + timeZone += 60; + } + + return timeZone; +#endif + +#if defined(HAVE_TM_GMTOFF) && !defined (TCL_GOT_TIMEZONE) +# define TCL_GOT_TIMEZONE + time_t curTime = (time_t) currentTime; + struct tm *timeDataPtr = localtime(¤tTime); + int timeZone; + + timeZone = -(timeDataPtr->tm_gmtoff / 60); + if (timeDataPtr->tm_isdst) { + timeZone += 60; + } + + return timeZone; +#endif + + /* + * Must prefer timezone variable over gettimeofday, as gettimeofday does + * not return timezone information on many systems that have moved this + * information outside of the kernel. + */ + +#if defined(HAVE_TIMEZONE_VAR) && !defined (TCL_GOT_TIMEZONE) +# define TCL_GOT_TIMEZONE + static int setTZ = 0; + int timeZone; + + if (!setTZ) { + tzset(); + setTZ = 1; + } + + /* + * Note: this is not a typo in "timezone" below! See tzset + * documentation for details. + */ + + timeZone = timezone / 60; + + return timeZone; +#endif + +#if defined(HAVE_GETTIMEOFDAY) && !defined (TCL_GOT_TIMEZONE) +# define TCL_GOT_TIMEZONE + struct timeval tv; + struct timezone tz; + int timeZone; + + gettimeofday(&tv, &tz); + timeZone = tz.tz_minuteswest; + if (tz.tz_dsttime) { + timeZone += 60; + } + + return timeZone; +#endif + +#ifndef TCL_GOT_TIMEZONE + /* + * Cause compile error, we don't know how to get timezone. + */ + error: autoconf did not figure out how to determine the timezone. +#endif + +} + +/* + *---------------------------------------------------------------------- + * + * TclGetTime -- + * + * Gets the current system time in seconds and microseconds + * since the beginning of the epoch: 00:00 UCT, January 1, 1970. + * + * Results: + * Returns the current time in timePtr. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +void +TclGetTime(timePtr) + Tcl_Time *timePtr; /* Location to store time information. */ +{ + struct timeval tv; + struct timezone tz; + + (void) gettimeofday(&tv, &tz); + timePtr->sec = tv.tv_sec; + timePtr->usec = tv.tv_usec; +} |
