diff options
| author | cvs2fossil <cvs2fossil> | 1999-02-19 02:17:04 (GMT) |
|---|---|---|
| committer | cvs2fossil <cvs2fossil> | 1999-02-19 02:17:04 (GMT) |
| commit | c78065296b1912e5d37bfdf52a39f33b1b1ad6e8 (patch) | |
| tree | 87ec50b593f8b962e619e10d77b9322ad677da11 | |
| parent | c1ea1fac3d9e8068d1921cfc1dad655ef1d5af0c (diff) | |
| download | tcl-scriptics_tclpro_1_2_synthetic.zip tcl-scriptics_tclpro_1_2_synthetic.tar.gz tcl-scriptics_tclpro_1_2_synthetic.tar.bz2 | |
Created branch scriptics-tclpro-1-2-syntheticscriptics_tclpro_1_2scriptics_tclpro_1_2_synthetic
| -rw-r--r-- | README | 376 | ||||
| -rw-r--r-- | changes | 3742 | ||||
| -rw-r--r-- | doc/DString.3 | 145 | ||||
| -rw-r--r-- | doc/Notifier.3 | 537 | ||||
| -rw-r--r-- | doc/OpenFileChnl.3 | 499 | ||||
| -rw-r--r-- | doc/regexp.n | 145 | ||||
| -rw-r--r-- | generic/tcl.h | 1580 | ||||
| -rw-r--r-- | generic/tclFCmd.c | 816 | ||||
| -rw-r--r-- | generic/tclIO.c | 6053 | ||||
| -rw-r--r-- | generic/tclIOUtil.c | 872 | ||||
| -rw-r--r-- | generic/tclInt.h | 2147 | ||||
| -rw-r--r-- | generic/tclParse.c | 938 | ||||
| -rw-r--r-- | generic/tclTest.c | 3096 | ||||
| -rw-r--r-- | generic/tclUtil.c | 2843 | ||||
| -rw-r--r-- | mac/README | 195 | ||||
| -rw-r--r-- | tests/README | 96 | ||||
| -rw-r--r-- | tests/env.test | 152 | ||||
| -rw-r--r-- | tests/event.test | 567 | ||||
| -rw-r--r-- | tests/http.test | 417 | ||||
| -rw-r--r-- | tests/parse.test | 556 | ||||
| -rw-r--r-- | tests/pkgMkIndex.test | 340 | ||||
| -rw-r--r-- | tests/socket.test | 1593 | ||||
| -rw-r--r-- | tools/README | 4 | ||||
| -rw-r--r-- | tools/configure.in | 34 | ||||
| -rw-r--r-- | tools/tcl.hpj.in (renamed from tools/tcl.hpj) | 0 | ||||
| -rw-r--r-- | unix/Makefile.in | 1049 | ||||
| -rw-r--r-- | unix/README | 103 | ||||
| -rw-r--r-- | unix/configure.in | 1307 | ||||
| -rw-r--r-- | win/README | 189 | ||||
| -rw-r--r-- | win/README.binary | 518 | ||||
| -rw-r--r-- | win/makefile.vc | 488 | ||||
| -rw-r--r-- | win/pkgIndex.tcl | 11 | ||||
| -rw-r--r-- | win/stub16.c | 198 | ||||
| -rw-r--r-- | win/tcl.rc | 42 | ||||
| -rw-r--r-- | win/tcl16.rc | 37 | ||||
| -rw-r--r-- | win/tclWinFCmd.c | 1401 | ||||
| -rw-r--r-- | win/tclWinFile.c | 647 | ||||
| -rw-r--r-- | win/tclsh.rc | 36 |
38 files changed, 0 insertions, 33769 deletions
@@ -1,376 +0,0 @@ -Tcl - -RCS: @(#) $Id: README,v 1.13 1999/02/09 03:31:55 stanton Exp $ - -1. Introduction ---------------- - -This directory and its descendants contain the sources and documentation -for Tcl, an embeddable scripting language. The information here -corresponds to release 8.0.5, which is the fifth patch update for Tcl 8.0. -This patch includes many bug fixes; see the "changes" file for a complete -list. Tcl 8.0 is a major new release that replaces the core of the -interpreter with an on-the-fly bytecode compiler to improve execution -speed. It also includes several other new features such as namespaces and -binary I/O, plus many bug fixes. The compiler introduces a few -incompatibilities that may affect existing Tcl scripts; the -incompatibilities are relatively obscure but may require modifications to -some old scripts before they can run with this version. The compiler -introduces many new C-level APIs, but the old APIs are still supported. -See below for more details. - -2. Documentation ----------------- - -The best way to get started with Tcl is to read one of the introductory -books on Tcl: - - Practical Programming in Tcl and Tk, 2nd Edition, by Brent Welch, - Prentice-Hall, 1997, ISBN 0-13-616830-2 - - Tcl and the Tk Toolkit, by John Ousterhout, - Addison-Wesley, 1994, ISBN 0-201-63337-X - - Exploring Expect, by Don Libes, - O'Reilly and Associates, 1995, ISBN 1-56592-090-2 - -Other books are listed at -http://www.scriptics.com/resource/doc/books/ -http://www.tclconsortium.org/resources/books.html - -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.scriptics.com -These Web pages include information about the latest releases, products -related to Tcl and Tk, 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, Macintoshes, and several 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 Scriptics Tcl Resource Center - (http://www.scriptics.com/resource). Also, check in - the FTP directory from which you retrieved the base - distribution. - - (b) Make sure you have the most recent patch release. Look in the - FTP directory from which you retrieved this distribution to see - if it has been updated with patches. Patch releases fix bugs - without changing any features, so you should normally use the - latest patch release for the version of Tcl that you want. - Patch releases are available in two forms. A file like - tcl8.0.5.tar.Z is a complete release for patch level 5 of Tcl - version 8.0. If there is a file with a higher patch level than - this release, just fetch the file with the highest patch level - and use it. - -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 8.0 --------------------------------- - -Here are the most significant changes in Tcl 8.0. In addition to these -changes, there are several smaller changes and bug fixes. See the file -"changes" for a complete list of all changes. - - 1. Bytecode compiler. The core of the Tcl interpreter has been - replaced with an on-the-fly compiler that translates Tcl scripts to - byte codes; a new interpreter then executes the byte codes. In - earlier versions of Tcl, strings were used as a universal - representation; in Tcl 8.0 strings are replaced with Tcl_Obj - structures ("objects") that can hold both a string value and an - internal form such as a binary integer or compiled bytecodes. The - new objects make it possible to store information in efficient - internal forms and avoid the constant translations to and from - strings that occurred with the old interpreter. We have not yet - converted all of Tcl to take full advantage of the compiler and - objects and have not converted any of Tk yet, but even so you - should see speedups of 2-3x on many programs and you may see - speedups as much as 10-20x in some cases (such as code that - manipulates long lists). Future releases should achieve even - greater speedups. The compiler introduces only a few minor changes - at the level of Tcl scripts, but it introduces many new C APIs for - managing objects. See, for example, the manual entries doc/*Obj*.3. - - 2. Namespaces. There is a new namespace mechanism based on the - namespace implementation by Michael McLennan of Lucent Technologies. - This includes new "namespace" and "variable" commands. There are - many new C APIs associated with namespaces, but they will not be - exported until Tcl 8.1. Note: the syntax of the namespace command - has been changed slightly since the b1 release. See the changes - file for details. - - 3. Binary I/O. The new object system in Tcl 8.0 supports binary - strings (internally, strings are counted in addition to being null - terminated). There is a new "binary" command for inserting and - extracting data to/from binary strings. Commands such as "puts", - "gets", and "read" commands now operate correctly on binary data. - There is a new variable tcl_platform(byteOrder) to identify the - native byte order for the current host. - - 4. Random numbers. The "expr" command now contains a random number - generator, which can be accessed via the "rand()" and "srand()" math - functions. - - 5. Safe-Tcl enhancements. There is a new "hidden command" - mechanism, implemented with the Tcl commands "interp hide", "interp - expose", "interp invokehidden", and "interp hidden" and the C APIs - Tcl_HideCommand and Tcl_ExposeCommand. There is now support for - safe packages and extension loading, including new library - procedures such as safe::interpCreate (see the manual entry safe.n - for details). - - 6. There is a new package "registry" available under Windows for - accessing the Windows registry. - - 7. There is a new command "file attributes" for getting and setting - things like permissions and owner. There is also a new command - "file nativename" for getting back the platform-specific name for a - particular file. - - 8. There is a new "fcopy" command to copy data between channels. - This replaces and improves upon the not-so-secret unsupported old - command "unsupported0". - - 9. There is a new package "http" for doing GET, POST, and HEAD - requests via the HTTP/1.0 protocol. See the manual entry http.n - for details. - - 10. There are new library procedures for finding word breaks in - strings. See the manual entry library.n for details. - - 11. There are new C APIs Tcl_Finalize (for cleaning up before - unloading the Tcl DLL) and Tcl_Ungets for pushing bytes back into a - channel's input buffer. - - 12. Tcl now supports serial I/O devices on Windows and Unix, with a - new fconfigure -mode option. The Windows driver does not yet - support event-driven I/O. - - 13. The lsort command has new options -dictionary and -index. The - -index option allows for very rapid sorting based on an element - of a list. - - 14. The event notifier has been completely rewritten (again). It - should now allow Tcl to use an external event loop (like Motif's) - when it is embedded in other applications. No script-level - interfaces have changed, but many of the C APIs have. - -Tcl 8.0 introduces the following incompatibilities that may affect Tcl -scripts that worked under Tcl 7.6 and earlier releases: - - 1. Variable and command names may not include the character sequence - "::" anymore: this sequence is now used as a namespace separator. - - 2. The semantics of some Tcl commands have been changed slightly to - maximize performance under the compiler. These incompatibilities - are documented on the Web so that we can keep the list up-to-date. - See the URL http://www.sunlabs.com/research/tcl/compiler.html. - - 3. 2-digit years are now parsed differently by the "clock" command - to handle year 2000 issues better (years 00-38 are treated as - 2000-2038 instead of 1900-1938). - - 4. The old Macintosh commands "cp", "mkdir", "mv", "rm", and "rmdir" - are no longer supported; all of these features are now available on - all platforms via the "file" command. - - 5. The variable tcl_precision is now shared between interpreters - and defaults to 12 digits instead of 6; safe interpreters cannot - modify tcl_precision. The new object system in Tcl 8.0 causes - floating-to-string conversions (and the associated rounding) to - occur much less often than in Tcl 7.6, which can sometimes cause - behavioral changes. - - 6. The C APIs associated with the notifier have changed substantially. - - 7. The procedures Tcl_CreateModalTimeout and Tcl_DeleteModalTimeout - have been removed. - - 8. Tcl_CreateFileHandler and Tcl_DeleteFileHandler now take Unix - fd's and are only supported on the Unix platform - - 9. The C APIs for creating channel drivers have changed as part of - the new notifier implementation. The Tcl_File interfaces have been - removed. Tcl_GetChannelFile has been replaced with - Tcl_GetChannelHandle. Tcl_MakeFileChannel now takes a platform- - specific file handle. Tcl_DriverGetOptionProc procedures now take - an additional interp argument. - -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. Tcl Resource Center ----------------------- -Visit http://www.scritics.com/resource/ to see an annotated index of -many Tcl resources available on the World Wide Web. This includes -papers, books, and FAQs, as well as extensions, applications, binary -releases, and patches. You can contribute patches by sending them -to <patches@scriptics.com>. You can also recommend more URLs for the -resource center using the forms labeled "Add a Resource". - -8. Mailing lists ----------------- - -A couple of Mailing List have been set up to discuss Macintosh or -Windows related Tcl issues. In order to use these Mailing Lists you -must have access to the internet. To subscribe send a message to: - - wintcl-request@tclconsortium.org - mactcl-request@tclconsortium.org - -In the body of the message (the subject will be ignored) put: - - subscribe mactcl Joe Blow - -Replacing Joe Blow with your real name, of course. (Use wintcl -instead of mactcl if your interested in the Windows list.) If you -would just like to receive more information about the list without -subscribing put the line: - - information mactcl - -in the body instead (or wintcl). - -9. 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 Scriptics. We'll see -anything on comp.lang.tcl, and in addition someone else who reads -comp.lang.tcl may be able to offer a solution. The normal turn-around -time for bugs is 3-6 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 -Scriptics (info@scriptics.com), NeoSoft (info@neosoft.com), -Computerized Processes Unlimited (gwl@cpu.com), -and Data Kinetics (education@dkl.com). - -10. Tcl version numbers ----------------------- - -You can test the current version of Tcl by examining the -tcl_version and tcl_patchLevel variables. The tcl_patchLevel -variable follows the naming rules outlined below (e.g., 8.0.4). -The tcl_version just has the major.minor numbers in it (e.g., 8.0) - -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. - -(Note: This compatibility is true for Tcl scripts, but historically the Tcl -C APIs have changed enough between releases that you may need to work a bit to -upgrade extensions.) - -Patch releases have a suffix such as p1 or p2. These releases contain -bug fixes only. A patch release (e.g Tcl 7.6p2) should be completely -compatible with the base release from which it is derived (e.g. Tcl -7.6), and you should normally use the highest available patch release. - -As of 8.0.3, the patch releases use a second . instead of 'p'. So, -the 8.0 release went to 8.0p1, 8.0p2, 8.0.3, 8.0.4, and 8.0.5. The -alphas and betas will still use the 'a' and 'b' letters in their -tcl_patchLevel. - diff --git a/changes b/changes deleted file mode 100644 index 7b34909..0000000 --- a/changes +++ /dev/null @@ -1,3742 +0,0 @@ -Recent user-visible changes to Tcl: - -RCS: @(#) $Id: changes,v 1.41 1999/02/03 19:12:25 stanton Exp $ - -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. (JL) -*** 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 ----------------------- - -5/1/96 (bug fix) "file tail ~" did not correctly return the tail -portion of the user's home directory. (SS) - -5/1/96 (bug fix) Fixed bug in TclGetEnv where it didn't lookup environment -variables correctly: could confuse "H" and "HOME", for example. (JO) - -5/1/96 (bug fix) Changed to install tclConfig.sh under "make install-binaries", -not "make install-libraries". (JO) - -5/2/96 (bug fix) Changed pkg_mkIndex not to attempt to "load" a file unless -it has the standard shared library extension. On SunOS, attempts to load -Tcl scripts cause the whole application to be aborted (there's no way to -get the error back into Tcl). (JO) - -5/7/96 (bug fix) Moved initScript in tclUnixInit.c to writable memory to -avoid potential core dumps. (JO) - -5/7/96 (bug fix) Auto_reset procedure was removing procedure from init.tcl, -such as pkg_mkIndex. (JO) - -5/7/96 (bug fix) Fixed cast on socket address resolution code that -would cause a failure to connect on Dec Alphas. (JL) - -5/7/96 (bug fix) Added "time", "subst" and "fileevent" commands to set of -commands available in a safe interpreter. (JL) - -5/13/96 (bug fix) Preventing OS level handles for stdin, stdout and stderr -from being implicitly closed when the last reference to the standard -channel containing that handle is discarded when an interpreter is deleted. -Explicitly closing standard channels by using "close" still works. (JL) - -5/21/96 (bug fix) Do not create channels for stdin, stdout and stderr on -Unix if the devices are closed. This prevents a duplicate channel name -panic later on when the fd is used to open a channel and the channel is -registered in an interpreter. (JL) - -5/23/96 (bug fix) Fixed bug that prevented the use of standard channels in -interpreters created after the last interpreter was destroyed. In the sequence - - interp = Tcl_CreateInterp(); - Tcl_DeleteInterp(interp); - interp = Tcl_CreateInterp(); - -channels for stdio would not be available in the second interpreter. (JL) - -5/23/96 (bug fix) Fixed bug that allowed Tcl_MakeFileChannel to create new -channels with Tcl_Files in them that are already used by another channel. -This would cause core dumps when the Tcl_Files were being freed twice. (JL) - -5/23/96 (bug fix) Fixed a logical timing bug that caused a standard channel -to be removed from the standard channel table too early when the channel -was being closed. If the channel was being flushed asynchronously, it could -get recreated before being actually destroyed, and the recreated channel -would contain the same Tcl_File as the one being closed, leading to -dangling pointers and core dumps. (JL) - -5/27/96 (bug fix) Fixed a bug in Tcl_GetChannelOption which caused it to -always return a list of one element, a list of the settings, for --translation and -eofchar options. Now correctly returns the value -described by the documentation (Mark Diekhans found this, thanks!). (JL) - -5/30/96 (bug fix) Fixed a couple of syntax errors in io.test. (JL) - -5/30/96 (bug fix) If a fileevent scripts gets an error, delete it before -causing a background error. This is to allow the error handler to reinstall -the fileevent and to prevent infinite loops if the event loop is reentered -in the error handler. (JL) - -5/31/96 (bug fix) Channels now will get properly flushed on exit. (JL) - -6/5/96 (bug fix) Changed Tcl_Ckalloc, Tcl_Ckfree, and Tcl_Ckrealloc to -Tcl_Alloc, Tcl_Free, and Tcl_Realloc. Added documentation for these -routines now that they are officially supported. Extension writers -should use these routines instead of free() and malloc(). (SS) - -6/10/96 (bug fix) Changes the Tcl close command so that it no longer -waits on nonblocking pipes for the piped processes to exit; instead it -reaps them in the background. (JL) - -6/11/96 (bug fix) Increased the length of the listen queue for server -sockets on Unix from 5 to 100. Some OSes will disregard this and reset it -to 5, but we should try to get as long a queue as we can, for performance -reasons. (JL) - -6/11/96 (bug fix) Fixed windows sockets bug that caused a cascade of events -if the fileevent script read less than was available. Now reading less than -is available does not cause a flood of Tcl events. (JL, SS) - -6/11/96 (bug fix) Fixed bug in background flushing on closed channels that -would prevent the last buffer from getting flushed. (JL) - -6/13/96 (bug fix) Fixed bug in Windows sockets that caused a core dump if -a DLL linked with tcl.dll and referred to e.g. ntohs() without opening a -Tcl socket. The problem was that the indirection table was not being -initialized. (JL) - -6/13/96 (bug fix) Fixed OS level resource leak that would occur when a -Tcl channel was still registered in some interpreter when the process -exits. Previously the channel was not being closed and the OS level handles -were not being released; the output was being flushed but the device was -not being closed. Now the device is properly closed. This was only a -problem on Win3.1 and MacOS. (JL, SS) - -6/28/96 (bug fix) Fixed bug where transient errors were leaving an error -code around, so that it would erroneously get reported later. This bug was -exercised intermittently by closing a channel to a file on a very loaded -NFS server, or to a socket whose other end blocked. (JL, BW) - -7/3/96 (bug fix) Fileevents declared in an interpreter are now deleted -when the channel is closed in that interpreter. Before this fix, the -fileevent would hang around until the channel is completely closed, and -would cause errors if events happened before the channel was closed. This -could happen in two cases: first if the channel is shared between several -interpreters, and second if an async flush is in progress that prevents the -channel from being closed until the flush finishes. (JL) - -7/10/96 (bug fix) Fixed bugs in both "lrange" and "lreplace" commands -where too much white space was being removed. For example, the command - lreplace {\}\ hello} end end -was returning "\}\", losing the significant space in the first list -element and corrupting the list. (JO) - -7/20/96 (bug fix) The procedure pkg_mkIndex didn't work properly for -extensions that depend on Tk, because it didn't load Tk into the child -interpreter before loading the extension. Now it loads Tk if Tk is -present in the parent. (JO) - -7/23/96 (bug fix) Added compat version of strftime to fix crashes -resulting from bad implementations under Windows. (SS) - -7/23/96 (bug fix) Standard implementations of gmtime() and localtime() -under Windows did not handle dates before 1970, so they were replaced -with a revised implementation. (SS) - -7/23/96 (bug fix) Tcl would crash on exit under Borland 5.0 because -the global environ pointer was left pointing to freed memory. (SS) - -7/29/96 (bug fix) Fixed memory leak in Tcl_LoadCmd that could occur if -a package's AppInit procedure called Tcl_StaticPackage to register -static packages. (JO) - -8/1/96 (bug fix) Fixed a series of bugs in Windows sockets so that async -writebehind in the presence of read event handlers now works, and so that -async writebehind also works on sockets for which a read event handler was -declared and whose channels were then closed before the async write -finished. The bug was reported by John Loverso and Steven Wahl, -independently, test case supplied by John Loverso. (JL) - ------------------ Released patch 7.5p1, 8/2/96 ----------------------- - -5/8/96 (new feature) Added Tcl_GetChannelMode C API for retrieving whether -a channel is open for reading and writing. (JL) - -5/8/96 (API changes) Revised C APIs for channel drivers: - - Removed all Tcl_Files from channel driver interface; you can now have - channels that are not based on Tcl_Files. - - Added channelReadyProc and watchChannelProc procedures to interface; - these are used to implement event notification for channels. - - Added getFileProc to channel driver, to allow the generic IO code - to retrieve a Tcl_File from a channel (presumably if the channel - uses Tcl_Files they will be stored inside its instanceData). (JL) -*** INCOMPATIBILITY with Tcl 7.5 *** - -5/8/96 (API change) The Tcl_CreateChannel C API was modified to not take -Tcl_File arguments, and instead to take a mask specifying whether the -channel is readable and/or writable. (JL) -*** INCOMPATIBILITY with Tcl 7.5 *** - -6/3/96 (bug fix) Made Tcl_SetVar2 robust against the case where the value -of the variable is a NULL pointer instead of "". (JL) - -6/17/96 (bug fix) Fixed "reading uninitialized memory" error reported by -Purify, in Tcl_Preserve/Tcl_Release. (JL) - -8/9/96 (bug fix) Fixed bug in init.tcl that caused incorrect error message -if the act of autoloading a procedure caused the procedure to be invoked -again. (JO) - -8/9/96 (bug fix) Configure script produced bad library names and extensions -under SunOS and a few other platforms if the --disable-load switch was used. -(JO) - -8/9/96 (bug fix) Tcl_UpdateLinkedVar generated an error if the variable -being updated was read-only. (JO) - -8/14/96 (bug fix) The macintosh now supports synchronous socket -connections. Other minor bugs were also fixed. (RJ) - -8/15/96 (configuration improvement) Changed the file patchlevel.h -to be tclPatch.h. This avoids conflict with the Tk file and is now -in 8.3 format on the Windows platform. (RJ) - -8/20/96 (bug fix) Fixed core dump in interp alias command for interpreters -created with Tcl_CreateInterp (as opposed to with Tcl_CreateSlave). (JL) - -8/20/96 (bug fix) No longer masking ECONNRESET on Windows sockets so -that the higher level of the IO mechanism sees the error instead of -entering an infinite loop. (JL) - -8/20/96 (bug fix) Destroying the last interpreter no longer closes the -standard channels. (JL) - -8/20/96 (bug fix) Closing one of the stdin, stdout or stderr channels and -then opening a new channel now correctly assigns the new channel as the -standard channel that was closed. (JL) - -8/20/96 (bug fix) Added code to unix/tclUnixChan.c for using ioctl with -FIONBIO instead of fcntl with O_NONBLOCK, for those versions of Unix where -either O_NONBLOCK is not supported or implemented incorrectly. (JL) - -8/21/96 (bug fix) Fixed "file extension" so it correctly returns the -extension on files like "foo..c" as "..c" instead of ".c". (SS) - -8/22/96 (bug fix) If environ[] contains static strings, Tcl would core -dump in TclSetupEnv because it was trying to write NULLs into the actual -data in environ[]. Now we instead copy as appropriate. (JL) - -8/22/96 (added impl) Added missing implementation of Tcl_MakeTcpClientChannel -for Windows platform. Code contributed by Mark Diekhans. (JL) - -8/22/96 (new feature) Added a new memory allocator for the Macintosh -version of Tcl. It's quite a bit faster than MetroWerk's version. (RJ) - -8/26/96 (documentation update) Removed old change bars (for all changes -in Tcl 7.5 and earlier releases) from manual entries. (JO) - -8/27/96 (enhancement) The exec and open commands behave better and work in -more situations under Windows NT and Windows 95. Documentation describes -what is still lacking. (CS) - -8/27/96 (enhancement) The Windows makefiles will now compile even if the -compiler is not in the path and/or the compiler's environment variables -have not been set up. (CS) - -8/27/96 (configuration improvement) The Windows resource files are -automatically updated when the version/patch level changes. The header file -now has a comment that reminds the user which other files must be manually -updated when the version/patch level changes. (CS) - -8/28/96 (new feature) Added file manipulation features (copy, rename, delete, -mkdir) that are supported on all platforms. They are implemented as -subcommands to the "file" command. See the documentation for the "file" -command for more information. (JH) - ------------------ Released 7.6b1, 8/30/96 ----------------------- - -9/3/96 (bug fix) Simplified code so that standard channels are created -lazily, they are added to an interpreter lazily, and they are never added -to a safe interpreter. (JL) - -9/3/96 (bug fix) Closing a channel after closing a standard channel, e.g. -stdout, would cause the implicit recreation of that standard channel. (JL) - -9/3/96 (new feature) Now calling Tcl_RegisterChannel with a NULL -interpreter increments the refcount so that code outside any interpreter -can use channels that are also registered in interpreters, without worrying -that the channel may turn into a dangling pointer at any time. Calling -Tcl_UnregisterChannel with a NULL interpreter only decrements the recount -so that code outside any interpreter can safely declare it is no longer -interested in a channel. (JL) - -9/4/96 (new features) Two changes to dynamic loading: - - If the file name is empty in the "load" command and there is no - statically loaded version of the package, a dynamically loaded - version will be used if there is one. - - Tcl_StaticPackage ignores redundant calls for the same package. (JO) - -9/6/96 (bug fix) Platform specific procedures for manipulating files are -no longer macros and have been prefixed with "Tclp", such as TclpRenameFile. -Unix file code now handles symbolic links and other special files correctly. -The semantics of file copy and file rename has been changed so that if -a target directory exists, the source files will NOT be merged with the -existing files. (JH) - -9/6/96 (bug fix) If standard channel is NULL, because Tcl cannot connect -to the standard channel, do not increment the refcount. The channel can -be NULL if there is for example no standard input. (JL) - -9/6/96 (portability improvement) Changed parsing of backslash sequences -like \n to translate directly to absolute values like 0xa instead of -letting the compiler do the translation. This guarantees that the -translation is done the same everywhere. (JO) - -9/9/96 (bug fix) If channel is opened and not associated with any -interpreter, but Tcl decides to use it as one of the standard channels, it -became impossible to close the channel with Tcl_Close -- instead you had -to call Tcl_UnregisterChannel. Fixed now so that it's safe to call -Tcl_Close even when Tcl is using the channel as one of the standard ones. (JL) - -9/11/96 (feature change) The Tcl library is now placed in the Tcl -shared libraries resource. You no longer need to place the Tcl files -in your applications explicitly. (RJ) - -9/11/96 (feature change) Extensions no longer automatically have the -resource fork of the extension opened for it. Instead you need to -use the tclMacLibrary.c file in your extension. (RJ) -*** POTENTIAL INCOMPATIBILITY *** - -9/12/96 (bug fix) The extension loading mechanism on the Macintosh now -looks at the 'cfrg' resource to determine where to load the code -fragment from. This means FAT fragments should now work. (RJ) - -9/18/96 (enhancement) The exec and open commands behave better and work in -more situations under Windows 3.X. Documentation describes what is still -lacking. (CS) - -9/19/96 (bug fix) Fixed a panic which would occur if you delete a -non-existent alias before any aliases are created. Now instead correctly -returns an error that the alias is not found. (JL) - -9/19/96 (bug fix) Slave interpreters could rename aliases and they would -not get deleted when the alias was being redefined. This led to dangling -pointers etc. (JL) - -9/19/96 (bug fix) Fixed a panic where a hash table entry was being deleted -twice during alias management operations. (JL) - -9/19/96 (bug fix) Fixed bug in event loop that could cause the input focus -in Tk to get confused during menu traversal, among other problems. The -problem was related to handling of the "marker" when its event was -deleted. (JO) - -9/26/96 (bug fix) Windows was losing EOF on a socket if the FD_CLOSE event -happened to precede any left over FD_READ events. Now correctly remembers -seeing FD_CLOSE, so that trailing FD_READ events are not discarded if they -do not contain any data. This allows Tcl to correctly get a zero read and -notice EOF. (JL) - -9/26/96 (bug fix) Was not resetting READABLE state properly on sockets -under Windows if the driver discarded an FD_READ event because no data was -present. Now correctly resets the state. (JL) - -9/30/96 (bug fix) Made EOF sticky on Windows sockets, so that fileevent -readable will fire repeatedly until the socket is closed. Previously the -fileevent fired only once. This could lead to never-closed connections if -the Tcl script in the fileevent wasn't closing the socket immediately. (JL) - -10/2/96 (new feature) Improved the package loader: - - Added new variable tcl_pkgPath, which holds the default - directories under which packages are normally installed (each - package goes in a separate subdirectory of a directory in - $tcl_pkgPath). These directories are included in auto_path by - default. - - Changed the package auto-loader to look for pkgIndex.tcl files - not only in the auto_path directories but also in their immediate - children. This should make it easier to install and uninstall - packages (don't have to change auto_path or merge pkgIndex.tcl - files). (JO) - -10/3/96 (bug fix) Changed tclsh to look for tclshrc.tcl instead of -tclsh.rc on startup under Windows. This is more consistent with wish and -uses the right extension. (SS) -*** POTENTIAL INCOMPATIBILITY *** - -10/8/96 (bug fix) Convertclock does not parse 24-hour times of the -form "hhmm" correctly when hour = 00. In the parse code, hour must be ->= 100 for minutes to be non-zero. Thanks to Lint LaCour for this -bug fix. (RJ) - -10/11/96 (bug fix) Under Windows, the pid command returned the process -handle instead of the process id. (SS) - ------------------ Released 7.6, 10/16/96 ----------------------- - -10/29/96 (bug fix) Under Windows, sockets would consume 100% CPU time after -the first accept(), due to a typo. (JL) - -10/29/96 (bug fix) Incorrect refcount management caused standard channels -not to get deleted at process exit or DLL unload time, causing a memory -leak of upwards of 20K each time. (JL) - -11/7/96 (bug fix) Auto-exec didn't work on file names that contained -spaces. (JO) - -11/8/96 (bug fix) Fixed core dump that would occur if more than one call -to Tcl_DeleteChannelHandler was made to delete a given channel handler. (JL) - -11/8/96 (bug fix) Fixed test for return value in Tcl_Seek and Tcl_SeekCmd -to only treat -1 as error, instead of all negative numbers. (JL) - -11/12/96 (bug fix) Do not blocking waiting for processes at the end of a -pipe during exit cleanup. (JL) - -11/12/96 (bug fix) If we are in exit cleanup, do not close the system level -file descriptors 0, 1 and 2. Previously they were being closed which is -incorrect, in the embedded case. This led to weird behavior for programs -that want to interpose on I/O through the standard file descriptors (e.g. -Netscape Navigator). (JL) - -11/15/96 (bug fix) Fixed core dump on Windows sockets due to dependency on -deletion order at exit. Now all socket functions check to see if sockets -are (still) initialized, before calling through function pointers. Before, -they would call and might end up calling unloaded object code. (JL) - -11/15/96 (bug fix) Fixed core dump in Windows socket initialization routine -if sockets were not installed on the system. Before, it was not properly -checking the result of attempting to load the socket DLL, so it would call -through uninitialized function pointers. (JL) - -11/15/96 (bug fix) Fixed memory leak in Windows sockets which left socket -DLL handle open and could hold the socket DLL in memory uneccessarily, -until a reboot. (JL) - -12/4/96 (bug fix) Fixed bug in Macintosh socket code that could result -in lost data if a client was closed too soon after sending data. (RJ) - -12/17/96 (bug fix) Fixed deadlock bug in Windows sockets due to losing an -event. This was happening because of an interaction between buffering and -nonblocking mode on sockets. Now switched to sockets being blocking by -default, so we are also no longer emulating blocking through a private -event loop. (JL) - -1/21/97 (performance bug fix) Client TCP connections were slow to create -because getservbyname was always called on the port. Now this is only -done if Tcl_GetInt fails. (BW) - -1/21/97 (configuration fix) Made it possible to override TCL_PACKAGE_PATH -during make. Previously it was only set during autoconf process. - -1/29/97 (bug fix) Fixed some problems with the clock command that -impacted how dates were scaned after the year 2000. (RJ) - ------------------ Released 7.6p2, 1/31/97 ----------------------- - -2/5/97 (bug fix) Fixed a bug where in CR-LF translation mode, \r bytes -in the input stream were not being handled correctly. (JL) - -2/24/97 (bug fix) Fix bug with exec under Win32s not being able to create -stderr file which caused all execs to fail. Fixed temp file leak under -Win32s. Fixed optional parameter bug with SearchPath that only happened -under Win32s 1.25. (CCS) - ----------------------------------------------------------- -Changes for Tcl 7.6 go above this line. -Changes for Tcl 7.7 go below this line. ----------------------------------------------------------- - -5/8/96 (new feature) Added Tcl_Ungets C API for putting a sequence of bytes -into a channel's input buffer. This can be used for "push" model channels -where the input is obtained via callbacks instead of by request of the -generic IO code. No Tcl procedure yet. (JL) - -11/15/96 (new feature) Implemented hidden commands. New C APIs: - Tcl_HideCommand -- hides an existing exposed command. - Tcl_ExposeCommand -- exposes an existing hidden command. -New tcl APIs: - interp invokehidden -- invokes a hidden command in a slave. - interp hide -- hides an existing exposed command. - interp expose -- exposes an existing hidden command. - interp hidden -- returns a list of hidden commands. -The implementation of Safe Tcl now uses the new hidden commands facility -to implement the safe base, instead of deleting the commands from a safe -interpreter. (JL) - -11/15/96 (new feature) Implemented the safe base, a mechanism for -installing and requesting security policies, purely in Tcl code. Overloads -the package command to also allow an interpreter to "require" a policy. The -following new library commands are provided: - tcl_safeCreateInterp -- creates a slave an initializes the - policy mechanism. - tcl_safeInitInterp -- initializes an existing slave with the - policy mechanism. - tcl_safeDeleteInterp -- deletes a slave and deinitializes the - policy mechanism. -Added a new file to the library, safeinit.tcl, to hold implementation. (JL) -On 7/9/97, removed the policy loading mechanism from the Safe Base. Left -only the Safe Base aliases dealing with auto-loading and source. (JL) - -12/6/96 (new feature) Implemented Tcl_Finalize, an API that should be -called by a process when it is done using Tcl. This API runs all the exit -handlers to allow them to clean up resources etc. (JL) - -12/17/96 (new feature) Add an http Tcl script package to the Tcl library. -This package implements the client side of HTTP/1.0; the GET, HEAD, -and POST requests. (BW) - -1/21/97 (new feature) Added a "marktrusted" subcommand to the "interp" and -to the interpreter object command. It removes the "safe" mark on an -interpreter and disables hard-wired checks for safety in the C sources. (JL) - -1/21/97 (removed feature) Removed "vwait" from set of commands available in -a safe interpreter. (JL) - -2/11/97 (new feature, bug fix) http package. Added -accept to http_config -so you can set the Accept header. Added -handler option to http_get so -you can supply your own data handler. Also fixed POST operation to -set the correct MIME type on the request. (BW) - ----------------------------------------------------------- -Changes for Tcl 7.7 go above this line. -Changes for Tcl 8.0 go below this line. ----------------------------------------------------------- - -9/17/96 (bug fix) Using "upvar" it was possible to turn an array element -into an array itself. Changed to disallow this; it was quirky and didn't -really work correctly anyway. (JO) - -10/21/96 (new feature) The core of the Tcl interpreter has been replaced -with an on-the-fly compiler that translates Tcl scripts to bytecoded -instructions; a new interpreter then executes the bytecodes. The compiler -introduces only a few minor changes at the level of Tcl scripts. The biggest -changes are to expressions and lists. - - A second level of substitutions is no longer done for expressions. - This substantially improves their execution time. This means that - the expression "$x*4" produces a different result than in the past - if x is "$y+2". Fortunately, not much code depends on the old - two-level semantics. Some expressions that do, such as - "expr [join $list +]" can be recoded to work in Tcl8.0 by adding - an eval: e.g., "eval expr [join $list +]". - - Lists are now completely parsed on the first list operation to - create a faster internal representation. In the past, if you had a - misformed list but the erroneous part was after the point you - inserted or extracted an element, then you never saw an error. - In Tcl8.0 an error will be reported. This should only effect - incorrect programs that took advantage of behavior of the old - implementation that was not documented in the man pages. -Other changes to Tcl scripts are discussed in the web page at -http://www.sunlabs.com/research/tcl/compiler.html. (BL) -*** POTENTIAL INCOMPATIBILITY *** - -10/21/96 (new feature) In earlier versions of Tcl, strings were used as a -universal representation; in Tcl 8.0 strings are replaced with Tcl_Obj -structures ("objects") that can hold both a string value and an internal -form such as a binary integer or compiled bytecodes. The new objects make it -possible to store information in efficient internal forms and avoid the -constant translations to and from strings that occurred with the old -interpreter. There are new many new C APIs for managing objects. Some of the -new library procedures for objects (such as Tcl_EvalObj) resemble existing -string-based procedures (such as Tcl_Eval) but take advantage of the -internal form stored in Tcl objects for greater speed. Other new procedures -manage objects and allow extension writers to define new kinds of objects. -See the manual entries doc/*Obj*.3 (BL) - -10/24/96 (bug fix) Fixed memory leak on exit caused by some IO related -data structures not being deallocated on exit because their refcount was -artificially boosted. (JL) - -10/24/96 (bug fix) Fixed core dump in Tcl_Close if called with NULL -Tcl_Channel. (JL) - -11/19/96 (new feature) Added library procedures for finding word -breaks in strings in a platform specific manner. See the library.n -manual entry for more information. (SS) - -11/22/96 (feature improvements) Added support for different levels of -tracing during bytecode compilation and execution. This should help in -tracking down suspected problems with the compiler or with converting -existing code to use Tcl8.0. Two global Tcl variables, traceCompile -and traceExec, can be set to generate tracing information in stdout: - - traceCompile: 0 no tracing (default) - 1 trace compilations of top level commands and procs - 2 trace and display instructions for all compilations - - traceExec: 0 no tracing - 1 trace only calls to Tcl procs - 2 trace invocations of all commands including procs - 3 detailed trace showing the result of each instruction -traceExec >= 2 provides a one line summary of each called command and -its arguments. Commands that have been "compiled away" such as set are -not shown. (BL) - -11/30/96 (bug fix) The command "info nameofexecutable" could sometimes -return the name of a directory. (JO) - -11/30/96 (feature improvements) Changed the code in library/init.tcl -that reads in pkgIndex.tcl so that (a) it reads the files from child -directories before those in the parent, so that the parent gets -precedence, and (b) it doesn't quit if there is an error in a -pkgIndex.tcl file; instead, it prints an error message on standard -error and continues. (JO) - -10/5/96 (feature improvements) Partial implementation of binary string -support: the ability for Tcl string values to contain embedded null bytes. -Changed the Tcl object-based APIs to take a byte pointer and length pair -instead of a null-terminated C string. Modified several object type managers -to support binary strings but not, for example, the list type manager. -Existing string-based C APIs are unchanged and will truncate binary -strings. Compiled scripts containing nulls are also truncated. (BL) - -12/12/96 (feature change) Removed the commands "cp", "mkdir", "mv", -"rm", and "rmdir" from the Macintosh version of Tcl. They were never -officially supported and their functionality is now available via -the file command. (RJ) - ------------------ Released 8.0a1, 12/20/96 ----------------------- - -1/7/97 (bug fix) Under Windows, "file stat c:" was returning error instead -of stat for current dir on c: drive. - -1/10/97 (new feature) Added Tcl_GetIndexFromObj procedure for quick -lookups of keyword arguments. (JO) - -1/12/97 (new feature) Serial IO channel drivers for Windows and Unix, -available by using Tcl open command to open pseudo-files like "com1:" or -"/dev/ttya". New option to Tcl fconfigure command for serial files: -"-mode baud,parity,data,stop" to specify baud rate, parity, data bits, and -stop bits. Serial IO is not yet available on Mac. - -1/16/97 (feature change) Restored the Tcl7.x "two level substitution -semantics" for expressions. Expressions not enclosed in braces are -implemented, in general, by calling the expr command procedure -(Tcl_ExprObjCmd) at runtime after the Tcl interpreter has already done a -first round of substitutions. This is slow (about Tcl7.x speed) because new -code for the expression is generally compiled each time. However, if the -expression has only variable substitutions (and not command substitutions), -"optimistic" fast code is generated inline. This inline code will fail if a -second round of substitutions is needed (i.e., if the value of a substituted -variable itself requires more substitutions). The optimistic code will -catch the error and back off to call the slower but guaranteed correct -expr command procedure. (BL) - -1/16/97 (feature improvements) Added Tcl_ExprLongObj and Tcl_ExprDoubleObj -to round out expression-related procedures. (BL) - -1/16/97 (feature change) Under Windows, at startup the environment variables -"path", "comspec", and "windir" in any capitalization are converted -automatically to upper case. The PATH variable could be spelled as path, -Path, PaTh, etc. and it makes programming rather annoying. All other -environment variables are left alone. (CS) - -1/20/97 (new features) Rewrote the "lsort" command: - - The new version is based on reentrant merge sort code provided - by Richard Hipp, so it eliminates the reentrancy and stability - problems with the old qsort-based implementation. - - The new version supports a -dictionary option for sorting, and - it also supports a -index option for sorting lists using one - element for comparison. - - The new version is an object command, so it works well with the - Tcl compiler, especially in conjunction with the new -index - option. When the -index option is used, this version of lsort - is more than 100 times faster than the Tcl 7.6 lsort, which had - to use the -command option to get the same effect. (JO) - -1/20/97 (feature improvements) Added the improved debugging support for Tcl -objects prototyped by Karl Lehenbauer <karl@hammer1.ops.NeoSoft.com>. -If TCL_MEM_DEBUG is defined, the object creation calls use Tcl_DbCkalloc -directly in order to record the caller's source file name and line -number. (BL) - -1/21/97 (removed feature) Desupported the tcl_precision variable: if -set, it is ignored. Tcl now uses the full 17 digits of precision when -converting real numbers to strings (with the new object system real -numbers are rarely converted to strings so there is no efficiency -disadvantage to printing all 17 digits; the new scheme improves -accuracy and simplifies several APIs). (JO) -*** POTENTIAL INCOMPATIBILITY *** - -1/21/97 (feature change) Removed the "interp" argument for the -procedures Tcl_GetStringFromObj, Tcl_StringObjAppend, and -Tcl_StringObjAppendObj. Also removed the "interp" argument for -the updateStringProc procedure in Tcl_ObjType structures. With -the tcl_precision changes above, these are no longer needed. (JO) -*** POTENTIAL INCOMPATIBILITY with Tcl 8.0a1, but not with Tcl 7.6 *** - -1/22/97 (bug fix) Fixed http.tcl so that http_reset does not result in -an extra call to the command callback. In addition, if the transaction -gets a premature eof, the state(status) is "eof", not "ok". (BW) - ------------------ Released 8.0a2, 1/24/97 ----------------------- - -1/29/97 (feature change) Changed how two digit years are parsed in the -clock command. The old interface just added 1900 which will seem -broken by the year 2000. The new scheme follows the POSIX standard -and treats dates 70-99 as 1970-1999 and dates 00-38 as 2000-2038. All -other two digit dates are undefined. (RJ) -*** POTENTIAL INCOMPATIBILITY *** - -2/4/97 (bug fix) Fixed bug in clock code that dealt with relative -dates. Using the relative month code you could get an invalid date -because it jumped into a non-existant day. (For example, Jan 31 -to Feb 31.) The code now will return the last valid day of the -month in these situations. Thanks to Hume Smith for sending in -this bug fix. (RJ) - -2/10/97 (feature change) Eliminated Tcl_StringObjAppend and -Tcl_StringObjAppendObj procedures, replaced them with Tcl_AppendToObj -and Tcl_AppendStringsToObj procedures. Added new procedure -Tcl_SetObjLength. (JO) -*** POTENTIAL INCOMPATIBILITY with Tcl 8.0a2, but not with Tcl 7.6 *** - -2/10/97 (new feature) Added Tcl_WrongNumArgs procedure for generating -error messages about incorrect number of arguments. (JO) - -2/11/97 (new feature, bug fix) http package. Added -accept to http_config -so you can set the Accept header. Added -handler option to http_get so -you can supply your own data handler. Also fixed POST operation to -set the correct MIME type on the request. (BW) - -2/22/97 (bug fix) Fixed bug that caused $tcl_platform(osVersion) to be -computed incorrectly under AIX. (JO) - -2/25/97 (new feature, feature change) Added support for both int and long -integer objects. Added Tcl_NewLongObj/Tcl_GetLongFromObj/Tcl_SetLongFromObj -procedures and renamed the Tcl_Obj internalRep intValue member to -longValue. Tcl_GetIntFromObj now checks for integer values too large to -represent as non-long integers. Changed Tcl_GetAllObjTypes to -Tcl_AppendAllObjTypes. (BL) - -3/5/97 (new feature) Added new Tcl_SetListObj procedure to round out -collection of procedures that set the type and value of existing Tcl -objects. (BL) - -3/6/97 (new feature) Added -global flag for interp invokehidden. (JL) - -3/6/97 (new feature, feature change) Added isNativeObjectProc field to the -Tcl_CmdInfo structure to indicate (when 1) if the command has an -object-based command procedure. Removed the nameLength arg from -Tcl_CreateObjCommand since command names can't contain null characters. (BL) - -3/6/97 (bug fix) Fixed bug in "unknown" procedure that caused auto- -loading to fail on commands whose names begin with digits. (JO) - -3/7/97 (bug fix) Auto-loading now works in Safe Base. Safe interpreters -only accept the Version 2 and onwards tclIndex files. (JL) - -3/13/97 (bug fix) Fixed core dump due to interaction between aliases and -hidden commands. Bug found by Lindsay Marshall. (JL) - -3/14/97 (bug fix) Fixed mac bugs relating to time. The -gmt option -now adjusts the time in the correct direction. (Thanks to Ed Hume for -reporting a fix to this problem.) Also fixed file "mtime" etc. to -return times from GMT rather than local time zone. (RJ) - -3/18/97 (feature change) Declaration of objv in Tcl_ObjCmdProc function -changed from "Tcl_Obj *objv[]" to "Tcl_Obj *CONST objv[]". All Tcl object -commands changed to use new declaration of objv. Naive translation of -string-based command procs to object-based command procs could very easily -have yielded code where the contents of the objv array were changed. This -is not a problem with string-based command procs, but doing something as -simple as objv[2] = objv[3] would corrupt the runtime stack and cause Tcl to -crash. Introduced CONST in declaration of objv so that attempted assignment -of new pointer values to elements of the objv array will be caught by the -compiler. (CCS) -*** POTENTIAL INCOMPATIBILITY with Tcl 8.0a2 *** - -3/19/97 (bug fix) Fixed panic due to object sharing. The root cause was -that old code was using Tcl_ResetResult instead of Tcl_ResetObjResult. (JL) - -3/20/97 (new feature) Added a new subcommand for the file -command. file attributes filename can give a list of platform-specific -options (such as file/creator type on the Mac, permissions on Unix) or -set the values of them. Added a new subcommand for the file -command. file nativename name gives back the platform-specific form -for the file. This is useful when the filename is needed to pass to -the OS, such as exec under Windows 95 or AppleScript on the Mac. For -more info, see file.n. (SRP) - -3/24/97 (removed feature) Removed the tcl_safePolicyPath procedure. Now -the policy path is computed from the auto_path by appending the directory -'policies' to each element. Also fixed several bugs in automatic tracking -of auto_path by computed policy path. (JL) -*** POTENTIAL INCOMPATIBILITY with Tcl 8.0a2 but not with Tcl 7.6 *** - -4/8/97 (new feature) If the variable whose name is passed to lappend doesn't -already exist, and there are no value arguments, lappend now creates the -variable with an empty value instead of returning an error. Change suggested -by Tom Tromey. (BL) - -4/9/97 (feature change) Changed the name of the TCL_PART1_NOT_PARSED flag to -TCL_PARSE_PART1. (BL) -*** POTENTIAL INCOMPATIBILITY with Tcl 8.0a2 but not with Tcl 7.6 *** - -4/10/97 (bug fixes) Fixed various compilation-related bugs: - - "UpdateStringOfCmdName should never be invoked" panic. - - Bad code generated for expressions not in {}'s inside catch commands. - - Segmentation fault in some command procedures when two argument - object pointers refer to the same object. - - Second level of substitutions were never done for expressions not - in {}'s that consist of a single variable reference: e.g., - "set x 27; set bool {$x}; if $bool {puts foo}" would fail with error. - - Bad code generated when code storage was grown while compiling some - expressions: ones with compilation errors or consisting of only a - variable reference. - - Bugs involving multiple interpreters: wasn't checking that a - procedure's code was compiled for the same interpreter as the one - executing it, and didn't invalidate code on hidden-exposed command - transitions. - - "Bad stack top" panic when executing scripts that require a huge - amount of stack space. - - Incorrect sharing of code for procedure bodies, and procedure code - deallocated before last execution of the procedure finished. - - Fixed compilation of expression words in quotes. For example, - if "0 < 3" {puts foo}. - - Fixed performance bug in array set command with large assignments. - - Tcl_SetObjLength segmentation fault setting length of empty object. - - If Tcl_SetObjectResult was passed the same object as the interpreter's - result object, it freed the object instead of doing nothing. Bug fix - by Michael J. McLennan. - - Tcl_ListObjAppendList inserted elements from the wrong list. Bug fix - by Michael J. McLennan. - - Segmentation fault if empty variable list was specified in a foreach - command. Bug fix by Jan Nijtmans. - - NULL command name was always passed to Tcl_CreateTrace callback - procedure. - - Wrong string representation generated for the value LONG_MIN. - For example, expr 1<<31 printed incorrectly on a 32 bit machine. - - "set {a($x)} 1" stored value in wrong variable. - - Tcl_GetBooleanFromObj was not checking for garbage after a numeric - value. - - Garbled "bad operand type" error message when evaluating expressions - not surrounded by {}'s. (BL) - -4/16/97 (new feature) The expr command now has the "rand()" and -"srand()" functions for getting random numbers in expr. (RJ) - -4/23/97 (bug fix) Fixed core dump in bgerror when the error handler command -deletes the current interpreter. Found by Juergen Schoenwald. (JL) - -4/23/97 (feature change) The notifier interfaces have been redesigned -to make embedding in applications with external event loops possible. -A number of interfaces in the notifier and the channel drivers have -changed. Refer to the Notifier.3 and CrtChannel.3 manual entries for -more details. (SS) -*** POTENTIAL INCOMPATIBILITY *** - -4/23/97 (removed feature) The Tcl_File interfaces have been removed. -The Tcl_CreateFileHandler/Tcl_DeleteFileHandler interfaces now take -Unix fd's and are only supported on the Unix platform. -Tcl_GetChannelFile has been replaced with Tcl_GetChannelHandle. -Tcl_MakeFileChannel now takes a platform specific file handle. (SS) -*** POTENTIAL INCOMPATIBILITY *** - -4/23/97 (removed feature) The modal timeout interface has been -removed (Tcl_CreateModalTimeout/Tcl_DeleteModalTimeout) (SS) -*** POTENTIAL INCOMPATIBILITY *** - -4/23/97 (feature change) Channel drivers are now required to correctly -implement blocking behavior when they are in blocking mode. (SS) -*** POTENTIAL INCOMPATIBILITY *** - -4/23/97 (new feature) Added the "binary" command for manipulating -binary strings. Also, changed the "puts", "gets", and "read" commands -to preserve embedded nulls. (SS) - -4/23/97 (new feature) Added tcl_platform(byteOrder) element to the -tcl_platform array to identify the native byte order for the current -host. (SS) - -4/23/97 (bug fix) Fixed bug in date parsing around year boundaries. (SS) - -4/24/97 (bug fix) In the process of copying a file owned by another user, -Tcl was changing the owner of the copy back to the owner of the original -file, therefore causing further file operations to fail because the current -user didn't own the copy anymore. The owner of the copy is now left as the -current user. (CCS) - -4/24/97 (feature change) Under Windows, don't automatically uppercase the -environment variable "windir" -- it's supposed to be lower case. (CCS) - -4/29/97 (new feature) Added namespace support based on a namespace -implementation by Michael J. McLennan of Lucent Technologies. A namespace -encapsulates a collection of commands and variables to ensure that they -won't interfere the commands and variables of other namespaces. The global -namespace holds all global variables and commands. Additional namespaces are -created with the new namespace command. The new variable command lets you -create Tcl variables inside a namespace. The names of Tcl variables and -commands may now be qualified by the name of the namespace containing them. -The key namespace-related commands are summarized below: - - namespace ?eval? name arg ?arg...? - Used to define the commands and variables in a namespace. - Optionally creates the namespace. - - namespace export ?-clear? ?pattern pattern...? - Specifies which commands are exported from a namespace. These - are the ones that can be imported into another namespace. - - namespace import ?-force? ?pattern pattern...? - Makes the specified commands accessible in the current namespace. - - namespace current - Returns the name of the current namespace. - - variable name ?value? ?name ?value?...? - Creates one or more namespace variables. (BTL) - -5/1/97 (bug fix) Under Windows, file times were reported in GMT. Should be -reported in local time. (CCS) - -5/2/97 (feature change) Changed the name of the two Tcl variables used for -tracing bytecode compilation and execution to tcl_traceCompile and -tcl_traceExec respectively. These variables are now documented in the -tclvars man page. (BL) - -5/5/97 (new feature) Support "end" as the index for "lsort -index". (BW) - -5/5/97 (bug fixes) Cleaned up the way the http package resets connections (BW) - -5/8/97 (feature change) Newly created Tcl objects now have a reference count -of zero instead of one. This simplifies C code that stores newly created -objects in Tcl variables or in data structures such as list objects. That C -code must increment the new object's reference count since the variable or -data structure will contain a long-term reference to the object. Formerly, -when new objects started out with reference count one, it was necessary to -decrement the new object's reference count after the store to make sure it -was left with the correct value; this is no longer necessary. (BL) - -5/9/97 (new feature) Added the Tcl_GetsObj interface that takes an -object reference instead of a dynamic string (as in Tcl_Gets). (SS) - -5/12/97 (new feature) Added Tcl_CreateAliasObj and Tcl_GetAliasObj C APIs -to allow an alias command to be created with a vector of Tcl_Obj structures -and to get the vector back later. (JL) - -5/12/97 (feature change) Changed Tcl_ExposeCommand and Tcl_HideCommand to -leave an object result instead of a string result. (JL) - -5/14/97 (feature change) Improved the handling of the interpreter result. -This is still either an object or a string, but the two values are now kept -consistent unless some C code reads or writes interp->result directly. See -the SetResult man page for details. Removed the Tcl_ResetObjResult -procedure. (BL) -*** POTENTIAL INCOMPATIBILITY with Tcl 8.0a2 *** - -5/16/97 (new feature) Added "fcopy" command to move data between -channels. Refer to the manual page for more information. Removed the -"unsupported0" command since it is obsolete now. (SS) - -5/16/97 (new feature) Added Tcl_GetStringResult procedure to allow programs -to get an interpreter's result as a string. If the result was previously set -to an object, this procedure will convert the object to a string. Use of -Tcl_GetStringResult is intended to replace direct access to interp->result, -which is not safe. (BL) - -5/20/97 (new features) Fixed "fcopy" to return the number of bytes -transferred in the blocking case. Updated the http package to use -fcopy instead of unsupported0. Added -timeout and -handler options to -http_get. http_get is now blocking by default. It is only non-blocking -if you supply a -command argument. (BW) - -5/22/97 (bug fix) Fixed several bugs in the "lsort" command having to do -with the -dictionary option and the presence of numbers embedded in the -strings. (JO) - ------------------ Released 8.0b1, 5/27/97 ----------------------- - -6/2/97 (bug fix) Fixed bug in startup code that caused a problem in -finding the library files when they are installed in a directory -containing a space in the name. (SS) - -6/2/97 (bug fix) Fixed bug in Unix notifier where the select mask was -not being cleared under some circumstances. (SS) - -6/4/97 (bug fix) Fixed bug that prevented creation of Tk widgets in -namespaces. Tcl_CreateObjCommand and Tcl_CreateCommand now always create -commands in the global namespace unless the command names are qualified. Tcl -procedures continue to be created in the current namespace by default. (BL) - -6/6/97 (new features) Added new namespace API procedures -Tcl_AppendExportList and Tcl_Export to allow C code to get and set a -namespace's export list. (BL) - -6/11/97 (new feature) Added Tcl_ConcatObj. This object-based routine -parallels the string-based routine Tcl_Concat. (SRP) - -6/11/97 (new feature) Added Tcl_SetObjErrorCode. This object-based -routines parallels the string-based routine Tcl_SetErrorCode. (SRP) - -6/12/97 (bug fix) Fix the "unknown" procedure so that wish under Windows -will exec an external program, instead of always complaining "console1 not -opened for writing". (CCS) - -6/12/97 (bug fix) Fixed core dump experienced by the following simple -script: - interp create x - x alias exec exec - interp delete x -This panic was caused by not installing the new CmdDeleteProc when exec -got redefined by the alias creation step. Reported by Lindsay Marshal (JL) - -6/13/97 (new features) Tcl objects newly created by Tcl_NewObj now have a -string representation that points to a shared heap string of length 1. (They -used to have NULL bytes and typePtr fields. This was treated as a special -case to indicate an empty string, but made type manager implementations -complex and error prone.) The new procedure Tcl_InvalidateStringRep is used -to mark an object's string representation invalid and to free any storage -associated with the old string representation. (BL) -*** POTENTIAL INCOMPATIBILITY with Tcl 8.0b1, but not with Tcl7.6 *** - -6/16/97 (bug fix) Tcl_ScanCountedElement could leave braces unmatched -if the string ended with a backslash. (JO) - -6/17/97 (bug fix) Fixed channel event bug where readable events would be -lost during recursive events loops if the input buffers contained -data. (SS) - -6/17/97 (bug fix) Fixed bug in Windows socket code that didn't -reenable read events in the case where an external entity is also -reading from the socket. (SS) - -6/18/97 (bug fix) Changed initial setting of the notifier service mode -to TCL_SERVICE_NONE to avoid unexpected event handling during -initialization. (SS) - -6/19/97 (bug fix/feature change) The command callback to fcopy is now -called in case of errors during the background copy. This adds a second, -optional argument to the callback that is the error string. The callback -in case of errors is required for proper cleanup by the user of fcopy. (BW) -*** POTENTIAL INCOMPATIBILITY with Tcl 8.0b1, but not with Tcl 7.6 *** - -6/19/97 (bug fix) Fixed a panic due to the following four line script: - interp create x - x alias foo bar - x eval rename foo blotz - x alias foo {} -The problem was that the interp code was not using the actual current name -of the command to be deleted as a result of un-aliasing foo. (JL) - -6/19/97 (feature change) Pass interp down to the ChannelOption and -driver specific calls so system errors can be differentiated from syntax -ones. Changed Tcl_DriverGetOptionProc type. Affects Tcl_GetChannelOption, -TcpGetOptionProc, TtyGetOptionProc, etc. (DL) -*** POTENTIAL INCOMPATIBILITY *** - -6/19/97 (new feature) Added Tcl_BadChannelOption for use by by driver -specific option procedures (Set and Get) to return a complete and -meaningful error message. (DL) - -6/19/97 (bug fixes) If a system call error occurs while doing an -fconfigure on tcp or tty/com channel: return the appropriate error -message (instead of the syntax error one or none). (Fixed for Unix and -most of the Win and Mac drivers). (DL) - -6/20/97 (feature change) Eval is no longer assumed as the subcommand name -in namespace commands: you must now write "namespace eval nsName {...}". -Abbreviations of namespace subcommand names are now allowed. (BL) -*** POTENTIAL INCOMPATIBILITY with Tcl 8.0b1, but not with Tcl7.6 *** - -6/20/97 (feature change) Changed the errorInfo traceback message for -compilation errors from "invoked from within" to "while compiling". (BL) - -6/20/97 (bug fixes) Fixed various compilation-related bugs: - - "UpdateStringOfCmdName should never be called" and - "UpdateStringOfByteCode should never be called" panics. - - Segfault in TclObjInterpProc getting procedure name after evaluation - stack is reallocated (grown). - - Could not use ":" at end of variable and command names. - - Bad code generated for while and for commands with test expressions - enclosed in quotes: e.g., "set i 0; while "$i > 5" {}". - - Command trace procedures would crash if they did a Tcl_EvalObj that - reallocated the evaluation stack. - - Break and continue commands did not reset the interpreter result. - - The Tcl_ExprXXX routines, both string- or object-based, always - modified the interpreter result even if there was no error. - - The argument parsing procedure used by several compile procedures - always treated "]" as end of a command: e.g., "set a ]" would fail. - - Changed errorInfo traceback message for compilation errors from - "invoked from within" to "while compiling". - - Problem initializing Tcl object managers during interpreter creation. - - Added check and error message if formal parameter to a procedure is - an array element. (BL) - -6/23/97 (new feature) Added "registry" package to allow manipulation -of the Windows system registry. See manual entry for details. (SS) - -6/24/97 (feature change) Converted http to a package and added the -http1.0 subdirectory of the Tcl script library. This means you have -to do a "package require http" to use this, as advertised in the man page. (BW) -*** POTENTIAL INCOMPATIBILITY with Tcl 8.0b1, but not with Tcl 7.6 *** - -6/24/97 (bug fix) Ensure that Tcl_Set/GetVar C APIs, when called without -TCL_LEAVE_ERR_MSG, don't touch the interp result. (DL) - -6/26/97 (feature change) Changed name of Tcl_ExprStringObj to -Tcl_ExprObj. (BL) -*** POTENTIAL INCOMPATIBILITY with Tcl 8.0b1, but not with Tcl 7.6 *** - ------------------ Released 8.0b2, 6/30/97 ----------------------- - -7/1/97 (new feature) TCL_BUILD_SHARED flag set in tclConfig.sh -when Tcl has been built with --enable-shared. A new tclLibObjs -make target, echoing the list of the .o's needed to build a tcl -library, is now provided. (DL) - -7/1/97 (feature change) compat/getcwd.c removed and changed the -only place where getcwd is used so a new USEGETWD flag selects -the use of the replacement "getwd". Adding this flag is recommended -for SunOS 4 (because getcwd on SunOS 4 uses a pipe to pwd(1)!). (DL) - -7/7/97 (feature change) The split command now supports binary data (i.e., -null characters in strings). (BL) - -7/7/97 (bug fix) string first returned the wrong result if the first -argument string was empty. (BL) - -7/8/97 (bug fix) Fixed core dump in fcopy that could occur when a command -callback was supplied and an error or eof condition caused no background -activity. A refcount bug triggered a panic in Tcl_ListObjAppendElement. (BW) - -7/8/97 (bug fix) Relaxed the pattern matching on http_get so you do not -need a trailing path component. You can now get away with just -http_get sunscript.sun.com (BW) - -7/9/97 (bug fix) Creating anonymous interpreters no longer smashes existing -commands with names similar to the generated name. Previously creating an -anonymous interpreter could smash an existing command, now it skips until -it finds a command name that isn't being used. (JL) - -7/9/97 (feature change) Removed the policy management mechanism from the -Safe Base; left the aliases to source and load modules, and to do a limited -form of the "file" command. See entry of 11/15/96. (JL) - -7/9/97 (bug fixes) Fixed various compilation-related bugs: - - Line numbers in errorInfo now are the same as those in Tcl7.6 unless -there are compilation errors. Compilation error messages now include the -entire command in error. - - Trailing ::s after namespace names weren't being ignored. - - Could not refer to an namespace variable with an empty name using a -name of the form "n::". (BL) - -7/9/97 (bug fix) Fixed bug in Tcl_Export that prevented you from exporting -from other than the current namespace. (BL) - -7/9/97 (bug fix) env.test was removing env var needed for proper finding -of libraries in child process. (DL) - -7/10/97 (bug fixes/new feature) Cleanup in Tcl_MakeSafe. Less information -is leaked to safe interps. Error message fixes for interp sub commands. -Likewise changes in safealias.tcl; tcl_safeCreateInterp can now be called -without argument to generate the slave name (like in interp create). (DL) - -7/10/97 (bug fixes) Bytecode compiler now generates more detailed -command location information: subcommands as well as commands now have -location information. This means command trace procedures now get the -correct source string for each command in their command parameter. (BL) - -7/22/97 (bug fixes) Performance improvement in Safe interpreters -handling. Added new mask value to (tclInt.h) Interp.flags record. (DL) - -7/22/97 (bug fix) Fixed panic in 'interp target {} foo'. This bug -was present since Tcl 7.6. (JL) - -7/22/97 (bug fix) Fixed bug in compilation of procedures in namespaces: the -procedure's namespace must be used to look up compile procedures, not the -current namespace. (BL) - -7/22/97 (bug fix) Use of the -channel option of http_get was not setting -the end of line translations mode on the channel, so copying binary data -with the -channel option was corrupting the result on non-unix platforms. (BW) - -7/22/97 (bug fixes) file commands and ~user (seg fault and other -improper returns). (DL) - -7/23/97 (feature change) Reenabled "vwait" in Safe Base. (JL) - -7/23/97 (bug fixes) Fixed two bugs involving read traces on array variables -in procedures: trace procedures were sometimes not called, and reading -nonexistant array elements didn't create undefined element variables that -could later be defined by trace procedures. (BL) - -7/24/97 (bug fix) Windows memory allocation performance was -superlinear in some cases. Made the Mac allocator generic and changed -both the Mac and Windows platforms to use the new allocator instead of -malloc and free. (SS) - -7/24/97 - 8/12/97 (bug fixes/change of features) Completely revamped safe -sourcing/loading (see safe.n) to hide pathnames, use virtual -paths tokens instead, improved security in several respects and made it -more tunable. Multi level interp loading can work too now. Package auto -loading now works in safe interps as long as the package directory is in -the auto_path (no deep crawling allowed in safe interps). (DL) -*** POTENTIAL INCOMPATIBILITY with previous alpha and beta releases *** - -7/24/97 (bug fixes) Made Tcl_SetVar* and Tcl_NewString* treat a NULL value -as an empty string. (This fixes hairy crash case where you would crash -because load command for other interps assumed presence of -errorInfo...). (DL) - -7/28/97 (bug fix) Fixed pkg_mkIndex to understand namespaces. It will -use the export list of a namespace and create auto_index entries for -all export commands. Those names are in their fully qualified form in the -auto_index. Therefore, I tweaked unknown to try both $cmd and ::$cmd. -Also fixed pkg_mkIndex so you can have "package require" commands inside -your packages. These commands are ignored, which is mostly ok except -when you must load another package before loading yours because of -linking dependencies. (BW) - -7/28/97 (bug fix) A variable created by the variable command now persists -until the namespace is destroyed or the variable is unset. This is true even -if the variable has not been initialized; these variables used to be -destroyed if an error occurred when accessing them. In addition, the "info -vars" command lists uninitialized namespace variables, while the "info -exists" command returns 0 for them. (BL) - -7/29/97 (feature change) Changed the http package to use the ::http -namespace. http_get renamed to http::geturl, http_config renamed to -http::config, http_formatQuery renamed to http::formatQuery. -It now provides the 2.0 version of the package. -The 1.0 version is still available with the old names. -*** POTENTIAL INCOMPATIBILITY with Tcl 8.0b2 but not with Tcl 7.6 *** - -7/29/97 (bug fix, new feature) Tcl_Main now uses Tcl objects internally to -preserve NULLs in commands and command output. Added new API procedure -Tcl_RecordAndEvalObj that resembles Tcl_RecordAndEval but takes an object -containing a command. (BL) - -7/30/97 (bug fix) Tcl freed strings in the environ array even if it -did not allocate them. (SS) - -7/30/97 (bug fix) If a procedure is renamed into a different namespace, it -now executes in the context of that namespace. (BL) - -7/30/97 (bug fix) Prevent renaming of commands into and from namespaces as -part of hiding them. (JL) - -7/31/97 (feature change) Moved the history command from C to tcl. -This uses the ::history namespace. The "words" and "substitute" options -are no longer supported. In addition, the "keep" option without a value -returns the current keep limit. There is a new "clear" option. -The unknown command now supports !! again. (BW) -*** POTENTIAL INCOMPATIBILTY *** - -7/30/97 (bug fix) Made sure that a slave can not fool the master into -hiding the wrong command. Made sure we don't crash in hiding + namespaces -issues. (DL) - -8/4/97 (bug fix) Concat, eval, uplevel, and similar commands were -incorrectly trimming trailing space characters from their arguments -even when the space characters were preceded by a backslash. (JO) - -8/4/97 (bug fix) Removed the hard link between bgerror and tkerror. -Only bgerror is supported in tcl core. Tk will still look for a -tkerror but using regular tcl code for that feature. (DL) -*** POTENTIAL INCOMPATIBILTY with code relying on the hard link *** - -8/6/97 (bug fix) Reduced size required for compiled bytecodes by using a -more compact encoding for the command pc-to-source map. (BL) - -8/6/97 (new feature) Added support for additional compilation and execution -statistics when Tcl is compiled with the TCL_COMPILE_STATS flag. (BL) - -8/7/97 (bug fix) Expressions not in {}s that have a comparison operator as -the topmost operator must be compiled out-of-line (call the expr cmd at -runtime) to properly support expr's two-level substitution semantics. An -example is "set a 2; set b {$a}; puts [expr $b == 2]". (BL) - -8/11/97 (bug fix) The catch command would sometimes crash if a variable name -was given and the bytecode evaluation stack was grown when executing the -argument script. (BL) - -8/12/97 (feature change) Reinstated the variable tcl_precision to control -the number of digits used when floating-point values are converted to -strings, with default of 12 digits. However, had to make tcl_precision -shared among all interpreters (except that safe interpreters can't -modify it). This makes the Tcl 8.0 behavior almost identical to 7.6 -except that the default precision is 12 instead of 6. (JO) -*** POTENTIAL INCOMPATIBILITY *** - ------------------ Released 8.0, 8/18/97 ----------------------- - -8/19/97 (bug fix) Minimal fix for glob -nocomplain bugs: -"glob -nocomplain unreadableDir/*" was generating an anonymous -error. More in depth fixes will come with 8.1. (DL). - -8/20/97 (bug fix) Removed check for FLT_MIN in binary command so -underflow conditions are handled by the compiler automatic -conversions. (SS) - -8/20/97 (bug fixes) Fixed several compilation-related bugs: - - Array cmd wasn't detecting arrays that, while compiled, do not yet - exist (e.g., are marked undefined since they haven't been assigned - to yet). - - The GetToken procedure in tclCompExpr.c wasn't recognizing properly - whether an integer token was invalid. For example, "0x$" is not - a valid integer. - - Performance bug in TclExecuteByteCode: the size of its stack frame - was reduced by over 20% by moving errorInfo code elsewhere. - - Uninitialized memory read error in tclCompile.c. (BL) - -8/21/97 (bug fix) safe::interpConfigure now behave like Tk widget's -configure : it changes only the options you provide and you can get -the current value of any single option. New ?-nested boolean? and -?-statics boolean? for all safe::interp* commands but we still -accept (upward compatibility) the previously defined non valued -flags ?-noStatics? and ?-nestedLoadOk?. Improved the documentation. (DL). - -8/22/97 (bug fix) Updated PrintDbl.3 to reflect the fact that the -tcl_precision variable is still used and that it is now shared by all -interpreters. (BL) - -8/25/97 (bug fix) Fixed array access bug in IllegalExprOperandType -procedure in tclExecute.c: it was not properly supporting the || and && -operators. (BL) - -8/27/97 (bug fix) In cases where a channel handler was created with an -empty event mask while data was still buffered in the channel, the -channel code would get stuck spinning on a timer that would starve -idle handlers. This mostly happened in Tk when reading from stdin. (SS) - -9/4/97 (bug fix) Slave interps now inherit the maximum recursion limit -of their parent instead of starting back at the default. {nb: this still -does not prevent stack overflow by multi-interps recursion or aliasing} (DL) - -9/11/97 (bug fix) An uninitialized variable in Tcl_WaitPid caused -pipes to fail to report eof properly under Windows. (SS) - -9/12/97 (bug fix) "exec" was misidentifying some DOS executables as not -executable. (CCS) - -9/14/97 (bug fix) Was using the wrong structure in sizeof operation in -tclUnixChan.c. (JL) - -9/15/97 (bug fix) Fixed notifier to break out of do-one-event loop if -Tcl_WaitForEvent returns 1, so that callers of Tcl_DoOneEvent will get -a chance to check whether the event just handled is significant. This -affected mainly recursive calls to Tcl_VWaitCmd; these did not get a -chance to notice that the variable they were waiting for has been set -and thus they didn't terminate the vwait. (JL, DL, SS) - -9/15/97 (bug fix) Alignment problems in "binary format" would cause a -crash on some platforms when formatting floating point numbers. (SS) - -9/15/97 (bug fix) Fixed bug in Macintosh socket code. Now passes all -tests in socket.test that are not platform specific. (Thanks to Mark -Roseman for the pointer on the fix.) (RJ) - -9/18/97 (bug fix) Fixed bug -dictionary option of lsort that could -cause the compare function to run off the end of an array if the -number only contained 0's. (Thanks to Greg Couch for the report.) (RJ) - -9/18/97 (bug fix) TclFinalizeEnvironment was not cleaning up -properly. (DL, JI) - -9/18/97 (bug fix) Fixed long-standing bug where an "array get" command -did not trigger traces on the array or its elements. (BL) - -9/18/97 (bug fixes) Fixed compilation-related bugs: - - Fixed errorInfo traceback information for toplevel coomands that - contain nested commands. - - In the expr command, && and || now accept boolean operands as well - as numeric ones. (BL) - -9/22/97 (bug fix) Fixed bug that prevented translation modes from being -set independently for input and output on sockets if input was "auto". (JL) - -9/24/97 (bug fix) Tcl_EvalFile(3) and thus source(n) now works fine on -files containing NUL chars. (DL) - -9/26/97 (bug fix) Fixed use of uninitialized memory in the environ array -that later could cause random core dumps. Applies to all platforms. (JL) - -9/26/97 (bug fix) Fixed use of uninitialized memory in socket address data -structure under some circumstances. This could cause random core dumps. -This applies only to Unix. (JL) - -9/26/97 (bug fix) Opening files on PC-NFS volumes would cause a hang -until the system timed after the file was closed. (SS) - -10/6/97 (bug fix) The join(n) command, though objectified, was loosing -NULs in the joinString and in list elements after the 2nd one. -Now you can "join $list \0" for instance. (DL) - -10/9/97 (bug fix) Under windows, if env(TMP) or env(TEMP) referred to a -non-existent directory, exec would fail when trying to create its temporary -files. (CCS) - -10/9/97 (bug fix) Under mac and windows, "info hostname" would crash if -sockets were installed but the hostname could not be determined anyhow. -Tcl_GetHostName() was returning NULL when it should have been returning -an empty string. (CCS) - -10/10/97 (bug fix) "file attribute /" returned error on windows. (CCS) - -10/10/97 (bug fix) Fixed the auto_load procedure to handle procedures -defined in namespaces better. Also fixed pgk_mkIndex so it sees procedures -defined in nested namespaces. Index entries are still only made for -exported procedures. (BW) - -10/13/97 (bug fix) On unix, for files with unknown group or owner -attributes, querying the "file attributes" would return an error rather than -returning the group's or owner's id number, although tha command accepts -numbers when setting the file's group or owner. (CCS) - -10/22/97 (bug fix) "fcopy" did not eval the callback script at the -global scope. (SS) - -10/22/97 (bug fix) Fixed the signature of the CopyDone callback used in -the http package(s) so they can handle error cases properly. (BW) - -10/28/97 (bug fixes) Fixed a problem where lappend would free the Tcl object -in a variable if a Tcl_ObjSetVar2 failed because of an error calling a trace -on the variable. (BL) - -10/28/97 (bug fix) Changed binary scan to properly handle sign -extension of integers on 64-bit or larger machines. (SS) - -11/3/97 (bug fixes) Fixed several bugs: - - expressions such as "expr ($x)" must be compiled out-of-line - (call the expr command procedure at runtime) to ensure the correct - behavior when "$x" is an expression such as "5+10". - - "array set a {}" now creates a new array var with an empty array - value if the var didn't already exist. - - "lreplace $foo end end" no longer returns an error (just an empty - list) if foo is empty. - - upvar will no longer create a variable in a namespace that refers - to a variable in a procedure. - - deleting a command trace within a command trace callback would - make the code that calls traces to reference freed memory. - - significantly sped up "string first" and "string last" (fix from - darrel@gemstone.com). - - seg fault in Tcl_NewStringObj() when a NULL is passed as the byte - pointer argument and Tcl is compiled with -DTCL_MEM_DEBUG. - - documentation and error msg fixes. (BL) - -11/3/97 (bug fix) Fixed a number of I/O bugs related to word sizes on -64-bit machines. (SS) - -11/6/97 (bug fix) The exit code of the first process created by Tcl -on Windows was not properly reported due to an initialization -problem. (SS) - ------------------ Released 8.0p1, 11/7/97 ----------------------- - -11/19/97 (bug fix) Fixed bug in linsert where it sometimes accidently -cleared out a shared argument list object. (BL). - -11/19/97 (bug fix) Autoloading in namespaces was not working properly. -auto_mkindex is still not really namespace aware but most common -cases should now be handled properly (see init.test). (BW, DL) - -11/20/97 (enhancement) Made the changes required by the new Apple -Universal Headers V.3.0, so that Tcl will compile with CW Pro 2. - -11/24/97 (bug fix) Fixed tests in clock test suite that needed the --gmt flag set. Thanks to Jan Nijtmans for reporting the problem. (RJ) - ------------------ Released 8.0p2, 11/25/97 ----------------------- - -12/3/97 (bug fix/optimization) Removed uneeded and potentially dangerous -instances of double evaluations if "if" and "expr" statements from -the library files. It is recommended that unless you need a double -evaluation you always use "expr {...}" instead of "expr ..." and -"if {...} ..." instead of "if ... ...". It will also be faster -thanks to the byte compiler. (DL) - ----- Shipped as part of the plugin2.0b5 as 8.0p2Plugin1, Dec 8th 97 ---- - -12/8/97 (bug fix) Need to protect the newly accepted channel in an -accept callback on a socket, otherwise the callback may close it and -cause an error, which would cause the C code to attempt to close the -now deleted channel. Bumping the refcount assures that the channel sticks -around to be really closed in this case. (JL) - -12/8/97 (bug fix) Need to protect the channel in a fileevent so that it -is not deleted before the fileevent handler returns. (CS, JL) - -12/18/97 (bug fix) In the opt argument parsing package: if the description -had only flags, the "too many arguments" case was not detected. The default -value was not used for the special "args" ending argument. (DL) - -1/15/98 (improvement) Moved common part of initScript in common file. -Moved windows specific initialization to init.tcl so you can initialize -Tcl in windows without having to call Tcl_Init which is now only -searching for init.tcl {back ported from 8.1}. (DL) - ----- Shipped as part of the plugin as 8.0p2Plugin2, Jan 15th 98 ---- - -5/27/98 (bug fix) Windows socket driver did not notice new data arriving -on nonblocking sockets until the event loop was entered. (SS) - -5/27/98 (bug fix) Windows socket driver used FIONREAD, which is not -supported correctly by WinSock. (SS) - -6/9/98 (bug fix) Generic channel code failed to report readable file -events on buffered data that was left behind by a gets or read that -did not consume all available data. (SS) - -6/18/98 (bug fix) Compilation of loop expressions was too aggressive -and incorrectly inlined non-literal expressions. (SS) - -6/18/98 (bug fix) "info var" and "info locals" incorrectly reported -the existence of compiler temporary variables. (SS) - -6/18/98 (bug fix) Dictionary sorting used signed character -comparisons. (SS) - -6/18/98 (bug fix) Compile procs corrupted the exception stack in some -cases. (SS) - -6/18/98 (bug fix) Array set had erratic behavior when initializing a -variable from an empty value list. (SS) - -6/18/98 (bug fix) The Windows registry package had a bad bounds check -that could lead to a crash. (SS) - -6/18/98 (bug fix) The foreach compile proc did not correctly handle -non-local variable references. (SS) - -6/25/98 (new features) Added name resolution hooks to support [incr Tcl]. -There are new internal Tcl_*Resolver* APIs to add, query and remove the hooks. -With this changes it should be possible to dynamically load [incr Tcl] -as an extension. (MM) - -7/1/97 (bug fix) The commands "info args, body, default, procs" did -not correctly handle imported procedures. (RJ) - -7/6/98 (improvement) pkg_mkIndex now implements the "package require" -command. This makes it possible to create index files for packages -that require another package and then execute code from that package in -their file. Previously, this would throw an error because the required -package had not been loaded. The -nopkgrequied flag is provided to -revert back to the old functionality. (EMS) - -7/6/98 (improvement) back-ported the -direct flag from 8.1 into -pkg_mkIndex. This results in pkgIndex.tcl files that contain direct -source or load commands instead of tclPkgSetup commands. (EMS) - -7/6/98 (improvement) made changes to the AuxData items structures to support -storage of compiled scripts on disk. Also some related minor changes in -the compilation and execution engine. (EMS) - -6/4/98 (enhancement) Added new internal routines to support inserting -and deleting from the stat, access, and open-file-channel mechanisms. -TclAccessInsertProc, TclStatInsertProc, & TclOpenFileChannelInsertProc -insert pointers to such routines; TclAccessDeleteProc, TclStatDeleteProc, -& TclOpenFileChannelDeleteProc delete pointers to such routines. See -the file generic/tclIOUtils.c for more details. (SKS) - -7/1/98 (enhancement) Added a new internal C variable -tclPreInitScript. This is a pointer to a string that may hold an -initialization script; If this pointer is non-NULL it is evaluated in -Tcl_Init() prior to the built-in initialization script defined in the -file generic/tclInitScript.h. (SKS) - -7/6/98 (bug fix) Removed dead code in PlatformInitExitHandler so that -the TCL_LIBRARY value can be safely patched in binaries. (BW) - -7/24/98 (enhancement) Incorporated a new version of auto_mkindex that -can support the [incr Tcl] class structures. This version will index -all procedures in a source file, not just those where "proc" starts -at the beginning of the line. If you want the old behavior, use the -auto_mkindex_old procedure. (MM) - -7/24/98 (feature change) Changed the Windows registry key to be -HKEY_LOCAL_MACHINE\Software\Scriptics\Tcl\8.0, and to store the path -in the default value instead of "Root". Also, this key can be -specified at compile time in case Tcl is being used in a different -context where it needs an alternate library path from the standard Tcl -installation. (SS) - -7/24/98 (feature change) Changed the search order for init.tcl. The -tcl_library variable can now be set before calling Tcl_Init to avoid -doing any searches. If it isn't set, then Tcl checks -env(TCL_LIBRARY), the static value set at compile time, an install -directory relative to the executable, a source directory relative to -the executable, and a tcl directory relative to the source heirarchy -containing the executable. See the comment at the top of -generic/tclInitScript.h for more details. (SS) - -7/27/98 (config change) Changed the use of the DBGX flag in configure.in -and the makefile to be TCL_DBGX. Users of tclConfig.sh may need to pass -this through their configure files with AC_SUBST. (BW) - -729/98 (bug fix) Changed [info body] to return a copy of the body of a -compiled procedure instead of the body itself, to avoid invalidation -of the internal rep and loss of the byte-codes. (EMS) - -8/5/98 (bug fix) The platform init code could walk off the end of a -buffer when reading the PkgPath registry value on Windows. (SS) - -8/5/98 (Windows makefile change) Introduced a set of macros to deal with -exporting symbols when compiling DLLS on Windows. See win/README for -details. (EMS) - -8/5/98 (addendum) Added a second Windows registry key under -HKEY_LOCAL_MACHINE\Software\Scriptics\Tcl\8.0, named "pkgPath". -This is a multi-string value used to initialize the tcl_pkgPath -variable. This is required if extension DLLs are in architecture specific -subdirectories. (SS) - -8/6/98 (new feature) Added tcl_findLibrary to init.tcl for use by -extensions, including Tk. This searches in a canonical way for -an extensions library directory and initialization file. (BW) - -8/10/98 (bug fix) Imported commands used to get lost if the target -of the import was redefined. Tcl_CreateCommand and Tcl_CreateObjCommand -were updated to restore import links. (Note that if you rename a command, -the import links move to the new name, and if you delete a command then -the import links get lost. These semantics have not changed.) (MC) - --------- Released 8.0.3 to the Tcl Consortium CD-ROM project, 8/10/98 ------ - -9/3/98 (bug fix) Tcl_Realloc was failing under Windows because the -GlobalReAlloc API was not correctly re-allocating blocks that were -32k+. The fix was to use newer Win32 APIs (HeapAlloc, HeapFree, and -HeapReAlloc.) (BS) - -10/5/98 (bug fix) Fixed bug in pkg_mkIndex that caused some files that do -a "package require" of packages in the Tcl libraries to give a warning like - warning: "xx.tcl" provides more than one package ({xx 2.0} {yy 0.3}) -and generate a broken pkgIndex.tcl file. (EMS) - -10/5/98 (bug fix) Pkg_mkIndex was not doing a case-insensitive comparison -of extensions to determine whether to load or source a file. Thus, under -Windows, MYDLLNAME.DLL was sourced, and mydllname.dll loaded. (EMS) - -10/5/98 (new feature) Created a new Tcl_Obj type, "procbody". This object's -internal representation holds a pointer to a Proc structure. Extended -TclCreateProc to take both strings and "procbody". (EMS) - -10/13/98 (bug fix) The "info complete" command can now handle strings -with NULLs embedded. Thanks to colin@field.medicine.adelaide.edu.au -for providing this fix. (RJ) - -10/13/98 (bug fix) The "lsort -dictionary" command did not properly -handle some numbers starting with 0. Thanks to Richard Hipp -<drh@acm.org> for submitting the fix to Scriptics. (RJ) - -10/13/98 (bug fix) The function Tcl_SetListObj was creating an invalid -Tcl_Obj if the list had zero elements (despite what the comments said -it would do). Thanks to Sebastian Wangnick for reporting the -problem. (RJ) - -10/20/98 (new feature) Added tcl_platform(debug) element to the -tcl_platform array on Windows platform. The existence of the debug -element of the tcl_platform array indicates that the particular Tcl -shell has been compiled with debug information. Using -"info exists tcl_platform(debug)" a Tcl script can direct the -interpreter to load debug versions of DLLs with the load -command. (SKS) - -10/20/98 (feature change) The Makefile and configure scripts have been -changed for IRIX to build n32 binaries instead of the old 32 abi -format. If you have extensions built with the o32 abi's you will need -to update them to n32 for them to work with Tcl. (RJ) -*** POTENTIAL INCOMPATIBILITY *** - -10/23/98 (bug fix) tcl_findLibrary had a stray ] in one of the -pathnames it searched for the initialization script. tclInitScript.h -was incorrectly adding the parent of tcl_library to tcl_pkgPath. This -logic was moved into init.tcl, and the initialization of auto_path was -documented. Thanks to Donald Porter and Tom Silva for related -patches. (BW) - -10/29/98 (bug fix) Fixed Tcl_NotifyChannel to use Tcl_Preserve instead -of Tcl_RegisterChannel so that 1) unregistered channels do not get -closed after their first fileevent, and 2) errors that occur during -close in a fileevent script are actually reflected by the close -command. (BW) - -10/30/98 (bug fix) Overhaul of pkg_mkIndex to deal with transitive -package requires and packages split among scripts and binary files. -Also fixed ommision of global for errorInfo in tcl_findLibrary. (BW) - -11/08/98 (bug fix) Fixed the resource command to always detect the -case where a file is opened a second time with the same permissions. -IM claims that this will always cause the same FileRef to be returned, -but in MacOS 8.1+, this is no longer the case, so we have to test for -this equality explicitly. (JI) - -11/10/98 (feature change) When compiling with Metrowerk's MSL, use the -exit function from MSL rather than ExitToShell. This allows MSL to -clean up its temporary files. Thanks to Vince Darley for this -improvement. (JI) - ------------------ Released 8.0.4, 11/19/98 ----------------------- - -11/20/98 (bug fix) Handle possible NULL return in TclGetStdFiles. (RJ) - -11/20/98 (bug fix) The dltests would not build on SGI. They reported -that you could not mix n32 with 032 binaries. The configure script -has been modified to get the EXTRA_CFLAGS from the tcl configure -script. [Bug id: 840] (RJ) - -12/3/98 (bug fix) Windows NT creates sockets so they are inheritable -by default. Fixed socket code so it turns off this bit right after -creation so sockets aren't kept open by exec'ed processes. [Bug: 892] -Thanks to Kevin Kenny for this fix. (SS) - -1/11/98 (bug fix) On HP, "info sharedlibextension" was returning -empty string on static apps. It now always returns ".sl". (RJ) - -1/28/99 (configure change) Now support -pipe option on gcc. (RJ) - -2/2/99 (bug fix) Fixed initialization problem on Windows where no -searching for init.tcl would be performed if the registry keys were -missing. (stanton) - -2/2/99 (bug fix) Added support for HKEY_PERFORMANCE_DATA and -HKEY_DYN_DATA keys in the "registry" command. (stanton) - -2/2/99 (bug fix) ENOTSUP and EOPNOTSUPP clashed on some Linux -variants. (stanton) - -2/2/99 (enhancement) The "open" command has been changed to use the -object interfaces. (stanton) - -2/2/99 (bug fix) In some cases Tcl would crash due to an overflow of -the exception stack resulting from a missing byte code in some -expressions. (stanton) - -2/2/99 (bug fix) Changed configure so Linux and IRIX shared libraries -are linked with the system libraries. (stanton) - -2/2/99 (bug fix) Added support for BSDI 4.x (BSD/OS-4*) to the -configure script. (stanton) - -2/2/99 (bug fix) Fixed bug where upvar could resurrect a namespace -variable after the namespace had been deleted. (stanton) - -2/2/99 (bug fix) In some cases when creating variables, the -interpreter result was being modified even if the TCL_LEAVE_ERR_MSG -flag was set. (stanton) - -2/2/99 (bug fix & new feature) Changed the socket drivers to properly -handle failures during an async socket connection. Added a new -fconfigure option "-error" to retrieve the failure message. See the -socket.n manual entry for details. (stanton) - -2/2/99 (bug fix) Deleting a renamed interp alias could result in a -panic. (stanton) - -2/2/99 (feature change/bug fix) Changed the behavior of "file -extension" so that it splits at the last period. Now the extension of -a file like "foo..o" is ".o" instead of "..o" as in previous versions. -*** POTENTIAL INCOMPATIBILITY *** diff --git a/doc/DString.3 b/doc/DString.3 deleted file mode 100644 index e8cc5e1..0000000 --- a/doc/DString.3 +++ /dev/null @@ -1,145 +0,0 @@ -'\" -'\" 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. -'\" -'\" RCS: @(#) $Id: DString.3,v 1.2 1998/09/14 18:39:48 stanton Exp $ -'\" -.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 -\fBTcl_DStringSetLength\fR(\fIdsPtr, newLength\fR) -.sp -\fBTcl_DStringFree\fR(\fIdsPtr\fR) -.sp -\fBTcl_DStringResult\fR(\fIinterp, dsPtr\fR) -.sp -\fBTcl_DStringGetResult\fR(\fIinterp, dsPtr\fR) -.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 -.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. -.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 -\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. - -.SH KEYWORDS -append, dynamic string, free, result diff --git a/doc/Notifier.3 b/doc/Notifier.3 deleted file mode 100644 index dcd8250..0000000 --- a/doc/Notifier.3 +++ /dev/null @@ -1,537 +0,0 @@ -'\" -'\" Copyright (c) 1995-1997 Sun Microsystems, Inc. -'\" -'\" See the file "license.terms" for information on usage and redistribution -'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. -'\" -'\" RCS: @(#) $Id: Notifier.3,v 1.2 1998/09/14 18:39:49 stanton Exp $ -'\" -.so man.macros -.TH Notifier 3 8.0 Tcl "Tcl Library Procedures" -.BS -.VS -.SH NAME -Tcl_CreateEventSource, Tcl_DeleteEventSource, Tcl_SetMaxBlockTime, Tcl_QueueEvent, Tcl_DeleteEvents, Tcl_WaitForEvent, Tcl_SetTimer, Tcl_ServiceAll, Tcl_ServiceEvent, Tcl_GetServiceMode, Tcl_SetServiceMode \- the event queue and notifier interfaces - -.SH SYNOPSIS -.nf -\fB#include <tcl.h>\fR -.sp -\fBTcl_CreateEventSource\fR(\fIsetupProc, checkProc, clientData\fB)\fR -.sp -\fBTcl_DeleteEventSource\fR(\fIsetupProc, checkProc, clientData\fB)\fR -.sp -\fBTcl_SetMaxBlockTime\fR(\fItimePtr\fB)\fR -.sp -\fBTcl_QueueEvent\fR(\fIevPtr, position\fR) -.VS -.sp -\fBTcl_DeleteEvents\fR(\fIdeleteProc, clientData\fR) -.sp -int -\fBTcl_WaitForEvent\fR(\fItimePtr\fR) -.sp -\fBTcl_SetTimer\fR(\fItimePtr\fR) -.sp -int -\fBTcl_ServiceAll\fR() -.sp -int -\fBTcl_ServiceEvent\fR(\fIflags\fR) -.sp -int -\fBTcl_GetServiceMode\fR() -.sp -int -\fBTcl_SetServiceMode\fR(\fImode\fR) -.VE - -.SH ARGUMENTS -.AS Tcl_EventDeleteProc milliseconds -.AS Tcl_EventSetupProc *setupProc -.AP Tcl_EventSetupProc *setupProc in -Procedure to invoke to prepare for event wait in \fBTcl_DoOneEvent\fR. -.AP Tcl_EventCheckProc *checkProc in -Procedure for \fBTcl_DoOneEvent\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, \fIcheckProc\fR, or -\fIdeleteProc\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 \fBTcl_Alloc\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 -What types of events to service. These flags are the same as those -passed to \fBTcl_DoOneEvent\fR. -.AP Tcl_EventDeleteProc *deleteProc in -Procedure to invoke for each queued event in \fBTcl_DeleteEvents\fR. -.VS -.AP int mode in -Inidicates whether events should be serviced by \fBTcl_ServiceAll\fR. -Must be one of \fBTCL_SERVICE_NONE\fR or \fBTCL_SERVICE_ALL\fR. -.VE -.BE - -.SH INTRODUCTION -.PP -.VS -The interfaces described here are used to customize the Tcl event -loop. The two most common customizations are to add new sources of -events and to merge Tcl's event loop with some other event loop, such -as one provided by an application in which Tcl is embedded. Each of -these tasks is described in a separate section below. -.VE -.PP -The procedures in this manual entry 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 on Unix systems. 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. The procedures -\fBTcl_CreateEventSource\fR, \fBTcl_DeleteEventSource\fR, -and \fBTcl_SetMaxBlockTime\fR, \fBTcl_QueueEvent\fR, and -\fBTcl_DeleteEvents\fR are used primarily by event sources. -.IP [2] -The event queue: there is a single queue for the whole application, -containing events that have been detected but not yet serviced. Event -sources place events onto the queue so that they may be processed in -order at appropriate times during the event loop. 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. -.VS -\fBTcl_QueueEvent\fR is used (primarily -by event sources) to add events to the event queue and -\fBTcl_DeleteEvents\fR is used to remove events from the queue without -processing them. -.IP [3] -The event loop: in order to detect and process events, the application -enters a loop that waits for events to occur, places them on the event -queue, and then processes them. Most applications will do this by -calling the procedure \fBTcl_DoOneEvent\fR, which is described in a -separate manual entry. -.PP -Most Tcl applications need not worry about any of the internals of -the Tcl notifier. However, the notifier now has enough flexibility -to be retargeted either for a new platform or to use an external event -loop (such as the Motif event loop, when Tcl is embedded in a Motif -application). The procedures \fBTcl_WaitForEvent\fR and -\fBTcl_SetTimer\fR are normally implemented by Tcl, but may be -replaced with new versions to retarget the notifier (the \fBTcl_Sleep\fR, -\fBTcl_CreateFileHandler\fR, and \fBTcl_DeleteFileHandler\fR must -also be replaced; see CREATING A NEW NOTIFIER below for details). -The procedures \fBTcl_ServiceAll\fR, \fBTcl_ServiceEvent\fR, -\fBTcl_GetServiceMode\fR, and \fBTcl_SetServiceMode\fR are provided -to help connect Tcl's event loop to an external event loop such as -Motif's. -.SH "NOTIFIER BASICS" -.VE -.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 -.VS -from the queue, and return. It does this by calling -\fBTcl_ServiceEvent\fR and passing in the \fIflags\fR argument. -.VE -.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 perform event-source specific initialization and -.VS -possibly call \fBTcl_SetMaxBlockTime\fR to limit how long -.VE -\fBTcl_WaitForEvent\fR will block if no new events occur. -.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. 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. - -.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 -be 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 make sure that the application wakes up -when events of the desired type occur. This is typically done in a -platform-dependent fashion. For example, under Unix an event source -might call \fBTcl_CreateFileHandler\fR; under Windows it might -request notification with a Windows event. For timer-driven event -sources such as timer events or any polled event, the event source -can call \fBTcl_SetMaxBlockTime\fR to force the application to wake -up after a specified time even if no events have occurred. -.VS -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. If an event source knows that it already has events ready to -report, it can request a zero maximum block time. For example, the -setup procedure for the X event source looks to see if there are -events already queued. If there are, it calls -\fBTcl_SetMaxBlockTime\fR with a 0 block time so that -\fBTcl_WaitForEvent\fR does not block if there is no new data on the X -connection. -.VE -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 -.VS -Information provided to \fBTcl_SetMaxBlockTime\fR -is only used for the next call to \fBTcl_WaitForEvent\fR; it is -discarded after \fBTcl_WaitForEvent\fR returns. -.VE -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 -.VS -If the application uses an external event loop rather than -\fBTcl_DoOneEvent\fR, the event sources may need to call -\fBTcl_SetMaxBlockTime\fR at other times. For example, if a new event -handler is registered that needs to poll for events, the event source -may call \fBTcl_SetMaxBlockTime\fR to set the block time to zero to -force the external event loop to call Tcl. In this case, -\fBTcl_SetMaxBlockTime\fR invokes \fBTcl_SetTimer\fR with the shortest -interval seen since the last call to \fBTcl_DoOneEvent\fR or -\fBTcl_ServiceAll\fR. -.PP -In addition to the generic procedure \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. For example, on Unix systems -the \fBTcl_CreateFileHandler\fR interface can be used to wait for file events. -.VE -.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. -.PP -If an event source's check procedure detects an interesting event, 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 -.VS -When it is time to handle an event from the queue (steps 1 and 4 -above) \fBTcl_ServiceEvent\fR will invoke the \fIproc\fR specified -.VE -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 -.VS -current call to \fBTcl_ServiceEvent\fR; this is used by the event source -.VE -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 -.VS -should be deferred for processing later; in this case \fBTcl_ServiceEvent\fR -.VE -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 -.VS -When \fIproc\fR returns 1, \fBTcl_ServiceEvent\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 \fBTcl_Alloc\fR or the Tcl macro \fBckalloc\fR) -before calling \fBTcl_QueueEvent\fR, but it -will be freed by \fBTcl_ServiceEvent\fR, not by the event source. -.PP -\fBTcl_DeleteEvents\fR can be used to explicitly remove one or more -events from the event queue. \fBTcl_DeleteEvents\fR calls \fIproc\fR -for each event in the queue, deleting those for with the procedure -returns 1. Events for which the procedure returns 0 are left in the -queue. \fIProc\fR should match the following prototype: -.CS -typedef int Tcl_EventDeleteProc( - Tcl_Event *\fIevPtr\fR, - ClientData \fIclientData\fR); -.CE -The \fIclientData\fR argument will be the same as the \fIclientData\fR -argument to \fBTcl_DeleteEvents\fR; it is typically used to point to -private information managed by the event source. The \fIevPtr\fR will -point to the next event in the queue. -.VE - -.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, which are -.VS -available on all platforms, and \fBTcl_CreateFileHandler\fR and -\fBTcl_DeleteFileHandler\fR, which are Unix-specific. Most of these -procedures are generic, in that they are the same for all notifiers. -However, five of the procedures are notifier-dependent: -\fBTcl_SetTimer\fR, \fBTcl_Sleep\fR, \fBTcl_WaitForEvent\fR, -\fBTcl_CreateFileHandler\fR and \fBTcl_DeleteFileHandler\fR. To -support a new platform or to integrate Tcl with an -application-specific event loop, you must write new versions of these -procedures. -.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 \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). -.PP -Ideally, \fBTcl_WaitForEvent\fR should only wait for an event -to occur; it should not actually process the event in any way. -Later on, the -event sources will process the raw events and create Tcl_Events on -the event queue in their \fIcheckProc\fR procedures. -However, on some platforms (such as Windows) this isn't possible; -events may be processed in \fBTcl_WaitForEvent\fR, including queuing -Tcl_Events and more (for example, callbacks for native widgets may be -invoked). The return value from \fBTcl_WaitForEvent\fR must be either -0, 1, or \-1. On platforms such as Windows where events get processed in -\fBTcl_WaitForEvent\fR, a return value of 1 means that there may be more -events still pending that haven't been processed. This is a sign to the -caller that it must call \fBTcl_WaitForEvent\fR again if it wants all -pending events to be processed. A 0 return value means that calling -\fBTcl_WaitForEvent\fR again will not have any effect: either this is a -platform where \fBTcl_WaitForEvent\fR only waits without doing any event -processing, or \fBTcl_WaitForEvent\fR knows for sure that there are no -additional events to process (e.g. it returned because the time -elapsed). Finally, a return value of \-1 means that the event loop is -no longer operational and the application should probably unwind and -terminate. Under Windows this happens when a WM_QUIT message is received; -under Unix it happens when \fBTcl_WaitForEvent\fR would have waited -forever because there were no active event sources and the timeout was -infinite. -.PP -If the notifier will be used with an external event loop, then it must -also support the \fBTcl_SetTimer\fR interface. \fBTcl_SetTimer\fR is -invoked by \fBTcl_SetMaxBlockTime\fR whenever the maximum blocking -time has been reduced. \fBTcl_SetTimer\fR should arrange for the -external event loop to invoke \fBTcl_ServiceAll\fR after the specified -interval even if no events have occurred. This interface is needed -because \fBTcl_WaitForEvent\fR isn't invoked when there is an external -event loop. If the -notifier will only be used from \fBTcl_DoOneEvent\fR, then -\fBTcl_SetTimer\fR need not do anything. -.PP -On Unix systems, the file event source also needs support from the -notifier. The file event source consists of the -\fBTcl_CreateFileHandler\fR and \fBTcl_DeleteFileHandler\fR -procedures, which are described elsewhere. -.PP -The \fBTcl_Sleep\fR and \fBTcl_DoOneEvent\fR interfaces are described -elsewhere. -.PP -The easiest way to create a new notifier is to look at the code -for an existing notifier, such as the files \fBunix/tclUnixNotfy.c\fR -or \fBwin/tclWinNotify.c\fR in the Tcl source distribution. - -.SH "EXTERNAL EVENT LOOPS" -.PP -The notifier interfaces are designed so that Tcl can be embedded into -applications that have their own private event loops. In this case, -the application does not call \fBTcl_DoOneEvent\fR except in the case -of recursive event loops such as calls to the Tcl commands \fBupdate\fR -or \fBvwait\fR. Most of the time is spent in the external event loop -of the application. In this case the notifier must arrange for the -external event loop to call back into Tcl when something -happens on the various Tcl event sources. These callbacks should -arrange for appropriate Tcl events to be placed on the Tcl event queue. -.PP -Because the external event loop is not calling \fBTcl_DoOneEvent\fR on -a regular basis, it is up to the notifier to arrange for -\fBTcl_ServiceEvent\fR to be called whenever events are pending on the -Tcl event queue. The easiest way to do this is to invoke -\fBTcl_ServiceAll\fR at the end of each callback from the external -event loop. This will ensure that all of the event sources are -polled, any queued events are serviced, and any pending idle handlers -are processed before returning control to the application. In -addition, event sources that need to poll for events can call -\fBTcl_SetMaxBlockTime\fR to force the external event loop to call -Tcl even if no events are available on the system event queue. -.PP -As a side effect of processing events detected in the main external -event loop, Tcl may invoke \fBTcl_DoOneEvent\fR to start a recursive event -loop in commands like \fBvwait\fR. \fBTcl_DoOneEvent\fR will invoke -the external event loop, which will result in callbacks as described -in the preceding paragraph, which will result in calls to -\fBTcl_ServiceAll\fR. However, in these cases it is undesirable to -service events in \fBTcl_ServiceAll\fR. Servicing events there is -unnecessary because control will immediately return to the -external event loop and hence to \fBTcl_DoOneEvent\fR, which can -service the events itself. Furthermore, \fBTcl_DoOneEvent\fR is -supposed to service only a single event, whereas \fBTcl_ServiceAll\fR -normally services all pending events. To handle this situation, -\fBTcl_DoOneEvent\fR sets a flag for \fBTcl_ServiceAll\fR -that causes it to return without servicing any events. -This flag is called the \fIservice mode\fR; -\fBTcl_DoOneEvent\fR restores it to its previous value before it returns. -.PP -In some cases, however, it may be necessary for \fBTcl_ServiceAll\fR -to service events -even when it has been invoked from \fBTcl_DoOneEvent\fR. This happens -when there is yet another recursive event loop invoked via an -event handler called by \fBTcl_DoOneEvent\fR (such as one that is -part of a native widget). In this case, \fBTcl_DoOneEvent\fR may not -have a chance to service events so \fBTcl_ServiceAll\fR must service -them all. Any recursive event loop that calls an external event -loop rather than \fBTcl_DoOneEvent\fR must reset the service mode so -that all events get processed in \fBTcl_ServiceAll\fR. This is done -by invoking the \fBTcl_SetServiceMode\fR procedure. If -\fBTcl_SetServiceMode\fR is passed \fBTCL_SERVICE_NONE\fR, then calls -to \fBTcl_ServiceAll\fR will return immediately without processing any -events. If \fBTcl_SetServiceMode\fR is passed \fBTCL_SERVICE_ALL\fR, -then calls to \fBTcl_ServiceAll\fR will behave normally. -\fBTcl_SetServiceMode\fR returns the previous value of the service -mode, which should be restored when the recursive loop exits. -\fBTcl_GetServiceMode\fR returns the current value of the service -mode. -.VE - -.SH KEYWORDS -event, notifier, event queue, event sources, file events, timer, idle, service mode diff --git a/doc/OpenFileChnl.3 b/doc/OpenFileChnl.3 deleted file mode 100644 index c0d121c..0000000 --- a/doc/OpenFileChnl.3 +++ /dev/null @@ -1,499 +0,0 @@ -'\" -'\" Copyright (c) 1996-1997 Sun Microsystems, Inc. -'\" -'\" See the file "license.terms" for information on usage and redistribution -'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. -'\" -'\" RCS: @(#) $Id: OpenFileChnl.3,v 1.2 1998/09/14 18:39:49 stanton Exp $ -.so man.macros -.TH Tcl_OpenFileChannel 3 8.0 Tcl "Tcl Library Procedures" -.BS -'\" Note: do not modify the .SH NAME line immediately below! -.SH NAME -Tcl_OpenFileChannel, Tcl_OpenCommandChannel, Tcl_MakeFileChannel, Tcl_GetChannel, Tcl_RegisterChannel, Tcl_UnregisterChannel, Tcl_Close, Tcl_Read, Tcl_Gets, Tcl_Write, Tcl_Flush, Tcl_Seek, Tcl_Tell, Tcl_Eof, Tcl_InputBlocked, Tcl_InputBuffered, 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) -.VS -.sp -Tcl_Channel -\fBTcl_MakeFileChannel\fR(\fIhandle, readOrWrite\fR) -.VE -.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_GetsObj\fR(\fIchannel, lineObjPtr\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(\fIinterp, channel, 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. -.VS -.AP ClientData handle in -Operating system specific handle for I/O to a file. For Unix this is a -file descriptor, for Windows it is a HANDLE. -.AP int readOrWrite in -OR-ed combination of \fBTCL_READABLE\fR and \fBTCL_WRITABLE\fR to indicate -what operations are valid on \fIhandle\fR. -.VE -.AP int *modePtr out -Points at an integer variable that will receive an OR-ed combination of -\fBTCL_READABLE\fR and \fBTCL_WRITABLE\fR denoting whether the channel is -open for reading and writing. -.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 len in -The length of the input or output. -.AP int atEnd in -If nonzero, store the input at the end of the input queue, otherwise store -it at the head of the input queue. -.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. The line read -will be appended to any data already in the dynamic string. -.AP Tcl_Obj *linePtrObj in -A pointer to a Tcl object in which to store the line read from the -channel. The line read will be appended to the current value of the -object. -.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. -.PP -The newly created channel is not registered in the supplied interpreter; to -register it, use \fBTcl_RegisterChannel\fR, described below. -If one of the standard channels, \fBstdin, stdout\fR or \fBstderr\fR was -previously closed, the act of creating the new channel also assigns it as a -replacement for the standard channel. - -.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. -.PP -The newly created channel is not registered in the supplied interpreter; to -register it, use \fBTcl_RegisterChannel\fR, described below. -If one of the standard channels, \fBstdin, stdout\fR or \fBstderr\fR was -previously closed, the act of creating the new channel also assigns it as a -replacement for the standard channel. - -.SH TCL_MAKEFILECHANNEL -.PP -\fBTcl_MakeFileChannel\fR makes a \fBTcl_Channel\fR from an existing, -platform-specific, file handle. -The newly created channel is not registered in the supplied interpreter; to -register it, use \fBTcl_RegisterChannel\fR, described below. -If one of the standard channels, \fBstdin, stdout\fR or \fBstderr\fR was -previously closed, the act of creating the new channel also assigns it as a -replacement for the standard channel. - -.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, and the caller should -not call \fBTcl_Close\fR for the channel; the channel will be closed -automatically when it is unregistered from the interpreter. -.PP -Code executing outside of any Tcl interpreter can call -\fBTcl_RegisterChannel\fR with \fIinterp\fR as NULL, to indicate that it -wishes to hold a reference to this channel. Subsequently, the channel can -be registered in a Tcl interpreter and it will only be closed when the -matching number of calls to \fBTcl_UnregisterChannel\fR have been made. -This allows code executing outside of any interpreter to safely hold a -reference to a channel that is also registered in a Tcl interpreter. - -.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. -.PP -Code not associated with a Tcl interpreter can call -\fBTcl_UnregisterChannel\fR with \fIinterp\fR as NULL, to indicate to Tcl -that it no longer holds a reference to that channel. If this is the last -reference to the channel, it will now be closed. - -.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. 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 using \fBTcl_RegisterChannel\fR; see the documentation for -\fBTcl_RegisterChannel\fR, above, for details. If the channel has ever been -given as the \fBchan\fR argument in a call to \fBTcl_RegisterChannel\fR, -you should instead use \fBTcl_UnregisterChannel\fR, which will internally -call \fBTcl_Close\fR when all calls to \fBTcl_RegisterChannel\fR have been -matched by corresponding calls to \fBTcl_UnregisterChannel\fR. - -.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 AND TCL_GETSOBJ -.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. -.PP -\fBTcl_GetsObj\fR is the same as \fBTcl_Gets\fR except the resulting -characters are appended to a Tcl object \fBlineObjPtr\fR rather than a -dynamic string. -.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. - -.VS -.SH "PLATFORM ISSUES" -.PP -The handles returned from \fBTcl_GetChannelHandle\fR depend on the -platform and the channel type. On Unix platforms, the handle is -always a Unix file descriptor as returned from the \fBopen\fR system -call. On Windows platforms, the handle is a file \fBHANDLE\fR when -the channel was created with \fBTcl_OpenFileChannel\fR, -\fBTcl_OpenCommandChannel\fR, or \fBTcl_MakeFileChannel\fR. Other -channel types may return a different type of handle on Windows -platforms. On the Macintosh platform, the handle is a file reference -number as returned from \fBHOpenDF\fR. -.VE - -.SH "SEE ALSO" -DString(3), fconfigure(n), filename(n), fopen(2), Tcl_CreateChannel(3) - -.SH KEYWORDS -access point, blocking, buffered I/O, channel, channel driver, end of file, -flush, input, nonblocking, output, read, seek, write diff --git a/doc/regexp.n b/doc/regexp.n deleted file mode 100644 index ed61c8d..0000000 --- a/doc/regexp.n +++ /dev/null @@ -1,145 +0,0 @@ -'\" -'\" 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. -'\" -'\" RCS: @(#) $Id: regexp.n,v 1.2 1998/09/14 18:39:54 stanton Exp $ -'\" -.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 -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. -.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/generic/tcl.h b/generic/tcl.h deleted file mode 100644 index 77b25e5..0000000 --- a/generic/tcl.h +++ /dev/null @@ -1,1580 +0,0 @@ -/* - * 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-1997 Sun Microsystems, Inc. - * Copyright (c) 1993-1996 Lucent Technologies. - * Copyright (c) 1998-1999 Scriptics Corporation. - * - * See the file "license.terms" for information on usage and redistribution - * of this file, and for a DISCLAIMER OF ALL WARRANTIES. - * - * RCS: @(#) $Id: tcl.h,v 1.33 1999/02/03 02:58:25 stanton Exp $ - */ - -#ifndef _TCL -#define _TCL - -/* - * When version numbers change here, must also go into the following files - * and update the version numbers: - * - * README - * library/init.tcl (only if major.minor changes, not patchlevel) - * unix/configure.in - * win/makefile.bc (only if major.minor changes, not patchlevel) - * win/makefile.vc (only if major.minor changes, not patchlevel) - * win/README - * win/README.binary - * mac/README - * - * The release level should be 0 for alpha, 1 for beta, and 2 for - * final/patch. The release serial value is the number that follows the - * "a", "b", or "p" in the patch level; for example, if the patch level - * is 7.6b2, TCL_RELEASE_SERIAL is 2. It restarts at 1 whenever the - * release level is changed, except for the final release which is 0 - * (the first patch will start at 1). - */ - -#define TCL_MAJOR_VERSION 8 -#define TCL_MINOR_VERSION 0 -#define TCL_RELEASE_LEVEL 2 -#define TCL_RELEASE_SERIAL 5 - -#define TCL_VERSION "8.0" -#define TCL_PATCH_LEVEL "8.0.5" - -/* - * The following definitions set up the proper options for Windows - * compilers. We use this method because there is no autoconf equivalent. - */ - -#ifndef __WIN32__ -# if defined(_WIN32) || defined(WIN32) -# define __WIN32__ -# endif -#endif - -#ifdef __WIN32__ -# ifndef STRICT -# define STRICT -# endif -# ifndef USE_PROTOTYPE -# define USE_PROTOTYPE 1 -# endif -# ifndef HAS_STDARG -# define HAS_STDARG 1 -# endif -# ifndef USE_PROTOTYPE -# define USE_PROTOTYPE 1 -# endif - -/* - * Under Windows we need to call Tcl_Alloc in all cases to avoid competing - * C run-time library issues. - */ - -# ifndef USE_TCLALLOC -# define USE_TCLALLOC 1 -# endif -#endif /* __WIN32__ */ - -/* - * The following definitions set up the proper options for Macintosh - * compilers. We use this method because there is no autoconf equivalent. - */ - -#ifdef MAC_TCL -# ifndef HAS_STDARG -# define HAS_STDARG 1 -# endif -# ifndef USE_TCLALLOC -# define USE_TCLALLOC 1 -# endif -# ifndef NO_STRERROR -# define NO_STRERROR 1 -# endif -#endif - -/* - * Utility macros: STRINGIFY takes an argument and wraps it in "" (double - * quotation marks), JOIN joins two arguments. - */ - -#define VERBATIM(x) x -#ifdef _MSC_VER -# define STRINGIFY(x) STRINGIFY1(x) -# define STRINGIFY1(x) #x -# define JOIN(a,b) JOIN1(a,b) -# define JOIN1(a,b) a##b -#else -# ifdef RESOURCE_INCLUDED -# define STRINGIFY(x) STRINGIFY1(x) -# define STRINGIFY1(x) #x -# define JOIN(a,b) JOIN1(a,b) -# define JOIN1(a,b) a##b -# else -# ifdef __STDC__ -# define STRINGIFY(x) #x -# define JOIN(a,b) a##b -# else -# define STRINGIFY(x) "x" -# define JOIN(a,b) VERBATIM(a)VERBATIM(b) -# endif -# endif -#endif - -/* - * A special definition used to allow this header file to be included - * in resource files so that they can get obtain version information from - * this file. Resource compilers don't like all the C stuff, like typedefs - * and procedure declarations, that occur below. - */ - -#ifndef RESOURCE_INCLUDED - -#ifndef BUFSIZ -#include <stdio.h> -#endif - -/* - * 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 - -/* - * Macros used to declare a function to be exported by a DLL. - * Used by Windows, maps to no-op declarations on non-Windows systems. - * The default build on windows is for a DLL, which causes the DLLIMPORT - * and DLLEXPORT macros to be nonempty. To build a static library, the - * macro STATIC_BUILD should be defined. - * The support follows the convention that a macro called BUILD_xxxx, where - * xxxx is the name of a library we are building, is set on the compile line - * for sources that are to be placed in the library. See BUILD_tcl in this - * file for an example of how the macro is to be used. - */ - -#ifdef __WIN32__ -# ifdef STATIC_BUILD -# define DLLIMPORT -# define DLLEXPORT -# else -# if defined(_MSC_VER) || (defined(__GNUC__) && defined(__declspec)) -# define DLLIMPORT __declspec(dllimport) -# define DLLEXPORT __declspec(dllexport) -# else -# define DLLIMPORT -# define DLLEXPORT -# endif -# endif -#else -# define DLLIMPORT -# define DLLEXPORT -#endif - -#ifdef TCL_STORAGE_CLASS -# undef TCL_STORAGE_CLASS -#endif -#ifdef BUILD_tcl -# define TCL_STORAGE_CLASS DLLEXPORT -#else -# define TCL_STORAGE_CLASS DLLIMPORT -#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" TCL_STORAGE_CLASS -#else -# define EXTERN extern TCL_STORAGE_CLASS -#endif - -/* - * Macro to use instead of "void" for arguments that must have - * type "void *" in ANSI C; maps them to type "char *" in - * non-ANSI systems. - */ -#ifndef __WIN32__ -#ifndef VOID -# ifdef __STDC__ -# define VOID void -# else -# define VOID char -# endif -#endif -#else /* __WIN32__ */ -/* - * The following code is copied from winnt.h - */ -#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 used for returning a string result from - * commands. Direct access to the result field is discouraged in Tcl 8.0. - * The interpreter result is either an object or a string, and the two - * values are kept consistent unless some C code sets interp->result - * directly. Programmers should use either the procedure Tcl_GetObjResult() - * or Tcl_GetStringResult() to read the interpreter's result. See the - * SetResult man page for details. - * - * Note: any change to the Tcl_Interp definition below must be mirrored - * in the "real" definition in tclInt.h. - * - * Note: Tcl_ObjCmdProc procedures do not directly set result and freeProc. - * Instead, they set a Tcl_Obj member in the "real" structure that can be - * accessed with Tcl_GetObjResult() and Tcl_SetObjResult(). - */ - -typedef struct Tcl_Interp { - char *result; /* If the last command returned a string - * result, this points to it. */ - void (*freeProc) _ANSI_ARGS_((char *blockPtr)); - /* Zero means the string result is - * statically allocated. TCL_DYNAMIC means - * it was allocated with ckalloc and should - * be freed with ckfree. Other values give - * the address of procedure to invoke to - * free the result. Tcl_Eval must free it - * before executing next command. */ - int errorLine; /* When TCL_ERROR is returned, this gives - * the line number within the command where - * the error occurred (1 if first line). */ -} Tcl_Interp; - -typedef struct Tcl_AsyncHandler_ *Tcl_AsyncHandler; -typedef struct Tcl_Channel_ *Tcl_Channel; -typedef struct Tcl_Command_ *Tcl_Command; -typedef struct Tcl_Event Tcl_Event; -typedef struct Tcl_Pid_ *Tcl_Pid; -typedef struct Tcl_RegExp_ *Tcl_RegExp; -typedef struct Tcl_TimerToken_ *Tcl_TimerToken; -typedef struct Tcl_Trace_ *Tcl_Trace; -typedef struct Tcl_Var_ *Tcl_Var; - -/* - * When a TCL command returns, the interpreter contains a result from the - * command. Programmers are strongly encouraged to use one of the - * procedures Tcl_GetObjResult() or Tcl_GetStringResult() to read the - * interpreter's result. See the SetResult man page for details. Besides - * this result, the command procedure returns an integer code, which is - * one of the following: - * - * TCL_OK Command completed normally; the interpreter's - * result contains the command's result. - * TCL_ERROR The command couldn't be completed successfully; - * the interpreter's result describes what went wrong. - * TCL_RETURN The command requests that the current procedure - * return; the interpreter's result contains the - * procedure's return value. - * TCL_BREAK The command requests that the innermost loop - * be exited; the interpreter's result is meaningless. - * TCL_CONTINUE Go on to the next iteration of the current loop; - * the interpreter's result is meaningless. - */ - -#define TCL_OK 0 -#define TCL_ERROR 1 -#define TCL_RETURN 2 -#define TCL_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; - -/* - * Forward declaration of Tcl_Obj to prevent an error when the forward - * reference to Tcl_Obj is encountered in the procedure types declared - * below. - */ - -struct Tcl_Obj; - -/* - * 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 void (Tcl_DupInternalRepProc) _ANSI_ARGS_((struct Tcl_Obj *srcPtr, - struct Tcl_Obj *dupPtr)); -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_FreeInternalRepProc) _ANSI_ARGS_((struct Tcl_Obj *objPtr)); -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 void (Tcl_NamespaceDeleteProc) _ANSI_ARGS_((ClientData clientData)); -typedef int (Tcl_ObjCmdProc) _ANSI_ARGS_((ClientData clientData, - Tcl_Interp *interp, int objc, struct Tcl_Obj * CONST objv[])); -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 int (Tcl_SetFromAnyProc) _ANSI_ARGS_((Tcl_Interp *interp, - struct Tcl_Obj *objPtr)); -typedef void (Tcl_UpdateStringProc) _ANSI_ARGS_((struct Tcl_Obj *objPtr)); -typedef char *(Tcl_VarTraceProc) _ANSI_ARGS_((ClientData clientData, - Tcl_Interp *interp, char *part1, char *part2, int flags)); - -/* - * The following structure represents a type of object, which is a - * particular internal representation for an object plus a set of - * procedures that provide standard operations on objects of that type. - */ - -typedef struct Tcl_ObjType { - char *name; /* Name of the type, e.g. "int". */ - Tcl_FreeInternalRepProc *freeIntRepProc; - /* Called to free any storage for the type's - * internal rep. NULL if the internal rep - * does not need freeing. */ - Tcl_DupInternalRepProc *dupIntRepProc; - /* Called to create a new object as a copy - * of an existing object. */ - Tcl_UpdateStringProc *updateStringProc; - /* Called to update the string rep from the - * type's internal representation. */ - Tcl_SetFromAnyProc *setFromAnyProc; - /* Called to convert the object's internal - * rep to this type. Frees the internal rep - * of the old type. Returns TCL_ERROR on - * failure. */ -} Tcl_ObjType; - -/* - * One of the following structures exists for each object in the Tcl - * system. An object stores a value as either a string, some internal - * representation, or both. - */ - -typedef struct Tcl_Obj { - int refCount; /* When 0 the object will be freed. */ - char *bytes; /* This points to the first byte of the - * object's string representation. The array - * must be followed by a null byte (i.e., at - * offset length) but may also contain - * embedded null characters. The array's - * storage is allocated by ckalloc. NULL - * means the string rep is invalid and must - * be regenerated from the internal rep. - * Clients should use Tcl_GetStringFromObj - * to get a pointer to the byte array as a - * readonly value. */ - int length; /* The number of bytes at *bytes, not - * including the terminating null. */ - Tcl_ObjType *typePtr; /* Denotes the object's type. Always - * corresponds to the type of the object's - * internal rep. NULL indicates the object - * has no internal rep (has no type). */ - union { /* The internal representation: */ - long longValue; /* - an long integer value */ - double doubleValue; /* - a double-precision floating value */ - VOID *otherValuePtr; /* - another, type-specific value */ - struct { /* - internal rep as two pointers */ - VOID *ptr1; - VOID *ptr2; - } twoPtrValue; - } internalRep; -} Tcl_Obj; - -/* - * Macros to increment and decrement a Tcl_Obj's reference count, and to - * test whether an object is shared (i.e. has reference count > 1). - * Note: clients should use Tcl_DecrRefCount() when they are finished using - * an object, and should never call TclFreeObj() directly. TclFreeObj() is - * only defined and made public in tcl.h to support Tcl_DecrRefCount's macro - * definition. Note also that Tcl_DecrRefCount() refers to the parameter - * "obj" twice. This means that you should avoid calling it with an - * expression that is expensive to compute or has side effects. - */ - -EXTERN void Tcl_IncrRefCount _ANSI_ARGS_((Tcl_Obj *objPtr)); -EXTERN void Tcl_DecrRefCount _ANSI_ARGS_((Tcl_Obj *objPtr)); -EXTERN int Tcl_IsShared _ANSI_ARGS_((Tcl_Obj *objPtr)); - -#ifdef TCL_MEM_DEBUG -# define Tcl_IncrRefCount(objPtr) \ - Tcl_DbIncrRefCount(objPtr, __FILE__, __LINE__) -# define Tcl_DecrRefCount(objPtr) \ - Tcl_DbDecrRefCount(objPtr, __FILE__, __LINE__) -# define Tcl_IsShared(objPtr) \ - Tcl_DbIsShared(objPtr, __FILE__, __LINE__) -#else -# define Tcl_IncrRefCount(objPtr) \ - ++(objPtr)->refCount -# define Tcl_DecrRefCount(objPtr) \ - if (--(objPtr)->refCount <= 0) TclFreeObj(objPtr) -# define Tcl_IsShared(objPtr) \ - ((objPtr)->refCount > 1) -#endif - -/* - * Macros and definitions that help to debug the use of Tcl objects. - * When TCL_MEM_DEBUG is defined, the Tcl_New* declarations are - * overridden to call debugging versions of the object creation procedures. - */ - -EXTERN Tcl_Obj * Tcl_NewBooleanObj _ANSI_ARGS_((int boolValue)); -EXTERN Tcl_Obj * Tcl_NewDoubleObj _ANSI_ARGS_((double doubleValue)); -EXTERN Tcl_Obj * Tcl_NewIntObj _ANSI_ARGS_((int intValue)); -EXTERN Tcl_Obj * Tcl_NewListObj _ANSI_ARGS_((int objc, - Tcl_Obj *CONST objv[])); -EXTERN Tcl_Obj * Tcl_NewLongObj _ANSI_ARGS_((long longValue)); -EXTERN Tcl_Obj * Tcl_NewObj _ANSI_ARGS_((void)); -EXTERN Tcl_Obj * Tcl_NewStringObj _ANSI_ARGS_((char *bytes, - int length)); - -#ifdef TCL_MEM_DEBUG -# define Tcl_NewBooleanObj(val) \ - Tcl_DbNewBooleanObj(val, __FILE__, __LINE__) -# define Tcl_NewDoubleObj(val) \ - Tcl_DbNewDoubleObj(val, __FILE__, __LINE__) -# define Tcl_NewIntObj(val) \ - Tcl_DbNewLongObj(val, __FILE__, __LINE__) -# define Tcl_NewListObj(objc, objv) \ - Tcl_DbNewListObj(objc, objv, __FILE__, __LINE__) -# define Tcl_NewLongObj(val) \ - Tcl_DbNewLongObj(val, __FILE__, __LINE__) -# define Tcl_NewObj() \ - Tcl_DbNewObj(__FILE__, __LINE__) -# define Tcl_NewStringObj(bytes, len) \ - Tcl_DbNewStringObj(bytes, len, __FILE__, __LINE__) -#endif /* TCL_MEM_DEBUG */ - -/* - * The following definitions support Tcl's namespace facility. - * Note: the first five fields must match exactly the fields in a - * Namespace structure (see tcl.h). - */ - -typedef struct Tcl_Namespace { - char *name; /* The namespace's name within its parent - * namespace. This contains no ::'s. The - * name of the global namespace is "" - * although "::" is an synonym. */ - char *fullName; /* The namespace's fully qualified name. - * This starts with ::. */ - ClientData clientData; /* Arbitrary value associated with this - * namespace. */ - Tcl_NamespaceDeleteProc* deleteProc; - /* Procedure invoked when deleting the - * namespace to, e.g., free clientData. */ - struct Tcl_Namespace* parentPtr; - /* Points to the namespace that contains - * this one. NULL if this is the global - * namespace. */ -} Tcl_Namespace; - -/* - * The following structure represents a call frame, or activation record. - * A call frame defines a naming context for a procedure call: its local - * scope (for local variables) and its namespace scope (used for non-local - * variables; often the global :: namespace). A call frame can also define - * the naming context for a namespace eval or namespace inscope command: - * the namespace in which the command's code should execute. The - * Tcl_CallFrame structures exist only while procedures or namespace - * eval/inscope's are being executed, and provide a Tcl call stack. - * - * A call frame is initialized and pushed using Tcl_PushCallFrame and - * popped using Tcl_PopCallFrame. Storage for a Tcl_CallFrame must be - * provided by the Tcl_PushCallFrame caller, and callers typically allocate - * them on the C call stack for efficiency. For this reason, Tcl_CallFrame - * is defined as a structure and not as an opaque token. However, most - * Tcl_CallFrame fields are hidden since applications should not access - * them directly; others are declared as "dummyX". - * - * WARNING!! The structure definition must be kept consistent with the - * CallFrame structure in tclInt.h. If you change one, change the other. - */ - -typedef struct Tcl_CallFrame { - Tcl_Namespace *nsPtr; - int dummy1; - int dummy2; - char *dummy3; - char *dummy4; - char *dummy5; - int dummy6; - char *dummy7; - char *dummy8; - int dummy9; - char* dummy10; -} Tcl_CallFrame; - -/* - * Information about commands that is returned by Tcl_GetCommandInfo and - * passed to Tcl_SetCommandInfo. objProc is an objc/objv object-based - * command procedure while proc is a traditional Tcl argc/argv - * string-based procedure. Tcl_CreateObjCommand and Tcl_CreateCommand - * ensure that both objProc and proc are non-NULL and can be called to - * execute the command. However, it may be faster to call one instead of - * the other. The member isNativeObjectProc is set to 1 if an - * object-based procedure was registered by Tcl_CreateObjCommand, and to - * 0 if a string-based procedure was registered by Tcl_CreateCommand. - * The other procedure is typically set to a compatibility wrapper that - * does string-to-object or object-to-string argument conversions then - * calls the other procedure. - */ - -typedef struct Tcl_CmdInfo { - int isNativeObjectProc; /* 1 if objProc was registered by a call to - * Tcl_CreateObjCommand; 0 otherwise. - * Tcl_SetCmdInfo does not modify this - * field. */ - Tcl_ObjCmdProc *objProc; /* Command's object-based procedure. */ - ClientData objClientData; /* ClientData for object proc. */ - Tcl_CmdProc *proc; /* Command's string-based procedure. */ - ClientData clientData; /* ClientData for string proc. */ - Tcl_CmdDeleteProc *deleteProc; - /* Procedure to call when command is - * deleted. */ - ClientData deleteData; /* Value to pass to deleteProc (usually - * the same as clientData). */ - Tcl_Namespace *namespacePtr; /* Points to the namespace that contains - * this command. Note that Tcl_SetCmdInfo - * will not change a command's namespace; - * use Tcl_RenameCommand to do that. */ - -} 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 malloced 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 that may be passed to Tcl_GetIndexFromObj to force it to disallow - * abbreviated strings. - */ - -#define TCL_EXACT 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_NAMESPACE_ONLY 2 -#define TCL_APPEND_VALUE 4 -#define TCL_LIST_ELEMENT 8 -#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 -#define TCL_PARSE_PART1 0x400 - -/* - * 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. - */ - -EXTERN char * Tcl_Alloc _ANSI_ARGS_((unsigned int size)); -EXTERN void Tcl_Free _ANSI_ARGS_((char *ptr)); -EXTERN char * Tcl_Realloc _ANSI_ARGS_((char *ptr, - unsigned int size)); - -#ifdef TCL_MEM_DEBUG - -# define Tcl_Alloc(x) Tcl_DbCkalloc(x, __FILE__, __LINE__) -# define Tcl_Free(x) Tcl_DbCkfree(x, __FILE__, __LINE__) -# define Tcl_Realloc(x,y) Tcl_DbCkrealloc((x), (y),__FILE__, __LINE__) -# 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 - -/* - * If USE_TCLALLOC is true, then we need to call Tcl_Alloc instead of - * the native malloc/free. The only time USE_TCLALLOC should not be - * true is when compiling the Tcl/Tk libraries on Unix systems. In this - * case we can safely call the native malloc/free directly as a performance - * optimization. - */ - -# if USE_TCLALLOC -# define ckalloc(x) Tcl_Alloc(x) -# define ckfree(x) Tcl_Free(x) -# define ckrealloc(x,y) Tcl_Realloc(x,y) -# else -# define ckalloc(x) malloc(x) -# define ckfree(x) free(x) -# define ckrealloc(x,y) realloc(x,y) -# endif -# define Tcl_DumpActiveMemory(x) -# define Tcl_ValidateAllMemory(x,y) - -#endif /* TCL_MEM_DEBUG */ - -/* - * 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, - CONST char *key)); - Tcl_HashEntry *(*createProc) _ANSI_ARGS_((struct Tcl_HashTable *tablePtr, - CONST 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 Tcl_QueueEvent: - */ - -typedef enum { - TCL_QUEUE_TAIL, TCL_QUEUE_HEAD, TCL_QUEUE_MARK -} Tcl_QueuePosition; - -/* - * Values to pass to Tcl_SetServiceMode to specify the behavior of notifier - * event routines. - */ - -#define TCL_SERVICE_NONE 0 -#define TCL_SERVICE_ALL 1 - -/* - * The following structure keeps is used to hold a time value, either as - * an absolute time (the number of seconds from the epoch) or as an - * elapsed time. On Unix systems the epoch is Midnight Jan 1, 1970 GMT. - * On Macintosh systems the epoch is Midnight Jan 1, 1904 GMT. - */ - -typedef struct Tcl_Time { - long sec; /* Seconds. */ - long usec; /* Microseconds. */ -} 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, int mode)); -typedef int (Tcl_DriverCloseProc) _ANSI_ARGS_((ClientData instanceData, - Tcl_Interp *interp)); -typedef int (Tcl_DriverInputProc) _ANSI_ARGS_((ClientData instanceData, - char *buf, int toRead, int *errorCodePtr)); -typedef int (Tcl_DriverOutputProc) _ANSI_ARGS_((ClientData instanceData, - char *buf, int toWrite, int *errorCodePtr)); -typedef int (Tcl_DriverSeekProc) _ANSI_ARGS_((ClientData instanceData, - long offset, int mode, int *errorCodePtr)); -typedef int (Tcl_DriverSetOptionProc) _ANSI_ARGS_(( - ClientData instanceData, Tcl_Interp *interp, - char *optionName, char *value)); -typedef int (Tcl_DriverGetOptionProc) _ANSI_ARGS_(( - ClientData instanceData, Tcl_Interp *interp, - char *optionName, Tcl_DString *dsPtr)); -typedef void (Tcl_DriverWatchProc) _ANSI_ARGS_(( - ClientData instanceData, int mask)); -typedef int (Tcl_DriverGetHandleProc) _ANSI_ARGS_(( - ClientData instanceData, int direction, - ClientData *handlePtr)); - -/* - * 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_DriverWatchProc *watchProc; /* Set up the notifier to watch - * for events on this channel. */ - Tcl_DriverGetHandleProc *getHandleProc; - /* Get an OS handle from the channel - * or NULL if not supported. */ - VOID *reserved; /* reserved for future expansion */ -} 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. */ - -/* - * Enum for different types of file paths. - */ - -typedef enum Tcl_PathType { - TCL_PATH_ABSOLUTE, - TCL_PATH_RELATIVE, - TCL_PATH_VOLUME_RELATIVE -} Tcl_PathType; - -/* - * Exported Tcl procedures: - */ - -EXTERN void Tcl_AddErrorInfo _ANSI_ARGS_((Tcl_Interp *interp, - char *message)); -EXTERN void Tcl_AddObjErrorInfo _ANSI_ARGS_((Tcl_Interp *interp, - char *message, int length)); -EXTERN void Tcl_AllowExceptions _ANSI_ARGS_((Tcl_Interp *interp)); -EXTERN int Tcl_AppendAllObjTypes _ANSI_ARGS_(( - Tcl_Interp *interp, Tcl_Obj *objPtr)); -EXTERN void Tcl_AppendElement _ANSI_ARGS_((Tcl_Interp *interp, - char *string)); -EXTERN void Tcl_AppendResult _ANSI_ARGS_( - TCL_VARARGS(Tcl_Interp *,interp)); -EXTERN void Tcl_AppendToObj _ANSI_ARGS_((Tcl_Obj *objPtr, - char *bytes, int length)); -EXTERN void Tcl_AppendStringsToObj _ANSI_ARGS_( - TCL_VARARGS(Tcl_Obj *,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_((CONST char *src, - int *readPtr)); -EXTERN int Tcl_BadChannelOption _ANSI_ARGS_((Tcl_Interp *interp, - char *optionName, char *optionList)); -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)); -#define Tcl_Ckalloc Tcl_Alloc -#define Tcl_Ckfree Tcl_Free -#define Tcl_Ckrealloc Tcl_Realloc -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 Tcl_Obj * Tcl_ConcatObj _ANSI_ARGS_((int objc, - Tcl_Obj *CONST objv[])); -EXTERN int Tcl_ConvertCountedElement _ANSI_ARGS_((CONST char *src, - int length, char *dst, int flags)); -EXTERN int Tcl_ConvertElement _ANSI_ARGS_((CONST char *src, - char *dst, int flags)); -EXTERN int Tcl_ConvertToType _ANSI_ARGS_((Tcl_Interp *interp, - Tcl_Obj *objPtr, Tcl_ObjType *typePtr)); -EXTERN int Tcl_CreateAlias _ANSI_ARGS_((Tcl_Interp *slave, - char *slaveCmd, Tcl_Interp *target, - char *targetCmd, int argc, char **argv)); -EXTERN int Tcl_CreateAliasObj _ANSI_ARGS_((Tcl_Interp *slave, - char *slaveCmd, Tcl_Interp *target, - char *targetCmd, int objc, - Tcl_Obj *CONST objv[])); -EXTERN Tcl_Channel Tcl_CreateChannel _ANSI_ARGS_(( - Tcl_ChannelType *typePtr, char *chanName, - ClientData instanceData, int mask)); -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_(( - int fd, 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 Tcl_Command Tcl_CreateObjCommand _ANSI_ARGS_(( - Tcl_Interp *interp, char *cmdName, - Tcl_ObjCmdProc *proc, ClientData clientData, - Tcl_CmdDeleteProc *deleteProc)); -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_DbDecrRefCount _ANSI_ARGS_((Tcl_Obj *objPtr, - char *file, int line)); -EXTERN void Tcl_DbIncrRefCount _ANSI_ARGS_((Tcl_Obj *objPtr, - char *file, int line)); -EXTERN int Tcl_DbIsShared _ANSI_ARGS_((Tcl_Obj *objPtr, - char *file, int line)); -EXTERN Tcl_Obj * Tcl_DbNewBooleanObj _ANSI_ARGS_((int boolValue, - char *file, int line)); -EXTERN Tcl_Obj * Tcl_DbNewDoubleObj _ANSI_ARGS_((double doubleValue, - char *file, int line)); -EXTERN Tcl_Obj * Tcl_DbNewListObj _ANSI_ARGS_((int objc, - Tcl_Obj *CONST objv[], char *file, int line)); -EXTERN Tcl_Obj * Tcl_DbNewLongObj _ANSI_ARGS_((long longValue, - char *file, int line)); -EXTERN Tcl_Obj * Tcl_DbNewObj _ANSI_ARGS_((char *file, int line)); -EXTERN Tcl_Obj * Tcl_DbNewStringObj _ANSI_ARGS_((char *bytes, - int length, 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 int Tcl_DeleteCommandFromToken _ANSI_ARGS_(( - Tcl_Interp *interp, Tcl_Command command)); -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_DeleteEvents _ANSI_ARGS_(( - Tcl_EventDeleteProc *proc, - ClientData clientData)); -EXTERN void Tcl_DeleteEventSource _ANSI_ARGS_(( - Tcl_EventSetupProc *setupProc, - Tcl_EventCheckProc *checkProc, - ClientData clientData)); -EXTERN void Tcl_DeleteExitHandler _ANSI_ARGS_((Tcl_ExitProc *proc, - ClientData clientData)); -EXTERN void Tcl_DeleteFileHandler _ANSI_ARGS_((int fd)); -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_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, Tcl_Pid *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, - CONST char *string, int length)); -EXTERN char * Tcl_DStringAppendElement _ANSI_ARGS_(( - Tcl_DString *dsPtr, CONST 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 Tcl_Obj * Tcl_DuplicateObj _ANSI_ARGS_((Tcl_Obj *objPtr)); -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 *string)); -EXTERN int Tcl_EvalFile _ANSI_ARGS_((Tcl_Interp *interp, - char *fileName)); -EXTERN void Tcl_EventuallyFree _ANSI_ARGS_((ClientData clientData, - Tcl_FreeProc *freeProc)); -EXTERN int Tcl_EvalObj _ANSI_ARGS_((Tcl_Interp *interp, - Tcl_Obj *objPtr)); -EXTERN void Tcl_Exit _ANSI_ARGS_((int status)); -EXTERN int Tcl_ExposeCommand _ANSI_ARGS_((Tcl_Interp *interp, - char *hiddenCmdToken, char *cmdName)); -EXTERN int Tcl_ExprBoolean _ANSI_ARGS_((Tcl_Interp *interp, - char *string, int *ptr)); -EXTERN int Tcl_ExprBooleanObj _ANSI_ARGS_((Tcl_Interp *interp, - Tcl_Obj *objPtr, int *ptr)); -EXTERN int Tcl_ExprDouble _ANSI_ARGS_((Tcl_Interp *interp, - char *string, double *ptr)); -EXTERN int Tcl_ExprDoubleObj _ANSI_ARGS_((Tcl_Interp *interp, - Tcl_Obj *objPtr, double *ptr)); -EXTERN int Tcl_ExprLong _ANSI_ARGS_((Tcl_Interp *interp, - char *string, long *ptr)); -EXTERN int Tcl_ExprLongObj _ANSI_ARGS_((Tcl_Interp *interp, - Tcl_Obj *objPtr, long *ptr)); -EXTERN int Tcl_ExprObj _ANSI_ARGS_((Tcl_Interp *interp, - Tcl_Obj *objPtr, Tcl_Obj **resultPtrPtr)); -EXTERN int Tcl_ExprString _ANSI_ARGS_((Tcl_Interp *interp, - char *string)); -EXTERN void Tcl_Finalize _ANSI_ARGS_((void)); -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 TclFreeObj _ANSI_ARGS_((Tcl_Obj *objPtr)); -EXTERN void Tcl_FreeResult _ANSI_ARGS_((Tcl_Interp *interp)); -EXTERN int Tcl_GetAlias _ANSI_ARGS_((Tcl_Interp *interp, - char *slaveCmd, Tcl_Interp **targetInterpPtr, - char **targetCmdPtr, int *argcPtr, - char ***argvPtr)); -EXTERN int Tcl_GetAliasObj _ANSI_ARGS_((Tcl_Interp *interp, - char *slaveCmd, Tcl_Interp **targetInterpPtr, - char **targetCmdPtr, int *objcPtr, - Tcl_Obj ***objv)); -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 int Tcl_GetBooleanFromObj _ANSI_ARGS_(( - Tcl_Interp *interp, Tcl_Obj *objPtr, - 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 int Tcl_GetChannelHandle _ANSI_ARGS_((Tcl_Channel chan, - int direction, ClientData *handlePtr)); -EXTERN ClientData Tcl_GetChannelInstanceData _ANSI_ARGS_(( - Tcl_Channel chan)); -EXTERN int Tcl_GetChannelMode _ANSI_ARGS_((Tcl_Channel chan)); -EXTERN char * Tcl_GetChannelName _ANSI_ARGS_((Tcl_Channel chan)); -EXTERN int Tcl_GetChannelOption _ANSI_ARGS_((Tcl_Interp *interp, - Tcl_Channel chan, char *optionName, - Tcl_DString *dsPtr)); -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 int Tcl_GetDouble _ANSI_ARGS_((Tcl_Interp *interp, - char *string, double *doublePtr)); -EXTERN int Tcl_GetDoubleFromObj _ANSI_ARGS_(( - Tcl_Interp *interp, Tcl_Obj *objPtr, - double *doublePtr)); -EXTERN int Tcl_GetErrno _ANSI_ARGS_((void)); -EXTERN char * Tcl_GetHostName _ANSI_ARGS_((void)); -EXTERN int Tcl_GetIndexFromObj _ANSI_ARGS_((Tcl_Interp *interp, - Tcl_Obj *objPtr, char **tablePtr, char *msg, - int flags, int *indexPtr)); -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 int Tcl_GetIntFromObj _ANSI_ARGS_((Tcl_Interp *interp, - Tcl_Obj *objPtr, int *intPtr)); -EXTERN int Tcl_GetLongFromObj _ANSI_ARGS_((Tcl_Interp *interp, - Tcl_Obj *objPtr, long *longPtr)); -EXTERN Tcl_Interp * Tcl_GetMaster _ANSI_ARGS_((Tcl_Interp *interp)); -EXTERN CONST char * Tcl_GetNameOfExecutable _ANSI_ARGS_((void)); -EXTERN Tcl_Obj * Tcl_GetObjResult _ANSI_ARGS_((Tcl_Interp *interp)); -EXTERN Tcl_ObjType * Tcl_GetObjType _ANSI_ARGS_((char *typeName)); -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 int Tcl_GetsObj _ANSI_ARGS_((Tcl_Channel chan, - Tcl_Obj *objPtr)); -EXTERN int Tcl_GetServiceMode _ANSI_ARGS_((void)); -EXTERN Tcl_Interp * Tcl_GetSlave _ANSI_ARGS_((Tcl_Interp *interp, - char *slaveName)); -EXTERN Tcl_Channel Tcl_GetStdChannel _ANSI_ARGS_((int type)); -EXTERN char * Tcl_GetStringFromObj _ANSI_ARGS_((Tcl_Obj *objPtr, - int *lengthPtr)); -EXTERN char * Tcl_GetStringResult _ANSI_ARGS_((Tcl_Interp *interp)); -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 int Tcl_GlobalEvalObj _ANSI_ARGS_((Tcl_Interp *interp, - Tcl_Obj *objPtr)); -EXTERN char * Tcl_HashStats _ANSI_ARGS_((Tcl_HashTable *tablePtr)); -EXTERN int Tcl_HideCommand _ANSI_ARGS_((Tcl_Interp *interp, - char *cmdName, char *hiddenCmdToken)); -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 void Tcl_InvalidateStringRep _ANSI_ARGS_(( - Tcl_Obj *objPtr)); -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 int Tcl_ListObjAppendList _ANSI_ARGS_(( - Tcl_Interp *interp, Tcl_Obj *listPtr, - Tcl_Obj *elemListPtr)); -EXTERN int Tcl_ListObjAppendElement _ANSI_ARGS_(( - Tcl_Interp *interp, Tcl_Obj *listPtr, - Tcl_Obj *objPtr)); -EXTERN int Tcl_ListObjGetElements _ANSI_ARGS_(( - Tcl_Interp *interp, Tcl_Obj *listPtr, - int *objcPtr, Tcl_Obj ***objvPtr)); -EXTERN int Tcl_ListObjIndex _ANSI_ARGS_((Tcl_Interp *interp, - Tcl_Obj *listPtr, int index, - Tcl_Obj **objPtrPtr)); -EXTERN int Tcl_ListObjLength _ANSI_ARGS_((Tcl_Interp *interp, - Tcl_Obj *listPtr, int *intPtr)); -EXTERN int Tcl_ListObjReplace _ANSI_ARGS_((Tcl_Interp *interp, - Tcl_Obj *listPtr, int first, int count, - int objc, Tcl_Obj *CONST objv[])); -EXTERN void Tcl_Main _ANSI_ARGS_((int argc, char **argv, - Tcl_AppInitProc *appInitProc)); -EXTERN Tcl_Channel Tcl_MakeFileChannel _ANSI_ARGS_((ClientData handle, - 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 void Tcl_NotifyChannel _ANSI_ARGS_((Tcl_Channel channel, - int mask)); -EXTERN Tcl_Obj * Tcl_ObjGetVar2 _ANSI_ARGS_((Tcl_Interp *interp, - Tcl_Obj *part1Ptr, Tcl_Obj *part2Ptr, - int flags)); -EXTERN Tcl_Obj * Tcl_ObjSetVar2 _ANSI_ARGS_((Tcl_Interp *interp, - Tcl_Obj *part1Ptr, Tcl_Obj *part2Ptr, - Tcl_Obj *newValuePtr, int flags)); -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 int Tcl_RecordAndEvalObj _ANSI_ARGS_((Tcl_Interp *interp, - Tcl_Obj *cmdPtr, 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_RegisterObjType _ANSI_ARGS_(( - Tcl_ObjType *typePtr)); -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_ScanCountedElement _ANSI_ARGS_((CONST char *string, - int length, int *flagPtr)); -EXTERN int Tcl_ScanElement _ANSI_ARGS_((CONST char *string, - int *flagPtr)); -EXTERN int Tcl_Seek _ANSI_ARGS_((Tcl_Channel chan, - int offset, int mode)); -EXTERN int Tcl_ServiceAll _ANSI_ARGS_((void)); -EXTERN int Tcl_ServiceEvent _ANSI_ARGS_((int flags)); -EXTERN void Tcl_SetAssocData _ANSI_ARGS_((Tcl_Interp *interp, - char *name, Tcl_InterpDeleteProc *proc, - ClientData clientData)); -EXTERN void Tcl_SetBooleanObj _ANSI_ARGS_((Tcl_Obj *objPtr, - int boolValue)); -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_SetDoubleObj _ANSI_ARGS_((Tcl_Obj *objPtr, - double doubleValue)); -EXTERN void Tcl_SetErrno _ANSI_ARGS_((int err)); -EXTERN void Tcl_SetErrorCode _ANSI_ARGS_( - TCL_VARARGS(Tcl_Interp *,arg1)); -EXTERN void Tcl_SetIntObj _ANSI_ARGS_((Tcl_Obj *objPtr, - int intValue)); -EXTERN void Tcl_SetListObj _ANSI_ARGS_((Tcl_Obj *objPtr, - int objc, Tcl_Obj *CONST objv[])); -EXTERN void Tcl_SetLongObj _ANSI_ARGS_((Tcl_Obj *objPtr, - long longValue)); -EXTERN void Tcl_SetMaxBlockTime _ANSI_ARGS_((Tcl_Time *timePtr)); -EXTERN void Tcl_SetObjErrorCode _ANSI_ARGS_((Tcl_Interp *interp, - Tcl_Obj *errorObjPtr)); -EXTERN void Tcl_SetObjLength _ANSI_ARGS_((Tcl_Obj *objPtr, - int length)); -EXTERN void Tcl_SetObjResult _ANSI_ARGS_((Tcl_Interp *interp, - Tcl_Obj *resultObjPtr)); -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 int Tcl_SetServiceMode _ANSI_ARGS_((int mode)); -EXTERN void Tcl_SetStdChannel _ANSI_ARGS_((Tcl_Channel channel, - int type)); -EXTERN void Tcl_SetStringObj _ANSI_ARGS_((Tcl_Obj *objPtr, - char *bytes, int length)); -EXTERN void Tcl_SetTimer _ANSI_ARGS_((Tcl_Time *timePtr)); -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 void Tcl_SourceRCFile _ANSI_ARGS_((Tcl_Interp *interp)); -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 int Tcl_Ungets _ANSI_ARGS_((Tcl_Channel chan, char *str, - int len, int atHead)); -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 Tcl_Pid Tcl_WaitPid _ANSI_ARGS_((Tcl_Pid pid, int *statPtr, - int options)); -EXTERN int Tcl_Write _ANSI_ARGS_((Tcl_Channel chan, - char *s, int slen)); -EXTERN void Tcl_WrongNumArgs _ANSI_ARGS_((Tcl_Interp *interp, - int objc, Tcl_Obj *CONST objv[], char *message)); - -#undef TCL_STORAGE_CLASS -#define TCL_STORAGE_CLASS - -/* - * Convenience declaration of Tcl_AppInit for backwards compatibility. - * This function is not *implemented* by the tcl library, so the storage - * class is neither DLLEXPORT nor DLLIMPORT - */ - -EXTERN int Tcl_AppInit _ANSI_ARGS_((Tcl_Interp *interp)); - -#endif /* RESOURCE_INCLUDED */ - -#undef TCL_STORAGE_CLASS -#define TCL_STORAGE_CLASS DLLIMPORT - -#endif /* _TCL */ diff --git a/generic/tclFCmd.c b/generic/tclFCmd.c deleted file mode 100644 index 1d4ae62..0000000 --- a/generic/tclFCmd.c +++ /dev/null @@ -1,816 +0,0 @@ -/* - * tclFCmd.c - * - * This file implements the generic portion of file manipulation - * subcommands of the "file" command. - * - * Copyright (c) 1996-1997 Sun Microsystems, Inc. - * - * See the file "license.terms" for information on usage and redistribution - * of this file, and for a DISCLAIMER OF ALL WARRANTIES. - * - * RCS: @(#) $Id: tclFCmd.c,v 1.3 1998/09/14 18:39:59 stanton Exp $ - */ - -#include "tclInt.h" -#include "tclPort.h" - -/* - * Declarations for local procedures defined in this file: - */ - -static int CopyRenameOneFile _ANSI_ARGS_((Tcl_Interp *interp, - char *source, char *dest, int copyFlag, - int force)); -static char * FileBasename _ANSI_ARGS_((Tcl_Interp *interp, - char *path, Tcl_DString *bufferPtr)); -static int FileCopyRename _ANSI_ARGS_((Tcl_Interp *interp, - int argc, char **argv, int copyFlag)); -static int FileForceOption _ANSI_ARGS_((Tcl_Interp *interp, - int argc, char **argv, int *forcePtr)); - -/* - *--------------------------------------------------------------------------- - * - * TclFileRenameCmd - * - * This procedure implements the "rename" subcommand of the "file" - * command. Filename arguments need to be translated to native - * format before being passed to platform-specific code that - * implements rename functionality. - * - * Results: - * A standard Tcl result. - * - * Side effects: - * See the user documentation. - * - *--------------------------------------------------------------------------- - */ - -int -TclFileRenameCmd(interp, argc, argv) - Tcl_Interp *interp; /* Interp for error reporting. */ - int argc; /* Number of arguments. */ - char **argv; /* Argument strings passed to Tcl_FileCmd. */ -{ - return FileCopyRename(interp, argc, argv, 0); -} - -/* - *--------------------------------------------------------------------------- - * - * TclFileCopyCmd - * - * This procedure implements the "copy" subcommand of the "file" - * command. Filename arguments need to be translated to native - * format before being passed to platform-specific code that - * implements copy functionality. - * - * Results: - * A standard Tcl result. - * - * Side effects: - * See the user documentation. - * - *--------------------------------------------------------------------------- - */ - -int -TclFileCopyCmd(interp, argc, argv) - Tcl_Interp *interp; /* Used for error reporting */ - int argc; /* Number of arguments. */ - char **argv; /* Argument strings passed to Tcl_FileCmd. */ -{ - return FileCopyRename(interp, argc, argv, 1); -} - -/* - *--------------------------------------------------------------------------- - * - * FileCopyRename -- - * - * Performs the work of TclFileRenameCmd and TclFileCopyCmd. - * See comments for those procedures. - * - * Results: - * See above. - * - * Side effects: - * See above. - * - *--------------------------------------------------------------------------- - */ - -static int -FileCopyRename(interp, argc, argv, copyFlag) - Tcl_Interp *interp; /* Used for error reporting. */ - int argc; /* Number of arguments. */ - char **argv; /* Argument strings passed to Tcl_FileCmd. */ - int copyFlag; /* If non-zero, copy source(s). Otherwise, - * rename them. */ -{ - int i, result, force; - struct stat statBuf; - Tcl_DString targetBuffer; - char *target; - - i = FileForceOption(interp, argc - 2, argv + 2, &force); - if (i < 0) { - return TCL_ERROR; - } - i += 2; - if ((argc - i) < 2) { - Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], - " ", argv[1], " ?options? source ?source ...? target\"", - (char *) NULL); - return TCL_ERROR; - } - - /* - * If target doesn't exist or isn't a directory, try the copy/rename. - * More than 2 arguments is only valid if the target is an existing - * directory. - */ - - target = Tcl_TranslateFileName(interp, argv[argc - 1], &targetBuffer); - if (target == NULL) { - return TCL_ERROR; - } - - result = TCL_OK; - - /* - * Call TclStat() so that if target is a symlink that points to a - * directory we will put the sources in that directory instead of - * overwriting the symlink. - */ - - if ((TclStat(target, &statBuf) != 0) || !S_ISDIR(statBuf.st_mode)) { - if ((argc - i) > 2) { - errno = ENOTDIR; - Tcl_PosixError(interp); - Tcl_AppendResult(interp, "error ", - ((copyFlag) ? "copying" : "renaming"), ": target \"", - argv[argc - 1], "\" is not a directory", (char *) NULL); - result = TCL_ERROR; - } else { - /* - * Even though already have target == translated(argv[i+1]), - * pass the original argument down, so if there's an error, the - * error message will reflect the original arguments. - */ - - result = CopyRenameOneFile(interp, argv[i], argv[i + 1], copyFlag, - force); - } - Tcl_DStringFree(&targetBuffer); - return result; - } - - /* - * Move each source file into target directory. Extract the basename - * from each source, and append it to the end of the target path. - */ - - for ( ; i < argc - 1; i++) { - char *jargv[2]; - char *source, *newFileName; - Tcl_DString sourceBuffer, newFileNameBuffer; - - source = FileBasename(interp, argv[i], &sourceBuffer); - if (source == NULL) { - result = TCL_ERROR; - break; - } - jargv[0] = argv[argc - 1]; - jargv[1] = source; - Tcl_DStringInit(&newFileNameBuffer); - newFileName = Tcl_JoinPath(2, jargv, &newFileNameBuffer); - result = CopyRenameOneFile(interp, argv[i], newFileName, copyFlag, - force); - Tcl_DStringFree(&sourceBuffer); - Tcl_DStringFree(&newFileNameBuffer); - - if (result == TCL_ERROR) { - break; - } - } - Tcl_DStringFree(&targetBuffer); - return result; -} - -/* - *--------------------------------------------------------------------------- - * - * TclFileMakeDirsCmd - * - * This procedure implements the "mkdir" subcommand of the "file" - * command. Filename arguments need to be translated to native - * format before being passed to platform-specific code that - * implements mkdir functionality. - * - * Results: - * A standard Tcl result. - * - * Side effects: - * See the user documentation. - * - *---------------------------------------------------------------------- - */ -int -TclFileMakeDirsCmd(interp, argc, argv) - Tcl_Interp *interp; /* Used for error reporting. */ - int argc; /* Number of arguments */ - char **argv; /* Argument strings passed to Tcl_FileCmd. */ -{ - Tcl_DString nameBuffer, targetBuffer; - char *errfile; - int result, i, j, pargc; - char **pargv; - struct stat statBuf; - - pargv = NULL; - errfile = NULL; - Tcl_DStringInit(&nameBuffer); - Tcl_DStringInit(&targetBuffer); - - result = TCL_OK; - for (i = 2; i < argc; i++) { - char *name = Tcl_TranslateFileName(interp, argv[i], &nameBuffer); - if (name == NULL) { - result = TCL_ERROR; - break; - } - - Tcl_SplitPath(name, &pargc, &pargv); - if (pargc == 0) { - errno = ENOENT; - errfile = argv[i]; - break; - } - for (j = 0; j < pargc; j++) { - char *target = Tcl_JoinPath(j + 1, pargv, &targetBuffer); - - /* - * Call TclStat() so that if target is a symlink that points - * to a directory we will create subdirectories in that - * directory. - */ - - if (TclStat(target, &statBuf) == 0) { - if (!S_ISDIR(statBuf.st_mode)) { - errno = EEXIST; - errfile = target; - goto done; - } - } else if ((errno != ENOENT) - || (TclpCreateDirectory(target) != TCL_OK)) { - errfile = target; - goto done; - } - Tcl_DStringFree(&targetBuffer); - } - ckfree((char *) pargv); - pargv = NULL; - Tcl_DStringFree(&nameBuffer); - } - - done: - if (errfile != NULL) { - Tcl_AppendResult(interp, "can't create directory \"", - errfile, "\": ", Tcl_PosixError(interp), (char *) NULL); - result = TCL_ERROR; - } - - Tcl_DStringFree(&nameBuffer); - Tcl_DStringFree(&targetBuffer); - if (pargv != NULL) { - ckfree((char *) pargv); - } - return result; -} - -/* - *---------------------------------------------------------------------- - * - * TclFileDeleteCmd - * - * This procedure implements the "delete" subcommand of the "file" - * command. - * - * Results: - * A standard Tcl result. - * - * Side effects: - * See the user documentation. - * - *---------------------------------------------------------------------- - */ - -int -TclFileDeleteCmd(interp, argc, argv) - Tcl_Interp *interp; /* Used for error reporting */ - int argc; /* Number of arguments */ - char **argv; /* Argument strings passed to Tcl_FileCmd. */ -{ - Tcl_DString nameBuffer, errorBuffer; - int i, force, result; - char *errfile; - - i = FileForceOption(interp, argc - 2, argv + 2, &force); - if (i < 0) { - return TCL_ERROR; - } - i += 2; - if ((argc - i) < 1) { - Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], - " ", argv[1], " ?options? file ?file ...?\"", (char *) NULL); - return TCL_ERROR; - } - - errfile = NULL; - result = TCL_OK; - Tcl_DStringInit(&errorBuffer); - Tcl_DStringInit(&nameBuffer); - - for ( ; i < argc; i++) { - struct stat statBuf; - char *name; - - errfile = argv[i]; - Tcl_DStringSetLength(&nameBuffer, 0); - name = Tcl_TranslateFileName(interp, argv[i], &nameBuffer); - if (name == NULL) { - result = TCL_ERROR; - goto done; - } - - /* - * Call lstat() to get info so can delete symbolic link itself. - */ - - if (lstat(name, &statBuf) != 0) { - /* - * Trying to delete a file that does not exist is not - * considered an error, just a no-op - */ - - if (errno != ENOENT) { - result = TCL_ERROR; - } - } else if (S_ISDIR(statBuf.st_mode)) { - result = TclpRemoveDirectory(name, force, &errorBuffer); - if (result != TCL_OK) { - if ((force == 0) && (errno == EEXIST)) { - Tcl_AppendResult(interp, "error deleting \"", argv[i], - "\": directory not empty", (char *) NULL); - Tcl_PosixError(interp); - goto done; - } - - /* - * If possible, use the untranslated name for the file. - */ - - errfile = Tcl_DStringValue(&errorBuffer); - if (strcmp(name, errfile) == 0) { - errfile = argv[i]; - } - } - } else { - result = TclpDeleteFile(name); - } - - if (result == TCL_ERROR) { - break; - } - } - if (result != TCL_OK) { - Tcl_AppendResult(interp, "error deleting \"", errfile, - "\": ", Tcl_PosixError(interp), (char *) NULL); - } - done: - Tcl_DStringFree(&errorBuffer); - Tcl_DStringFree(&nameBuffer); - return result; -} - -/* - *--------------------------------------------------------------------------- - * - * CopyRenameOneFile - * - * Copies or renames specified source file or directory hierarchy - * to the specified target. - * - * Results: - * A standard Tcl result. - * - * Side effects: - * Target is overwritten if the force flag is set. Attempting to - * copy/rename a file onto a directory or a directory onto a file - * will always result in an error. - * - *---------------------------------------------------------------------- - */ - -static int -CopyRenameOneFile(interp, source, target, copyFlag, force) - Tcl_Interp *interp; /* Used for error reporting. */ - char *source; /* Pathname of file to copy. May need to - * be translated. */ - char *target; /* Pathname of file to create/overwrite. - * May need to be translated. */ - int copyFlag; /* If non-zero, copy files. Otherwise, - * rename them. */ - int force; /* If non-zero, overwrite target file if it - * exists. Otherwise, error if target already - * exists. */ -{ - int result; - Tcl_DString sourcePath, targetPath, errorBuffer; - char *targetName, *sourceName, *errfile; - struct stat sourceStatBuf, targetStatBuf; - - sourceName = Tcl_TranslateFileName(interp, source, &sourcePath); - if (sourceName == NULL) { - return TCL_ERROR; - } - targetName = Tcl_TranslateFileName(interp, target, &targetPath); - if (targetName == NULL) { - Tcl_DStringFree(&sourcePath); - return TCL_ERROR; - } - - errfile = NULL; - result = TCL_ERROR; - Tcl_DStringInit(&errorBuffer); - - /* - * We want to copy/rename links and not the files they point to, so we - * use lstat(). If target is a link, we also want to replace the - * link and not the file it points to, so we also use lstat() on the - * target. - */ - - if (lstat(sourceName, &sourceStatBuf) != 0) { - errfile = source; - goto done; - } - if (lstat(targetName, &targetStatBuf) != 0) { - if (errno != ENOENT) { - errfile = target; - goto done; - } - } else { - if (force == 0) { - errno = EEXIST; - errfile = target; - goto done; - } - - /* - * Prevent copying or renaming a file onto itself. Under Windows, - * stat always returns 0 for st_ino. However, the Windows-specific - * code knows how to deal with copying or renaming a file on top of - * itself. It might be a good idea to write a stat that worked. - */ - - if ((sourceStatBuf.st_ino != 0) && (targetStatBuf.st_ino != 0)) { - if ((sourceStatBuf.st_ino == targetStatBuf.st_ino) && - (sourceStatBuf.st_dev == targetStatBuf.st_dev)) { - result = TCL_OK; - goto done; - } - } - - /* - * Prevent copying/renaming a file onto a directory and - * vice-versa. This is a policy decision based on the fact that - * existing implementations of copy and rename on all platforms - * also prevent this. - */ - - if (S_ISDIR(sourceStatBuf.st_mode) - && !S_ISDIR(targetStatBuf.st_mode)) { - errno = EISDIR; - Tcl_AppendResult(interp, "can't overwrite file \"", target, - "\" with directory \"", source, "\"", (char *) NULL); - goto done; - } - if (!S_ISDIR(sourceStatBuf.st_mode) - && S_ISDIR(targetStatBuf.st_mode)) { - errno = EISDIR; - Tcl_AppendResult(interp, "can't overwrite directory \"", target, - "\" with file \"", source, "\"", (char *) NULL); - goto done; - } - } - - if (copyFlag == 0) { - result = TclpRenameFile(sourceName, targetName); - if (result == TCL_OK) { - goto done; - } - - if (errno == EINVAL) { - Tcl_AppendResult(interp, "error renaming \"", source, "\" to \"", - target, "\": trying to rename a volume or ", - "move a directory into itself", (char *) NULL); - goto done; - } else if (errno != EXDEV) { - errfile = target; - goto done; - } - - /* - * The rename failed because the move was across file systems. - * Fall through to copy file and then remove original. Note that - * the low-level TclpRenameFile is allowed to implement - * cross-filesystem moves itself. - */ - } - - if (S_ISDIR(sourceStatBuf.st_mode)) { - result = TclpCopyDirectory(sourceName, targetName, &errorBuffer); - if (result != TCL_OK) { - errfile = Tcl_DStringValue(&errorBuffer); - if (strcmp(errfile, sourceName) == 0) { - errfile = source; - } else if (strcmp(errfile, targetName) == 0) { - errfile = target; - } - } - } else { - result = TclpCopyFile(sourceName, targetName); - if (result != TCL_OK) { - /* - * Well, there really shouldn't be a problem with source, - * because up there we checked to see if it was ok to copy it. - */ - - errfile = target; - } - } - if ((copyFlag == 0) && (result == TCL_OK)) { - if (S_ISDIR(sourceStatBuf.st_mode)) { - result = TclpRemoveDirectory(sourceName, 1, &errorBuffer); - if (result != TCL_OK) { - errfile = Tcl_DStringValue(&errorBuffer); - if (strcmp(errfile, sourceName) == 0) { - errfile = source; - } - } - } else { - result = TclpDeleteFile(sourceName); - if (result != TCL_OK) { - errfile = source; - } - } - if (result != TCL_OK) { - Tcl_AppendResult(interp, "can't unlink \"", errfile, "\": ", - Tcl_PosixError(interp), (char *) NULL); - errfile = NULL; - } - } - - done: - if (errfile != NULL) { - Tcl_AppendResult(interp, - ((copyFlag) ? "error copying \"" : "error renaming \""), - source, (char *) NULL); - if (errfile != source) { - Tcl_AppendResult(interp, "\" to \"", target, (char *) NULL); - if (errfile != target) { - Tcl_AppendResult(interp, "\": \"", errfile, (char *) NULL); - } - } - Tcl_AppendResult(interp, "\": ", Tcl_PosixError(interp), - (char *) NULL); - } - Tcl_DStringFree(&errorBuffer); - Tcl_DStringFree(&sourcePath); - Tcl_DStringFree(&targetPath); - return result; -} - -/* - *--------------------------------------------------------------------------- - * - * FileForceOption -- - * - * Helps parse command line options for file commands that take - * the "-force" and "--" options. - * - * Results: - * The return value is how many arguments from argv were consumed - * by this function, or -1 if there was an error parsing the - * options. If an error occurred, an error message is left in - * interp->result. - * - * Side effects: - * None. - * - *--------------------------------------------------------------------------- - */ - -static int -FileForceOption(interp, argc, argv, forcePtr) - Tcl_Interp *interp; /* Interp, for error return. */ - int argc; /* Number of arguments. */ - char **argv; /* Argument strings. First command line - option, if it exists, begins at */ - int *forcePtr; /* If the "-force" was specified, *forcePtr - * is filled with 1, otherwise with 0. */ -{ - int force, i; - - force = 0; - for (i = 0; i < argc; i++) { - if (argv[i][0] != '-') { - break; - } - if (strcmp(argv[i], "-force") == 0) { - force = 1; - } else if (strcmp(argv[i], "--") == 0) { - i++; - break; - } else { - Tcl_AppendResult(interp, "bad option \"", argv[i], - "\": should be -force or --", (char *)NULL); - return -1; - } - } - *forcePtr = force; - return i; -} -/* - *--------------------------------------------------------------------------- - * - * FileBasename -- - * - * Given a path in either tcl format (with / separators), or in the - * platform-specific format for the current platform, return all the - * characters in the path after the last directory separator. But, - * if path is the root directory, returns no characters. - * - * Results: - * Appends the string that represents the basename to the end of - * the specified initialized DString, returning a pointer to the - * resulting string. If there is an error, an error message is left - * in interp, NULL is returned, and the Tcl_DString is unmodified. - * - * Side effects: - * None. - * - *--------------------------------------------------------------------------- - */ - -static char * -FileBasename(interp, path, bufferPtr) - Tcl_Interp *interp; /* Interp, for error return. */ - char *path; /* Path whose basename to extract. */ - Tcl_DString *bufferPtr; /* Initialized DString that receives - * basename. */ -{ - int argc; - char **argv; - - Tcl_SplitPath(path, &argc, &argv); - if (argc == 0) { - Tcl_DStringInit(bufferPtr); - } else { - if ((argc == 1) && (*path == '~')) { - Tcl_DString buffer; - - ckfree((char *) argv); - path = Tcl_TranslateFileName(interp, path, &buffer); - if (path == NULL) { - return NULL; - } - Tcl_SplitPath(path, &argc, &argv); - Tcl_DStringFree(&buffer); - } - Tcl_DStringInit(bufferPtr); - - /* - * Return the last component, unless it is the only component, and it - * is the root of an absolute path. - */ - - if (argc > 0) { - if ((argc > 1) - || (Tcl_GetPathType(argv[0]) == TCL_PATH_RELATIVE)) { - Tcl_DStringAppend(bufferPtr, argv[argc - 1], -1); - } - } - } - ckfree((char *) argv); - return Tcl_DStringValue(bufferPtr); -} - -/* - *---------------------------------------------------------------------- - * - * TclFileAttrsCmd -- - * - * Sets or gets the platform-specific attributes of a file. The objc-objv - * points to the file name with the rest of the command line following. - * This routine uses platform-specific tables of option strings - * and callbacks. The callback to get the attributes take three - * parameters: - * Tcl_Interp *interp; The interp to report errors with. - * Since this is an object-based API, - * the object form of the result should be - * used. - * CONST char *fileName; This is extracted using - * Tcl_TranslateFileName. - * TclObj **attrObjPtrPtr; A new object to hold the attribute - * is allocated and put here. - * The first two parameters of the callback used to write out the - * attributes are the same. The third parameter is: - * CONST *attrObjPtr; A pointer to the object that has - * the new attribute. - * They both return standard TCL errors; if the routine to get - * an attribute fails, no object is allocated and *attrObjPtrPtr - * is unchanged. - * - * Results: - * Standard TCL error. - * - * Side effects: - * May set file attributes for the file name. - * - *---------------------------------------------------------------------- - */ - -int -TclFileAttrsCmd(interp, objc, objv) - Tcl_Interp *interp; /* The interpreter for error reporting. */ - int objc; /* Number of command line arguments. */ - Tcl_Obj *CONST objv[]; /* The command line objects. */ -{ - Tcl_Obj *resultPtr = Tcl_GetObjResult(interp); - char *fileName; - int length, index; - Tcl_Obj *listObjPtr; - Tcl_Obj *elementObjPtr; - Tcl_DString buffer; - - if ((objc > 2) && ((objc % 2) == 0)) { - Tcl_AppendStringsToObj(resultPtr, - "wrong # args: must be \"file attributes name ?option? ?value? ?option value? ...\"", - (char *) NULL); - return TCL_ERROR; - } - - fileName = Tcl_GetStringFromObj(objv[0], &length); - if (Tcl_TranslateFileName(interp, fileName, &buffer) == NULL) { - return TCL_ERROR; - } - fileName = Tcl_DStringValue(&buffer); - - if (objc == 1) { - listObjPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL); - - for (index = 0; tclpFileAttrStrings[index] != NULL; index++) { - elementObjPtr = Tcl_NewStringObj(tclpFileAttrStrings[index], -1); - Tcl_ListObjAppendElement(interp, listObjPtr, elementObjPtr); - if ((*tclpFileAttrProcs[index].getProc)(interp, index, fileName, - &elementObjPtr) != TCL_OK) { - Tcl_DecrRefCount(listObjPtr); - return TCL_ERROR; - } - Tcl_ListObjAppendElement(interp, listObjPtr, elementObjPtr); - } - Tcl_SetObjResult(interp, listObjPtr); - } else if (objc == 2) { - if (Tcl_GetIndexFromObj(interp, objv[1], tclpFileAttrStrings, "option", - 0, &index) != TCL_OK) { - return TCL_ERROR; - } - if ((*tclpFileAttrProcs[index].getProc)(interp, index, fileName, - &elementObjPtr) != TCL_OK) { - return TCL_ERROR; - } - Tcl_SetObjResult(interp, elementObjPtr); - } else { - int i; - - for (i = 1; i < objc ; i += 2) { - if (Tcl_GetIndexFromObj(interp, objv[i], tclpFileAttrStrings, "option", - 0, &index) != TCL_OK) { - return TCL_ERROR; - } - if ((*tclpFileAttrProcs[index].setProc)(interp, index, fileName, - objv[i + 1]) != TCL_OK) { - return TCL_ERROR; - } - } - } - - Tcl_DStringFree(&buffer); - - return TCL_OK; -} diff --git a/generic/tclIO.c b/generic/tclIO.c deleted file mode 100644 index 9725902..0000000 --- a/generic/tclIO.c +++ /dev/null @@ -1,6053 +0,0 @@ -/* - * 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) 1998 Scriptics Corporation - * Copyright (c) 1995-1997 Sun Microsystems, Inc. - * - * See the file "license.terms" for information on usage and redistribution - * of this file, and for a DISCLAIMER OF ALL WARRANTIES. - * - * RCS: @(#) $Id: tclIO.c,v 1.5 1998/10/30 00:38:38 welch Exp $ - */ - -#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 - -/* - * The following structure encapsulates the state for a background channel - * copy. Note that the data buffer for the copy will be appended to this - * structure. - */ - -typedef struct CopyState { - struct Channel *readPtr; /* Pointer to input channel. */ - struct Channel *writePtr; /* Pointer to output channel. */ - int readFlags; /* Original read channel flags. */ - int writeFlags; /* Original write channel flags. */ - int toRead; /* Number of bytes to copy, or -1. */ - int total; /* Total bytes transferred (written). */ - Tcl_Interp *interp; /* Interp that started the copy. */ - Tcl_Obj *cmdPtr; /* Command to be invoked at completion. */ - int bufSize; /* Size of appended buffer. */ - char buffer[1]; /* Copy buffer, this must be the last - * field. */ -} CopyState; - -/* - * 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; - -/* - * 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; - -/* - * 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_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? */ - Tcl_TimerToken timer; /* Handle to wakeup timer for this channel. */ - CopyState *csPtr; /* State of background copy, or NULL. */ -} 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 even - * 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". */ -#define CHANNEL_DEAD (1<<13) /* The channel has been closed by - * the exit handler (on exit) but - * not deallocated. When any IO - * operation sees this flag on a - * channel, it does not call driver - * level functions to avoid referring - * to deallocated data. */ -#define CHANNEL_GETS_BLOCKED (1<<14) /* The last input operation was a gets - * that failed to get a comlete line. - * When set, file events will not be - * delivered for buffered data unless - * an EOL is present. */ - -/* - * 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; - -/* - * 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 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 void ChannelEventScriptInvoker _ANSI_ARGS_(( - ClientData clientData, int flags)); -static void ChannelTimerProc _ANSI_ARGS_(( - ClientData clientData)); -static void CheckForStdChannelsBeingClosed _ANSI_ARGS_(( - Tcl_Channel chan)); -static void CleanupChannelHandlers _ANSI_ARGS_(( - Tcl_Interp *interp, Channel *chanPtr)); -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 int CopyData _ANSI_ARGS_((CopyState *csPtr, int mask)); -static void CopyEventProc _ANSI_ARGS_((ClientData clientData, - int mask)); -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 DoRead _ANSI_ARGS_((Channel *chanPtr, char *srcPtr, - int slen)); -static int DoWrite _ANSI_ARGS_((Channel *chanPtr, char *srcPtr, - int slen)); -static int FlushChannel _ANSI_ARGS_((Tcl_Interp *interp, - Channel *chanPtr, int calledFromAsyncFlush)); -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 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)); -static int SetBlockMode _ANSI_ARGS_((Tcl_Interp *interp, - Channel *chanPtr, int mode)); -static void StopCopy _ANSI_ARGS_((CopyState *csPtr)); -static void UpdateInterest _ANSI_ARGS_((Channel *chanPtr)); -static int CheckForDeadChannel _ANSI_ARGS_((Tcl_Interp *interp, - Channel *chan)); - -/* - *---------------------------------------------------------------------- - * - * SetBlockMode -- - * - * This function sets the blocking mode for a channel and updates - * the state flags. - * - * Results: - * A standard Tcl result. - * - * Side effects: - * Modifies the blocking mode of the channel and possibly generates - * an error. - * - *---------------------------------------------------------------------- - */ - -static int -SetBlockMode(interp, chanPtr, mode) - Tcl_Interp *interp; /* Interp for error reporting. */ - Channel *chanPtr; /* Channel to modify. */ - int mode; /* One of TCL_MODE_BLOCKING or - * TCL_MODE_NONBLOCKING. */ -{ - int result = 0; - if (chanPtr->typePtr->blockModeProc != NULL) { - result = (chanPtr->typePtr->blockModeProc) (chanPtr->instanceData, - mode); - } - 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 (mode == TCL_MODE_BLOCKING) { - chanPtr->flags &= (~(CHANNEL_NONBLOCKING | BG_FLUSH_SCHEDULED)); - } else { - chanPtr->flags |= CHANNEL_NONBLOCKING; - } - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * - * 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) { - stdinChannel = TclGetDefaultStdChannel(TCL_STDIN); - stdinInitialized = 1; - - /* - * Artificially bump the refcount to ensure that the channel - * is only closed on exit. - * - * NOTE: Must only do this if stdinChannel is not NULL. It - * can be NULL in situations where Tcl is unable to connect - * to the standard input. - */ - - if (stdinChannel != (Tcl_Channel) NULL) { - (void) Tcl_RegisterChannel((Tcl_Interp *) NULL, - stdinChannel); - } - } - channel = stdinChannel; - break; - case TCL_STDOUT: - if (!stdoutInitialized) { - stdoutChannel = TclGetDefaultStdChannel(TCL_STDOUT); - stdoutInitialized = 1; - - /* - * Artificially bump the refcount to ensure that the channel - * is only closed on exit. - * - * NOTE: Must only do this if stdoutChannel is not NULL. It - * can be NULL in situations where Tcl is unable to connect - * to the standard output. - */ - - if (stdoutChannel != (Tcl_Channel) NULL) { - (void) Tcl_RegisterChannel((Tcl_Interp *) NULL, - stdoutChannel); - } - } - channel = stdoutChannel; - break; - case TCL_STDERR: - if (!stderrInitialized) { - stderrChannel = TclGetDefaultStdChannel(TCL_STDERR); - stderrInitialized = 1; - - /* - * Artificially bump the refcount to ensure that the channel - * is only closed on exit. - * - * NOTE: Must only do this if stderrChannel is not NULL. It - * can be NULL in situations where Tcl is unable to connect - * to the standard error. - */ - - if (stderrChannel != (Tcl_Channel) NULL) { - (void) Tcl_RegisterChannel((Tcl_Interp *) NULL, - stderrChannel); - } - } - 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; - } - 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; - - /* - * Set the channel back into blocking mode to ensure that we wait - * for all data to flush out. - */ - - (void) Tcl_SetChannelOption(NULL, (Tcl_Channel) chanPtr, - "-blocking", "on"); - - if ((chanPtr == (Channel *) stdinChannel) || - (chanPtr == (Channel *) stdoutChannel) || - (chanPtr == (Channel *) stderrChannel)) { - - /* - * Decrement the refcount which was earlier artificially bumped - * up to keep the channel from being closed. - */ - - chanPtr->refCount--; - } - - if (chanPtr->refCount <= 0) { - - /* - * 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. - */ - - (void) Tcl_Close((Tcl_Interp *) NULL, (Tcl_Channel) chanPtr); - - } else { - - /* - * The refcount is greater than zero, so flush the channel. - */ - - Tcl_Flush((Tcl_Channel) chanPtr); - - /* - * Call the device driver to actually close the underlying - * device for this channel. - */ - - (chanPtr->typePtr->closeProc) (chanPtr->instanceData, - (Tcl_Interp *) NULL); - - /* - * Finally, we clean up the fields in the channel data structure - * since all of them have been deleted already. We mark the - * channel with CHANNEL_DEAD to prevent any further IO operations - * on it. - */ - - chanPtr->instanceData = (ClientData) NULL; - chanPtr->flags |= CHANNEL_DEAD; - } - } - - /* - * Reinitialize all the variables to the initial state: - */ - - firstChanPtr = (Channel *) NULL; - nestedHandlerPtr = (NextChannelHandler *) NULL; - channelExitHandlerCreated = 0; - stdinChannel = NULL; - stdinInitialized = 0; - stdoutChannel = NULL; - stdoutInitialized = 0; - stderrChannel = NULL; - stderrInitialized = 0; -} - -/* - *---------------------------------------------------------------------- - * - * 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 stdinChan, stdoutChan, stderrChan; - - 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) { - stdinChan = Tcl_GetStdChannel(TCL_STDIN); - if (stdinChan != NULL) { - Tcl_RegisterChannel(interp, stdinChan); - } - stdoutChan = Tcl_GetStdChannel(TCL_STDOUT); - if (stdoutChan != NULL) { - Tcl_RegisterChannel(interp, stdoutChan); - } - stderrChan = Tcl_GetStdChannel(TCL_STDERR); - if (stderrChan != NULL) { - Tcl_RegisterChannel(interp, stderrChan); - } - } - - } - 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); - - ckfree(sPtr->script); - 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) { - if (!(chanPtr->flags & BG_FLUSH_SCHEDULED)) { - (void) Tcl_Close(interp, (Tcl_Channel) chanPtr); - } - } - } - Tcl_DeleteHashTable(hTblPtr); - ckfree((char *) hTblPtr); -} - -/* - *---------------------------------------------------------------------- - * - * CheckForStdChannelsBeingClosed -- - * - * Perform special handling for standard channels being closed. When - * given a standard channel, if the refcount is now 1, it means that - * the last reference to the standard channel is being explicitly - * closed. Now bump the refcount artificially down to 0, to ensure the - * normal handling of channels being closed will occur. Also reset the - * static pointer to the channel to NULL, to avoid dangling references. - * - * Results: - * None. - * - * Side effects: - * Manipulates the refcount on standard channels. May smash the global - * static pointer to a standard channel. - * - *---------------------------------------------------------------------- - */ - -static void -CheckForStdChannelsBeingClosed(chan) - Tcl_Channel chan; -{ - Channel *chanPtr = (Channel *) chan; - - if ((chan == stdinChannel) && (stdinInitialized)) { - if (chanPtr->refCount < 2) { - chanPtr->refCount = 0; - stdinChannel = NULL; - return; - } - } else if ((chan == stdoutChannel) && (stdoutInitialized)) { - if (chanPtr->refCount < 2) { - chanPtr->refCount = 0; - stdoutChannel = NULL; - return; - } - } else if ((chan == stderrChannel) && (stderrInitialized)) { - if (chanPtr->refCount < 2) { - chanPtr->refCount = 0; - stderrChannel = NULL; - return; - } - } -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_UnregisterChannel -- - * - * Deletes the hash entry for a channel associated with an interpreter. - * If the interpreter given as argument is NULL, it only decrements the - * reference count. - * - * 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; - - if (interp != (Tcl_Interp *) NULL) { - hTblPtr = (Tcl_HashTable *) Tcl_GetAssocData(interp, "tclIO", NULL); - if (hTblPtr == (Tcl_HashTable *) NULL) { - return TCL_OK; - } - hPtr = Tcl_FindHashEntry(hTblPtr, chanPtr->channelName); - if (hPtr == (Tcl_HashEntry *) NULL) { - return TCL_OK; - } - if ((Channel *) Tcl_GetHashValue(hPtr) != chanPtr) { - return TCL_OK; - } - Tcl_DeleteHashEntry(hPtr); - - /* - * Remove channel handlers that refer to this interpreter, so that they - * will not be present if the actual close is delayed and more events - * happen on the channel. This may occur if the channel is shared - * between several interpreters, or if the channel has async - * flushing active. - */ - - CleanupChannelHandlers(interp, chanPtr); - } - - chanPtr->refCount--; - - /* - * Perform special handling for standard channels being closed. If the - * refCount is now 1 it means that the last reference to the standard - * channel is being explicitly closed, so bump the refCount down - * artificially to 0. This will ensure that the channel is actually - * closed, below. Also set the static pointer to NULL for the channel. - */ - - CheckForStdChannelsBeingClosed(chan); - - /* - * If the refCount reached zero, close the actual channel. - */ - - if (chanPtr->refCount <= 0) { - - /* - * Ensure that if there is another buffer, it gets flushed - * whether or not we are doing a background flush. - */ - - if ((chanPtr->curOutPtr != NULL) && - (chanPtr->curOutPtr->nextAdded > - chanPtr->curOutPtr->nextRemoved)) { - chanPtr->flags |= BUFFER_READY; - } - 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. - * If the interpreter passed as argument is NULL, it only increments - * the channel refCount. - * - * 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"); - } - if (interp != (Tcl_Interp *) NULL) { - 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, instanceData, mask) - Tcl_ChannelType *typePtr; /* The channel type record. */ - char *chanName; /* Name of channel to record. */ - ClientData instanceData; /* Instance specific data. */ - int mask; /* TCL_READABLE & TCL_WRITABLE to indicate - * if the channel is readable, writable. */ -{ - 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 = mask; - - /* - * 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->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; - chanPtr->timer = NULL; - chanPtr->csPtr = NULL; - - /* - * 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 - * the channel was previously closed explicitly. - */ - - if ((stdinChannel == NULL) && (stdinInitialized == 1)) { - Tcl_SetStdChannel((Tcl_Channel)chanPtr, TCL_STDIN); - Tcl_RegisterChannel((Tcl_Interp *) NULL, (Tcl_Channel) chanPtr); - } else if ((stdoutChannel == NULL) && (stdoutInitialized == 1)) { - Tcl_SetStdChannel((Tcl_Channel)chanPtr, TCL_STDOUT); - Tcl_RegisterChannel((Tcl_Interp *) NULL, (Tcl_Channel) chanPtr); - } else if ((stderrChannel == NULL) && (stderrInitialized == 1)) { - Tcl_SetStdChannel((Tcl_Channel)chanPtr, TCL_STDERR); - Tcl_RegisterChannel((Tcl_Interp *) NULL, (Tcl_Channel) chanPtr); - } - return (Tcl_Channel) chanPtr; -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_GetChannelMode -- - * - * Computes a mask indicating whether the channel is open for - * reading and writing. - * - * Results: - * An OR-ed combination of TCL_READABLE and TCL_WRITABLE. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -int -Tcl_GetChannelMode(chan) - Tcl_Channel chan; /* The channel for which the mode is - * being computed. */ -{ - Channel *chanPtr; /* The actual channel. */ - - chanPtr = (Channel *) chan; - return (chanPtr->flags & (TCL_READABLE | TCL_WRITABLE)); -} - -/* - *---------------------------------------------------------------------- - * - * 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_GetChannelHandle -- - * - * Returns an OS handle associated with a channel. - * - * Results: - * Returns TCL_OK and places the handle in handlePtr, or returns - * TCL_ERROR on failure. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -int -Tcl_GetChannelHandle(chan, direction, handlePtr) - Tcl_Channel chan; /* The channel to get file from. */ - int direction; /* TCL_WRITABLE or TCL_READABLE. */ - ClientData *handlePtr; /* Where to store handle */ -{ - Channel *chanPtr; /* The actual channel. */ - ClientData handle; - int result; - - chanPtr = (Channel *) chan; - result = (chanPtr->typePtr->getHandleProc)(chanPtr->instanceData, - direction, &handle); - if (handlePtr) { - *handlePtr = handle; - } - return result; -} - -/* - *---------------------------------------------------------------------- - * - * 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; -} - -/* - *---------------------------------------------------------------------- - * - * CheckForDeadChannel -- - * - * This function checks is a given channel is Dead. - * (A channel that has been closed but not yet deallocated.) - * - * Results: - * True (1) if channel is Dead, False (0) if channel is Ok - * - * Side effects: - * None - * - *---------------------------------------------------------------------- - */ - -static int -CheckForDeadChannel(interp, chanPtr) - Tcl_Interp *interp; /* For error reporting (can be NULL) */ - Channel *chanPtr; /* The channel to check. */ -{ - if (chanPtr->flags & CHANNEL_DEAD) { - Tcl_SetErrno(EINVAL); - if (interp) { - Tcl_AppendResult(interp, - "unable to access channel: invalid channel", - (char *) NULL); - } - return 1; - } - return 0; -} - -/* - *---------------------------------------------------------------------- - * - * 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; - - /* - * Prevent writing on a dead channel -- a channel that has been closed - * but not yet deallocated. This can occur if the exit handler for the - * channel deallocation runs before all channels are deregistered in - * all interpreters. - */ - - if (CheckForDeadChannel(interp,chanPtr)) return -1; - - /* - * 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, - 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) { - errorCode = 0; - continue; - } - - /* - * If the channel is non-blocking and we would have blocked, - * start a background flushing handler and break out of the loop. - */ - - if ((errorCode == EWOULDBLOCK) || (errorCode == EAGAIN)) { - if (chanPtr->flags & CHANNEL_NONBLOCKING) { - if (!(chanPtr->flags & BG_FLUSH_SCHEDULED)) { - chanPtr->flags |= BG_FLUSH_SCHEDULED; - UpdateInterest(chanPtr); - } - errorCode = 0; - break; - } else { - panic("Blocking channel driver did not block on output"); - } - } - - /* - * Decide whether to report the error upwards or defer it. - */ - - if (calledFromAsyncFlush) { - if (chanPtr->unreportedError == 0) { - chanPtr->unreportedError = errorCode; - } - } else { - Tcl_SetErrno(errorCode); - if (interp != NULL) { - Tcl_SetResult(interp, - Tcl_PosixError(interp), TCL_VOLATILE); - } - } - - /* - * 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 the asynchronous flushing - * mechanism active, cancel the asynchronous flushing. - */ - - if ((chanPtr->outQueueHead == (ChannelBuffer *) NULL) && - (chanPtr->flags & BG_FLUSH_SCHEDULED)) { - chanPtr->flags &= (~(BG_FLUSH_SCHEDULED)); - (chanPtr->typePtr->watchProc)(chanPtr->instanceData, - chanPtr->interestMask); - } - - /* - * 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 = 0; /* 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. */ - - if (chanPtr == NULL) { - return result; - } - - /* - * 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->flags & TCL_WRITABLE)) { - int dummy; - char c; - - c = (char) chanPtr->outEofChar; - (chanPtr->typePtr->outputProc) (chanPtr->instanceData, &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; - } - - /* - * OK, close the channel itself. - */ - - result = (chanPtr->typePtr->closeProc) (chanPtr->instanceData, interp); - - if (chanPtr->channelName != (char *) NULL) { - ckfree(chanPtr->channelName); - } - - /* - * 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); - } - } - - /* - * Cancel any outstanding timer. - */ - - Tcl_DeleteTimerHandler(chanPtr->timer); - - /* - * Mark the channel as deleted by clearing the type structure. - */ - - chanPtr->typePtr = NULL; - - 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. */ - NextChannelHandler *nhPtr; - - if (chan == (Tcl_Channel) NULL) { - return TCL_OK; - } - - /* - * Perform special handling for standard channels being closed. If the - * refCount is now 1 it means that the last reference to the standard - * channel is being explicitly closed, so bump the refCount down - * artificially to 0. This will ensure that the channel is actually - * closed, below. Also set the static pointer to NULL for the channel. - */ - - CheckForStdChannelsBeingClosed(chan); - - chanPtr = (Channel *) chan; - if (chanPtr->refCount > 0) { - panic("called Tcl_Close on channel with refCount > 0"); - } - - /* - * Remove any references to channel handlers for this channel that - * may be about to be invoked. - */ - - for (nhPtr = nestedHandlerPtr; - nhPtr != (NextChannelHandler *) NULL; - nhPtr = nhPtr->nestedHandlerPtr) { - if (nhPtr->nextHandlerPtr && - (nhPtr->nextHandlerPtr->chanPtr == chanPtr)) { - nhPtr->nextHandlerPtr = NULL; - } - } - - /* - * Remove all the channel handler records attached to the channel - * itself. - */ - - for (chPtr = chanPtr->chPtr; - chPtr != (ChannelHandler *) NULL; - chPtr = chNext) { - chNext = chPtr->nextPtr; - ckfree((char *) chPtr); - } - chanPtr->chPtr = (ChannelHandler *) NULL; - - - /* - * Cancel any pending copy operation. - */ - - StopCopy(chanPtr->csPtr); - - /* - * Must set the interest mask now to 0, otherwise infinite loops - * will occur if Tcl_DoOneEvent is called before the channel is - * finally deleted in FlushChannel. This can happen if the channel - * has a background flush active. - */ - - chanPtr->interestMask = 0; - - /* - * Remove any EventScript records for this channel. - */ - - for (ePtr = chanPtr->scriptRecordPtr; - ePtr != (EventScriptRecord *) NULL; - ePtr = eNextPtr) { - eNextPtr = ePtr->nextPtr; - ckfree(ePtr->script); - 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); - } - - /* - * 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; -} - -/* - *---------------------------------------------------------------------- - * - * 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 = (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 the channel is in the middle of a background copy, fail. - */ - - if (chanPtr->csPtr) { - Tcl_SetErrno(EBUSY); - return -1; - } - - /* - * If length passed is negative, assume that the output is null terminated - * and compute its length. - */ - - if (slen < 0) { - slen = strlen(srcPtr); - } - - return DoWrite(chanPtr, srcPtr, slen); -} - -/* - *---------------------------------------------------------------------- - * - * DoWrite -- - * - * 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. - * - *---------------------------------------------------------------------- - */ - -static int -DoWrite(chanPtr, srcPtr, slen) - Channel *chanPtr; /* The channel to buffer output for. */ - char *srcPtr; /* Data to write. */ - int slen; /* Number of bytes to write. */ -{ - 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? */ - - /* - * 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; - } - - /* - * If the channel is in the middle of a background copy, fail. - */ - - if (chanPtr->csPtr) { - Tcl_SetErrno(EBUSY); - return -1; - } - - /* - * 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. */ - - /* - * Prevent reading from a dead channel -- a channel that has been closed - * but not yet deallocated, which can happen if the exit handler for - * channel cleanup has run but the channel is still registered in some - * interpreter. - */ - - if (CheckForDeadChannel(NULL,chanPtr)) return EINVAL; - - /* - * 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; - } - - /* - * 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) { - return 0; - } - - nread = (chanPtr->typePtr->inputProc) (chanPtr->instanceData, - bufPtr->buf + bufPtr->nextAdded, toRead, &result); - - if (nread == 0) { - chanPtr->flags |= CHANNEL_EOF; - } else if (nread < 0) { - if ((result == EWOULDBLOCK) || (result == EAGAIN)) { - chanPtr->flags |= CHANNEL_BLOCKED; - result = EAGAIN; - if (chanPtr->flags & CHANNEL_NONBLOCKING) { - Tcl_SetErrno(result); - } else { - panic("Blocking channel driver did not block on input"); - } - } 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; - } - } - 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'; - bufPtr->nextRemoved--; - } else { - 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 (at least 1) or -1 on failure. - * - * Side effects: - * Consumes input from the channel. - * - *---------------------------------------------------------------------- - */ - -static int -GetEOL(chanPtr) - Channel *chanPtr; /* Channel to queue input on. */ -{ - 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? */ - - /* - * 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 the channel is in the middle of a background copy, fail. - */ - - if (chanPtr->csPtr) { - Tcl_SetErrno(EBUSY); - 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 | CHANNEL_GETS_BLOCKED)); - - 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) { - goto blocked; - } - chanPtr->flags &= (~(CHANNEL_BLOCKED)); - } - if (GetInput(chanPtr) != 0) { - goto blocked; - } - } - - blocked: - - /* - * We didn't get a complete line so we need to indicate to UpdateInterest - * that the gets blocked. It will wait for more data instead of firing - * a timer, avoiding a busy wait. This is where we are assuming that the - * next operation is a gets. No more file events will be delivered on - * this channel until new data arrives or some operation is performed - * on the channel (e.g. gets, read, fconfigure) that changes the blocking - * state. Note that this means a file event will not be delivered even - * though a read would be able to consume the buffered data. - */ - - chanPtr->flags |= CHANNEL_GETS_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. */ - - 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 the channel is in the middle of a background copy, fail. - */ - - if (chanPtr->csPtr) { - Tcl_SetErrno(EBUSY); - return -1; - } - - return DoRead(chanPtr, bufPtr, toRead); -} - -/* - *---------------------------------------------------------------------- - * - * DoRead -- - * - * 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. - * - *---------------------------------------------------------------------- - */ - -static int -DoRead(chanPtr, bufPtr, toRead) - Channel *chanPtr; /* The channel from which to read. */ - char *bufPtr; /* Where to store input read. */ - int toRead; /* Maximum number of characters to read. */ -{ - 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. */ - - /* - * 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 | CHANNEL_GETS_BLOCKED)); - - for (copied = 0; copied < toRead; copied += copiedNow) { - copiedNow = CopyAndTranslateBuffer(chanPtr, bufPtr + copied, - toRead - copied); - if (copiedNow == 0) { - if (chanPtr->flags & CHANNEL_EOF) { - goto done; - } - if (chanPtr->flags & CHANNEL_BLOCKED) { - if (chanPtr->flags & CHANNEL_NONBLOCKING) { - goto done; - } - chanPtr->flags &= (~(CHANNEL_BLOCKED)); - } - result = GetInput(chanPtr); - if (result != 0) { - if (result != EAGAIN) { - copied = -1; - } - goto done; - } - } - } - - chanPtr->flags &= (~(CHANNEL_BLOCKED)); - - done: - /* - * Update the notifier state so we don't block while there is still - * data in the buffers. - */ - - UpdateInterest(chanPtr); - return copied; -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_Gets -- - * - * Reads a complete line of input from the channel into a - * Tcl_DString. - * - * 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; - - lineLen = GetEOL(chanPtr); - if (lineLen < 0) { - copiedTotal = -1; - goto done; - } - 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); - - done: - /* - * Update the notifier state so we don't block while there is still - * data in the buffers. - */ - - UpdateInterest(chanPtr); - return copiedTotal; -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_GetsObj -- - * - * Reads a complete line of input from the channel into a - * string object. - * - * 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_GetsObj(chan, objPtr) - Tcl_Channel chan; /* Channel from which to read. */ - Tcl_Obj *objPtr; /* The characters of the line read - * (excluding the terminating newline if - * present) will be appended to this - * object. 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; - - lineLen = GetEOL(chanPtr); - if (lineLen < 0) { - copiedTotal = -1; - goto done; - } - - (void) Tcl_GetStringFromObj(objPtr, &offset); - Tcl_SetObjLength(objPtr, lineLen + offset); - buf = Tcl_GetStringFromObj(objPtr, NULL) + offset; - - for (copiedTotal = 0; copiedTotal < lineLen; copiedTotal += copiedNow) { - copiedNow = CopyAndTranslateBuffer(chanPtr, buf + copiedTotal, - lineLen - copiedTotal); - } - if ((copiedTotal > 0) && (buf[copiedTotal - 1] == '\n')) { - copiedTotal--; - } - Tcl_SetObjLength(objPtr, copiedTotal + offset); - - done: - /* - * Update the notifier state so we don't block while there is still - * data in the buffers. - */ - - UpdateInterest(chanPtr); - return copiedTotal; -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_Ungets -- - * - * Causes the supplied string to be added to the input queue of - * the channel, at either the head or tail of the queue. - * - * Results: - * The number of bytes stored in the channel, or -1 on error. - * - * Side effects: - * Adds input to the input queue of a channel. - * - *---------------------------------------------------------------------- - */ - -int -Tcl_Ungets(chan, str, len, atEnd) - Tcl_Channel chan; /* The channel for which to add the input. */ - char *str; /* The input itself. */ - int len; /* The length of the input. */ - int atEnd; /* If non-zero, add at end of queue; otherwise - * add at head of queue. */ -{ - Channel *chanPtr; /* The real IO channel. */ - ChannelBuffer *bufPtr; /* Buffer to contain the data. */ - int i; - - 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 the channel is in the middle of a background copy, fail. - */ - - if (chanPtr->csPtr) { - Tcl_SetErrno(EBUSY); - return -1; - } - - /* - * If we have encountered a sticky EOF, just punt without storing. - * (sticky EOF is set if we have seen the input eofChar, to prevent - * reading beyond the eofChar). Otherwise, clear the EOF flags, and - * clear the BLOCKED bit. We want to discover these conditions anew - * in each operation. - */ - - if (chanPtr->flags & CHANNEL_STICKY_EOF) { - return len; - } - chanPtr->flags &= (~(CHANNEL_BLOCKED | CHANNEL_EOF)); - - bufPtr = (ChannelBuffer *) ckalloc((unsigned) - (CHANNELBUFFER_HEADER_SIZE + len)); - for (i = 0; i < len; i++) { - bufPtr->buf[i] = str[i]; - } - bufPtr->bufSize = len; - bufPtr->nextAdded = len; - bufPtr->nextRemoved = 0; - - if (chanPtr->inQueueHead == (ChannelBuffer *) NULL) { - bufPtr->nextPtr = (ChannelBuffer *) NULL; - chanPtr->inQueueHead = bufPtr; - chanPtr->inQueueTail = bufPtr; - } else if (atEnd) { - bufPtr->nextPtr = (ChannelBuffer *) NULL; - chanPtr->inQueueTail->nextPtr = bufPtr; - chanPtr->inQueueTail = bufPtr; - } else { - bufPtr->nextPtr = chanPtr->inQueueHead; - chanPtr->inQueueHead = bufPtr; - } - - /* - * Update the notifier state so we don't block while there is still - * data in the buffers. - */ - - UpdateInterest(chanPtr); - return len; -} - -/* - *---------------------------------------------------------------------- - * - * 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; - 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; - } - - /* - * If the channel is in the middle of a background copy, fail. - */ - - if (chanPtr->csPtr) { - Tcl_SetErrno(EBUSY); - return -1; - } - - /* - * Disallow seek on dead channels -- channels that have been closed but - * not yet been deallocated. Such channels can be found if the exit - * handler for channel cleanup has run but the channel is still - * registered in an interpreter. - */ - - if (CheckForDeadChannel(NULL,chanPtr)) 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, - TCL_MODE_BLOCKING); - } - if (result != 0) { - Tcl_SetErrno(result); - return -1; - } - chanPtr->flags &= (~(CHANNEL_NONBLOCKING)); - if (chanPtr->flags & BG_FLUSH_SCHEDULED) { - 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, - (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, - 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; - 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 dead channels -- channels that have been closed but - * not yet been deallocated. Such channels can be found if the exit - * handler for channel cleanup has run but the channel is still - * registered in an interpreter. - */ - - if (CheckForDeadChannel(NULL,chanPtr)) 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; - } - - /* - * If the channel is in the middle of a background copy, fail. - */ - - if (chanPtr->csPtr) { - Tcl_SetErrno(EBUSY); - 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) && - (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; - } - - /* - * 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, - (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 the buffer size is smaller than 10 bytes or larger than one MByte, - * do not accept the requested size and leave the current buffer size. - */ - - if (sz < 10) { - return; - } - if (sz > (1024 * 1024)) { - return; - } - - 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_BadChannelOption -- - * - * This procedure generates a "bad option" error message in an - * (optional) interpreter. It is used by channel drivers when - * a invalid Set/Get option is requested. Its purpose is to concatenate - * the generic options list to the specific ones and factorize - * the generic options error message string. - * - * Results: - * TCL_ERROR. - * - * Side effects: - * An error message is generated in interp's result object to - * indicate that a command was invoked with the a bad option - * The message has the form - * bad option "blah": should be one of - * <...generic options...>+<...specific options...> - * "blah" is the optionName argument and "<specific options>" - * is a space separated list of specific option words. - * The function takes good care of inserting minus signs before - * each option, commas after, and an "or" before the last option. - * - *---------------------------------------------------------------------- - */ - -int -Tcl_BadChannelOption(interp, optionName, optionList) - Tcl_Interp *interp; /* Current interpreter. (can be NULL)*/ - char *optionName; /* 'bad option' name */ - char *optionList; /* Specific options list to append - * to the standard generic options. - * can be NULL for generic options - * only. - */ -{ - if (interp) { - CONST char *genericopt = - "blocking buffering buffersize eofchar translation"; - char **argv; - int argc, i; - Tcl_DString ds; - - Tcl_DStringInit(&ds); - Tcl_DStringAppend(&ds, (char *) genericopt, -1); - if (optionList && (*optionList)) { - Tcl_DStringAppend(&ds, " ", 1); - Tcl_DStringAppend(&ds, optionList, -1); - } - if (Tcl_SplitList(interp, Tcl_DStringValue(&ds), - &argc, &argv) != TCL_OK) { - panic("malformed option list in channel driver"); - } - Tcl_ResetResult(interp); - Tcl_AppendResult(interp, "bad option \"", optionName, - "\": should be one of ", (char *) NULL); - argc--; - for (i = 0; i < argc; i++) { - Tcl_AppendResult(interp, "-", argv[i], ", ", (char *) NULL); - } - Tcl_AppendResult(interp, "or -", argv[i], (char *) NULL); - Tcl_DStringFree(&ds); - ckfree((char *) argv); - } - Tcl_SetErrno(EINVAL); - return TCL_ERROR; -} - -/* - *---------------------------------------------------------------------- - * - * 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: - * None. - * - *---------------------------------------------------------------------- - */ - -int -Tcl_GetChannelOption(interp, chan, optionName, dsPtr) - Tcl_Interp *interp; /* For error reporting - can be NULL. */ - Tcl_Channel chan; /* Channel on which to get option. */ - char *optionName; /* Option to get. */ - Tcl_DString *dsPtr; /* Where to store value(s). */ -{ - size_t len; /* Length of optionName string. */ - char optionVal[128]; /* Buffer for sprintf. */ - Channel *chanPtr = (Channel *) chan; - int flags; - - /* - * If we are in the middle of a background copy, use the saved flags. - */ - - if (chanPtr->csPtr) { - if (chanPtr == chanPtr->csPtr->readPtr) { - flags = chanPtr->csPtr->readFlags; - } else { - flags = chanPtr->csPtr->writeFlags; - } - } else { - flags = chanPtr->flags; - } - - /* - * Disallow options on dead channels -- channels that have been closed but - * not yet been deallocated. Such channels can be found if the exit - * handler for channel cleanup has run but the channel is still - * registered in an interpreter. - */ - - if (CheckForDeadChannel(interp,chanPtr)) return TCL_ERROR; - - /* - * 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, - (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 (flags & CHANNEL_LINEBUFFERED) { - Tcl_DStringAppendElement(dsPtr, "line"); - } else if (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"); - } - TclFormatInt(optionVal, 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 (((flags & (TCL_READABLE|TCL_WRITABLE)) == - (TCL_READABLE|TCL_WRITABLE)) && (len == 0)) { - Tcl_DStringStartSublist(dsPtr); - } - if (flags & TCL_READABLE) { - if (chanPtr->inEofChar == 0) { - Tcl_DStringAppendElement(dsPtr, ""); - } else { - char buf[4]; - - sprintf(buf, "%c", chanPtr->inEofChar); - Tcl_DStringAppendElement(dsPtr, buf); - } - } - if (flags & TCL_WRITABLE) { - if (chanPtr->outEofChar == 0) { - Tcl_DStringAppendElement(dsPtr, ""); - } else { - char buf[4]; - - sprintf(buf, "%c", chanPtr->outEofChar); - Tcl_DStringAppendElement(dsPtr, buf); - } - } - if (((flags & (TCL_READABLE|TCL_WRITABLE)) == - (TCL_READABLE|TCL_WRITABLE)) && (len == 0)) { - 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 (((flags & (TCL_READABLE|TCL_WRITABLE)) == - (TCL_READABLE|TCL_WRITABLE)) && (len == 0)) { - Tcl_DStringStartSublist(dsPtr); - } - if (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 (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 (((flags & (TCL_READABLE|TCL_WRITABLE)) == - (TCL_READABLE|TCL_WRITABLE)) && (len == 0)) { - Tcl_DStringEndSublist(dsPtr); - } - if (len > 0) { - return TCL_OK; - } - } - if (chanPtr->typePtr->getOptionProc != (Tcl_DriverGetOptionProc *) NULL) { - /* - * let the driver specific handle additional options - * and result code and message. - */ - - return (chanPtr->typePtr->getOptionProc) (chanPtr->instanceData, - interp, optionName, dsPtr); - } else { - /* - * no driver specific options case. - */ - - if (len == 0) { - return TCL_OK; - } - return Tcl_BadChannelOption(interp, optionName, NULL); - } -} - -/* - *---------------------------------------------------------------------- - * - * 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 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; - - /* - * If the channel is in the middle of a background copy, fail. - */ - - if (chanPtr->csPtr) { - if (interp) { - Tcl_AppendResult(interp, - "unable to set channel options: background copy in progress", - (char *) NULL); - } - return TCL_ERROR; - } - - - /* - * Disallow options on dead channels -- channels that have been closed but - * not yet been deallocated. Such channels can be found if the exit - * handler for channel cleanup has run but the channel is still - * registered in an interpreter. - */ - - if (CheckForDeadChannel(NULL,chanPtr)) return TCL_ERROR; - - 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; - } - return SetBlockMode(interp, chanPtr, newMode); - } - - 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_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_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)) { - char *readMode, *writeMode; - - if (Tcl_SplitList(interp, newValue, &argc, &argv) == TCL_ERROR) { - return TCL_ERROR; - } - - if (argc == 1) { - readMode = (chanPtr->flags & TCL_READABLE) ? argv[0] : NULL; - writeMode = (chanPtr->flags & TCL_WRITABLE) ? argv[0] : NULL; - } else if (argc == 2) { - readMode = (chanPtr->flags & TCL_READABLE) ? argv[0] : NULL; - writeMode = (chanPtr->flags & TCL_WRITABLE) ? argv[1] : NULL; - } else { - if (interp) { - Tcl_AppendResult(interp, - "bad value for -translation: must be a one or two", - " element list", (char *) NULL); - } - ckfree((char *) argv); - return TCL_ERROR; - } - - if (readMode) { - if (*readMode == '\0') { - newMode = chanPtr->inputTranslation; - } else if (strcmp(readMode, "auto") == 0) { - newMode = TCL_TRANSLATE_AUTO; - } else if (strcmp(readMode, "binary") == 0) { - chanPtr->inEofChar = 0; - newMode = TCL_TRANSLATE_LF; - } else if (strcmp(readMode, "lf") == 0) { - newMode = TCL_TRANSLATE_LF; - } else if (strcmp(readMode, "cr") == 0) { - newMode = TCL_TRANSLATE_CR; - } else if (strcmp(readMode, "crlf") == 0) { - newMode = TCL_TRANSLATE_CRLF; - } else if (strcmp(readMode, "platform") == 0) { - newMode = TCL_PLATFORM_TRANSLATION; - } else { - if (interp) { - 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; - } - - /* - * Reset the EOL flags since we need to look at any buffered - * data to see if the new translation mode allows us to - * complete the line. - */ - - if (newMode != chanPtr->inputTranslation) { - chanPtr->inputTranslation = (Tcl_EolTranslation) newMode; - chanPtr->flags &= ~(INPUT_SAW_CR); - chanPtr->flags &= ~(CHANNEL_GETS_BLOCKED); - UpdateInterest(chanPtr); - } - } - if (writeMode) { - if (*writeMode == '\0') { - /* Do nothing. */ - } else if (strcmp(writeMode, "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(writeMode, "binary") == 0) { - chanPtr->outEofChar = 0; - chanPtr->outputTranslation = TCL_TRANSLATE_LF; - } else if (strcmp(writeMode, "lf") == 0) { - chanPtr->outputTranslation = TCL_TRANSLATE_LF; - } else if (strcmp(writeMode, "cr") == 0) { - chanPtr->outputTranslation = TCL_TRANSLATE_CR; - } else if (strcmp(writeMode, "crlf") == 0) { - chanPtr->outputTranslation = TCL_TRANSLATE_CRLF; - } else if (strcmp(writeMode, "platform") == 0) { - chanPtr->outputTranslation = TCL_PLATFORM_TRANSLATION; - } else { - if (interp) { - 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); - } - - return Tcl_BadChannelOption(interp, optionName, (char *) NULL); -} - -/* - *---------------------------------------------------------------------- - * - * CleanupChannelHandlers -- - * - * Removes channel handlers that refer to the supplied interpreter, - * so that if the actual channel is not closed now, these handlers - * will not run on subsequent events on the channel. This would be - * erroneous, because the interpreter no longer has a reference to - * this channel. - * - * Results: - * None. - * - * Side effects: - * Removes channel handlers. - * - *---------------------------------------------------------------------- - */ - -static void -CleanupChannelHandlers(interp, chanPtr) - Tcl_Interp *interp; - Channel *chanPtr; -{ - EventScriptRecord *sPtr, *prevPtr, *nextPtr; - - /* - * Remove fileevent records on this channel that refer to the - * given 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); - - ckfree(sPtr->script); - ckfree((char *) sPtr); - } else { - prevPtr = sPtr; - } - } -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_NotifyChannel -- - * - * This procedure is called by a channel driver when a driver - * detects an event on a channel. This procedure is responsible - * for actually handling the event by invoking any channel - * handler callbacks. - * - * Results: - * None. - * - * Side effects: - * Whatever the channel handler callback procedure does. - * - *---------------------------------------------------------------------- - */ - -void -Tcl_NotifyChannel(channel, mask) - Tcl_Channel channel; /* Channel that detected an event. */ - int mask; /* OR'ed combination of TCL_READABLE, - * TCL_WRITABLE, or TCL_EXCEPTION: indicates - * which events were detected. */ -{ - Channel *chanPtr = (Channel *) channel; - ChannelHandler *chPtr; - NextChannelHandler nh; - - /* - * Preserve the channel struct in case the script closes it. - */ - - Tcl_Preserve((ClientData) channel); - - /* - * If we are flushing in the background, be sure to call FlushChannel - * for writable events. Note that we have to discard the writable - * event so we don't call any write handlers before the flush is - * complete. - */ - - if ((chanPtr->flags & BG_FLUSH_SCHEDULED) && (mask & TCL_WRITABLE)) { - FlushChannel(NULL, chanPtr, 1); - mask &= ~TCL_WRITABLE; - } - - /* - * Add this invocation to the list of recursive invocations of - * ChannelHandlerEventProc. - */ - - nh.nextHandlerPtr = (ChannelHandler *) NULL; - nh.nestedHandlerPtr = 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 & mask) != 0) { - nh.nextHandlerPtr = chPtr->nextPtr; - (*(chPtr->proc))(chPtr->clientData, mask); - chPtr = nh.nextHandlerPtr; - } else { - chPtr = chPtr->nextPtr; - } - } - - /* - * Update the notifier interest, since it may have changed after - * invoking event handlers. - */ - - if (chanPtr->typePtr != NULL) { - UpdateInterest(chanPtr); - } - - Tcl_Release((ClientData) channel); - - nestedHandlerPtr = nh.nestedHandlerPtr; -} - -/* - *---------------------------------------------------------------------- - * - * UpdateInterest -- - * - * Arrange for the notifier to call us back at appropriate times - * based on the current state of the channel. - * - * Results: - * None. - * - * Side effects: - * May schedule a timer or driver handler. - * - *---------------------------------------------------------------------- - */ - -static void -UpdateInterest(chanPtr) - Channel *chanPtr; /* Channel to update. */ -{ - int mask = chanPtr->interestMask; - - /* - * If there are flushed buffers waiting to be written, then - * we need to watch for the channel to become writable. - */ - - if (chanPtr->flags & BG_FLUSH_SCHEDULED) { - mask |= TCL_WRITABLE; - } - - /* - * If there is data in the input queue, and we aren't blocked waiting for - * an EOL, then we need to schedule a timer so we don't block in the - * notifier. Also, cancel the read interest so we don't get duplicate - * events. - */ - - if (mask & TCL_READABLE) { - if (!(chanPtr->flags & CHANNEL_GETS_BLOCKED) - && (chanPtr->inQueueHead != (ChannelBuffer *) NULL) - && (chanPtr->inQueueHead->nextRemoved < - chanPtr->inQueueHead->nextAdded)) { - mask &= ~TCL_READABLE; - if (!chanPtr->timer) { - chanPtr->timer = Tcl_CreateTimerHandler(0, ChannelTimerProc, - (ClientData) chanPtr); - } - } - } - (chanPtr->typePtr->watchProc)(chanPtr->instanceData, mask); -} - -/* - *---------------------------------------------------------------------- - * - * ChannelTimerProc -- - * - * Timer handler scheduled by UpdateInterest to monitor the - * channel buffers until they are empty. - * - * Results: - * None. - * - * Side effects: - * May invoke channel handlers. - * - *---------------------------------------------------------------------- - */ - -static void -ChannelTimerProc(clientData) - ClientData clientData; -{ - Channel *chanPtr = (Channel *) clientData; - - if (!(chanPtr->flags & CHANNEL_GETS_BLOCKED) - && (chanPtr->interestMask & TCL_READABLE) - && (chanPtr->inQueueHead != (ChannelBuffer *) NULL) - && (chanPtr->inQueueHead->nextRemoved < - chanPtr->inQueueHead->nextAdded)) { - /* - * Restart the timer in case a channel handler reenters the - * event loop before UpdateInterest gets called by Tcl_NotifyChannel. - */ - - chanPtr->timer = Tcl_CreateTimerHandler(0, ChannelTimerProc, - (ClientData) chanPtr); - Tcl_NotifyChannel((Tcl_Channel)chanPtr, TCL_READABLE); - - } else { - chanPtr->timer = NULL; - UpdateInterest(chanPtr); - } -} - -/* - *---------------------------------------------------------------------- - * - * 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; - - /* - * 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; - } - - UpdateInterest(chanPtr); -} - -/* - *---------------------------------------------------------------------- - * - * 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 not found, return without doing anything. - */ - - if (chPtr == (ChannelHandler *) NULL) { - return; - } - - /* - * 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; - } - } - - /* - * Splice it out of the list of channel handlers. - */ - - 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; - } - - UpdateInterest(chanPtr); -} - -/* - *---------------------------------------------------------------------- - * - * 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); - - ckfree(esPtr->script); - 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)) { - ckfree(esPtr->script); - 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 interpreter so we can report errors on it - * later. Note that we do not need to preserve the channel because - * that is done by Tcl_NotifyChannel before calling channel handlers. - */ - - Tcl_Preserve((ClientData) interp); - result = Tcl_GlobalEval(interp, script); - - /* - * On error, cause a background error and remove the channel handler - * and the script record. - * - * NOTE: Must delete channel handler before causing the background error - * because the background error may want to reinstall the handler. - */ - - if (result != TCL_OK) { - if (chanPtr->typePtr != NULL) { - DeleteScriptRecord(interp, chanPtr, mask); - } - Tcl_BackgroundError(interp); - } - 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) { - EventScriptRecord *esPtr; - for (esPtr = chanPtr->scriptRecordPtr; - esPtr != (EventScriptRecord *) NULL; - esPtr = esPtr->nextPtr) { - if ((esPtr->interp == interp) && (esPtr->mask == mask)) { - Tcl_SetResult(interp, esPtr->script, TCL_STATIC); - break; - } - } - 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; - } - TclFormatInt(buf, 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); - } - TclFormatInt(buf, IOQueued); - Tcl_AppendElement(interp, buf); - - TclFormatInt(buf, Tcl_Tell((Tcl_Channel) chanPtr)); - Tcl_AppendElement(interp, buf); - - TclFormatInt(buf, 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 if (strcmp(argv[3], "none") == 0) { - mask = 0; - } else { - Tcl_AppendResult(interp, "bad event name \"", argv[3], - "\": must be readable, writable, or none", (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); - ckfree(esPtr->script); - 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) { - char *event; - if (esPtr->mask) { - event = ((esPtr->mask == TCL_READABLE) - ? "readable" : "writable"); - } else { - event = "none"; - } - Tcl_AppendElement(interp, event); - 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); - ckfree(esPtr->script); - ckfree((char *) esPtr); - } - chanPtr->scriptRecordPtr = (EventScriptRecord *) NULL; - return TCL_OK; - } - - if ((cmd[0] == 's') && (strncmp(cmd, "set", (unsigned) len) == 0)) { - if (argc != 5) { - Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], - " channelName delete index event\"", (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 (strcmp(argv[4], "readable") == 0) { - mask = TCL_READABLE; - } else if (strcmp(argv[4], "writable") == 0) { - mask = TCL_WRITABLE; - } else if (strcmp(argv[4], "none") == 0) { - mask = 0; - } else { - Tcl_AppendResult(interp, "bad event name \"", argv[4], - "\": must be readable, writable, or none", (char *) NULL); - return TCL_ERROR; - } - esPtr->mask = mask; - Tcl_CreateChannelHandler((Tcl_Channel) chanPtr, mask, - ChannelEventScriptInvoker, (ClientData) esPtr); - return TCL_OK; - } - Tcl_AppendResult(interp, "bad command ", cmd, ", must be one of ", - "add, delete, list, set, or removeall", (char *) NULL); - return TCL_ERROR; - -} - -/* - *---------------------------------------------------------------------- - * - * TclCopyChannel -- - * - * This routine copies data from one channel to another, either - * synchronously or asynchronously. If a command script is - * supplied, the operation runs in the background. The script - * is invoked when the copy completes. Otherwise the function - * waits until the copy is completed before returning. - * - * Results: - * A standard Tcl result. - * - * Side effects: - * May schedule a background copy operation that causes both - * channels to be marked busy. - * - *---------------------------------------------------------------------- - */ - -int -TclCopyChannel(interp, inChan, outChan, toRead, cmdPtr) - Tcl_Interp *interp; /* Current interpreter. */ - Tcl_Channel inChan; /* Channel to read from. */ - Tcl_Channel outChan; /* Channel to write to. */ - int toRead; /* Amount of data to copy, or -1 for all. */ - Tcl_Obj *cmdPtr; /* Pointer to script to execute or NULL. */ -{ - Channel *inPtr = (Channel *) inChan; - Channel *outPtr = (Channel *) outChan; - int readFlags, writeFlags; - CopyState *csPtr; - int nonBlocking = (cmdPtr) ? CHANNEL_NONBLOCKING : 0; - - if (inPtr->csPtr) { - Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "channel \"", - Tcl_GetChannelName(inChan), "\" is busy", NULL); - return TCL_ERROR; - } - if (outPtr->csPtr) { - Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "channel \"", - Tcl_GetChannelName(outChan), "\" is busy", NULL); - return TCL_ERROR; - } - - readFlags = inPtr->flags; - writeFlags = outPtr->flags; - - /* - * Set up the blocking mode appropriately. Background copies need - * non-blocking channels. Foreground copies need blocking channels. - * If there is an error, restore the old blocking mode. - */ - - if (nonBlocking != (readFlags & CHANNEL_NONBLOCKING)) { - if (SetBlockMode(interp, inPtr, - nonBlocking ? TCL_MODE_NONBLOCKING : TCL_MODE_BLOCKING) - != TCL_OK) { - return TCL_ERROR; - } - } - if (inPtr != outPtr) { - if (nonBlocking != (writeFlags & CHANNEL_NONBLOCKING)) { - if (SetBlockMode(NULL, outPtr, - nonBlocking ? TCL_MODE_BLOCKING : TCL_MODE_NONBLOCKING) - != TCL_OK) { - if (nonBlocking != (readFlags & CHANNEL_NONBLOCKING)) { - SetBlockMode(NULL, inPtr, - (readFlags & CHANNEL_NONBLOCKING) - ? TCL_MODE_NONBLOCKING : TCL_MODE_BLOCKING); - return TCL_ERROR; - } - } - } - } - - /* - * Make sure the output side is unbuffered. - */ - - outPtr->flags = (outPtr->flags & ~(CHANNEL_LINEBUFFERED)) - | CHANNEL_UNBUFFERED; - - /* - * Allocate a new CopyState to maintain info about the current copy in - * progress. This structure will be deallocated when the copy is - * completed. - */ - - csPtr = (CopyState*) ckalloc(sizeof(CopyState) + inPtr->bufSize); - csPtr->bufSize = inPtr->bufSize; - csPtr->readPtr = inPtr; - csPtr->writePtr = outPtr; - csPtr->readFlags = readFlags; - csPtr->writeFlags = writeFlags; - csPtr->toRead = toRead; - csPtr->total = 0; - csPtr->interp = interp; - if (cmdPtr) { - Tcl_IncrRefCount(cmdPtr); - } - csPtr->cmdPtr = cmdPtr; - inPtr->csPtr = csPtr; - outPtr->csPtr = csPtr; - - /* - * Start copying data between the channels. - */ - - return CopyData(csPtr, 0); -} - -/* - *---------------------------------------------------------------------- - * - * CopyData -- - * - * This function implements the lowest level of the copying - * mechanism for TclCopyChannel. - * - * Results: - * Returns TCL_OK on success, else TCL_ERROR. - * - * Side effects: - * Moves data between channels, may create channel handlers. - * - *---------------------------------------------------------------------- - */ - -static int -CopyData(csPtr, mask) - CopyState *csPtr; /* State of copy operation. */ - int mask; /* Current channel event flags. */ -{ - Tcl_Interp *interp; - Tcl_Obj *cmdPtr, *errObj = NULL; - Tcl_Channel inChan, outChan; - int result = TCL_OK; - int size; - int total; - - inChan = (Tcl_Channel)csPtr->readPtr; - outChan = (Tcl_Channel)csPtr->writePtr; - interp = csPtr->interp; - cmdPtr = csPtr->cmdPtr; - - /* - * Copy the data the slow way, using the translation mechanism. - */ - - while (csPtr->toRead != 0) { - - /* - * Check for unreported background errors. - */ - - if (csPtr->readPtr->unreportedError != 0) { - Tcl_SetErrno(csPtr->readPtr->unreportedError); - csPtr->readPtr->unreportedError = 0; - goto readError; - } - if (csPtr->writePtr->unreportedError != 0) { - Tcl_SetErrno(csPtr->writePtr->unreportedError); - csPtr->writePtr->unreportedError = 0; - goto writeError; - } - - /* - * Read up to bufSize bytes. - */ - - if ((csPtr->toRead == -1) - || (csPtr->toRead > csPtr->bufSize)) { - size = csPtr->bufSize; - } else { - size = csPtr->toRead; - } - size = DoRead(csPtr->readPtr, csPtr->buffer, size); - - if (size < 0) { - readError: - errObj = Tcl_NewObj(); - Tcl_AppendStringsToObj(errObj, "error reading \"", - Tcl_GetChannelName(inChan), "\": ", - Tcl_PosixError(interp), (char *) NULL); - break; - } else if (size == 0) { - /* - * We had an underflow on the read side. If we are at EOF, - * then the copying is done, otherwise set up a channel - * handler to detect when the channel becomes readable again. - */ - - if (Tcl_Eof(inChan)) { - break; - } else if (!(mask & TCL_READABLE)) { - if (mask & TCL_WRITABLE) { - Tcl_DeleteChannelHandler(outChan, CopyEventProc, - (ClientData) csPtr); - } - Tcl_CreateChannelHandler(inChan, TCL_READABLE, - CopyEventProc, (ClientData) csPtr); - } - return TCL_OK; - } - - /* - * Now write the buffer out. - */ - - size = DoWrite(csPtr->writePtr, csPtr->buffer, size); - if (size < 0) { - writeError: - errObj = Tcl_NewObj(); - Tcl_AppendStringsToObj(errObj, "error writing \"", - Tcl_GetChannelName(outChan), "\": ", - Tcl_PosixError(interp), (char *) NULL); - break; - } - - /* - * Check to see if the write is happening in the background. If so, - * stop copying and wait for the channel to become writable again. - */ - - if (csPtr->writePtr->flags & BG_FLUSH_SCHEDULED) { - if (!(mask & TCL_WRITABLE)) { - if (mask & TCL_READABLE) { - Tcl_DeleteChannelHandler(outChan, CopyEventProc, - (ClientData) csPtr); - } - Tcl_CreateChannelHandler(outChan, TCL_WRITABLE, - CopyEventProc, (ClientData) csPtr); - } - return TCL_OK; - } - - /* - * Update the current byte count if we care. - */ - - if (csPtr->toRead != -1) { - csPtr->toRead -= size; - } - csPtr->total += size; - - /* - * For background copies, we only do one buffer per invocation so - * we don't starve the rest of the system. - */ - - if (cmdPtr) { - /* - * The first time we enter this code, there won't be a - * channel handler established yet, so do it here. - */ - - if (mask == 0) { - Tcl_CreateChannelHandler(outChan, TCL_WRITABLE, - CopyEventProc, (ClientData) csPtr); - } - return TCL_OK; - } - } - - /* - * Make the callback or return the number of bytes transferred. - * The local total is used because StopCopy frees csPtr. - */ - - total = csPtr->total; - if (cmdPtr) { - /* - * Get a private copy of the command so we can mutate it - * by adding arguments. Note that StopCopy frees our saved - * reference to the original command obj. - */ - - cmdPtr = Tcl_DuplicateObj(cmdPtr); - Tcl_IncrRefCount(cmdPtr); - StopCopy(csPtr); - Tcl_Preserve((ClientData) interp); - - Tcl_ListObjAppendElement(interp, cmdPtr, Tcl_NewIntObj(total)); - if (errObj) { - Tcl_ListObjAppendElement(interp, cmdPtr, errObj); - } - if (Tcl_GlobalEvalObj(interp, cmdPtr) != TCL_OK) { - Tcl_BackgroundError(interp); - result = TCL_ERROR; - } - Tcl_DecrRefCount(cmdPtr); - Tcl_Release((ClientData) interp); - } else { - StopCopy(csPtr); - if (errObj) { - Tcl_SetObjResult(interp, errObj); - result = TCL_ERROR; - } else { - Tcl_ResetResult(interp); - Tcl_SetIntObj(Tcl_GetObjResult(interp), total); - } - } - return result; -} - -/* - *---------------------------------------------------------------------- - * - * CopyEventProc -- - * - * This routine is invoked as a channel event handler for - * the background copy operation. It is just a trivial wrapper - * around the CopyData routine. - * - * Results: - * None. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -static void -CopyEventProc(clientData, mask) - ClientData clientData; - int mask; -{ - (void) CopyData((CopyState *)clientData, mask); -} - -/* - *---------------------------------------------------------------------- - * - * StopCopy -- - * - * This routine halts a copy that is in progress. - * - * Results: - * None. - * - * Side effects: - * Removes any pending channel handlers and restores the blocking - * and buffering modes of the channels. The CopyState is freed. - * - *---------------------------------------------------------------------- - */ - -static void -StopCopy(csPtr) - CopyState *csPtr; /* State for bg copy to stop . */ -{ - int nonBlocking; - - if (!csPtr) { - return; - } - - /* - * Restore the old blocking mode and output buffering mode. - */ - - nonBlocking = (csPtr->readFlags & CHANNEL_NONBLOCKING); - if (nonBlocking != (csPtr->readPtr->flags & CHANNEL_NONBLOCKING)) { - SetBlockMode(NULL, csPtr->readPtr, - nonBlocking ? TCL_MODE_NONBLOCKING : TCL_MODE_BLOCKING); - } - if (csPtr->writePtr != csPtr->writePtr) { - if (nonBlocking != (csPtr->writePtr->flags & CHANNEL_NONBLOCKING)) { - SetBlockMode(NULL, csPtr->writePtr, - nonBlocking ? TCL_MODE_NONBLOCKING : TCL_MODE_BLOCKING); - } - } - csPtr->writePtr->flags &= ~(CHANNEL_LINEBUFFERED | CHANNEL_UNBUFFERED); - csPtr->writePtr->flags |= - csPtr->writeFlags & (CHANNEL_LINEBUFFERED | CHANNEL_UNBUFFERED); - - - if (csPtr->cmdPtr) { - Tcl_DeleteChannelHandler((Tcl_Channel)csPtr->readPtr, CopyEventProc, - (ClientData)csPtr); - if (csPtr->readPtr != csPtr->writePtr) { - Tcl_DeleteChannelHandler((Tcl_Channel)csPtr->writePtr, - CopyEventProc, (ClientData)csPtr); - } - Tcl_DecrRefCount(csPtr->cmdPtr); - } - csPtr->readPtr->csPtr = NULL; - csPtr->writePtr->csPtr = NULL; - ckfree((char*) csPtr); -} diff --git a/generic/tclIOUtil.c b/generic/tclIOUtil.c deleted file mode 100644 index c02738e..0000000 --- a/generic/tclIOUtil.c +++ /dev/null @@ -1,872 +0,0 @@ -/* - * 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. - * - * RCS: @(#) $Id: tclIOUtil.c,v 1.5 1998/09/14 18:40:00 stanton Exp $ - */ - -#include "tclInt.h" -#include "tclPort.h" - -/* - * The following typedef declarations allow for hooking into the chain - * of functions maintained for 'Tcl_Stat(...)', 'Tcl_Access(...)' & - * 'Tcl_OpenFileChannel(...)'. Basically for each hookable function - * a linked list is defined. - */ - -typedef struct StatProc { - TclStatProc_ *proc; /* Function to process a 'stat()' call */ - struct StatProc *nextPtr; /* The next 'stat()' function to call */ -} StatProc; - -typedef struct AccessProc { - TclAccessProc_ *proc; /* Function to process a 'access()' call */ - struct AccessProc *nextPtr; /* The next 'access()' function to call */ -} AccessProc; - -typedef struct OpenFileChannelProc { - TclOpenFileChannelProc_ *proc; /* Function to process a - * 'Tcl_OpenFileChannel()' call */ - struct OpenFileChannelProc *nextPtr; - /* The next 'Tcl_OpenFileChannel()' - * function to call */ -} OpenFileChannelProc; - -/* - * For each type of hookable function, a static node is declared to - * hold the function pointer for the "built-in" routine (e.g. - * 'TclpStat(...)') and the respective list is initialized as a pointer - * to that node. - * - * The "delete" functions (e.g. 'TclStatDeleteProc(...)') ensure that - * these statically declared list entry cannot be inadvertently removed. - * - * This method avoids the need to call any sort of "initialization" - * function - */ - -static StatProc defaultStatProc = { - &TclpStat, NULL -}; -static StatProc *statProcList = &defaultStatProc; - -static AccessProc defaultAccessProc = { - &TclpAccess, NULL -}; -static AccessProc *accessProcList = &defaultAccessProc; - -static OpenFileChannelProc defaultOpenFileChannelProc = { - &TclpOpenFileChannel, NULL -}; -static OpenFileChannelProc *openFileChannelProcList = - &defaultOpenFileChannelProc; - -/* - *---------------------------------------------------------------------- - * - * 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; - Interp *iPtr = (Interp *) interp; - Tcl_DString buffer; - char *nativeName; - Tcl_Channel chan; - Tcl_Obj *cmdObjPtr; - - 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 (TclStat(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; - } - - /* - * Transfer the buffer memory allocated above to the object system. - * Tcl_EvalObj will own this new string object if needed, - * so past the Tcl_EvalObj point, we must not ckfree(cmdBuffer) - * but rather use the reference counting mechanism. - * (Nb: and we must not thus not use goto error after this point) - */ - cmdObjPtr = Tcl_NewObj(); - cmdObjPtr->bytes = cmdBuffer; - cmdObjPtr->length = result; - - Tcl_IncrRefCount(cmdObjPtr); - result = Tcl_EvalObj(interp, cmdObjPtr); - Tcl_DecrRefCount(cmdObjPtr); - - 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; - Tcl_DStringFree(&buffer); - return result; - -error: - if (cmdBuffer != (char *) NULL) { - ckfree(cmdBuffer); - } - iPtr->scriptFile = oldScriptFile; - Tcl_DStringFree(&buffer); - return TCL_ERROR; -} - -/* - *---------------------------------------------------------------------- - * - * 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; -} - -/* - *---------------------------------------------------------------------- - * - * TclStat -- - * - * This procedure replaces the library version of stat and lsat. - * The chain of functions that have been "inserted" into the - * 'statProcList' will be called in succession until either - * a value of zero is returned, or the entire list is visited. - * - * Results: - * See stat documentation. - * - * Side effects: - * See stat documentation. - * - *---------------------------------------------------------------------- - */ - -int -TclStat(path, buf) - CONST char *path; /* Path of file to stat (in current CP). */ - TclStat_ *buf; /* Filled with results of stat call. */ -{ - StatProc *statProcPtr = statProcList; - int retVal = -1; - - /* - * Call each of the "stat" function in succession. A non-return - * value of -1 indicates the particular function has succeeded. - */ - - while ((retVal == -1) && (statProcPtr != NULL)) { - retVal = (*statProcPtr->proc)(path, buf); - statProcPtr = statProcPtr->nextPtr; - } - - return (retVal); -} - -/* - *---------------------------------------------------------------------- - * - * TclAccess -- - * - * This procedure replaces the library version of access. - * The chain of functions that have been "inserted" into the - * 'accessProcList' will be called in succession until either - * a value of zero is returned, or the entire list is visited. - * - * Results: - * See access documentation. - * - * Side effects: - * See access documentation. - * - *---------------------------------------------------------------------- - */ - -int -TclAccess(path, mode) - CONST char *path; /* Path of file to access (in current CP). */ - int mode; /* Permission setting. */ -{ - AccessProc *accessProcPtr = accessProcList; - int retVal = -1; - - /* - * Call each of the "access" function in succession. A non-return - * value of -1 indicates the particular function has succeeded. - */ - - while ((retVal == -1) && (accessProcPtr != NULL)) { - retVal = (*accessProcPtr->proc)(path, mode); - accessProcPtr = accessProcPtr->nextPtr; - } - - return (retVal); -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_OpenFileChannel -- - * - * The chain of functions that have been "inserted" into the - * 'openFileChannelProcList' will be called in succession until - * either a valid file channel is returned, or the entire list is - * visited. - * - * Results: - * The new channel or NULL, if the named file could not be opened. - * - * Side effects: - * May open the channel and may cause creation of a file on the - * file system. - * - *---------------------------------------------------------------------- - */ - -Tcl_Channel -Tcl_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? */ -{ - OpenFileChannelProc *openFileChannelProcPtr = openFileChannelProcList; - Tcl_Channel retVal = NULL; - - /* - * Call each of the "Tcl_OpenFileChannel" function in succession. - * A non-NULL return value indicates the particular function has - * succeeded. - */ - - while ((retVal == NULL) && (openFileChannelProcPtr != NULL)) { - retVal = (*openFileChannelProcPtr->proc)(interp, fileName, - modeString, permissions); - openFileChannelProcPtr = openFileChannelProcPtr->nextPtr; - } - - return (retVal); -} - -/* - *---------------------------------------------------------------------- - * - * TclStatInsertProc -- - * - * Insert the passed procedure pointer at the head of the list of - * functions which are used during a call to 'TclStat(...)'. The - * passed function should be have exactly like 'TclStat' when called - * during that time (see 'TclStat(...)' for more informatin). - * The function will be added even if it already in the list. - * - * Results: - * Normally TCL_OK; TCL_ERROR if memory for a new node in the list - * could not be allocated. - * - * Side effects: - * Memory allocataed and modifies the link list for 'TclStat' - * functions. - * - *---------------------------------------------------------------------- - */ - -int -TclStatInsertProc (proc) - TclStatProc_ *proc; -{ - int retVal = TCL_ERROR; - - if (proc != NULL) { - StatProc *newStatProcPtr; - - newStatProcPtr = (StatProc *)Tcl_Alloc(sizeof(StatProc));; - - if (newStatProcPtr != NULL) { - newStatProcPtr->proc = proc; - newStatProcPtr->nextPtr = statProcList; - statProcList = newStatProcPtr; - - retVal = TCL_OK; - } - } - - return (retVal); -} - -/* - *---------------------------------------------------------------------- - * - * TclStatDeleteProc -- - * - * Removed the passed function pointer from the list of 'TclStat' - * functions. Ensures that the built-in stat function is not - * removvable. - * - * Results: - * TCL_OK if the procedure pointer was successfully removed, - * TCL_ERROR otherwise. - * - * Side effects: - * Memory is deallocated and the respective list updated. - * - *---------------------------------------------------------------------- - */ - -int -TclStatDeleteProc (proc) - TclStatProc_ *proc; -{ - int retVal = TCL_ERROR; - StatProc *tmpStatProcPtr = statProcList; - StatProc *prevStatProcPtr = NULL; - - /* - * Traverse the 'statProcList' looking for the particular node - * whose 'proc' member matches 'proc' and remove that one from - * the list. Ensure that the "default" node cannot be removed. - */ - - while ((retVal == TCL_ERROR) && (tmpStatProcPtr != &defaultStatProc)) { - if (tmpStatProcPtr->proc == proc) { - if (prevStatProcPtr == NULL) { - statProcList = tmpStatProcPtr->nextPtr; - } else { - prevStatProcPtr->nextPtr = tmpStatProcPtr->nextPtr; - } - - Tcl_Free((char *)tmpStatProcPtr); - - retVal = TCL_OK; - } else { - prevStatProcPtr = tmpStatProcPtr; - tmpStatProcPtr = tmpStatProcPtr->nextPtr; - } - } - - return (retVal); -} - -/* - *---------------------------------------------------------------------- - * - * TclAccessInsertProc -- - * - * Insert the passed procedure pointer at the head of the list of - * functions which are used during a call to 'TclAccess(...)'. The - * passed function should be have exactly like 'TclAccess' when - * called during that time (see 'TclAccess(...)' for more informatin). - * The function will be added even if it already in the list. - * - * Results: - * Normally TCL_OK; TCL_ERROR if memory for a new node in the list - * could not be allocated. - * - * Side effects: - * Memory allocataed and modifies the link list for 'TclAccess' - * functions. - * - *---------------------------------------------------------------------- - */ - -int -TclAccessInsertProc(proc) - TclAccessProc_ *proc; -{ - int retVal = TCL_ERROR; - - if (proc != NULL) { - AccessProc *newAccessProcPtr; - - newAccessProcPtr = (AccessProc *)Tcl_Alloc(sizeof(AccessProc));; - - if (newAccessProcPtr != NULL) { - newAccessProcPtr->proc = proc; - newAccessProcPtr->nextPtr = accessProcList; - accessProcList = newAccessProcPtr; - - retVal = TCL_OK; - } - } - - return (retVal); -} - -/* - *---------------------------------------------------------------------- - * - * TclAccessDeleteProc -- - * - * Removed the passed function pointer from the list of 'TclAccess' - * functions. Ensures that the built-in access function is not - * removvable. - * - * Results: - * TCL_OK if the procedure pointer was successfully removed, - * TCL_ERROR otherwise. - * - * Side effects: - * Memory is deallocated and the respective list updated. - * - *---------------------------------------------------------------------- - */ - -int -TclAccessDeleteProc(proc) - TclAccessProc_ *proc; -{ - int retVal = TCL_ERROR; - AccessProc *tmpAccessProcPtr = accessProcList; - AccessProc *prevAccessProcPtr = NULL; - - /* - * Traverse the 'accessProcList' looking for the particular node - * whose 'proc' member matches 'proc' and remove that one from - * the list. Ensure that the "default" node cannot be removed. - */ - - while ((retVal == TCL_ERROR) && (tmpAccessProcPtr != &defaultAccessProc)) { - if (tmpAccessProcPtr->proc == proc) { - if (prevAccessProcPtr == NULL) { - accessProcList = tmpAccessProcPtr->nextPtr; - } else { - prevAccessProcPtr->nextPtr = tmpAccessProcPtr->nextPtr; - } - - Tcl_Free((char *)tmpAccessProcPtr); - - retVal = TCL_OK; - } else { - prevAccessProcPtr = tmpAccessProcPtr; - tmpAccessProcPtr = tmpAccessProcPtr->nextPtr; - } - } - - return (retVal); -} - -/* - *---------------------------------------------------------------------- - * - * TclOpenFileChannelInsertProc -- - * - * Insert the passed procedure pointer at the head of the list of - * functions which are used during a call to - * 'Tcl_OpenFileChannel(...)'. The passed function should be have - * exactly like 'Tcl_OpenFileChannel' when called during that time - * (see 'Tcl_OpenFileChannel(...)' for more informatin). The - * function will be added even if it already in the list. - * - * Results: - * Normally TCL_OK; TCL_ERROR if memory for a new node in the list - * could not be allocated. - * - * Side effects: - * Memory allocataed and modifies the link list for - * 'Tcl_OpenFileChannel' functions. - * - *---------------------------------------------------------------------- - */ - -int -TclOpenFileChannelInsertProc(proc) - TclOpenFileChannelProc_ *proc; -{ - int retVal = TCL_ERROR; - - if (proc != NULL) { - OpenFileChannelProc *newOpenFileChannelProcPtr; - - newOpenFileChannelProcPtr = - (OpenFileChannelProc *)Tcl_Alloc(sizeof(OpenFileChannelProc));; - - if (newOpenFileChannelProcPtr != NULL) { - newOpenFileChannelProcPtr->proc = proc; - newOpenFileChannelProcPtr->nextPtr = openFileChannelProcList; - openFileChannelProcList = newOpenFileChannelProcPtr; - - retVal = TCL_OK; - } - } - - return (retVal); -} - -/* - *---------------------------------------------------------------------- - * - * TclOpenFileChannelDeleteProc -- - * - * Removed the passed function pointer from the list of - * 'Tcl_OpenFileChannel' functions. Ensures that the built-in - * open file channel function is not removvable. - * - * Results: - * TCL_OK if the procedure pointer was successfully removed, - * TCL_ERROR otherwise. - * - * Side effects: - * Memory is deallocated and the respective list updated. - * - *---------------------------------------------------------------------- - */ - -int -TclOpenFileChannelDeleteProc(proc) - TclOpenFileChannelProc_ *proc; -{ - int retVal = TCL_ERROR; - OpenFileChannelProc *tmpOpenFileChannelProcPtr = openFileChannelProcList; - OpenFileChannelProc *prevOpenFileChannelProcPtr = NULL; - - /* - * Traverse the 'openFileChannelProcList' looking for the particular - * node whose 'proc' member matches 'proc' and remove that one from - * the list. Ensure that the "default" node cannot be removed. - */ - - while ((retVal == TCL_ERROR) && - (tmpOpenFileChannelProcPtr != &defaultOpenFileChannelProc)) { - if (tmpOpenFileChannelProcPtr->proc == proc) { - if (prevOpenFileChannelProcPtr == NULL) { - openFileChannelProcList = tmpOpenFileChannelProcPtr->nextPtr; - } else { - prevOpenFileChannelProcPtr->nextPtr = - tmpOpenFileChannelProcPtr->nextPtr; - } - - Tcl_Free((char *)tmpOpenFileChannelProcPtr); - - retVal = TCL_OK; - } else { - prevOpenFileChannelProcPtr = tmpOpenFileChannelProcPtr; - tmpOpenFileChannelProcPtr = tmpOpenFileChannelProcPtr->nextPtr; - } - } - - return (retVal); -} diff --git a/generic/tclInt.h b/generic/tclInt.h deleted file mode 100644 index 48d4018..0000000 --- a/generic/tclInt.h +++ /dev/null @@ -1,2147 +0,0 @@ -/* - * 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-1997 Sun Microsystems, Inc. - * Copyright (c) 1993-1997 Lucent Technologies. - * Copyright (c) 1998-1999 by Scriptics Corporation. - * - * See the file "license.terms" for information on usage and redistribution - * of this file, and for a DISCLAIMER OF ALL WARRANTIES. - * - * RCS: @(#) $Id: tclInt.h,v 1.23 1999/02/03 21:28:00 stanton Exp $ - */ - -#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 - -#ifdef BUILD_tcl -# undef TCL_STORAGE_CLASS -# define TCL_STORAGE_CLASS DLLEXPORT -#endif - -/* - * The following procedures allow namespaces to be customized to - * support special name resolution rules for commands/variables. - * - */ - -struct Tcl_ResolvedVarInfo; - -typedef Tcl_Var (Tcl_ResolveRuntimeVarProc) _ANSI_ARGS_(( - Tcl_Interp* interp, struct Tcl_ResolvedVarInfo *vinfoPtr)); - -typedef void (Tcl_ResolveVarDeleteProc) _ANSI_ARGS_(( - struct Tcl_ResolvedVarInfo *vinfoPtr)); - -/* - * The following structure encapsulates the routines needed to resolve a - * variable reference at runtime. Any variable specific state will typically - * be appended to this structure. - */ - - -typedef struct Tcl_ResolvedVarInfo { - Tcl_ResolveRuntimeVarProc *fetchProc; - Tcl_ResolveVarDeleteProc *deleteProc; -} Tcl_ResolvedVarInfo; - - - -typedef int (Tcl_ResolveCompiledVarProc) _ANSI_ARGS_(( - Tcl_Interp* interp, char* name, int length, - Tcl_Namespace *context, Tcl_ResolvedVarInfo **rPtr)); - -typedef int (Tcl_ResolveVarProc) _ANSI_ARGS_(( - Tcl_Interp* interp, char* name, Tcl_Namespace *context, - int flags, Tcl_Var *rPtr)); - -typedef int (Tcl_ResolveCmdProc) _ANSI_ARGS_((Tcl_Interp* interp, - char* name, Tcl_Namespace *context, int flags, - Tcl_Command *rPtr)); - -typedef struct Tcl_ResolverInfo { - Tcl_ResolveCmdProc *cmdResProc; /* Procedure handling command name - * resolution. */ - Tcl_ResolveVarProc *varResProc; /* Procedure handling variable name - * resolution for variables that - * can only be handled at runtime. */ - Tcl_ResolveCompiledVarProc *compiledVarResProc; - /* Procedure handling variable name - * resolution at compile time. */ -} Tcl_ResolverInfo; - -/* - *---------------------------------------------------------------- - * Data structures related to namespaces. - *---------------------------------------------------------------- - */ - -/* - * The structure below defines a namespace. - * Note: the first five fields must match exactly the fields in a - * Tcl_Namespace structure (see tcl.h). If you change one, be sure to - * change the other. - */ - -typedef struct Namespace { - char *name; /* The namespace's simple (unqualified) - * name. This contains no ::'s. The name of - * the global namespace is "" although "::" - * is an synonym. */ - char *fullName; /* The namespace's fully qualified name. - * This starts with ::. */ - ClientData clientData; /* An arbitrary value associated with this - * namespace. */ - Tcl_NamespaceDeleteProc *deleteProc; - /* Procedure invoked when deleting the - * namespace to, e.g., free clientData. */ - struct Namespace *parentPtr; /* Points to the namespace that contains - * this one. NULL if this is the global - * namespace. */ - Tcl_HashTable childTable; /* Contains any child namespaces. Indexed - * by strings; values have type - * (Namespace *). */ - long nsId; /* Unique id for the namespace. */ - Tcl_Interp *interp; /* The interpreter containing this - * namespace. */ - int flags; /* OR-ed combination of the namespace - * status flags NS_DYING and NS_DEAD - * listed below. */ - int activationCount; /* Number of "activations" or active call - * frames for this namespace that are on - * the Tcl call stack. The namespace won't - * be freed until activationCount becomes - * zero. */ - int refCount; /* Count of references by namespaceName * - * objects. The namespace can't be freed - * until refCount becomes zero. */ - Tcl_HashTable cmdTable; /* Contains all the commands currently - * registered in the namespace. Indexed by - * strings; values have type (Command *). - * Commands imported by Tcl_Import have - * Command structures that point (via an - * ImportedCmdRef structure) to the - * Command structure in the source - * namespace's command table. */ - Tcl_HashTable varTable; /* Contains all the (global) variables - * currently in this namespace. Indexed - * by strings; values have type (Var *). */ - char **exportArrayPtr; /* Points to an array of string patterns - * specifying which commands are exported. - * A pattern may include "string match" - * style wildcard characters to specify - * multiple commands; however, no namespace - * qualifiers are allowed. NULL if no - * export patterns are registered. */ - int numExportPatterns; /* Number of export patterns currently - * registered using "namespace export". */ - int maxExportPatterns; /* Mumber of export patterns for which - * space is currently allocated. */ - int cmdRefEpoch; /* Incremented if a newly added command - * shadows a command for which this - * namespace has already cached a Command * - * pointer; this causes all its cached - * Command* pointers to be invalidated. */ - int resolverEpoch; /* Incremented whenever the name resolution - * rules change for this namespace; this - * invalidates all byte codes compiled in - * the namespace, causing the code to be - * recompiled under the new rules. */ - Tcl_ResolveCmdProc *cmdResProc; - /* If non-null, this procedure overrides - * the usual command resolution mechanism - * in Tcl. This procedure is invoked - * within Tcl_FindCommand to resolve all - * command references within the namespace. */ - Tcl_ResolveVarProc *varResProc; - /* If non-null, this procedure overrides - * the usual variable resolution mechanism - * in Tcl. This procedure is invoked - * within Tcl_FindNamespaceVar to resolve all - * variable references within the namespace - * at runtime. */ - Tcl_ResolveCompiledVarProc *compiledVarResProc; - /* If non-null, this procedure overrides - * the usual variable resolution mechanism - * in Tcl. This procedure is invoked - * within LookupCompiledLocal to resolve - * variable references within the namespace - * at compile time. */ -} Namespace; - -/* - * Flags used to represent the status of a namespace: - * - * NS_DYING - 1 means Tcl_DeleteNamespace has been called to delete the - * namespace but there are still active call frames on the Tcl - * stack that refer to the namespace. When the last call frame - * referring to it has been popped, it's variables and command - * will be destroyed and it will be marked "dead" (NS_DEAD). - * The namespace can no longer be looked up by name. - * NS_DEAD - 1 means Tcl_DeleteNamespace has been called to delete the - * namespace and no call frames still refer to it. Its - * variables and command have already been destroyed. This bit - * allows the namespace resolution code to recognize that the - * namespace is "deleted". When the last namespaceName object - * in any byte code code unit that refers to the namespace has - * been freed (i.e., when the namespace's refCount is 0), the - * namespace's storage will be freed. - */ - -#define NS_DYING 0x01 -#define NS_DEAD 0x02 - -/* - * Flag passed to TclGetNamespaceForQualName to have it create all namespace - * components of a namespace-qualified name that cannot be found. The new - * namespaces are created within their specified parent. Note that this - * flag's value must not conflict with the values of the flags - * TCL_GLOBAL_ONLY, TCL_NAMESPACE_ONLY, and FIND_ONLY_NS (defined in - * tclNamesp.c). - */ - -#define CREATE_NS_IF_UNKNOWN 0x800 - -/* - *---------------------------------------------------------------- - * 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 Tcl_Obj value. These structures are kept in procedure call frames - * (for local variables recognized by the compiler) or in the heap (for - * global variables and any variable not known to the compiler). For each - * Var structure in the heap, a hash table entry holds the variable name and - * a pointer to the Var structure. - */ - -typedef struct Var { - union { - Tcl_Obj *objPtr; /* The variable's object value. Used for - * scalar variables and array elements. */ - 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 *linkPtr; /* If this is a global variable being - * referred to in a procedure, or a variable - * created by "upvar", this field points to - * the referenced variable's Var struct. */ - } value; - char *name; /* NULL if the variable is in a hashtable, - * otherwise points to the variable's - * name. It is used, e.g., by TclLookupVar - * and "info locals". The storage for the - * characters of the name is not owned by - * the Var and must not be freed when - * freeing the Var. */ - Namespace *nsPtr; /* Points to the namespace that contains - * this variable or NULL if the variable is - * a local variable in a Tcl procedure. */ - Tcl_HashEntry *hPtr; /* If variable is in a hashtable, either the - * 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). NULL if the variable is not in a - * hashtable. This is used to delete an - * variable from its hashtable if it is no - * longer needed. */ - int refCount; /* Counts number of active uses of this - * variable, not including its entry in the - * call frame or the hash table: 1 for each - * additional variable whose linkPtr points - * here, 1 for each nested trace active on - * variable, and 1 if the variable is a - * namespace 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. The first three (VAR_SCALAR, VAR_ARRAY, and - * VAR_LINK) are mutually exclusive and give the "type" of the variable. - * VAR_UNDEFINED is independent of the variable's type. - * - * VAR_SCALAR - 1 means this is a scalar variable and not - * an array or link. The "objPtr" field points - * to the variable's value, a Tcl object. - * VAR_ARRAY - 1 means this is an array variable rather - * than a scalar variable or link. The - * "tablePtr" field points to the array's - * hashtable for its elements. - * VAR_LINK - 1 means this Var structure contains a - * pointer to another Var structure that - * either has the real value or is itself - * another VAR_LINK pointer. Variables like - * this come about through "upvar" and "global" - * commands, or through references to variables - * in enclosing namespaces. - * VAR_UNDEFINED - 1 means that the variable is in the process - * of being deleted. An undefined variable - * logically does not exist and survives only - * while it has a trace, or if it is a global - * variable currently being used by some - * procedure. - * VAR_IN_HASHTABLE - 1 means this variable is in a hashtable and - * the Var structure is malloced. 0 if it is - * a local variable that was assigned a slot - * in a procedure frame by the compiler so the - * Var storage is part of the call frame. - * 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. - * VAR_ARRAY_ELEMENT - 1 means that this variable is an array - * element, so it is not legal for it to be - * an array itself (the VAR_ARRAY flag had - * better not be set). - * VAR_NAMESPACE_VAR - 1 means that this variable was declared - * as a namespace variable. This flag ensures - * it persists until its namespace is - * destroyed or until the variable is unset; - * it will persist even if it has not been - * initialized and is marked undefined. - * The variable's refCount is incremented to - * reflect the "reference" from its namespace. - * - * The following additional flags are used with the CompiledLocal type - * defined below: - * - * VAR_ARGUMENT - 1 means that this variable holds a procedure - * argument. - * VAR_TEMPORARY - 1 if the local variable is an anonymous - * temporary variable. Temporaries have a NULL - * name. - * VAR_RESOLVED - 1 if name resolution has been done for this - * variable. - */ - -#define VAR_SCALAR 0x1 -#define VAR_ARRAY 0x2 -#define VAR_LINK 0x4 -#define VAR_UNDEFINED 0x8 -#define VAR_IN_HASHTABLE 0x10 -#define VAR_TRACE_ACTIVE 0x20 -#define VAR_ARRAY_ELEMENT 0x40 -#define VAR_NAMESPACE_VAR 0x80 - -#define VAR_ARGUMENT 0x100 -#define VAR_TEMPORARY 0x200 -#define VAR_RESOLVED 0x400 - -/* - * Macros to ensure that various flag bits are set properly for variables. - * The ANSI C "prototypes" for these macros are: - * - * EXTERN void TclSetVarScalar _ANSI_ARGS_((Var *varPtr)); - * EXTERN void TclSetVarArray _ANSI_ARGS_((Var *varPtr)); - * EXTERN void TclSetVarLink _ANSI_ARGS_((Var *varPtr)); - * EXTERN void TclSetVarArrayElement _ANSI_ARGS_((Var *varPtr)); - * EXTERN void TclSetVarUndefined _ANSI_ARGS_((Var *varPtr)); - * EXTERN void TclClearVarUndefined _ANSI_ARGS_((Var *varPtr)); - */ - -#define TclSetVarScalar(varPtr) \ - (varPtr)->flags = ((varPtr)->flags & ~(VAR_ARRAY|VAR_LINK)) | VAR_SCALAR - -#define TclSetVarArray(varPtr) \ - (varPtr)->flags = ((varPtr)->flags & ~(VAR_SCALAR|VAR_LINK)) | VAR_ARRAY - -#define TclSetVarLink(varPtr) \ - (varPtr)->flags = ((varPtr)->flags & ~(VAR_SCALAR|VAR_ARRAY)) | VAR_LINK - -#define TclSetVarArrayElement(varPtr) \ - (varPtr)->flags = ((varPtr)->flags & ~VAR_ARRAY) | VAR_ARRAY_ELEMENT - -#define TclSetVarUndefined(varPtr) \ - (varPtr)->flags |= VAR_UNDEFINED - -#define TclClearVarUndefined(varPtr) \ - (varPtr)->flags &= ~VAR_UNDEFINED - -/* - * Macros to read various flag bits of variables. - * The ANSI C "prototypes" for these macros are: - * - * EXTERN int TclIsVarScalar _ANSI_ARGS_((Var *varPtr)); - * EXTERN int TclIsVarLink _ANSI_ARGS_((Var *varPtr)); - * EXTERN int TclIsVarArray _ANSI_ARGS_((Var *varPtr)); - * EXTERN int TclIsVarUndefined _ANSI_ARGS_((Var *varPtr)); - * EXTERN int TclIsVarArrayElement _ANSI_ARGS_((Var *varPtr)); - * EXTERN int TclIsVarTemporary _ANSI_ARGS_((Var *varPtr)); - * EXTERN int TclIsVarArgument _ANSI_ARGS_((Var *varPtr)); - * EXTERN int TclIsVarResolved _ANSI_ARGS_((Var *varPtr)); - */ - -#define TclIsVarScalar(varPtr) \ - ((varPtr)->flags & VAR_SCALAR) - -#define TclIsVarLink(varPtr) \ - ((varPtr)->flags & VAR_LINK) - -#define TclIsVarArray(varPtr) \ - ((varPtr)->flags & VAR_ARRAY) - -#define TclIsVarUndefined(varPtr) \ - ((varPtr)->flags & VAR_UNDEFINED) - -#define TclIsVarArrayElement(varPtr) \ - ((varPtr)->flags & VAR_ARRAY_ELEMENT) - -#define TclIsVarTemporary(varPtr) \ - ((varPtr)->flags & VAR_TEMPORARY) - -#define TclIsVarArgument(varPtr) \ - ((varPtr)->flags & VAR_ARGUMENT) - -#define TclIsVarResolved(varPtr) \ - ((varPtr)->flags & VAR_RESOLVED) - -/* - *---------------------------------------------------------------- - * Data structures related to procedures. These are used primarily - * in tclProc.c, tclCompile.c, and tclExecute.c. - *---------------------------------------------------------------- - */ - -/* - * Forward declaration to prevent an error when the forward reference to - * Command is encountered in the Proc and ImportRef types declared below. - */ - -struct Command; - -/* - * The variable-length structure below describes a local variable of a - * procedure that was recognized by the compiler. These variables have a - * name, an element in the array of compiler-assigned local variables in the - * procedure's call frame, and various other items of information. If the - * local variable is a formal argument, it may also have a default value. - * The compiler can't recognize local variables whose names are - * expressions (these names are only known at runtime when the expressions - * are evaluated) or local variables that are created as a result of an - * "upvar" or "uplevel" command. These other local variables are kept - * separately in a hash table in the call frame. - */ - -typedef struct CompiledLocal { - struct CompiledLocal *nextPtr; - /* Next compiler-recognized local variable - * for this procedure, or NULL if this is - * the last local. */ - int nameLength; /* The number of characters in local - * variable's name. Used to speed up - * variable lookups. */ - int frameIndex; /* Index in the array of compiler-assigned - * variables in the procedure call frame. */ - int flags; /* Flag bits for the local variable. Same as - * the flags for the Var structure above, - * although only VAR_SCALAR, VAR_ARRAY, - * VAR_LINK, VAR_ARGUMENT, VAR_TEMPORARY, and - * VAR_RESOLVED make sense. */ - Tcl_Obj *defValuePtr; /* Pointer to the default value of an - * argument, if any. NULL if not an argument - * or, if an argument, no default value. */ - Tcl_ResolvedVarInfo *resolveInfo; - /* Customized variable resolution info - * supplied by the Tcl_ResolveCompiledVarProc - * associated with a namespace. Each variable - * is marked by a unique ClientData tag - * during compilation, and that same tag - * is used to find the variable at runtime. */ - char name[4]; /* Name of the local variable starts here. - * If the name is NULL, this will just be - * '\0'. The actual size of this field will - * be large enough to hold the name. MUST - * BE THE LAST FIELD IN THE STRUCTURE! */ -} CompiledLocal; - -/* - * The structure below defines a command procedure, which consists of a - * collection of Tcl commands plus information about arguments and other - * local variables recognized at compile time. - */ - -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. */ - struct Command *cmdPtr; /* Points to the Command structure for - * this procedure. This is used to get - * the namespace in which to execute - * the procedure. */ - Tcl_Obj *bodyPtr; /* Points to the ByteCode object for - * procedure's body command. */ - int numArgs; /* Number of formal parameters. */ - int numCompiledLocals; /* Count of local variables recognized by - * the compiler including arguments and - * temporaries. */ - CompiledLocal *firstLocalPtr; /* Pointer to first of the procedure's - * compiler-allocated local variables, or - * NULL if none. The first numArgs entries - * in this list describe the procedure's - * formal arguments. */ - CompiledLocal *lastLocalPtr; /* Pointer to the last allocated local - * variable or NULL if none. This has - * frame index (numCompiledLocals-1). */ -} 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 call frame. A call frame defines a naming - * context for a procedure call: its local naming scope (for local - * variables) and its global naming scope (a namespace, perhaps the global - * :: namespace). A call frame can also define the naming context for a - * namespace eval or namespace inscope command: the namespace in which the - * command's code should execute. The Tcl_CallFrame structures exist only - * while procedures or namespace eval/inscope's are being executed, and - * provide a kind of Tcl call stack. - * - * WARNING!! The structure definition must be kept consistent with the - * Tcl_CallFrame structure in tcl.h. If you change one, change the other. - */ - -typedef struct CallFrame { - Namespace *nsPtr; /* Points to the namespace used to resolve - * commands and global variables. */ - int isProcCallFrame; /* If nonzero, the frame was pushed to - * execute a Tcl procedure and may have - * local vars. If 0, the frame was pushed - * to execute a namespace command and var - * references are treated as references to - * namespace vars; varTablePtr and - * compiledLocals are ignored. */ - int objc; /* This and objv below describe the - * arguments for this procedure call. */ - Tcl_Obj *CONST *objv; /* Array of argument objects. */ - struct CallFrame *callerPtr; - /* Value of interp->framePtr when this - * procedure was invoked (i.e. next higher - * 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). */ - int level; /* Level of this procedure, for "uplevel" - * purposes (i.e. corresponds to nesting of - * callerVarPtr's, not callerPtr's). 1 for - * outermost procedure, 0 for top-level. */ - Proc *procPtr; /* Points to the structure defining the - * called procedure. Used to get information - * such as the number of compiled local - * variables (local variables assigned - * entries ["slots"] in the compiledLocals - * array below). */ - Tcl_HashTable *varTablePtr; /* Hash table containing local variables not - * recognized by the compiler, or created at - * execution time through, e.g., upvar. - * Initially NULL and created if needed. */ - int numCompiledLocals; /* Count of local variables recognized by - * the compiler including arguments. */ - Var* compiledLocals; /* Points to the array of local variables - * recognized by the compiler. The compiler - * emits code that refers to these variables - * using an index into this array. */ -} CallFrame; - -/* - *---------------------------------------------------------------- - * Data structures related to history. These are used primarily - * in tclHistory.c - *---------------------------------------------------------------- - */ - -/* - * 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; - -/* - * 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 builtinFuncIndex; /* If this is a builtin math function, its - * index in the array of builtin functions. - * (tclCompilation.h lists these indices.) - * The value is -1 if this is a new function - * defined by Tcl_CreateMathFunc. The value - * is also -1 if a builtin function is - * replaced by a Tcl_CreateMathFunc call. */ - 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. - * NULL if isBuiltinFunc is 1. */ - ClientData clientData; /* Additional argument to pass to the - * function when invoking it. NULL if - * isBuiltinFunc is 1. */ -} MathFunc; - -/* - *---------------------------------------------------------------- - * Data structures related to bytecode compilation and execution. - * These are used primarily in tclCompile.c, tclExecute.c, and - * tclBasic.c. - *---------------------------------------------------------------- - */ - -/* - * Forward declaration to prevent an error when the forward reference to - * CompileEnv is encountered in the procedure type CompileProc declared - * below. - */ - -struct CompileEnv; - -/* - * The type of procedures called by the Tcl bytecode compiler to compile - * commands. Pointers to these procedures are kept in the Command structure - * describing each command. When a CompileProc returns, the interpreter's - * result is set to error information, if any. In addition, the CompileProc - * returns an integer value, which is one of the following: - * - * TCL_OK Compilation completed normally. - * TCL_ERROR Compilation failed because of an error; - * the interpreter's result describes what went wrong. - * TCL_OUT_LINE_COMPILE Compilation failed because, e.g., the command is - * too complex for effective inline compilation. The - * CompileProc believes the command is legal but - * should be compiled "out of line" by emitting code - * to invoke its command procedure at runtime. - */ - -#define TCL_OUT_LINE_COMPILE (TCL_CONTINUE + 1) - -typedef int (CompileProc) _ANSI_ARGS_((Tcl_Interp *interp, char *string, - char *lastChar, int compileFlags, struct CompileEnv *compEnvPtr)); - -/* - * The data structure defining the execution environment for ByteCode's. - * There is one ExecEnv structure per Tcl interpreter. It holds the - * evaluation stack that holds command operands and results. The stack grows - * towards increasing addresses. The "stackTop" member is cached by - * TclExecuteByteCode in a local variable: it must be set before calling - * TclExecuteByteCode and will be restored by TclExecuteByteCode before it - * returns. - */ - -typedef union StackItem { - Tcl_Obj *o; /* Stack item as a pointer to a Tcl_Obj. */ - int i; /* Stack item as an integer. */ - VOID *p; /* Stack item as an arbitrary pointer. */ -} StackItem; - -typedef struct ExecEnv { - StackItem *stackPtr; /* Points to the first item in the - * evaluation stack on the heap. */ - int stackTop; /* Index of current top of stack; -1 when - * the stack is empty. */ - int stackEnd; /* Index of last usable item in stack. */ -} ExecEnv; - -/* - *---------------------------------------------------------------- - * Data structures related to commands. - *---------------------------------------------------------------- - */ - -/* - * An imported command is created in an namespace when it imports a "real" - * command from another namespace. An imported command has a Command - * structure that points (via its ClientData value) to the "real" Command - * structure in the source namespace's command table. The real command - * records all the imported commands that refer to it in a list of ImportRef - * structures so that they can be deleted when the real command is deleted. */ - -typedef struct ImportRef { - struct Command *importedCmdPtr; - /* Points to the imported command created in - * an importing namespace; this command - * redirects its invocations to the "real" - * command. */ - struct ImportRef *nextPtr; /* Next element on the linked list of - * imported commands that refer to the - * "real" command. The real command deletes - * these imported commands on this list when - * it is deleted. */ -} ImportRef; - -/* - * Data structure used as the ClientData of imported commands: commands - * created in an namespace when it imports a "real" command from another - * namespace. - */ - -typedef struct ImportedCmdData { - struct Command *realCmdPtr; /* "Real" command that this imported command - * refers to. */ - struct Command *selfPtr; /* Pointer to this imported command. Needed - * only when deleting it in order to remove - * it from the real command's linked list of - * imported commands that refer to it. */ -} ImportedCmdData; - -/* - * A Command structure exists for each command in a namespace. The - * Tcl_Command opaque type actually refers to these structures. - */ - -typedef struct Command { - Tcl_HashEntry *hPtr; /* Pointer to the hash table entry that - * refers to this command. The hash table is - * either a namespace's command table or an - * interpreter's hidden command table. This - * pointer is 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). */ - Namespace *nsPtr; /* Points to the namespace containing this - * command. */ - int refCount; /* 1 if in command hashtable plus 1 for each - * reference from a CmdName Tcl object - * representing a command's name in a - * ByteCode instruction sequence. This - * structure can be freed when refCount - * becomes zero. */ - int cmdEpoch; /* Incremented to invalidate any references - * that point to this command when it is - * renamed, deleted, hidden, or exposed. */ - CompileProc *compileProc; /* Procedure called to compile command. NULL - * if no compile proc exists for command. */ - Tcl_ObjCmdProc *objProc; /* Object-based command procedure. */ - ClientData objClientData; /* Arbitrary value passed to object proc. */ - Tcl_CmdProc *proc; /* String-based command procedure. */ - ClientData clientData; /* Arbitrary value passed to string proc. */ - Tcl_CmdDeleteProc *deleteProc; - /* Procedure invoked when deleting command - * to, e.g., free all client data. */ - ClientData deleteData; /* Arbitrary value passed to deleteProc. */ - int deleted; /* Means that the command is in the process - * of being deleted (its deleteProc is - * currently executing). Other attempts to - * delete the command should be ignored. */ - ImportRef *importRefPtr; /* List of each imported Command created in - * another namespace when this command is - * imported. These imported commands - * redirect invocations back to this - * command. The list is used to remove all - * those imported commands when deleting - * this "real" command. */ -} Command; - -/* - *---------------------------------------------------------------- - * Data structures related to name resolution procedures. - *---------------------------------------------------------------- - */ - -/* - * The interpreter keeps a linked list of name resolution schemes. - * The scheme for a namespace is consulted first, followed by the - * list of schemes in an interpreter, followed by the default - * name resolution in Tcl. Schemes are added/removed from the - * interpreter's list by calling Tcl_AddInterpResolver and - * Tcl_RemoveInterpResolver. - */ - -typedef struct ResolverScheme { - char *name; /* Name identifying this scheme. */ - Tcl_ResolveCmdProc *cmdResProc; - /* Procedure handling command name - * resolution. */ - Tcl_ResolveVarProc *varResProc; - /* Procedure handling variable name - * resolution for variables that - * can only be handled at runtime. */ - Tcl_ResolveCompiledVarProc *compiledVarResProc; - /* Procedure handling variable name - * resolution at compile time. */ - - struct ResolverScheme *nextPtr; - /* Pointer to next record in linked list. */ -} ResolverScheme; - -/* - *---------------------------------------------------------------- - * 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. - * - * The interpreter's result is held in both the string and the - * objResultPtr fields. These fields hold, respectively, the result's - * string or object value. The interpreter's result is always in the - * result field if that is non-empty, otherwise it is in objResultPtr. - * The two fields are kept consistent unless some C code sets - * interp->result directly. Programs should not access result and - * objResultPtr directly; instead, they should always get and set the - * result using procedures such as Tcl_SetObjResult, Tcl_GetObjResult, - * and Tcl_GetStringResult. See the SetResult man page for details. - */ - - char *result; /* If the last command returned a string - * result, this points to it. Should not be - * accessed directly; see comment above. */ - Tcl_FreeProc *freeProc; /* Zero means a string result is statically - * allocated. TCL_DYNAMIC means string - * result was allocated with ckalloc and - * should be freed with ckfree. Other values - * give address of procedure to invoke to - * free the string result. Tcl_Eval must - * free it before executing next command. */ - int errorLine; /* When TCL_ERROR is returned, this gives - * the line number in the command where the - * error occurred (1 means first line). */ - Tcl_Obj *objResultPtr; /* If the last command returned an object - * result, this points to it. Should not be - * accessed directly; see comment above. */ - Namespace *globalNsPtr; /* The interpreter's global namespace. */ - Tcl_HashTable mathFuncTable;/* Contains all 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. - */ - - 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 - * executing). NULL means no procedure is - * active or "uplevel 0" is executing. */ - 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 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 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. */ - - /* - * Miscellaneous information: - */ - - int cmdCount; /* Total number of times a command procedure - * has been called for this interpreter. */ - 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. */ - int termOffset; /* Offset of character just after last one - * compiled or executed by Tcl_EvalObj. */ - int compileEpoch; /* Holds the current "compilation epoch" - * for this interpreter. This is - * incremented to invalidate existing - * ByteCodes when, e.g., a command with a - * compile procedure is redefined. */ - Proc *compiledProcPtr; /* If a procedure is being compiled, a - * pointer to its Proc structure; otherwise, - * this is NULL. Set by ObjInterpProc in - * tclProc.c and used by tclCompile.c to - * process local variables appropriately. */ - ResolverScheme *resolverPtr; - /* Linked list of name resolution schemes - * added to this interpreter. Schemes - * are added/removed by calling - * Tcl_AddInterpResolver and - * Tcl_RemoveInterpResolver. */ - 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. */ - long randSeed; /* Seed used for rand() function. */ - 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. */ - struct ExecEnv *execEnvPtr; /* Execution environment for Tcl bytecode - * execution. Contains a pointer to the - * Tcl evaluation stack. */ - Tcl_Obj *emptyObjPtr; /* Points to an object holding an empty - * string. Returned by Tcl_ObjSetVar2 when - * variable traces change a variable in a - * gross way. */ - char resultSpace[TCL_RESULT_SIZE+1]; - /* Static space holding 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_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_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: Non-zero means initialization specific to - * expressions has been carried out. - * DONT_COMPILE_CMDS_INLINE: Non-zero means that the bytecode compiler - * should not compile any commands into an inline - * sequence of instructions. This is set 1, for - * example, when command traces are requested. - * RAND_SEED_INITIALIZED: Non-zero means that the randSeed value of the - * interp has not be initialized. This is set 1 - * when we first use the rand() or srand() functions. - * SAFE_INTERP: Non zero means that the current interp is a - * safe interp (ie it has only the safe commands - * installed, less priviledge than a regular interp). - */ - -#define DELETED 1 -#define ERR_IN_PROGRESS 2 -#define ERR_ALREADY_LOGGED 4 -#define ERROR_CODE_SET 8 -#define EXPR_INITIALIZED 0x10 -#define DONT_COMPILE_CMDS_INLINE 0x20 -#define RAND_SEED_INITIALIZED 0x40 -#define SAFE_INTERP 0x80 - -/* - *---------------------------------------------------------------- - * 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. The CHAR_TYPE macro takes a pointer to a signed character - * and a pointer to the last character in the source string. If the - * src pointer is pointing at the terminating null of the string, - * CHAR_TYPE returns TCL_COMMAND_END. - */ - -extern unsigned char tclTypeTable[]; -#define CHAR_TYPE(src,last) \ - (((src)==(last))?TCL_COMMAND_END:(tclTypeTable)[(int)(*(src) + 128)]) - -/* - * Possible values returned by CHAR_TYPE. Note that except for TCL_DOLLAR, - * these are all one byte values with a single bit set 1. This means these - * values may be bit-or'ed together (except for TCL_DOLLAR) to quickly test - * whether a character is one of several different kinds of characters. - * - * 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 semicolon or close-bracket - * or terminating null. - * 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 0x01 -#define TCL_SPACE 0x02 -#define TCL_COMMAND_END 0x04 -#define TCL_QUOTE 0x08 -#define TCL_OPEN_BRACKET 0x10 -#define TCL_OPEN_BRACE 0x20 -#define TCL_CLOSE_BRACE 0x40 -#define TCL_BACKSLASH 0x80 -#define TCL_DOLLAR 0x00 - -/* - * 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)) - -/* - * This macro is used to determine the offset needed to safely allocate any - * data structure in memory. Given a starting offset or size, it "rounds up" - * or "aligns" the offset to the next 8-byte boundary so that any data - * structure can be placed at the resulting offset without fear of an - * alignment error. - * - * WARNING!! DO NOT USE THIS MACRO TO ALIGN POINTERS: it will produce - * the wrong result on platforms that allocate addresses that are divisible - * by 4 or 2. Only use it for offsets or sizes. - */ - -#define TCL_ALIGN(x) (((int)(x) + 7) & ~7) - -/* - * 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; - -/* - * Flags for TclInvoke: - * - * TCL_INVOKE_HIDDEN Invoke a hidden command; if not set, - * invokes an exposed command. - * TCL_INVOKE_NO_UNKNOWN If set, "unknown" is not invoked if - * the command to be invoked is not found. - * Only has an effect if invoking an exposed - * command, i.e. if TCL_INVOKE_HIDDEN is not - * also set. - */ - -#define TCL_INVOKE_HIDDEN (1<<0) -#define TCL_INVOKE_NO_UNKNOWN (1<<1) - -/* - * The structure used as the internal representation of Tcl list - * objects. This is an array of pointers to the element objects. This array - * is grown (reallocated and copied) as necessary to hold all the list's - * element pointers. The array might contain more slots than currently used - * to hold all element pointers. This is done to make append operations - * faster. - */ - -typedef struct List { - int maxElemCount; /* Total number of element array slots. */ - int elemCount; /* Current number of list elements. */ - Tcl_Obj **elements; /* Array of pointers to element objects. */ -} List; - -/* - * The following types are used for getting and storing platform-specific - * file attributes in tclFCmd.c and the various platform-versions of - * that file. This is done to have as much common code as possible - * in the file attributes code. For more information about the callbacks, - * see TclFileAttrsCmd in tclFCmd.c. - */ - -typedef int (TclGetFileAttrProc) _ANSI_ARGS_((Tcl_Interp *interp, - int objIndex, char *fileName, - Tcl_Obj **attrObjPtrPtr)); -typedef int (TclSetFileAttrProc) _ANSI_ARGS_((Tcl_Interp *interp, - int objIndex, char *fileName, - Tcl_Obj *attrObjPtr)); - -typedef struct TclFileAttrProcs { - TclGetFileAttrProc *getProc; /* The procedure for getting attrs. */ - TclSetFileAttrProc *setProc; /* The procedure for setting attrs. */ -} TclFileAttrProcs; - -/* - * Opaque handle used in pipeline routines to encapsulate platform-dependent - * state. - */ - -typedef struct TclFile_ *TclFile; - -/* - *---------------------------------------------------------------- - * Data structures related to hooking 'TclStat(...)' and - * 'TclAccess(...)'. - *---------------------------------------------------------------- - */ - -typedef struct stat TclStat_; -typedef int (TclStatProc_) _ANSI_ARGS_((CONST char *path, TclStat_ *buf)); -typedef int (TclAccessProc_) _ANSI_ARGS_((CONST char *path, int mode)); -typedef Tcl_Channel (TclOpenFileChannelProc_) _ANSI_ARGS_((Tcl_Interp *interp, - char *fileName, char *modeString, - int permissions)); - -typedef int (*TclCmdProcType) _ANSI_ARGS_((ClientData clientData, - Tcl_Interp *interp, int argc, char *argv[])); -typedef int (*TclObjCmdProcType) _ANSI_ARGS_((ClientData clientData, - Tcl_Interp *interp, int objc, struct Tcl_Obj * CONST objv[])); - -/* - *---------------------------------------------------------------- - * Variables shared among Tcl modules but not used by the outside world. - *---------------------------------------------------------------- - */ - -extern Tcl_Time tclBlockTime; -extern int tclBlockTimeSet; -extern char * tclExecutableName; -extern Tcl_ChannelType tclFileChannelType; -extern char * tclMemDumpFileName; -extern TclPlatformType tclPlatform; -extern char * tclpFileAttrStrings[]; -extern CONST TclFileAttrProcs tclpFileAttrProcs[]; - -/* - * Variables denoting the Tcl object types defined in the core. - */ - -extern Tcl_ObjType tclBooleanType; -extern Tcl_ObjType tclByteCodeType; -extern Tcl_ObjType tclDoubleType; -extern Tcl_ObjType tclIntType; -extern Tcl_ObjType tclListType; -extern Tcl_ObjType tclProcBodyType; -extern Tcl_ObjType tclStringType; - -/* - * The head of the list of free Tcl objects, and the total number of Tcl - * objects ever allocated and freed. - */ - -extern Tcl_Obj * tclFreeObjList; - -#ifdef TCL_COMPILE_STATS -extern long tclObjsAlloced; -extern long tclObjsFreed; -#endif /* TCL_COMPILE_STATS */ - -/* - * Pointer to a heap-allocated string of length zero that the Tcl core uses - * as the value of an empty string representation for an object. This value - * is shared by all new objects allocated by Tcl_NewObj. - */ - -extern char * tclEmptyStringRep; - -/* - *---------------------------------------------------------------- - * Procedures shared among Tcl modules but not used by the outside - * world: - *---------------------------------------------------------------- - */ - -EXTERN void panic _ANSI_ARGS_(TCL_VARARGS(char *,format)); -EXTERN int TclAccess _ANSI_ARGS_((CONST char *path, - int mode)); -EXTERN int TclAccessDeleteProc _ANSI_ARGS_((TclAccessProc_ *proc)); -EXTERN int TclAccessInsertProc _ANSI_ARGS_((TclAccessProc_ *proc)); -EXTERN void TclAllocateFreeObjects _ANSI_ARGS_((void)); -EXTERN int TclChdir _ANSI_ARGS_((Tcl_Interp *interp, - char *dirName)); -EXTERN int TclCleanupChildren _ANSI_ARGS_((Tcl_Interp *interp, - int numPids, Tcl_Pid *pidPtr, - Tcl_Channel errorChan)); -EXTERN void TclCleanupCommand _ANSI_ARGS_((Command *cmdPtr)); -EXTERN int TclCopyAndCollapse _ANSI_ARGS_((int count, - char *src, char *dst)); -EXTERN int TclCopyChannel _ANSI_ARGS_((Tcl_Interp *interp, - Tcl_Channel inChan, Tcl_Channel outChan, - int toRead, Tcl_Obj *cmdPtr)); -/* - * TclCreatePipeline unofficially exported for use by BLT. - */ -EXTERN int TclCreatePipeline _ANSI_ARGS_((Tcl_Interp *interp, - int argc, char **argv, Tcl_Pid **pidArrayPtr, - TclFile *inPipePtr, TclFile *outPipePtr, - TclFile *errFilePtr)); -EXTERN int TclCreateProc _ANSI_ARGS_((Tcl_Interp *interp, - Namespace *nsPtr, char *procName, - Tcl_Obj *argsPtr, Tcl_Obj *bodyPtr, - Proc **procPtrPtr)); -EXTERN void TclDeleteCompiledLocalVars _ANSI_ARGS_(( - Interp *iPtr, CallFrame *framePtr)); -EXTERN void TclDeleteVars _ANSI_ARGS_((Interp *iPtr, - Tcl_HashTable *tablePtr)); -EXTERN int TclDoGlob _ANSI_ARGS_((Tcl_Interp *interp, - char *separators, Tcl_DString *headPtr, - char *tail)); -EXTERN void TclDumpMemoryInfo _ANSI_ARGS_((FILE *outFile)); -EXTERN void TclExpandParseValue _ANSI_ARGS_((ParseValue *pvPtr, - int needed)); -EXTERN void TclExprFloatError _ANSI_ARGS_((Tcl_Interp *interp, - double value)); -EXTERN int TclFileAttrsCmd _ANSI_ARGS_((Tcl_Interp *interp, - int objc, Tcl_Obj *CONST objv[])); -EXTERN int TclFileCopyCmd _ANSI_ARGS_((Tcl_Interp *interp, - int argc, char **argv)) ; -EXTERN int TclFileDeleteCmd _ANSI_ARGS_((Tcl_Interp *interp, - int argc, char **argv)); -EXTERN int TclFileMakeDirsCmd _ANSI_ARGS_((Tcl_Interp *interp, - int argc, char **argv)) ; -EXTERN int TclFileRenameCmd _ANSI_ARGS_((Tcl_Interp *interp, - int argc, char **argv)) ; -EXTERN void TclFinalizeCompExecEnv _ANSI_ARGS_((void)); -EXTERN void TclFinalizeEnvironment _ANSI_ARGS_((void)); -EXTERN void TclFinalizeExecEnv _ANSI_ARGS_((void)); -EXTERN int TclFindElement _ANSI_ARGS_((Tcl_Interp *interp, - char *list, int listLength, char **elementPtr, - char **nextPtr, int *sizePtr, int *bracePtr)); -EXTERN Proc * TclFindProc _ANSI_ARGS_((Interp *iPtr, - char *procName)); -EXTERN int TclFormatInt _ANSI_ARGS_((char *buffer, long n)); -EXTERN void TclFreePackageInfo _ANSI_ARGS_((Interp *iPtr)); -EXTERN void TclGetAndDetachPids _ANSI_ARGS_((Tcl_Interp *interp, - Tcl_Channel chan)); -EXTERN char * TclGetCwd _ANSI_ARGS_((Tcl_Interp *interp)); -EXTERN int TclGetDate _ANSI_ARGS_((char *p, - unsigned long now, long zone, - unsigned long *timePtr)); -EXTERN Tcl_Channel TclGetDefaultStdChannel _ANSI_ARGS_((int type)); -EXTERN Tcl_Obj * TclGetElementOfIndexedArray _ANSI_ARGS_(( - Tcl_Interp *interp, int localIndex, - Tcl_Obj *elemPtr, int leaveErrorMsg)); -EXTERN char * TclGetEnv _ANSI_ARGS_((CONST char *name)); -EXTERN char * TclGetExtension _ANSI_ARGS_((char *name)); -EXTERN int TclGetFrame _ANSI_ARGS_((Tcl_Interp *interp, - char *string, CallFrame **framePtrPtr)); -EXTERN TclCmdProcType TclGetInterpProc _ANSI_ARGS_((void)); -EXTERN int TclGetIntForIndex _ANSI_ARGS_((Tcl_Interp *interp, - Tcl_Obj *objPtr, int endValue, int *indexPtr)); -EXTERN Tcl_Obj * TclGetIndexedScalar _ANSI_ARGS_((Tcl_Interp *interp, - int localIndex, int leaveErrorMsg)); -EXTERN int TclGetLong _ANSI_ARGS_((Tcl_Interp *interp, - char *string, long *longPtr)); -EXTERN int TclGetLoadedPackages _ANSI_ARGS_(( - Tcl_Interp *interp, char *targetName)); -EXTERN int TclGetNamespaceForQualName _ANSI_ARGS_(( - Tcl_Interp *interp, char *qualName, - Namespace *cxtNsPtr, int flags, - Namespace **nsPtrPtr, Namespace **altNsPtrPtr, - Namespace **actualCxtPtrPtr, - char **simpleNamePtr)); -EXTERN TclObjCmdProcType TclGetObjInterpProc _ANSI_ARGS_((void)); -EXTERN int TclGetOpenMode _ANSI_ARGS_((Tcl_Interp *interp, - char *string, int *seekFlagPtr)); -EXTERN Tcl_Command TclGetOriginalCommand _ANSI_ARGS_(( - Tcl_Command command)); -EXTERN char * TclGetUserHome _ANSI_ARGS_((char *name, - Tcl_DString *bufferPtr)); -EXTERN int TclGlobalInvoke _ANSI_ARGS_((Tcl_Interp *interp, - int argc, char **argv, int flags)); -EXTERN int TclGuessPackageName _ANSI_ARGS_((char *fileName, - Tcl_DString *bufPtr)); -EXTERN int TclHasSockets _ANSI_ARGS_((Tcl_Interp *interp)); -EXTERN int TclHideUnsafeCommands _ANSI_ARGS_(( - Tcl_Interp *interp)); -EXTERN int TclInExit _ANSI_ARGS_((void)); -EXTERN Tcl_Obj * TclIncrElementOfIndexedArray _ANSI_ARGS_(( - Tcl_Interp *interp, int localIndex, - Tcl_Obj *elemPtr, long incrAmount)); -EXTERN Tcl_Obj * TclIncrIndexedScalar _ANSI_ARGS_(( - Tcl_Interp *interp, int localIndex, - long incrAmount)); -EXTERN Tcl_Obj * TclIncrVar2 _ANSI_ARGS_((Tcl_Interp *interp, - Tcl_Obj *part1Ptr, Tcl_Obj *part2Ptr, - long incrAmount, int part1NotParsed)); -EXTERN void TclInitCompiledLocals _ANSI_ARGS_(( - Tcl_Interp *interp, CallFrame *framePtr, - Namespace *nsPtr)); -EXTERN void TclInitNamespaces _ANSI_ARGS_((void)); -EXTERN int TclInterpInit _ANSI_ARGS_((Tcl_Interp *interp)); -EXTERN int TclInvoke _ANSI_ARGS_((Tcl_Interp *interp, - int argc, char **argv, int flags)); -EXTERN int TclInvokeObjectCommand _ANSI_ARGS_(( - ClientData clientData, Tcl_Interp *interp, - int argc, char **argv)); -EXTERN int TclInvokeStringCommand _ANSI_ARGS_(( - ClientData clientData, Tcl_Interp *interp, - int objc, Tcl_Obj *CONST objv[])); -EXTERN 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 TclLooksLikeInt _ANSI_ARGS_((char *p)); -EXTERN Var * TclLookupVar _ANSI_ARGS_((Tcl_Interp *interp, - char *part1, char *part2, int flags, char *msg, - int createPart1, int createPart2, - Var **arrayPtrPtr)); -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_Obj * TclNewProcBodyObj _ANSI_ARGS_((Proc *procPtr)); -EXTERN int TclObjCommandComplete _ANSI_ARGS_((Tcl_Obj *cmdPtr)); -EXTERN int TclObjInterpProc _ANSI_ARGS_((ClientData clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *CONST objv[])); -EXTERN int TclObjInvoke _ANSI_ARGS_((Tcl_Interp *interp, - int objc, Tcl_Obj *CONST objv[], int flags)); -EXTERN int TclObjInvokeGlobal _ANSI_ARGS_((Tcl_Interp *interp, - int objc, Tcl_Obj *CONST objv[], int flags)); -EXTERN int TclOpenFileChannelDeleteProc _ANSI_ARGS_(( - TclOpenFileChannelProc_ *proc)); -EXTERN int TclOpenFileChannelInsertProc _ANSI_ARGS_(( - TclOpenFileChannelProc_ *proc)); -EXTERN char * TclpAlloc _ANSI_ARGS_((unsigned int size)); - -/* - * On a Mac, we can exit gracefully if the stack gets too small. - */ - -#ifdef MAC_TCL -EXTERN int TclpCheckStackSpace _ANSI_ARGS_((void)); -#else -#define TclpCheckStackSpace() (1) -#endif - -EXTERN int TclpCloseFile _ANSI_ARGS_((TclFile file)); -EXTERN int TclpCopyFile _ANSI_ARGS_((char *source, char *dest)); -EXTERN int TclpCopyDirectory _ANSI_ARGS_((char *source, - char *dest, Tcl_DString *errorPtr)); -EXTERN Tcl_Channel TclpCreateCommandChannel _ANSI_ARGS_(( - TclFile readFile, TclFile writeFile, - TclFile errorFile, int numPids, Tcl_Pid *pidPtr)); -EXTERN int TclpCreateDirectory _ANSI_ARGS_((char *path)); -EXTERN int TclpCreatePipe _ANSI_ARGS_((TclFile *readPipe, - TclFile *writePipe)); -EXTERN int TclpCreateProcess _ANSI_ARGS_((Tcl_Interp *interp, - int argc, char **argv, TclFile inputFile, - TclFile outputFile, TclFile errorFile, - Tcl_Pid *pidPtr)); -EXTERN TclFile TclpCreateTempFile _ANSI_ARGS_((char *contents, - Tcl_DString *namePtr)); -EXTERN int TclpDeleteFile _ANSI_ARGS_((char *path)); -EXTERN void TclpFinalize _ANSI_ARGS_((void)); -EXTERN void TclpFree _ANSI_ARGS_((char *ptr)); -EXTERN unsigned long TclpGetClicks _ANSI_ARGS_((void)); -EXTERN unsigned long TclpGetSeconds _ANSI_ARGS_((void)); -EXTERN void TclpGetTime _ANSI_ARGS_((Tcl_Time *time)); -EXTERN int TclpGetTimeZone _ANSI_ARGS_((unsigned long time)); -EXTERN char * TclpGetTZName _ANSI_ARGS_((void)); -EXTERN int TclpListVolumes _ANSI_ARGS_((Tcl_Interp *interp)); -EXTERN TclFile TclpMakeFile _ANSI_ARGS_((Tcl_Channel channel, - int direction)); -EXTERN TclFile TclpOpenFile _ANSI_ARGS_((char *fname, int mode)); -EXTERN Tcl_Channel TclpOpenFileChannel _ANSI_ARGS_((Tcl_Interp *interp, - char *fileName, char *modeString, - int permissions)); -EXTERN char * TclpRealloc _ANSI_ARGS_((char *ptr, - unsigned int size)); -EXTERN int TclpRemoveDirectory _ANSI_ARGS_((char *path, - int recursive, Tcl_DString *errorPtr)); -EXTERN int TclpRenameFile _ANSI_ARGS_((char *source, char *dest)); -#ifndef TclpSysAlloc -EXTERN VOID * TclpSysAlloc _ANSI_ARGS_((long size, int isBin)); -#endif -#ifndef TclpSysFree -EXTERN void TclpSysFree _ANSI_ARGS_((VOID *ptr)); -#endif -#ifndef TclpSysRealloc -EXTERN VOID * TclpSysRealloc _ANSI_ARGS_((VOID *cp, - unsigned int size)); -#endif -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 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, Tcl_Command cmd)); -EXTERN void TclPrintByteCodeObj _ANSI_ARGS_((Tcl_Interp *interp, - Tcl_Obj *objPtr)); -EXTERN void TclProcCleanupProc _ANSI_ARGS_((Proc *procPtr)); -EXTERN int TclProcCompileProc _ANSI_ARGS_((Tcl_Interp *interp, - Proc *procPtr, Tcl_Obj *bodyPtr, Namespace *nsPtr, - CONST char *description, CONST char *procName)); -EXTERN void TclProcDeleteProc _ANSI_ARGS_((ClientData clientData)); -EXTERN int TclProcInterpProc _ANSI_ARGS_((ClientData clientData, - Tcl_Interp *interp, int argc, char **argv)); -EXTERN int TclRenameCommand _ANSI_ARGS_((Tcl_Interp *interp, - char *oldName, char *newName)) ; -EXTERN void TclResetShadowedCmdRefs _ANSI_ARGS_(( - Tcl_Interp *interp, Command *newCmdPtr)); -EXTERN int TclServiceIdle _ANSI_ARGS_((void)); -EXTERN Tcl_Obj * TclSetElementOfIndexedArray _ANSI_ARGS_(( - Tcl_Interp *interp, int localIndex, - Tcl_Obj *elemPtr, Tcl_Obj *objPtr, - int leaveErrorMsg)); -EXTERN Tcl_Obj * TclSetIndexedScalar _ANSI_ARGS_((Tcl_Interp *interp, - int localIndex, Tcl_Obj *objPtr, - int leaveErrorMsg)); -EXTERN char * TclSetPreInitScript _ANSI_ARGS_((char *string)); -EXTERN void TclSetupEnv _ANSI_ARGS_((Tcl_Interp *interp)); -EXTERN int TclSockGetPort _ANSI_ARGS_((Tcl_Interp *interp, - char *string, char *proto, int *portPtr)); -EXTERN int TclSockMinimumBuffers _ANSI_ARGS_((int sock, - int size)); -EXTERN int TclStat _ANSI_ARGS_((CONST char *path, - TclStat_ *buf)); -EXTERN int TclStatDeleteProc _ANSI_ARGS_((TclStatProc_ *proc)); -EXTERN int TclStatInsertProc _ANSI_ARGS_((TclStatProc_ *proc)); -EXTERN void TclTeardownNamespace _ANSI_ARGS_((Namespace *nsPtr)); -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 char * TclWordEnd _ANSI_ARGS_((char *start, char *lastChar, - int nested, int *semiPtr)); - -/* - *---------------------------------------------------------------- - * Command procedures in the generic core: - *---------------------------------------------------------------- - */ - -EXTERN int Tcl_AfterObjCmd _ANSI_ARGS_((ClientData clientData, - Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); -EXTERN int Tcl_AppendObjCmd _ANSI_ARGS_((ClientData clientData, - Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); -EXTERN int Tcl_ArrayObjCmd _ANSI_ARGS_((ClientData clientData, - Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); -EXTERN int Tcl_BinaryObjCmd _ANSI_ARGS_((ClientData clientData, - Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); -EXTERN int Tcl_BreakCmd _ANSI_ARGS_((ClientData clientData, - Tcl_Interp *interp, int argc, char **argv)); -EXTERN int Tcl_CaseObjCmd _ANSI_ARGS_((ClientData clientData, - Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); -EXTERN int Tcl_CatchObjCmd _ANSI_ARGS_((ClientData clientData, - Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); -EXTERN int Tcl_CdObjCmd _ANSI_ARGS_((ClientData clientData, - Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); -EXTERN int Tcl_ClockObjCmd _ANSI_ARGS_((ClientData clientData, - Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); -EXTERN int Tcl_CloseObjCmd _ANSI_ARGS_((ClientData clientData, - Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); -EXTERN int Tcl_ConcatObjCmd _ANSI_ARGS_((ClientData clientData, - Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); -EXTERN int Tcl_ContinueCmd _ANSI_ARGS_((ClientData clientData, - Tcl_Interp *interp, int argc, char **argv)); -EXTERN int Tcl_EofObjCmd _ANSI_ARGS_((ClientData clientData, - Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); -EXTERN int Tcl_ErrorObjCmd _ANSI_ARGS_((ClientData clientData, - Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); -EXTERN int Tcl_EvalObjCmd _ANSI_ARGS_((ClientData clientData, - Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); -EXTERN int Tcl_ExecCmd _ANSI_ARGS_((ClientData clientData, - Tcl_Interp *interp, int argc, char **argv)); -EXTERN int Tcl_ExitObjCmd _ANSI_ARGS_((ClientData clientData, - Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); -EXTERN int Tcl_ExprObjCmd _ANSI_ARGS_((ClientData clientData, - Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); -EXTERN int Tcl_FblockedObjCmd _ANSI_ARGS_((ClientData clientData, - Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); -EXTERN int Tcl_FconfigureCmd _ANSI_ARGS_((ClientData clientData, - Tcl_Interp *interp, int argc, char **argv)); -EXTERN int Tcl_FcopyObjCmd _ANSI_ARGS_((ClientData dummy, - Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); -EXTERN int Tcl_FileObjCmd _ANSI_ARGS_((ClientData dummy, - Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); -EXTERN int Tcl_FileEventCmd _ANSI_ARGS_((ClientData clientData, - Tcl_Interp *interp, int argc, char **argv)); -EXTERN int Tcl_FlushObjCmd _ANSI_ARGS_((ClientData clientData, - Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); -EXTERN int Tcl_ForCmd _ANSI_ARGS_((ClientData clientData, - Tcl_Interp *interp, int argc, char **argv)); -EXTERN int Tcl_ForeachObjCmd _ANSI_ARGS_((ClientData clientData, - Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); -EXTERN int Tcl_FormatObjCmd _ANSI_ARGS_((ClientData dummy, - Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); -EXTERN int Tcl_GetsObjCmd _ANSI_ARGS_((ClientData clientData, - Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); -EXTERN int Tcl_GlobalObjCmd _ANSI_ARGS_((ClientData clientData, - Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); -EXTERN int Tcl_GlobCmd _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_InfoObjCmd _ANSI_ARGS_((ClientData clientData, - Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); -EXTERN int Tcl_InterpObjCmd _ANSI_ARGS_((ClientData clientData, - Tcl_Interp *interp, int argc, Tcl_Obj *CONST objv[])); -EXTERN int Tcl_JoinObjCmd _ANSI_ARGS_((ClientData clientData, - Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); -EXTERN int Tcl_LappendObjCmd _ANSI_ARGS_((ClientData clientData, - Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); -EXTERN int Tcl_LindexObjCmd _ANSI_ARGS_((ClientData clientData, - Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); -EXTERN int Tcl_LinsertObjCmd _ANSI_ARGS_((ClientData clientData, - Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); -EXTERN int Tcl_LlengthObjCmd _ANSI_ARGS_((ClientData clientData, - Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); -EXTERN int Tcl_ListObjCmd _ANSI_ARGS_((ClientData clientData, - Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); -EXTERN int Tcl_LoadCmd _ANSI_ARGS_((ClientData clientData, - Tcl_Interp *interp, int argc, char **argv)); -EXTERN int Tcl_LrangeObjCmd _ANSI_ARGS_((ClientData clientData, - Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); -EXTERN int Tcl_LreplaceObjCmd _ANSI_ARGS_((ClientData clientData, - Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); -EXTERN int Tcl_LsearchObjCmd _ANSI_ARGS_((ClientData clientData, - Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); -EXTERN int Tcl_LsortObjCmd _ANSI_ARGS_((ClientData clientData, - Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); -EXTERN int Tcl_NamespaceObjCmd _ANSI_ARGS_((ClientData clientData, - Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); -EXTERN int Tcl_OpenObjCmd _ANSI_ARGS_((ClientData clientData, - Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); -EXTERN int Tcl_PackageCmd _ANSI_ARGS_((ClientData clientData, - Tcl_Interp *interp, int argc, char **argv)); -EXTERN int Tcl_PidObjCmd _ANSI_ARGS_((ClientData clientData, - Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); -EXTERN int Tcl_ProcObjCmd _ANSI_ARGS_((ClientData clientData, - Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); -EXTERN int Tcl_PutsObjCmd _ANSI_ARGS_((ClientData clientData, - Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); -EXTERN int Tcl_PwdCmd _ANSI_ARGS_((ClientData clientData, - Tcl_Interp *interp, int argc, char **argv)); -EXTERN int Tcl_ReadObjCmd _ANSI_ARGS_((ClientData clientData, - Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); -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_RenameObjCmd _ANSI_ARGS_((ClientData clientData, - Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); -EXTERN int Tcl_ReturnObjCmd _ANSI_ARGS_((ClientData clientData, - Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); -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_SplitObjCmd _ANSI_ARGS_((ClientData clientData, - Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); -EXTERN int Tcl_SocketCmd _ANSI_ARGS_((ClientData clientData, - Tcl_Interp *interp, int argc, char **argv)); -EXTERN int Tcl_SourceObjCmd _ANSI_ARGS_((ClientData clientData, - Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); -EXTERN int Tcl_StringObjCmd _ANSI_ARGS_((ClientData clientData, - Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); -EXTERN int Tcl_SubstCmd _ANSI_ARGS_((ClientData clientData, - Tcl_Interp *interp, int argc, char **argv)); -EXTERN int Tcl_SwitchObjCmd _ANSI_ARGS_((ClientData clientData, - Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); -EXTERN int Tcl_TellCmd _ANSI_ARGS_((ClientData clientData, - Tcl_Interp *interp, int argc, char **argv)); -EXTERN int Tcl_TimeObjCmd _ANSI_ARGS_((ClientData clientData, - Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); -EXTERN int Tcl_TraceCmd _ANSI_ARGS_((ClientData clientData, - Tcl_Interp *interp, int argc, char **argv)); -EXTERN int Tcl_UnsetObjCmd _ANSI_ARGS_((ClientData clientData, - Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); -EXTERN int Tcl_UpdateCmd _ANSI_ARGS_((ClientData clientData, - Tcl_Interp *interp, int argc, char **argv)); -EXTERN int Tcl_UplevelObjCmd _ANSI_ARGS_((ClientData clientData, - Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); -EXTERN int Tcl_UpvarObjCmd _ANSI_ARGS_((ClientData clientData, - Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); -EXTERN int Tcl_VariableObjCmd _ANSI_ARGS_((ClientData clientData, - Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); -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)); - -/* - *---------------------------------------------------------------- - * Command procedures found only in the Mac version of the core: - *---------------------------------------------------------------- - */ - -#ifdef MAC_TCL -EXTERN int Tcl_EchoCmd _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_BeepObjCmd _ANSI_ARGS_((ClientData clientData, - Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); -EXTERN int Tcl_MacSourceObjCmd _ANSI_ARGS_((ClientData clientData, - Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); -EXTERN int Tcl_ResourceObjCmd _ANSI_ARGS_((ClientData clientData, - Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); -#endif - -/* - *---------------------------------------------------------------- - * Compilation procedures for commands in the generic core: - *---------------------------------------------------------------- - */ - -EXTERN int TclCompileBreakCmd _ANSI_ARGS_((Tcl_Interp *interp, - char *string, char *lastChar, int compileFlags, - struct CompileEnv *compileEnvPtr)); -EXTERN int TclCompileCatchCmd _ANSI_ARGS_((Tcl_Interp *interp, - char *string, char *lastChar, int compileFlags, - struct CompileEnv *compileEnvPtr)); -EXTERN int TclCompileContinueCmd _ANSI_ARGS_((Tcl_Interp *interp, - char *string, char *lastChar, int compileFlags, - struct CompileEnv *compileEnvPtr)); -EXTERN int TclCompileExprCmd _ANSI_ARGS_((Tcl_Interp *interp, - char *string, char *lastChar, int compileFlags, - struct CompileEnv *compileEnvPtr)); -EXTERN int TclCompileForCmd _ANSI_ARGS_((Tcl_Interp *interp, - char *string, char *lastChar, int compileFlags, - struct CompileEnv *compileEnvPtr)); -EXTERN int TclCompileForeachCmd _ANSI_ARGS_((Tcl_Interp *interp, - char *string, char *lastChar, int compileFlags, - struct CompileEnv *compileEnvPtr)); -EXTERN int TclCompileIfCmd _ANSI_ARGS_((Tcl_Interp *interp, - char *string, char *lastChar, int compileFlags, - struct CompileEnv *compileEnvPtr)); -EXTERN int TclCompileIncrCmd _ANSI_ARGS_((Tcl_Interp *interp, - char *string, char *lastChar, int compileFlags, - struct CompileEnv *compileEnvPtr)); -EXTERN int TclCompileSetCmd _ANSI_ARGS_((Tcl_Interp *interp, - char *string, char *lastChar, int compileFlags, - struct CompileEnv *compileEnvPtr)); -EXTERN int TclCompileWhileCmd _ANSI_ARGS_((Tcl_Interp *interp, - char *string, char *lastChar, int compileFlags, - struct CompileEnv *compileEnvPtr)); - -/* - *---------------------------------------------------------------- - * Macros used by the Tcl core to create and release Tcl objects. - * TclNewObj(objPtr) creates a new object denoting an empty string. - * TclDecrRefCount(objPtr) decrements the object's reference count, - * and frees the object if its reference count is zero. - * These macros are inline versions of Tcl_NewObj() and - * Tcl_DecrRefCount(). Notice that the names differ in not having - * a "_" after the "Tcl". Notice also that these macros reference - * their argument more than once, so you should avoid calling them - * with an expression that is expensive to compute or has - * side effects. The ANSI C "prototypes" for these macros are: - * - * EXTERN void TclNewObj _ANSI_ARGS_((Tcl_Obj *objPtr)); - * EXTERN void TclDecrRefCount _ANSI_ARGS_((Tcl_Obj *objPtr)); - *---------------------------------------------------------------- - */ - -#ifdef TCL_COMPILE_STATS -# define TclIncrObjsAllocated() \ - tclObjsAlloced++ -# define TclIncrObjsFreed() \ - tclObjsFreed++ -#else -# define TclIncrObjsAllocated() -# define TclIncrObjsFreed() -#endif /* TCL_COMPILE_STATS */ - -#ifdef TCL_MEM_DEBUG -# define TclNewObj(objPtr) \ - (objPtr) = (Tcl_Obj *) Tcl_DbCkalloc(sizeof(Tcl_Obj), __FILE__, __LINE__); \ - (objPtr)->refCount = 0; \ - (objPtr)->bytes = tclEmptyStringRep; \ - (objPtr)->length = 0; \ - (objPtr)->typePtr = NULL; \ - TclIncrObjsAllocated() -# define TclDbNewObj(objPtr, file, line) \ - (objPtr) = (Tcl_Obj *) Tcl_DbCkalloc(sizeof(Tcl_Obj), (file), (line)); \ - (objPtr)->refCount = 0; \ - (objPtr)->bytes = tclEmptyStringRep; \ - (objPtr)->length = 0; \ - (objPtr)->typePtr = NULL; \ - TclIncrObjsAllocated() -# define TclDecrRefCount(objPtr) \ - if (--(objPtr)->refCount <= 0) { \ - if ((objPtr)->refCount < -1) \ - panic("Reference count for %lx was negative: %s line %d", \ - (objPtr), __FILE__, __LINE__); \ - if (((objPtr)->bytes != NULL) \ - && ((objPtr)->bytes != tclEmptyStringRep)) { \ - ckfree((char *) (objPtr)->bytes); \ - } \ - if (((objPtr)->typePtr != NULL) \ - && ((objPtr)->typePtr->freeIntRepProc != NULL)) { \ - (objPtr)->typePtr->freeIntRepProc(objPtr); \ - } \ - ckfree((char *) (objPtr)); \ - TclIncrObjsFreed(); \ - } -#else /* not TCL_MEM_DEBUG */ -# define TclNewObj(objPtr) \ - if (tclFreeObjList == NULL) { \ - TclAllocateFreeObjects(); \ - } \ - (objPtr) = tclFreeObjList; \ - tclFreeObjList = (Tcl_Obj *) \ - tclFreeObjList->internalRep.otherValuePtr; \ - (objPtr)->refCount = 0; \ - (objPtr)->bytes = tclEmptyStringRep; \ - (objPtr)->length = 0; \ - (objPtr)->typePtr = NULL; \ - TclIncrObjsAllocated() -# define TclDecrRefCount(objPtr) \ - if (--(objPtr)->refCount <= 0) { \ - if (((objPtr)->bytes != NULL) \ - && ((objPtr)->bytes != tclEmptyStringRep)) { \ - ckfree((char *) (objPtr)->bytes); \ - } \ - if (((objPtr)->typePtr != NULL) \ - && ((objPtr)->typePtr->freeIntRepProc != NULL)) { \ - (objPtr)->typePtr->freeIntRepProc(objPtr); \ - } \ - (objPtr)->internalRep.otherValuePtr = (VOID *) tclFreeObjList; \ - tclFreeObjList = (objPtr); \ - TclIncrObjsFreed(); \ - } -#endif /* TCL_MEM_DEBUG */ - -/* - *---------------------------------------------------------------- - * Macro used by the Tcl core to set a Tcl_Obj's string representation - * to a copy of the "len" bytes starting at "bytePtr". This code - * works even if the byte array contains NULLs as long as the length - * is correct. Because "len" is referenced multiple times, it should - * be as simple an expression as possible. The ANSI C "prototype" for - * this macro is: - * - * EXTERN void TclInitStringRep _ANSI_ARGS_((Tcl_Obj *objPtr, - * char *bytePtr, int len)); - *---------------------------------------------------------------- - */ - -#define TclInitStringRep(objPtr, bytePtr, len) \ - if ((len) == 0) { \ - (objPtr)->bytes = tclEmptyStringRep; \ - (objPtr)->length = 0; \ - } else { \ - (objPtr)->bytes = (char *) ckalloc((unsigned) ((len) + 1)); \ - memcpy((VOID *) (objPtr)->bytes, (VOID *) (bytePtr), \ - (unsigned) (len)); \ - (objPtr)->bytes[len] = '\0'; \ - (objPtr)->length = (len); \ - } - -/* - *---------------------------------------------------------------- - * Macro used by the Tcl core to get the string representation's - * byte array pointer and length from a Tcl_Obj. This is an inline - * version of Tcl_GetStringFromObj(). "lengthPtr" must be the - * address of an integer variable or NULL; If non-NULL, that variable - * will be set to the string rep's length. The macro's expression - * result is the string rep's byte pointer which might be NULL. - * Note that the bytes referenced by this pointer must not be modified - * by the caller. The ANSI C "prototype" for this macro is: - * - * EXTERN char * TclGetStringFromObj _ANSI_ARGS_((Tcl_Obj *objPtr, - * int *lengthPtr)); - *---------------------------------------------------------------- - */ - -#define TclGetStringFromObj(objPtr, lengthPtr) \ - ((objPtr)->bytes? \ - ((lengthPtr)? \ - ((*(lengthPtr) = (objPtr)->length), (objPtr)->bytes) : \ - (objPtr)->bytes) : \ - Tcl_GetStringFromObj((objPtr), (lengthPtr))) - -/* - *---------------------------------------------------------------- - * Macro used by the Tcl core to reset an interpreter's Tcl object - * result to an unshared empty string object with ref count one. - * This does not clear any error information for the interpreter. - * The ANSI C "prototype" for this macro is: - * - * EXTERN void TclResetObjResult _ANSI_ARGS_((Tcl_Interp *interp)); - *--------------------------------------------------------------- - */ - -#define TclResetObjResult(interp) \ - { \ - register Tcl_Obj *objResultPtr = ((Interp *) interp)->objResultPtr; \ - if (Tcl_IsShared(objResultPtr)) { \ - TclDecrRefCount(objResultPtr); \ - TclNewObj(objResultPtr); \ - Tcl_IncrRefCount(objResultPtr); \ - ((Interp *) interp)->objResultPtr = objResultPtr; \ - } else { \ - if ((objResultPtr->bytes != NULL) \ - && (objResultPtr->bytes != tclEmptyStringRep)) { \ - ckfree((char *) objResultPtr->bytes); \ - } \ - objResultPtr->bytes = tclEmptyStringRep; \ - objResultPtr->length = 0; \ - if ((objResultPtr->typePtr != NULL) \ - && (objResultPtr->typePtr->freeIntRepProc != NULL)) { \ - objResultPtr->typePtr->freeIntRepProc(objResultPtr); \ - } \ - objResultPtr->typePtr = (Tcl_ObjType *) NULL; \ - } \ - } - -/* - *---------------------------------------------------------------- - * Procedures used in conjunction with Tcl namespaces. They are - * defined here instead of in tcl.h since they are not stable yet. - *---------------------------------------------------------------- - */ - -EXTERN void Tcl_AddInterpResolvers _ANSI_ARGS_((Tcl_Interp *interp, - char *name, Tcl_ResolveCmdProc *cmdProc, - Tcl_ResolveVarProc *varProc, - Tcl_ResolveCompiledVarProc *compiledVarProc)); -EXTERN int Tcl_AppendExportList _ANSI_ARGS_(( - Tcl_Interp *interp, Tcl_Namespace *nsPtr, - Tcl_Obj *objPtr)); -EXTERN Tcl_Namespace * Tcl_CreateNamespace _ANSI_ARGS_((Tcl_Interp *interp, - char *name, ClientData clientData, - Tcl_NamespaceDeleteProc *deleteProc)); -EXTERN void Tcl_DeleteNamespace _ANSI_ARGS_(( - Tcl_Namespace *nsPtr)); -EXTERN int Tcl_Export _ANSI_ARGS_((Tcl_Interp *interp, - Tcl_Namespace *nsPtr, char *pattern, - int resetListFirst)); -EXTERN Tcl_Command Tcl_FindCommand _ANSI_ARGS_((Tcl_Interp *interp, - char *name, Tcl_Namespace *contextNsPtr, - int flags)); -EXTERN Tcl_Namespace * Tcl_FindNamespace _ANSI_ARGS_((Tcl_Interp *interp, - char *name, Tcl_Namespace *contextNsPtr, - int flags)); -EXTERN int Tcl_GetInterpResolvers _ANSI_ARGS_((Tcl_Interp *interp, - char *name, Tcl_ResolverInfo *resInfo)); -EXTERN int Tcl_GetNamespaceResolvers _ANSI_ARGS_(( - Tcl_Namespace *namespacePtr, - Tcl_ResolverInfo *resInfo)); -EXTERN void Tcl_GetVariableFullName _ANSI_ARGS_(( - Tcl_Interp *interp, Tcl_Var variable, - Tcl_Obj *objPtr)); -EXTERN Tcl_Var Tcl_FindNamespaceVar _ANSI_ARGS_(( - Tcl_Interp *interp, char *name, - Tcl_Namespace *contextNsPtr, int flags)); -EXTERN int Tcl_ForgetImport _ANSI_ARGS_((Tcl_Interp *interp, - Tcl_Namespace *nsPtr, char *pattern)); -EXTERN Tcl_Command Tcl_GetCommandFromObj _ANSI_ARGS_(( - Tcl_Interp *interp, Tcl_Obj *objPtr)); -EXTERN void Tcl_GetCommandFullName _ANSI_ARGS_(( - Tcl_Interp *interp, Tcl_Command command, - Tcl_Obj *objPtr)); -EXTERN Tcl_Namespace * Tcl_GetCurrentNamespace _ANSI_ARGS_(( - Tcl_Interp *interp)); -EXTERN Tcl_Namespace * Tcl_GetGlobalNamespace _ANSI_ARGS_(( - Tcl_Interp *interp)); -EXTERN void Tcl_GetVariableFullName _ANSI_ARGS_(( - Tcl_Interp *interp, Tcl_Var variable, - Tcl_Obj *objPtr)); -EXTERN int Tcl_Import _ANSI_ARGS_((Tcl_Interp *interp, - Tcl_Namespace *nsPtr, char *pattern, - int allowOverwrite)); -EXTERN void Tcl_PopCallFrame _ANSI_ARGS_((Tcl_Interp* interp)); -EXTERN int Tcl_PushCallFrame _ANSI_ARGS_((Tcl_Interp* interp, - Tcl_CallFrame *framePtr, Tcl_Namespace *nsPtr, - int isProcCallFrame)); -EXTERN int Tcl_RemoveInterpResolvers _ANSI_ARGS_(( - Tcl_Interp *interp, char *name)); -EXTERN void Tcl_SetNamespaceResolvers _ANSI_ARGS_(( - Tcl_Namespace *namespacePtr, - Tcl_ResolveCmdProc *cmdProc, - Tcl_ResolveVarProc *varProc, - Tcl_ResolveCompiledVarProc *compiledVarProc)); - -# undef TCL_STORAGE_CLASS -# define TCL_STORAGE_CLASS DLLIMPORT - -#endif /* _TCLINT */ - diff --git a/generic/tclParse.c b/generic/tclParse.c deleted file mode 100644 index b822c24..0000000 --- a/generic/tclParse.c +++ /dev/null @@ -1,938 +0,0 @@ -/* - * 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-1997 Sun Microsystems, Inc. - * - * See the file "license.terms" for information on usage and redistribution - * of this file, and for a DISCLAIMER OF ALL WARRANTIES. - * - * RCS: @(#) $Id: tclParse.c,v 1.2 1998/09/14 18:40:01 stanton Exp $ - */ - -#include "tclInt.h" -#include "tclPort.h" - -/* - * Function prototypes for procedures local to this file: - */ - -static char * QuoteEnd _ANSI_ARGS_((char *string, char *lastChar, - int term)); -static char * ScriptEnd _ANSI_ARGS_((char *p, char *lastChar, - int nested)); -static char * VarNameEnd _ANSI_ARGS_((char *string, char *lastChar)); - -/* - *-------------------------------------------------------------- - * - * 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; - char *lastChar = string + strlen(string); - - 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(src-1, lastChar) == 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') { - char buf[30]; - - Tcl_ResetResult(interp); - sprintf(buf, "missing %c", termChar); - Tcl_SetResult(interp, buf, TCL_VOLATILE); - *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 = (string + iPtr->termOffset); - 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(interp); - 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; - char *lastChar = string + strlen(string); - - 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(src-1, lastChar) == 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; -} - -/* - *-------------------------------------------------------------- - * - * 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, lastChar, nested, semiPtr) - char *start; /* Beginning of a word of a Tcl command. */ - char *lastChar; /* Terminating character in string. */ - 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 == lastChar) { - return p+2; - } - continue; - } - break; - } - - /* - * Handle words beginning with a double-quote or a brace. - */ - - if (*p == '"') { - p = QuoteEnd(p+1, lastChar, '"'); - if (p == lastChar) { - 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 == lastChar) { - 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, lastChar, 1); - if (p == lastChar) { - 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, lastChar); - if (p == lastChar) { - 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 == lastChar) { - 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, lastChar, term) - char *string; /* Pointer to character just after opening - * "quote". */ - char *lastChar; /* Terminating character in string. */ - 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, lastChar, 1, (int *) NULL); - if (*p == 0) { - return p; - } - } - p++; - } else if (*p == '$') { - p = VarNameEnd(p, lastChar); - if (*p == 0) { - return p; - } - p++; - } else if (p == lastChar) { - 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, lastChar) - char *string; /* Pointer to dollar-sign character. */ - char *lastChar; /* Terminating character in string. */ -{ - register char *p = string+1; - - if (*p == '{') { - for (p++; (*p != '}') && (p != lastChar); p++) { - /* Empty loop body. */ - } - return p; - } - while (isalnum(UCHAR(*p)) || (*p == '_')) { - p++; - } - if ((*p == '(') && (p != string+1)) { - return QuoteEnd(p+1, lastChar, ')'); - } - 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, lastChar, nested) - char *p; /* Script to check. */ - char *lastChar; /* Terminating character in string. */ - 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 == lastChar)) { - return p+2; - } - Tcl_Backslash(p, &length); - p += length; - } else { - p++; - } - } while ((p != lastChar) && (*p != '\n')); - continue; - } - p = TclWordEnd(p, lastChar, nested, &commentOK); - if (p == lastChar) { - return p; - } - p++; - if (nested) { - if (*p == ']') { - return p; - } - } else { - if (p == lastChar) { - 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, or a "::" namespace separator. - * 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, - * underscore, or a "::" namespace separator: 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 == ':') { - if (*(string+1) == ':') { - string += 2; /* skip over the initial :: */ - while (*string == ':') { - string++; /* skip over a subsequent : */ - } - } else { - break; /* : by itself */ - } - } else { - 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; - } - - 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, cmd+strlen(cmd), 0); - return (*p != 0); -} - -/* - *---------------------------------------------------------------------- - * - * TclObjCommandComplete -- - * - * Given a partial or complete Tcl command in a Tcl object, 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 -TclObjCommandComplete(cmdPtr) - Tcl_Obj *cmdPtr; /* Points to object holding command - * to check. */ -{ - char *cmd, *p; - int length; - - cmd = Tcl_GetStringFromObj(cmdPtr, &length); - if (length == 0) { - return 1; - } - p = ScriptEnd(cmd, cmd+length, /*nested*/ 0); - return (*p != 0); -} diff --git a/generic/tclTest.c b/generic/tclTest.c deleted file mode 100644 index 23dc31f..0000000 --- a/generic/tclTest.c +++ /dev/null @@ -1,3096 +0,0 @@ -/* - * 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-1997 Sun Microsystems, Inc. - * - * See the file "license.terms" for information on usage and redistribution - * of this file, and for a DISCLAIMER OF ALL WARRANTIES. - * - * RCS: @(#) $Id: tclTest.c,v 1.8 1999/02/03 02:58:25 stanton Exp $ - */ - -#define TCL_TEST - -#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; - -/* - * The command trace below is used by the "testcmdtraceCmd" command - * to test the command tracing facilities. - */ - -static Tcl_Trace cmdTrace; - -/* - * 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; - -/* - * 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 CmdTraceDeleteProc _ANSI_ARGS_(( - ClientData clientData, Tcl_Interp *interp, - int level, char *command, Tcl_CmdProc *cmdProc, - ClientData cmdClientData, int argc, - char **argv)); -static void CmdTraceProc _ANSI_ARGS_((ClientData clientData, - Tcl_Interp *interp, int level, char *command, - Tcl_CmdProc *cmdProc, ClientData cmdClientData, - int argc, char **argv)); -static int CreatedCommandProc _ANSI_ARGS_(( - ClientData clientData, Tcl_Interp *interp, - int argc, char **argv)); -static int CreatedCommandProc2 _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 int GetTimesCmd _ANSI_ARGS_((ClientData clientData, - Tcl_Interp *interp, int argc, char **argv)); -static int NoopCmd _ANSI_ARGS_((ClientData clientData, - Tcl_Interp *interp, int argc, char **argv)); -static int NoopObjCmd _ANSI_ARGS_((ClientData clientData, - Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); -static void SpecialFree _ANSI_ARGS_((char *blockPtr)); -static int StaticInitProc _ANSI_ARGS_((Tcl_Interp *interp)); -static int TestaccessprocCmd _ANSI_ARGS_((ClientData dummy, - Tcl_Interp *interp, int argc, char **argv)); -static int TestAccessProc1 _ANSI_ARGS_((CONST char *path, - int mode)); -static int TestAccessProc2 _ANSI_ARGS_((CONST char *path, - int mode)); -static int TestAccessProc3 _ANSI_ARGS_((CONST char *path, - int mode)); -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 TestcmdtraceCmd _ANSI_ARGS_((ClientData dummy, - Tcl_Interp *interp, int argc, char **argv)); -static int TestchmodCmd _ANSI_ARGS_((ClientData dummy, - Tcl_Interp *interp, int argc, char **argv)); -static int TestcreatecommandCmd _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 TestexprlongCmd _ANSI_ARGS_((ClientData dummy, - Tcl_Interp *interp, int argc, char **argv)); -static int TestexprstringCmd _ANSI_ARGS_((ClientData dummy, - Tcl_Interp *interp, int argc, char **argv)); -static int TestfileCmd _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 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 TestgetvarfullnameCmd _ANSI_ARGS_(( - ClientData dummy, Tcl_Interp *interp, - int objc, Tcl_Obj *CONST objv[])); -static int TestinterpdeleteCmd _ANSI_ARGS_((ClientData dummy, - Tcl_Interp *interp, int argc, char **argv)); -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 TestMathFunc2 _ANSI_ARGS_((ClientData clientData, - Tcl_Interp *interp, Tcl_Value *args, - Tcl_Value *resultPtr)); -static Tcl_Channel TestOpenFileChannelProc1 _ANSI_ARGS_((Tcl_Interp *interp, - char *filename, char *modeString, int permissions)); -static Tcl_Channel TestOpenFileChannelProc2 _ANSI_ARGS_((Tcl_Interp *interp, - char *filename, char *modeString, int permissions)); -static Tcl_Channel TestOpenFileChannelProc3 _ANSI_ARGS_((Tcl_Interp *interp, - char *filename, char *modeString, int permissions)); -static int TestPanicCmd _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 TestsetCmd _ANSI_ARGS_((ClientData dummy, - Tcl_Interp *interp, int argc, char **argv)); -static int TestsetobjerrorcodeCmd _ANSI_ARGS_(( - ClientData dummy, Tcl_Interp *interp, - int objc, Tcl_Obj *CONST objv[])); -static int TestopenfilechannelprocCmd _ANSI_ARGS_((ClientData dummy, - Tcl_Interp *interp, int argc, char **argv)); -static int TestsetplatformCmd _ANSI_ARGS_((ClientData dummy, - Tcl_Interp *interp, int argc, char **argv)); -static int TestsetrecursionlimitCmd _ANSI_ARGS_(( - ClientData dummy, Tcl_Interp *interp, - int objc, Tcl_Obj *CONST objv[])); -static int TeststaticpkgCmd _ANSI_ARGS_((ClientData dummy, - Tcl_Interp *interp, int argc, char **argv)); -static int TestStatProc1 _ANSI_ARGS_((CONST char *path, - TclStat_ *buf)); -static int TestStatProc2 _ANSI_ARGS_((CONST char *path, - TclStat_ *buf)); -static int TestStatProc3 _ANSI_ARGS_((CONST char *path, - TclStat_ *buf)); -static int TeststatprocCmd _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 TestwordendObjCmd _ANSI_ARGS_((ClientData dummy, - Tcl_Interp *interp, int objc, - Tcl_Obj *CONST objv[])); - -/* - * External (platform specific) initialization routine, this declaration - * explicitly does not use EXTERN since this code does not get compiled - * into the library: - */ - -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. */ -{ - Tcl_ValueType t3ArgTypes[2]; - - if (Tcl_PkgProvide(interp, "Tcltest", TCL_VERSION) == TCL_ERROR) { - return TCL_ERROR; - } - - /* - * Create additional commands and math functions for testing Tcl. - */ - - Tcl_CreateCommand(interp, "noop", NoopCmd, (ClientData) 0, - (Tcl_CmdDeleteProc *) NULL); - Tcl_CreateObjCommand(interp, "noop", NoopObjCmd, (ClientData) 0, - (Tcl_CmdDeleteProc *) NULL); - Tcl_CreateCommand(interp, "testaccessproc", TestaccessprocCmd, (ClientData) 0, - (Tcl_CmdDeleteProc *) NULL); - 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, "testchmod", TestchmodCmd, - (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, "testcmdtrace", TestcmdtraceCmd, - (ClientData) 0, (Tcl_CmdDeleteProc *) NULL); - Tcl_CreateCommand(interp, "testcreatecommand", TestcreatecommandCmd, - (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, "testexprlong", TestexprlongCmd, - (ClientData) 0, (Tcl_CmdDeleteProc *) NULL); - Tcl_CreateCommand(interp, "testexprstring", TestexprstringCmd, - (ClientData) 0, (Tcl_CmdDeleteProc *) NULL); - Tcl_CreateCommand(interp, "testfile", TestfileCmd, - (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_CreateObjCommand(interp, "testgetvarfullname", - TestgetvarfullnameCmd, (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, "testopenfilechannelproc", - TestopenfilechannelprocCmd, (ClientData) 0, - (Tcl_CmdDeleteProc *) NULL); - Tcl_CreateCommand(interp, "testsetassocdata", TestsetassocdataCmd, - (ClientData) 0, (Tcl_CmdDeleteProc *) NULL); - Tcl_CreateCommand(interp, "testsetnoerr", TestsetCmd, - (ClientData) 0, (Tcl_CmdDeleteProc *) NULL); - Tcl_CreateCommand(interp, "testseterr", TestsetCmd, - (ClientData) TCL_LEAVE_ERR_MSG, (Tcl_CmdDeleteProc *) NULL); - Tcl_CreateObjCommand(interp, "testsetobjerrorcode", - TestsetobjerrorcodeCmd, (ClientData) 0, - (Tcl_CmdDeleteProc *) NULL); - Tcl_CreateCommand(interp, "testsetplatform", TestsetplatformCmd, - (ClientData) 0, (Tcl_CmdDeleteProc *) NULL); - Tcl_CreateObjCommand(interp, "testsetrecursionlimit", - TestsetrecursionlimitCmd, - (ClientData) 0, (Tcl_CmdDeleteProc *) NULL); - Tcl_CreateCommand(interp, "teststaticpkg", TeststaticpkgCmd, - (ClientData) 0, (Tcl_CmdDeleteProc *) NULL); - Tcl_CreateCommand(interp, "testtranslatefilename", - TesttranslatefilenameCmd, (ClientData) 0, - (Tcl_CmdDeleteProc *) NULL); - Tcl_CreateCommand(interp, "testupvar", TestupvarCmd, (ClientData) 0, - (Tcl_CmdDeleteProc *) NULL); - Tcl_CreateObjCommand(interp, "testwordend", TestwordendObjCmd, - (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_CreateCommand(interp, "gettimes", GetTimesCmd, (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); - Tcl_CreateCommand(interp, "teststatproc", TeststatprocCmd, (ClientData) 0, - (Tcl_CmdDeleteProc *) NULL); - t3ArgTypes[0] = TCL_EITHER; - t3ArgTypes[1] = TCL_EITHER; - Tcl_CreateMathFunc(interp, "T3", 2, t3ArgTypes, TestMathFunc2, - (ClientData) 0); - - /* - * 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; - char buf[30]; - - if (argc < 2) { - wrongNumArgs: - Tcl_SetResult(interp, "wrong # args", TCL_STATIC); - 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(buf, "%d", asyncPtr->id); - Tcl_SetResult(interp, buf, TCL_VOLATILE); - } 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) { - Tcl_SetResult(interp, "??", TCL_STATIC); - 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); - } - Tcl_AppendResult(interp, " ", info.namespacePtr->fullName, - (char *) NULL); - if (info.isNativeObjectProc) { - Tcl_AppendResult(interp, " nativeObjectProc", (char *) NULL); - } else { - Tcl_AppendResult(interp, " stringProc", (char *) NULL); - } - } else if (strcmp(argv[1], "modify") == 0) { - info.proc = CmdProc2; - info.clientData = (ClientData) "new_command_data"; - info.objProc = NULL; - info.objClientData = (ClientData) NULL; - info.deleteProc = CmdDelProc2; - info.deleteData = (ClientData) "new_delete_data"; - if (Tcl_SetCommandInfo(interp, argv[2], &info) == 0) { - Tcl_SetResult(interp, "0", TCL_STATIC); - } else { - Tcl_SetResult(interp, "1", TCL_STATIC); - } - } 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 procedures such as - * Tcl_GetCommandFullName. - * - * 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; - char buf[30]; - - 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(buf, "%lx", (long int) token); - Tcl_SetResult(interp, buf, TCL_VOLATILE); - } else if (strcmp(argv[1], "name") == 0) { - Tcl_Obj *objPtr; - - if (sscanf(argv[2], "%lx", &l) != 1) { - Tcl_AppendResult(interp, "bad command token \"", argv[2], - "\"", (char *) NULL); - return TCL_ERROR; - } - - objPtr = Tcl_NewObj(); - Tcl_GetCommandFullName(interp, (Tcl_Command) l, objPtr); - - Tcl_AppendElement(interp, - Tcl_GetCommandName(interp, (Tcl_Command) l)); - Tcl_AppendElement(interp, - Tcl_GetStringFromObj(objPtr, (int *) NULL)); - Tcl_DecrRefCount(objPtr); - } else { - Tcl_AppendResult(interp, "bad option \"", argv[1], - "\": must be create or name", (char *) NULL); - return TCL_ERROR; - } - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * - * TestcmdtraceCmd -- - * - * This procedure implements the "testcmdtrace" command. It is used - * to test Tcl_CreateTrace and Tcl_DeleteTrace. - * - * Results: - * A standard Tcl result. - * - * Side effects: - * Creates and deletes a command trace, and tests the invocation of - * a procedure by the command trace. - * - *---------------------------------------------------------------------- - */ - - /* ARGSUSED */ -static int -TestcmdtraceCmd(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 result; - - if (argc != 3) { - Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], - " option script\"", (char *) NULL); - return TCL_ERROR; - } - - if (strcmp(argv[1], "tracetest") == 0) { - Tcl_DStringInit(&buffer); - cmdTrace = Tcl_CreateTrace(interp, 50000, - (Tcl_CmdTraceProc *) CmdTraceProc, (ClientData) &buffer); - result = Tcl_Eval(interp, argv[2]); - if (result == TCL_OK) { - Tcl_ResetResult(interp); - Tcl_AppendResult(interp, Tcl_DStringValue(&buffer), NULL); - } - Tcl_DeleteTrace(interp, cmdTrace); - Tcl_DStringFree(&buffer); - } else if (strcmp(argv[1], "deletetest") == 0) { - /* - * Create a command trace then eval a script to check whether it is - * called. Note that this trace procedure removes itself as a - * further check of the robustness of the trace proc calling code in - * TclExecuteByteCode. - */ - - cmdTrace = Tcl_CreateTrace(interp, 50000, - (Tcl_CmdTraceProc *) CmdTraceDeleteProc, (ClientData) NULL); - result = Tcl_Eval(interp, argv[2]); - } else { - Tcl_AppendResult(interp, "bad option \"", argv[1], - "\": must be tracetest or deletetest", (char *) NULL); - return TCL_ERROR; - } - return TCL_OK; -} - -static void -CmdTraceProc(clientData, interp, level, command, cmdProc, cmdClientData, - argc, argv) - ClientData clientData; /* Pointer to buffer in which the - * command and arguments are appended. - * Accumulates test result. */ - Tcl_Interp *interp; /* Current interpreter. */ - int level; /* Current trace level. */ - char *command; /* The command being traced (after - * substitutions). */ - Tcl_CmdProc *cmdProc; /* Points to command's command procedure. */ - ClientData cmdClientData; /* Client data associated with command - * procedure. */ - int argc; /* Number of arguments. */ - char **argv; /* Argument strings. */ -{ - Tcl_DString *bufPtr = (Tcl_DString *) clientData; - int i; - - Tcl_DStringAppendElement(bufPtr, command); - - Tcl_DStringStartSublist(bufPtr); - for (i = 0; i < argc; i++) { - Tcl_DStringAppendElement(bufPtr, argv[i]); - } - Tcl_DStringEndSublist(bufPtr); -} - -static void -CmdTraceDeleteProc(clientData, interp, level, command, cmdProc, - cmdClientData, argc, argv) - ClientData clientData; /* Unused. */ - Tcl_Interp *interp; /* Current interpreter. */ - int level; /* Current trace level. */ - char *command; /* The command being traced (after - * substitutions). */ - Tcl_CmdProc *cmdProc; /* Points to command's command procedure. */ - ClientData cmdClientData; /* Client data associated with command - * procedure. */ - int argc; /* Number of arguments. */ - char **argv; /* Argument strings. */ -{ - /* - * Remove ourselves to test whether calling Tcl_DeleteTrace within - * a trace callback causes the for loop in TclExecuteByteCode that - * calls traces to reference freed memory. - */ - - Tcl_DeleteTrace(interp, cmdTrace); -} - -/* - *---------------------------------------------------------------------- - * - * TestcreatecommandCmd -- - * - * This procedure implements the "testcreatecommand" command. It is - * used to test that the Tcl_CreateCommand creates a new command in - * the namespace specified as part of its name, if any. It also - * checks that the namespace code ignore single ":"s in the middle - * or end of a command name. - * - * Results: - * A standard Tcl result. - * - * Side effects: - * Creates and deletes two commands ("test_ns_basic::createdcommand" - * and "value:at:"). - * - *---------------------------------------------------------------------- - */ - -static int -TestcreatecommandCmd(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], - " option\"", (char *) NULL); - return TCL_ERROR; - } - if (strcmp(argv[1], "create") == 0) { - Tcl_CreateCommand(interp, "test_ns_basic::createdcommand", - CreatedCommandProc, (ClientData) NULL, - (Tcl_CmdDeleteProc *) NULL); - } else if (strcmp(argv[1], "delete") == 0) { - Tcl_DeleteCommand(interp, "test_ns_basic::createdcommand"); - } else if (strcmp(argv[1], "create2") == 0) { - Tcl_CreateCommand(interp, "value:at:", - CreatedCommandProc2, (ClientData) NULL, - (Tcl_CmdDeleteProc *) NULL); - } else if (strcmp(argv[1], "delete2") == 0) { - Tcl_DeleteCommand(interp, "value:at:"); - } else { - Tcl_AppendResult(interp, "bad option \"", argv[1], - "\": must be create, delete, create2, or delete2", - (char *) NULL); - return TCL_ERROR; - } - return TCL_OK; -} - -static int -CreatedCommandProc(clientData, interp, argc, argv) - ClientData clientData; /* String to return. */ - Tcl_Interp *interp; /* Current interpreter. */ - int argc; /* Number of arguments. */ - char **argv; /* Argument strings. */ -{ - Tcl_CmdInfo info; - int found; - - found = Tcl_GetCommandInfo(interp, "test_ns_basic::createdcommand", - &info); - if (!found) { - Tcl_AppendResult(interp, "CreatedCommandProc could not get command info for test_ns_basic::createdcommand", - (char *) NULL); - return TCL_ERROR; - } - Tcl_AppendResult(interp, "CreatedCommandProc in ", - info.namespacePtr->fullName, (char *) NULL); - return TCL_OK; -} - -static int -CreatedCommandProc2(clientData, interp, argc, argv) - ClientData clientData; /* String to return. */ - Tcl_Interp *interp; /* Current interpreter. */ - int argc; /* Number of arguments. */ - char **argv; /* Argument strings. */ -{ - Tcl_CmdInfo info; - int found; - - found = Tcl_GetCommandInfo(interp, "value:at:", &info); - if (!found) { - Tcl_AppendResult(interp, "CreatedCommandProc2 could not get command info for test_ns_basic::createdcommand", - (char *) NULL); - return TCL_ERROR; - } - Tcl_AppendResult(interp, "CreatedCommandProc2 in ", - info.namespacePtr->fullName, (char *) NULL); - 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) { - Tcl_SetResult(interp, "wrong # args", TCL_STATIC); - 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: - Tcl_SetResult(interp, "wrong # args", TCL_STATIC); - 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; - } - Tcl_SetResult(interp, Tcl_DStringValue(&dstring), TCL_VOLATILE); - } else if (strcmp(argv[1], "gresult") == 0) { - if (argc != 3) { - goto wrongNumArgs; - } - if (strcmp(argv[2], "staticsmall") == 0) { - Tcl_SetResult(interp, "short", TCL_STATIC); - } else if (strcmp(argv[2], "staticlarge") == 0) { - Tcl_SetResult(interp, "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", TCL_STATIC); - } else if (strcmp(argv[2], "free") == 0) { - Tcl_SetResult(interp, (char *) ckalloc(100), 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) { - char buf[30]; - - if (argc != 2) { - goto wrongNumArgs; - } - sprintf(buf, "%d", Tcl_DStringLength(&dstring)); - Tcl_SetResult(interp, buf, TCL_VOLATILE); - } 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)); -} - -/* - *---------------------------------------------------------------------- - * - * TestexprlongCmd -- - * - * This procedure verifies that Tcl_ExprLong does not modify the - * interpreter result if there is no error. - * - * Results: - * A standard Tcl result. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -static int -TestexprlongCmd(clientData, interp, argc, argv) - ClientData clientData; /* Not used. */ - Tcl_Interp *interp; /* Current interpreter. */ - int argc; /* Number of arguments. */ - char **argv; /* Argument strings. */ -{ - long exprResult; - char buf[30]; - int result; - - Tcl_SetResult(interp, "This is a result", TCL_STATIC); - result = Tcl_ExprLong(interp, "4+1", &exprResult); - if (result != TCL_OK) { - return result; - } - sprintf(buf, ": %ld", exprResult); - Tcl_AppendResult(interp, buf, NULL); - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * - * TestexprstringCmd -- - * - * This procedure tests the basic operation of Tcl_ExprString. - * - * Results: - * A standard Tcl result. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -static int -TestexprstringCmd(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], - " expression\"", (char *) NULL); - return TCL_ERROR; - } - return Tcl_ExprString(interp, argv[1]); -} - -/* - *---------------------------------------------------------------------- - * - * 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((Tcl_Interp *) NULL, 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; -} - -/* - *---------------------------------------------------------------------- - * - * TestMathFunc2 -- - * - * This is a user-defined math procedure to test out math procedures - * that do have arguments, in this case 2. - * - * Results: - * A normal Tcl completion code. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - - /* ARGSUSED */ -static int -TestMathFunc2(clientData, interp, args, resultPtr) - ClientData clientData; /* Integer value to return. */ - Tcl_Interp *interp; /* Used to report errors. */ - Tcl_Value *args; /* Points to an array of two - * Tcl_Values for the two - * arguments. */ - Tcl_Value *resultPtr; /* Where to store the result. */ -{ - int result = TCL_OK; - - /* - * Return the maximum of the two arguments with the correct type. - */ - - if (args[0].type == TCL_INT) { - int i0 = args[0].intValue; - - if (args[1].type == TCL_INT) { - int i1 = args[1].intValue; - - resultPtr->type = TCL_INT; - resultPtr->intValue = ((i0 > i1)? i0 : i1); - } else if (args[1].type == TCL_DOUBLE) { - double d0 = i0; - double d1 = args[1].doubleValue; - - resultPtr->type = TCL_DOUBLE; - resultPtr->doubleValue = ((d0 > d1)? d0 : d1); - } else { - Tcl_SetResult(interp, "T2: wrong type for arg 2", TCL_STATIC); - result = TCL_ERROR; - } - } else if (args[0].type == TCL_DOUBLE) { - double d0 = args[0].doubleValue; - - if (args[1].type == TCL_INT) { - double d1 = args[1].intValue; - - resultPtr->type = TCL_DOUBLE; - resultPtr->doubleValue = ((d0 > d1)? d0 : d1); - } else if (args[1].type == TCL_DOUBLE) { - double d1 = args[1].doubleValue; - - resultPtr->type = TCL_DOUBLE; - resultPtr->doubleValue = ((d0 > d1)? d0 : d1); - } else { - Tcl_SetResult(interp, "T2: wrong type for arg 2", TCL_STATIC); - result = TCL_ERROR; - } - } else { - Tcl_SetResult(interp, "T2: wrong type for arg 1", TCL_STATIC); - result = TCL_ERROR; - } - return result; -} - -/* - *---------------------------------------------------------------------- - * - * 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); -} - -/* - *---------------------------------------------------------------------- - * - * 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; - char *oldData; - Tcl_InterpDeleteProc *procPtr; - - 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]); - - /* - * If we previously associated a malloced value with the variable, - * free it before associating a new value. - */ - - oldData = (char *) Tcl_GetAssocData(interp, argv[1], &procPtr); - if ((oldData != NULL) && (procPtr == CleanupTestSetassocdataTests)) { - ckfree(oldData); - } - - 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; -} - -/* - *---------------------------------------------------------------------- - * - * TestsetrecursionlimitCmd -- - * - * This procedure implements the "testsetrecursionlimit" command. It is - * used to change the interp recursion limit (to test the effects - * of Tcl_SetRecursionLimit). - * - * Results: - * A standard Tcl result. - * - * Side effects: - * Sets the interp's recursion limit. - * - *---------------------------------------------------------------------- - */ - -static int -TestsetrecursionlimitCmd(dummy, interp, objc, objv) - ClientData dummy; /* Not used. */ - Tcl_Interp *interp; /* Current interpreter. */ - int objc; /* Number of arguments. */ - Tcl_Obj *CONST objv[]; /* The argument objects. */ -{ - int value; - - if (objc != 2) { - Tcl_WrongNumArgs(interp, 1, objv, "integer"); - return TCL_ERROR; - } - if (Tcl_GetIntFromObj(interp, objv[1], &value) != TCL_OK) { - return TCL_ERROR; - } - value = Tcl_SetRecursionLimit(interp, value); - Tcl_SetIntObj(Tcl_GetObjResult(interp), value); - return TCL_OK; -} - - - -/* - *---------------------------------------------------------------------- - * - * 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. */ -{ - int flags = 0; - - 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) { - if (strcmp(argv[4], "global") == 0) { - flags = TCL_GLOBAL_ONLY; - } else if (strcmp(argv[4], "namespace") == 0) { - flags = TCL_NAMESPACE_ONLY; - } - return Tcl_UpVar(interp, argv[1], argv[2], argv[3], flags); - } else { - if (strcmp(argv[5], "global") == 0) { - flags = TCL_GLOBAL_ONLY; - } else if (strcmp(argv[5], "namespace") == 0) { - flags = TCL_NAMESPACE_ONLY; - } - return Tcl_UpVar2(interp, argv[1], argv[2], - (argv[3][0] == 0) ? (char *) NULL : argv[3], argv[4], - flags); - } -} - -/* - *---------------------------------------------------------------------- - * - * TestwordendCmd -- - * - * This procedure implements the "testwordend" command. It is used - * to test TclWordEnd. - * - * Results: - * A standard Tcl result. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - - /* ARGSUSED */ -static int -TestwordendObjCmd(dummy, interp, objc, objv) - ClientData dummy; /* Not used. */ - Tcl_Interp *interp; /* Current interpreter. */ - int objc; /* Number of arguments. */ - Tcl_Obj *CONST objv[]; /* The argument objects. */ -{ - Tcl_Obj *objPtr; - char *string, *end; - int length; - - if (objc != 2) { - Tcl_WrongNumArgs(interp, 1, objv, "string"); - return TCL_ERROR; - } - objPtr = Tcl_GetObjResult(interp); - string = Tcl_GetStringFromObj(objv[1], &length); - end = TclWordEnd(string, string+length, 0, NULL); - Tcl_AppendToObj(objPtr, end, length - (end - string)); - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * - * TestsetobjerrorcodeCmd -- - * - * This procedure implements the "testsetobjerrorcodeCmd". - * This tests up to five elements passed to the - * Tcl_SetObjErrorCode command. - * - * Results: - * A standard Tcl result. Always returns TCL_ERROR so that - * the error code can be tested. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - - /* ARGSUSED */ -static int -TestsetobjerrorcodeCmd(dummy, interp, objc, objv) - ClientData dummy; /* Not used. */ - Tcl_Interp *interp; /* Current interpreter. */ - int objc; /* Number of arguments. */ - Tcl_Obj *CONST objv[]; /* The argument objects. */ -{ - Tcl_Obj *listObjPtr; - - if (objc > 1) { - listObjPtr = Tcl_ConcatObj(objc - 1, objv + 1); - } else { - listObjPtr = Tcl_NewObj(); - } - Tcl_IncrRefCount(listObjPtr); - Tcl_SetObjErrorCode(interp, listObjPtr); - Tcl_DecrRefCount(listObjPtr); - return TCL_ERROR; -} - -/* - *---------------------------------------------------------------------- - * - * 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; -} - -/* - *--------------------------------------------------------------------------- - * - * TestchmodCmd -- - * - * Implements the "testchmod" cmd. Used when testing "file" - * command. The only attribute used by the Mac and Windows platforms - * is the user write flag; if this is not set, the file is - * made read-only. Otehrwise, the file is made read-write. - * - * Results: - * A standard Tcl result. - * - * Side effects: - * Changes permissions of specified files. - * - *--------------------------------------------------------------------------- - */ - -static int -TestchmodCmd(dummy, interp, argc, argv) - ClientData dummy; /* Not used. */ - Tcl_Interp *interp; /* Current interpreter. */ - int argc; /* Number of arguments. */ - char **argv; /* Argument strings. */ -{ - int i, mode; - char *rest; - - if (argc < 2) { - usage: - Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], - " mode file ?file ...?", (char *) NULL); - return TCL_ERROR; - } - - mode = (int) strtol(argv[1], &rest, 8); - if ((rest == argv[1]) || (*rest != '\0')) { - goto usage; - } - - for (i = 2; i < argc; i++) { - Tcl_DString buffer; - - argv[i] = Tcl_TranslateFileName(interp, argv[i], &buffer); - if (argv[i] == NULL) { - return TCL_ERROR; - } - if (chmod(argv[i], (unsigned) mode) != 0) { - Tcl_AppendResult(interp, argv[i], ": ", Tcl_PosixError(interp), - (char *) NULL); - return TCL_ERROR; - } - Tcl_DStringFree(&buffer); - } - return TCL_OK; -} - -static int -TestfileCmd(dummy, interp, argc, argv) - ClientData dummy; /* Not used. */ - Tcl_Interp *interp; /* Current interpreter. */ - int argc; /* Number of arguments. */ - char **argv; /* Argument strings. */ -{ - int force, i, j, result; - Tcl_DString error, name[2]; - - if (argc < 3) { - return TCL_ERROR; - } - - force = 0; - i = 2; - if (strcmp(argv[2], "-force") == 0) { - force = 1; - i = 3; - } - - Tcl_DStringInit(&name[0]); - Tcl_DStringInit(&name[1]); - Tcl_DStringInit(&error); - - if (argc - i > 2) { - return TCL_ERROR; - } - - for (j = i; j < argc; j++) { - argv[j] = Tcl_TranslateFileName(interp, argv[j], &name[j - i]); - if (argv[j] == NULL) { - return TCL_ERROR; - } - } - - if (strcmp(argv[1], "mv") == 0) { - result = TclpRenameFile(argv[i], argv[i + 1]); - } else if (strcmp(argv[1], "cp") == 0) { - result = TclpCopyFile(argv[i], argv[i + 1]); - } else if (strcmp(argv[1], "rm") == 0) { - result = TclpDeleteFile(argv[i]); - } else if (strcmp(argv[1], "mkdir") == 0) { - result = TclpCreateDirectory(argv[i]); - } else if (strcmp(argv[1], "cpdir") == 0) { - result = TclpCopyDirectory(argv[i], argv[i + 1], &error); - } else if (strcmp(argv[1], "rmdir") == 0) { - result = TclpRemoveDirectory(argv[i], force, &error); - } else { - result = TCL_ERROR; - goto end; - } - - if (result != TCL_OK) { - if (Tcl_DStringValue(&error)[0] != '\0') { - Tcl_AppendResult(interp, Tcl_DStringValue(&error), " ", NULL); - } - Tcl_AppendResult(interp, Tcl_ErrnoId(), (char *) NULL); - } - - end: - Tcl_DStringFree(&error); - Tcl_DStringFree(&name[0]); - Tcl_DStringFree(&name[1]); - - return result; -} - -/* - *---------------------------------------------------------------------- - * - * TestgetvarfullnameCmd -- - * - * Implements the "testgetvarfullname" cmd that is used when testing - * the Tcl_GetVariableFullName procedure. - * - * Results: - * A standard Tcl result. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -static int -TestgetvarfullnameCmd(dummy, interp, objc, objv) - ClientData dummy; /* Not used. */ - Tcl_Interp *interp; /* Current interpreter. */ - int objc; /* Number of arguments. */ - Tcl_Obj *CONST objv[]; /* The argument objects. */ -{ - char *name, *arg; - int flags = 0; - Tcl_Namespace *namespacePtr; - Tcl_CallFrame frame; - Tcl_Var variable; - int result; - - if (objc != 3) { - Tcl_WrongNumArgs(interp, 1, objv, "name scope"); - return TCL_ERROR; - } - - name = Tcl_GetStringFromObj(objv[1], (int *) NULL); - - arg = Tcl_GetStringFromObj(objv[2], (int *) NULL); - if (strcmp(arg, "global") == 0) { - flags = TCL_GLOBAL_ONLY; - } else if (strcmp(arg, "namespace") == 0) { - flags = TCL_NAMESPACE_ONLY; - } - - /* - * This command, like any other created with Tcl_Create[Obj]Command, - * runs in the global namespace. As a "namespace-aware" command that - * needs to run in a particular namespace, it must activate that - * namespace itself. - */ - - if (flags == TCL_NAMESPACE_ONLY) { - namespacePtr = Tcl_FindNamespace(interp, "::test_ns_var", - (Tcl_Namespace *) NULL, TCL_LEAVE_ERR_MSG); - if (namespacePtr == NULL) { - return TCL_ERROR; - } - result = Tcl_PushCallFrame(interp, &frame, namespacePtr, - /*isProcCallFrame*/ 0); - if (result != TCL_OK) { - return result; - } - } - - variable = Tcl_FindNamespaceVar(interp, name, (Tcl_Namespace *) NULL, - (flags | TCL_LEAVE_ERR_MSG)); - - if (flags == TCL_NAMESPACE_ONLY) { - Tcl_PopCallFrame(interp); - } - if (variable == (Tcl_Var) NULL) { - return TCL_ERROR; - } - Tcl_GetVariableFullName(interp, variable, Tcl_GetObjResult(interp)); - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * - * GetTimesCmd -- - * - * This procedure implements the "gettimes" command. It is - * used for computing the time needed for various basic operations - * such as reading variables, allocating memory, sprintf, converting - * variables, etc. - * - * Results: - * A standard Tcl result. - * - * Side effects: - * Allocates and frees memory, sets a variable "a" in the interpreter. - * - *---------------------------------------------------------------------- - */ - -static int -GetTimesCmd(unused, interp, argc, argv) - ClientData unused; /* Unused. */ - Tcl_Interp *interp; /* The current interpreter. */ - int argc; /* The number of arguments. */ - char **argv; /* The argument strings. */ -{ - Interp *iPtr = (Interp *) interp; - int i, n; - double timePer; - Tcl_Time start, stop; - Tcl_Obj *objPtr; - Tcl_Obj **objv; - char *s; - char newString[30]; - - /* alloc & free 100000 times */ - fprintf(stderr, "alloc & free 100000 6 word items\n"); - TclpGetTime(&start); - for (i = 0; i < 100000; i++) { - objPtr = (Tcl_Obj *) ckalloc(sizeof(Tcl_Obj)); - ckfree((char *) objPtr); - } - TclpGetTime(&stop); - timePer = (stop.sec - start.sec)*1000000 + (stop.usec - start.usec); - fprintf(stderr, " %.3f usec per alloc+free\n", timePer/100000); - - /* alloc 5000 times */ - fprintf(stderr, "alloc 5000 6 word items\n"); - objv = (Tcl_Obj **) ckalloc(5000 * sizeof(Tcl_Obj *)); - TclpGetTime(&start); - for (i = 0; i < 5000; i++) { - objv[i] = (Tcl_Obj *) ckalloc(sizeof(Tcl_Obj)); - } - TclpGetTime(&stop); - timePer = (stop.sec - start.sec)*1000000 + (stop.usec - start.usec); - fprintf(stderr, " %.3f usec per alloc\n", timePer/5000); - - /* free 5000 times */ - fprintf(stderr, "free 5000 6 word items\n"); - TclpGetTime(&start); - for (i = 0; i < 5000; i++) { - ckfree((char *) objv[i]); - } - TclpGetTime(&stop); - timePer = (stop.sec - start.sec)*1000000 + (stop.usec - start.usec); - fprintf(stderr, " %.3f usec per free\n", timePer/5000); - - /* Tcl_NewObj 5000 times */ - fprintf(stderr, "Tcl_NewObj 5000 times\n"); - TclpGetTime(&start); - for (i = 0; i < 5000; i++) { - objv[i] = Tcl_NewObj(); - } - TclpGetTime(&stop); - timePer = (stop.sec - start.sec)*1000000 + (stop.usec - start.usec); - fprintf(stderr, " %.3f usec per Tcl_NewObj\n", timePer/5000); - - /* Tcl_DecrRefCount 5000 times */ - fprintf(stderr, "Tcl_DecrRefCount 5000 times\n"); - TclpGetTime(&start); - for (i = 0; i < 5000; i++) { - objPtr = objv[i]; - Tcl_DecrRefCount(objPtr); - } - TclpGetTime(&stop); - timePer = (stop.sec - start.sec)*1000000 + (stop.usec - start.usec); - fprintf(stderr, " %.3f usec per Tcl_DecrRefCount\n", timePer/5000); - ckfree((char *) objv); - - /* TclGetStringFromObj 100000 times */ - fprintf(stderr, "TclGetStringFromObj of \"12345\" 100000 times\n"); - objPtr = Tcl_NewStringObj("12345", -1); - TclpGetTime(&start); - for (i = 0; i < 100000; i++) { - (void) TclGetStringFromObj(objPtr, &n); - } - TclpGetTime(&stop); - timePer = (stop.sec - start.sec)*1000000 + (stop.usec - start.usec); - fprintf(stderr, " %.3f usec per TclGetStringFromObj of \"12345\"\n", - timePer/100000); - - /* Tcl_GetIntFromObj 100000 times */ - fprintf(stderr, "Tcl_GetIntFromObj of \"12345\" 100000 times\n"); - TclpGetTime(&start); - for (i = 0; i < 100000; i++) { - if (Tcl_GetIntFromObj(interp, objPtr, &n) != TCL_OK) { - return TCL_ERROR; - } - } - TclpGetTime(&stop); - timePer = (stop.sec - start.sec)*1000000 + (stop.usec - start.usec); - fprintf(stderr, " %.3f usec per Tcl_GetIntFromObj of \"12345\"\n", - timePer/100000); - Tcl_DecrRefCount(objPtr); - - /* Tcl_GetInt 100000 times */ - fprintf(stderr, "Tcl_GetInt of \"12345\" 100000 times\n"); - TclpGetTime(&start); - for (i = 0; i < 100000; i++) { - if (Tcl_GetInt(interp, "12345", &n) != TCL_OK) { - return TCL_ERROR; - } - } - TclpGetTime(&stop); - timePer = (stop.sec - start.sec)*1000000 + (stop.usec - start.usec); - fprintf(stderr, " %.3f usec per Tcl_GetInt of \"12345\"\n", - timePer/100000); - - /* sprintf 100000 times */ - fprintf(stderr, "sprintf of 12345 100000 times\n"); - TclpGetTime(&start); - for (i = 0; i < 100000; i++) { - sprintf(newString, "%d", 12345); - } - TclpGetTime(&stop); - timePer = (stop.sec - start.sec)*1000000 + (stop.usec - start.usec); - fprintf(stderr, " %.3f usec per sprintf of 12345\n", - timePer/100000); - - /* hashtable lookup 100000 times */ - fprintf(stderr, "hashtable lookup of \"gettimes\" 100000 times\n"); - TclpGetTime(&start); - for (i = 0; i < 100000; i++) { - (void) Tcl_FindHashEntry(&iPtr->globalNsPtr->cmdTable, "gettimes"); - } - TclpGetTime(&stop); - timePer = (stop.sec - start.sec)*1000000 + (stop.usec - start.usec); - fprintf(stderr, " %.3f usec per hashtable lookup of \"gettimes\"\n", - timePer/100000); - - /* Tcl_SetVar 100000 times */ - fprintf(stderr, "Tcl_SetVar of \"12345\" 100000 times\n"); - TclpGetTime(&start); - for (i = 0; i < 100000; i++) { - s = Tcl_SetVar(interp, "a", "12345", TCL_LEAVE_ERR_MSG); - if (s == NULL) { - return TCL_ERROR; - } - } - TclpGetTime(&stop); - timePer = (stop.sec - start.sec)*1000000 + (stop.usec - start.usec); - fprintf(stderr, " %.3f usec per Tcl_SetVar of a to \"12345\"\n", - timePer/100000); - - /* Tcl_GetVar 100000 times */ - fprintf(stderr, "Tcl_GetVar of a==\"12345\" 100000 times\n"); - TclpGetTime(&start); - for (i = 0; i < 100000; i++) { - s = Tcl_GetVar(interp, "a", TCL_LEAVE_ERR_MSG); - if (s == NULL) { - return TCL_ERROR; - } - } - TclpGetTime(&stop); - timePer = (stop.sec - start.sec)*1000000 + (stop.usec - start.usec); - fprintf(stderr, " %.3f usec per Tcl_GetVar of a==\"12345\"\n", - timePer/100000); - - Tcl_ResetResult(interp); - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * - * NoopCmd -- - * - * This procedure is just used to time the overhead involved in - * parsing and invoking a command. - * - * Results: - * None. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -static int -NoopCmd(unused, interp, argc, argv) - ClientData unused; /* Unused. */ - Tcl_Interp *interp; /* The current interpreter. */ - int argc; /* The number of arguments. */ - char **argv; /* The argument strings. */ -{ - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * - * NoopObjCmd -- - * - * This object-based procedure is just used to time the overhead - * involved in parsing and invoking a command. - * - * Results: - * Returns the TCL_OK result code. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -static int -NoopObjCmd(unused, interp, objc, objv) - ClientData unused; /* Not used. */ - Tcl_Interp *interp; /* Current interpreter. */ - int objc; /* Number of arguments. */ - Tcl_Obj *CONST objv[]; /* The argument objects. */ -{ - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * - * TestsetCmd -- - * - * Implements the "testset{err,noerr}" cmds that are used when testing - * Tcl_Set/GetVar C Api with/without TCL_LEAVE_ERR_MSG flag - * - * Results: - * A standard Tcl result. - * - * Side effects: - * Variables may be set. - * - *---------------------------------------------------------------------- - */ - - /* ARGSUSED */ -TestsetCmd(data, interp, argc, argv) - ClientData data; /* Additional flags for Get/SetVar2. */ - register Tcl_Interp *interp; /* Current interpreter. */ - int argc; /* Number of arguments. */ - char **argv; /* Argument strings. */ -{ - int flags = (int) data; - char *value; - - if (argc == 2) { - Tcl_SetResult(interp, "before get", TCL_STATIC); - value = Tcl_GetVar2(interp, argv[1], (char *) NULL, - TCL_PARSE_PART1|flags); - if (value == NULL) { - return TCL_ERROR; - } - Tcl_AppendElement(interp, value); - return TCL_OK; - } else if (argc == 3) { - Tcl_SetResult(interp, "before set", TCL_STATIC); - value = Tcl_SetVar2(interp, argv[1], (char *) NULL, argv[2], - TCL_PARSE_PART1|flags); - if (value == NULL) { - return TCL_ERROR; - } - Tcl_AppendElement(interp, value); - return TCL_OK; - } else { - Tcl_AppendResult(interp, "wrong # args: should be \"", - argv[0], " varName ?newValue?\"", (char *) NULL); - return TCL_ERROR; - } -} - -/* - *---------------------------------------------------------------------- - * - * TeststatprocCmd -- - * - * Implements the "testTclStatProc" cmd that is used to test the - * 'TclStatInsertProc' & 'TclStatDeleteProc' C Apis. - * - * Results: - * A standard Tcl result. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -static int -TeststatprocCmd (dummy, interp, argc, argv) - ClientData dummy; /* Not used. */ - register Tcl_Interp *interp; /* Current interpreter. */ - int argc; /* Number of arguments. */ - char **argv; /* Argument strings. */ -{ - TclStatProc_ *proc; - int retVal; - - if (argc != 3) { - Tcl_AppendResult(interp, "wrong # args: should be \"", - argv[0], " option arg\"", (char *) NULL); - return TCL_ERROR; - } - - if (strcmp(argv[2], "TclpStat") == 0) { - proc = TclpStat; - } else if (strcmp(argv[2], "TestStatProc1") == 0) { - proc = TestStatProc1; - } else if (strcmp(argv[2], "TestStatProc2") == 0) { - proc = TestStatProc2; - } else if (strcmp(argv[2], "TestStatProc3") == 0) { - proc = TestStatProc3; - } else { - Tcl_AppendResult(interp, "bad arg \"", argv[1], "\": ", - "must be TclpStat, ", - "TestStatProc1, TestStatProc2, or TestStatProc3", - (char *) NULL); - return TCL_ERROR; - } - - if (strcmp(argv[1], "insert") == 0) { - if (proc == TclpStat) { - Tcl_AppendResult(interp, "bad arg \"", argv[1], "\": ", - "must be ", - "TestStatProc1, TestStatProc2, or TestStatProc3", - (char *) NULL); - return TCL_ERROR; - } - retVal = TclStatInsertProc(proc); - } else if (strcmp(argv[1], "delete") == 0) { - retVal = TclStatDeleteProc(proc); - } else { - Tcl_AppendResult(interp, "bad option \"", argv[1], "\": ", - "must be insert or delete", (char *) NULL); - return TCL_ERROR; - } - - if (retVal == TCL_ERROR) { - Tcl_AppendResult(interp, "\"", argv[2], "\": ", - "could not be ", argv[1], "ed", (char *) NULL); - } - - return retVal; -} - -/* Be careful in the compares in these tests, since the Macintosh puts a - * leading : in the beginning of non-absolute paths before passing them - * into the file command procedures. - */ - -static int -TestStatProc1(path, buf) - CONST char *path; - TclStat_ *buf; -{ - buf->st_size = 1234; - return ((strstr(path, "testStat1%.fil") == NULL) ? -1 : 0); -} - - -static int -TestStatProc2(path, buf) - CONST char *path; - TclStat_ *buf; -{ - buf->st_size = 2345; - return ((strstr(path, "testStat2%.fil") == NULL) ? -1 : 0); -} - - -static int -TestStatProc3(path, buf) - CONST char *path; - TclStat_ *buf; -{ - buf->st_size = 3456; - return ((strstr(path, "testStat3%.fil") == NULL) ? -1 : 0); -} - -/* - *---------------------------------------------------------------------- - * - * TestaccessprocCmd -- - * - * Implements the "testTclAccessProc" cmd that is used to test the - * 'TclAccessInsertProc' & 'TclAccessDeleteProc' C Apis. - * - * Results: - * A standard Tcl result. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -static int -TestaccessprocCmd (dummy, interp, argc, argv) - ClientData dummy; /* Not used. */ - register Tcl_Interp *interp; /* Current interpreter. */ - int argc; /* Number of arguments. */ - char **argv; /* Argument strings. */ -{ - TclAccessProc_ *proc; - int retVal; - - if (argc != 3) { - Tcl_AppendResult(interp, "wrong # args: should be \"", - argv[0], " option arg\"", (char *) NULL); - return TCL_ERROR; - } - - if (strcmp(argv[2], "TclpAccess") == 0) { - proc = TclpAccess; - } else if (strcmp(argv[2], "TestAccessProc1") == 0) { - proc = TestAccessProc1; - } else if (strcmp(argv[2], "TestAccessProc2") == 0) { - proc = TestAccessProc2; - } else if (strcmp(argv[2], "TestAccessProc3") == 0) { - proc = TestAccessProc3; - } else { - Tcl_AppendResult(interp, "bad arg \"", argv[1], "\": ", - "must be TclpAccess, ", - "TestAccessProc1, TestAccessProc2, or TestAccessProc3", - (char *) NULL); - return TCL_ERROR; - } - - if (strcmp(argv[1], "insert") == 0) { - if (proc == TclpAccess) { - Tcl_AppendResult(interp, "bad arg \"", argv[1], "\": ", - "must be ", - "TestAccessProc1, TestAccessProc2, or TestAccessProc3", - (char *) NULL); - return TCL_ERROR; - } - retVal = TclAccessInsertProc(proc); - } else if (strcmp(argv[1], "delete") == 0) { - retVal = TclAccessDeleteProc(proc); - } else { - Tcl_AppendResult(interp, "bad option \"", argv[1], "\": ", - "must be insert or delete", (char *) NULL); - return TCL_ERROR; - } - - if (retVal == TCL_ERROR) { - Tcl_AppendResult(interp, "\"", argv[2], "\": ", - "could not be ", argv[1], "ed", (char *) NULL); - } - - return retVal; -} - - -static int -TestAccessProc1(path, mode) - CONST char *path; - int mode; -{ - return ((strstr(path, "testAccess1%.fil") == NULL) ? -1 : 0); -} - - -static int -TestAccessProc2(path, mode) - CONST char *path; - int mode; -{ - return ((strstr(path, "testAccess2%.fil") == NULL) ? -1 : 0); -} - - -static int -TestAccessProc3(path, mode) - CONST char *path; - int mode; -{ - return ((strstr(path, "testAccess3%.fil") == NULL) ? -1 : 0); -} - -/* - *---------------------------------------------------------------------- - * - * TestopenfilechannelprocCmd -- - * - * Implements the "testTclOpenFileChannelProc" cmd that is used to test the - * 'TclOpenFileChannelInsertProc' & 'TclOpenFileChannelDeleteProc' C Apis. - * - * Results: - * A standard Tcl result. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -static int -TestopenfilechannelprocCmd (dummy, interp, argc, argv) - ClientData dummy; /* Not used. */ - register Tcl_Interp *interp; /* Current interpreter. */ - int argc; /* Number of arguments. */ - char **argv; /* Argument strings. */ -{ - TclOpenFileChannelProc_ *proc; - int retVal; - - if (argc != 3) { - Tcl_AppendResult(interp, "wrong # args: should be \"", - argv[0], " option arg\"", (char *) NULL); - return TCL_ERROR; - } - - if (strcmp(argv[2], "TclpOpenFileChannel") == 0) { - proc = TclpOpenFileChannel; - } else if (strcmp(argv[2], "TestOpenFileChannelProc1") == 0) { - proc = TestOpenFileChannelProc1; - } else if (strcmp(argv[2], "TestOpenFileChannelProc2") == 0) { - proc = TestOpenFileChannelProc2; - } else if (strcmp(argv[2], "TestOpenFileChannelProc3") == 0) { - proc = TestOpenFileChannelProc3; - } else { - Tcl_AppendResult(interp, "bad arg \"", argv[1], "\": ", - "must be TclpOpenFileChannel, ", - "TestOpenFileChannelProc1, TestOpenFileChannelProc2, or ", - "TestOpenFileChannelProc3", - (char *) NULL); - return TCL_ERROR; - } - - if (strcmp(argv[1], "insert") == 0) { - if (proc == TclpOpenFileChannel) { - Tcl_AppendResult(interp, "bad arg \"", argv[1], "\": ", - "must be ", - "TestOpenFileChannelProc1, TestOpenFileChannelProc2, or ", - "TestOpenFileChannelProc3", - (char *) NULL); - return TCL_ERROR; - } - retVal = TclOpenFileChannelInsertProc(proc); - } else if (strcmp(argv[1], "delete") == 0) { - retVal = TclOpenFileChannelDeleteProc(proc); - } else { - Tcl_AppendResult(interp, "bad option \"", argv[1], "\": ", - "must be insert or delete", (char *) NULL); - return TCL_ERROR; - } - - if (retVal == TCL_ERROR) { - Tcl_AppendResult(interp, "\"", argv[2], "\": ", - "could not be ", argv[1], "ed", (char *) NULL); - } - - return retVal; -} - - -static Tcl_Channel -TestOpenFileChannelProc1(interp, fileName, modeString, permissions) - Tcl_Interp *interp; /* Interpreter for error reporting; - * can be NULL. */ - char *fileName; /* Name of file to open. */ - char *modeString; /* A list of POSIX open modes or - * a string such as "rw". */ - int permissions; /* If the open involves creating a - * file, with what modes to create - * it? */ -{ - if (!strcmp("testOpenFileChannel1%.fil", fileName)) { - return (TclpOpenFileChannel(interp, "__testOpenFileChannel1%__.fil", - modeString, permissions)); - } else { - return (NULL); - } -} - - -static Tcl_Channel -TestOpenFileChannelProc2(interp, fileName, modeString, permissions) - Tcl_Interp *interp; /* Interpreter for error reporting; - * can be NULL. */ - char *fileName; /* Name of file to open. */ - char *modeString; /* A list of POSIX open modes or - * a string such as "rw". */ - int permissions; /* If the open involves creating a - * file, with what modes to create - * it? */ -{ - if (!strcmp("testOpenFileChannel2%.fil", fileName)) { - return (TclpOpenFileChannel(interp, "__testOpenFileChannel2%__.fil", - modeString, permissions)); - } else { - return (NULL); - } -} - - -static Tcl_Channel -TestOpenFileChannelProc3(interp, fileName, modeString, permissions) - Tcl_Interp *interp; /* Interpreter for error reporting; - * can be NULL. */ - char *fileName; /* Name of file to open. */ - char *modeString; /* A list of POSIX open modes or - * a string such as "rw". */ - int permissions; /* If the open involves creating a - * file, with what modes to create - * it? */ -{ - if (!strcmp("testOpenFileChannel3%.fil", fileName)) { - return (TclpOpenFileChannel(interp, "__testOpenFileChannel3%__.fil", - modeString, permissions)); - } else { - return (NULL); - } -} diff --git a/generic/tclUtil.c b/generic/tclUtil.c deleted file mode 100644 index bdbac1c..0000000 --- a/generic/tclUtil.c +++ /dev/null @@ -1,2843 +0,0 @@ -/* - * 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-1997 Sun Microsystems, Inc. - * - * See the file "license.terms" for information on usage and redistribution - * of this file, and for a DISCLAIMER OF ALL WARRANTIES. - * - * RCS: @(#) $Id: tclUtil.c,v 1.3 1998/09/14 18:40:02 stanton Exp $ - */ - -#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 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 - -/* - * The following values determine the precision used when converting - * floating-point values to strings. This information is linked to all - * of the tcl_precision variables in all interpreters via the procedure - * TclPrecTraceProc. - * - * NOTE: these variables are not thread-safe. - */ - -static char precisionString[10] = "12"; - /* The string value of all the tcl_precision - * variables. */ -static char precisionFormat[10] = "%.12g"; - /* The format string actually used in calls - * to sprintf. */ - - -/* - * 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 just after the last character in the - * list (i.e., at the character at list+listLength). 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 point - * just after the last character in the list. Note: this procedure does - * NOT collapse backslash sequences. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -int -TclFindElement(interp, list, listLength, elementPtr, nextPtr, sizePtr, - bracePtr) - Tcl_Interp *interp; /* Interpreter to use for error reporting. - * If NULL, then no error message is left - * after errors. */ - char *list; /* Points to the first byte of a string - * containing a Tcl list with zero or more - * elements (possibly in braces). */ - int listLength; /* Number of bytes in the list's string. */ - char **elementPtr; /* Where to put address 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 (next arg 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. */ -{ - char *p = list; - char *elemStart; /* Points to first byte of first element. */ - char *limit; /* Points just after list's last byte. */ - int openBraces = 0; /* Brace nesting level during parse. */ - int inQuotes = 0; - int size = 0; /* Init. avoids compiler warning. */ - int numChars; - char *p2; - - /* - * Skim off leading white space and check for an opening brace or - * quote. We treat embedded NULLs in the list as bytes belonging to - * a list element. 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. - */ - - limit = (list + listLength); - while ((p < limit) && (isspace(UCHAR(*p)))) { - p++; - } - if (p == limit) { /* no element found */ - elemStart = limit; - goto done; - } - - if (*p == '{') { - openBraces = 1; - p++; - } else if (*p == '"') { - inQuotes = 1; - p++; - } - elemStart = p; - if (bracePtr != 0) { - *bracePtr = openBraces; - } - - /* - * Find element's end (a space, close brace, or the end of the string). - */ - - while (p < limit) { - 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) { - openBraces--; - } else if (openBraces == 1) { - size = (p - elemStart); - p++; - if ((p >= limit) || isspace(UCHAR(*p))) { - goto done; - } - - /* - * Garbage after the closing brace; return an error. - */ - - if (interp != NULL) { - char buf[100]; - - p2 = p; - while ((p2 < limit) && (!isspace(UCHAR(*p2))) - && (p2 < p+20)) { - p2++; - } - sprintf(buf, - "list element in braces followed by \"%.*s\" instead of space", - (int) (p2-p), p); - Tcl_SetResult(interp, buf, TCL_VOLATILE); - } - return TCL_ERROR; - } - break; - - /* - * Backslash: skip over everything up to the end of the - * backslash sequence. - */ - - case '\\': { - (void) Tcl_Backslash(p, &numChars); - p += (numChars - 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 - elemStart); - goto done; - } - break; - - /* - * Double-quote: if element is in quotes then terminate it. - */ - - case '"': - if (inQuotes) { - size = (p - elemStart); - p++; - if ((p >= limit) || isspace(UCHAR(*p))) { - goto done; - } - - /* - * Garbage after the closing quote; return an error. - */ - - if (interp != NULL) { - char buf[100]; - - p2 = p; - while ((p2 < limit) && (!isspace(UCHAR(*p2))) - && (p2 < p+20)) { - p2++; - } - sprintf(buf, - "list element in quotes followed by \"%.*s\" %s", - (int) (p2-p), p, "instead of space"); - Tcl_SetResult(interp, buf, TCL_VOLATILE); - } - return TCL_ERROR; - } - break; - } - p++; - } - - - /* - * End of list: terminate element. - */ - - if (p == limit) { - 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 - elemStart); - } - - done: - while ((p < limit) && (isspace(UCHAR(*p)))) { - p++; - } - *elementPtr = elemStart; - *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 characters get copied from src to - * dst. Along the way, if backslash sequences are found outside braces, - * the backslashes are eliminated in the copy. After scanning count - * chars from source, a null character is placed at the end of dst. - * Returns the number of characters that got copied. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -int -TclCopyAndCollapse(count, src, dst) - int count; /* Number of characters to copy from src. */ - char *src; /* Copy from here... */ - char *dst; /* ... to here. */ -{ - char c; - int numRead; - int newCount = 0; - - for (c = *src; count > 0; src++, c = *src, count--) { - if (c == '\\') { - *dst = Tcl_Backslash(src, &numRead); - dst++; - src += numRead-1; - count -= numRead-1; - newCount++; - } else { - *dst = c; - dst++; - newCount++; - } - } - *dst = 0; - return newCount; -} - -/* - *---------------------------------------------------------------------- - * - * 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, 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; - char *p; - int length, 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)); - length = strlen(list); - for (i = 0, p = ((char *) argv) + size*sizeof(char *); - *list != 0; i++) { - char *prevList = list; - - result = TclFindElement(interp, list, length, &element, - &list, &elSize, &brace); - length -= (list - prevList); - 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) { - memcpy((VOID *) p, (VOID *) 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) - CONST char *string; /* String to convert to Tcl list element. */ - int *flagPtr; /* Where to store information to guide - * Tcl_ConvertCountedElement. */ -{ - return Tcl_ScanCountedElement(string, -1, flagPtr); -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_ScanCountedElement -- - * - * This procedure is a companion procedure to - * Tcl_ConvertCountedElement. 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. - * If length is -1, then the string is scanned up to the first - * null byte. - * - * Results: - * The return value is an overestimate of the number of characters - * that will be needed by Tcl_ConvertCountedElement to produce a - * valid list element from string. The word at *flagPtr is - * filled in with a value needed by Tcl_ConvertCountedElement - * when doing the actual conversion. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -int -Tcl_ScanCountedElement(string, length, flagPtr) - CONST char *string; /* String to convert to Tcl list element. */ - int length; /* Number of bytes in string, or -1. */ - int *flagPtr; /* Where to store information to guide - * Tcl_ConvertElement. */ -{ - int flags, nestingLevel; - CONST char *p, *lastChar; - - /* - * 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 any 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. - * - * Note: list elements produced by this procedure and - * Tcl_ConvertCountedElement must have the property that they can be - * enclosing in curly braces to make sub-lists. This means, for - * example, that we must not leave unmatched curly braces in the - * resulting list element. This property is necessary in order for - * procedures like Tcl_DStringStartSublist to work. - */ - - nestingLevel = 0; - flags = 0; - if (string == NULL) { - string = ""; - } - if (length == -1) { - length = strlen(string); - } - lastChar = string + length; - p = string; - if ((p == lastChar) || (*p == '{') || (*p == '"')) { - flags |= USE_BRACES; - } - for ( ; p != lastChar; 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 == lastChar) || (p[1] == '\n')) { - flags = TCL_DONT_USE_BRACES | BRACES_UNMATCHED; - } 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) - CONST char *src; /* Source information for list element. */ - char *dst; /* Place to put list-ified element. */ - int flags; /* Flags produced by Tcl_ScanElement. */ -{ - return Tcl_ConvertCountedElement(src, -1, dst, flags); -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_ConvertCountedElement -- - * - * This is a companion procedure to Tcl_ScanCountedElement. Given - * the information produced by Tcl_ScanCountedElement, 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_ConvertCountedElement(src, length, dst, flags) - CONST char *src; /* Source information for list element. */ - int length; /* Number of bytes in src, or -1. */ - char *dst; /* Place to put list-ified element. */ - int flags; /* Flags produced by Tcl_ScanElement. */ -{ - char *p = dst; - CONST char *lastChar; - - /* - * See the comment block at the beginning of the Tcl_ScanElement - * code for details of how this works. - */ - - if (src && length == -1) { - length = strlen(src); - } - if ((src == NULL) || (length == 0)) { - p[0] = '{'; - p[1] = '}'; - p[2] = 0; - return 2; - } - lastChar = src + length; - if ((flags & USE_BRACES) && !(flags & TCL_DONT_USE_BRACES)) { - *p = '{'; - p++; - for ( ; src != lastChar; 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 != lastChar; 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; - 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; - 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 < 2) || (element[length-2] != '\\')); - length--) { - /* Null loop body. */ - } - if (length == 0) { - continue; - } - memcpy((VOID *) p, (VOID *) element, (size_t) length); - p += length; - *p = ' '; - p++; - } - if (p != result) { - p[-1] = 0; - } else { - *p = 0; - } - return result; -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_ConcatObj -- - * - * Concatenate the strings from a set of objects into a single string - * object with spaces between the original strings. - * - * Results: - * The return value is a new string object containing a concatenation - * of the strings in objv. Its ref count is zero. - * - * Side effects: - * A new object is created. - * - *---------------------------------------------------------------------- - */ - -Tcl_Obj * -Tcl_ConcatObj(objc, objv) - int objc; /* Number of objects to concatenate. */ - Tcl_Obj *CONST objv[]; /* Array of objects to concatenate. */ -{ - int allocSize, finalSize, length, elemLength, i; - char *p; - char *element; - char *concatStr; - Tcl_Obj *objPtr; - - allocSize = 0; - for (i = 0; i < objc; i++) { - objPtr = objv[i]; - element = TclGetStringFromObj(objPtr, &length); - if ((element != NULL) && (length > 0)) { - allocSize += (length + 1); - } - } - if (allocSize == 0) { - allocSize = 1; /* enough for the NULL byte at end */ - } - - /* - * Allocate storage for the concatenated result. Note that allocSize - * is one more than the total number of characters, and so includes - * room for the terminating NULL byte. - */ - - concatStr = (char *) ckalloc((unsigned) allocSize); - - /* - * Now concatenate the elements. Clip white space off the front and back - * to generate a neater result, and ignore any empty elements. Also put - * a null byte at the end. - */ - - finalSize = 0; - if (objc == 0) { - *concatStr = '\0'; - } else { - p = concatStr; - for (i = 0; i < objc; i++) { - objPtr = objv[i]; - element = TclGetStringFromObj(objPtr, &elemLength); - while ((elemLength > 0) && (isspace(UCHAR(*element)))) { - element++; - elemLength--; - } - - /* - * Trim trailing white space. But, be careful not to trim - * a space character if it is preceded by a backslash: in - * this case it could be significant. - */ - - while ((elemLength > 0) - && isspace(UCHAR(element[elemLength-1])) - && ((elemLength < 2) || (element[elemLength-2] != '\\'))) { - elemLength--; - } - if (elemLength == 0) { - continue; /* nothing left of this element */ - } - memcpy((VOID *) p, (VOID *) element, (size_t) elemLength); - p += elemLength; - *p = ' '; - p++; - finalSize += (elemLength + 1); - } - if (p != concatStr) { - p[-1] = 0; - finalSize -= 1; /* we overwrote the final ' ' */ - } else { - *p = 0; - } - } - - TclNewObj(objPtr); - objPtr->bytes = concatStr; - objPtr->length = finalSize; - return objPtr; -} - -/* - *---------------------------------------------------------------------- - * - * 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) - char *string; /* String. */ - 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. Also, the object result is reset. - * - *---------------------------------------------------------------------- - */ - -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. */ -{ - 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_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); - } - } - - /* - * Reset the object result since we just set the string result. - */ - - TclResetObjResult(iPtr); -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_GetStringResult -- - * - * Returns an interpreter's result value as a string. - * - * Results: - * The interpreter's result as a string. - * - * Side effects: - * If the string result is empty, the object result is moved to the - * string result, then the object result is reset. - * - *---------------------------------------------------------------------- - */ - -char * -Tcl_GetStringResult(interp) - Tcl_Interp *interp; /* Interpreter whose result to return. */ -{ - /* - * If the string result is empty, move the object result to the - * string result, then reset the object result. - * FAILS IF OBJECT RESULT'S STRING REPRESENTATION CONTAINS NULLS. - */ - - if (*(interp->result) == 0) { - Tcl_SetResult(interp, - TclGetStringFromObj(Tcl_GetObjResult(interp), (int *) NULL), - TCL_VOLATILE); - } - return interp->result; -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_SetObjResult -- - * - * Arrange for objPtr to be an interpreter's result value. - * - * Results: - * None. - * - * Side effects: - * interp->objResultPtr is left pointing to the object referenced - * by objPtr. The object's reference count is incremented since - * there is now a new reference to it. The reference count for any - * old objResultPtr value is decremented. Also, the string result - * is reset. - * - *---------------------------------------------------------------------- - */ - -void -Tcl_SetObjResult(interp, objPtr) - Tcl_Interp *interp; /* Interpreter with which to associate the - * return object value. */ - Tcl_Obj *objPtr; /* Tcl object to be returned. If NULL, the - * obj result is made an empty string - * object. */ -{ - Interp *iPtr = (Interp *) interp; - Tcl_Obj *oldObjResult = iPtr->objResultPtr; - - iPtr->objResultPtr = objPtr; - Tcl_IncrRefCount(objPtr); /* since interp result is a reference */ - - /* - * We wait until the end to release the old object result, in case - * we are setting the result to itself. - */ - - TclDecrRefCount(oldObjResult); - - /* - * Reset the string result since we just set the result object. - */ - - if (iPtr->freeProc != NULL) { - if ((iPtr->freeProc == TCL_DYNAMIC) - || (iPtr->freeProc == (Tcl_FreeProc *) free)) { - ckfree(iPtr->result); - } else { - (*iPtr->freeProc)(iPtr->result); - } - iPtr->freeProc = 0; - } - iPtr->result = iPtr->resultSpace; - iPtr->resultSpace[0] = 0; -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_GetObjResult -- - * - * Returns an interpreter's result value as a Tcl object. The object's - * reference count is not modified; the caller must do that if it - * needs to hold on to a long-term reference to it. - * - * Results: - * The interpreter's result as an object. - * - * Side effects: - * If the interpreter has a non-empty string result, the result object - * is either empty or stale because some procedure set interp->result - * directly. If so, the string result is moved to the result object - * then the string result is reset. - * - *---------------------------------------------------------------------- - */ - -Tcl_Obj * -Tcl_GetObjResult(interp) - Tcl_Interp *interp; /* Interpreter whose result to return. */ -{ - Interp *iPtr = (Interp *) interp; - Tcl_Obj *objResultPtr; - int length; - - /* - * If the string result is non-empty, move the string result to the - * object result, then reset the string result. - */ - - if (*(iPtr->result) != 0) { - TclResetObjResult(iPtr); - - objResultPtr = iPtr->objResultPtr; - length = strlen(iPtr->result); - TclInitStringRep(objResultPtr, iPtr->result, length); - - if (iPtr->freeProc != NULL) { - if ((iPtr->freeProc == TCL_DYNAMIC) - || (iPtr->freeProc == (Tcl_FreeProc *) free)) { - ckfree(iPtr->result); - } else { - (*iPtr->freeProc)(iPtr->result); - } - iPtr->freeProc = 0; - } - iPtr->result = iPtr->resultSpace; - iPtr->resultSpace[0] = 0; - } - return iPtr->objResultPtr; -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_AppendResult -- - * - * Append a variable number of strings onto the interpreter's string - * result. - * - * Results: - * None. - * - * Side effects: - * The result of 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). - * - * If the string result is empty, the object result is moved to the - * string result, then the object result is reset. - * - *---------------------------------------------------------------------- - */ - -void -Tcl_AppendResult TCL_VARARGS_DEF(Tcl_Interp *,arg1) -{ - va_list argList; - Interp *iPtr; - char *string; - int newSpace; - - /* - * If the string result is empty, move the object result to the - * string result, then reset the object result. - * FAILS IF OBJECT RESULT'S STRING REPRESENTATION CONTAINS NULLS. - */ - - iPtr = (Interp *) TCL_VARARGS_START(Tcl_Interp *,arg1,argList); - if (*(iPtr->result) == 0) { - Tcl_SetResult((Tcl_Interp *) iPtr, - TclGetStringFromObj(Tcl_GetObjResult((Tcl_Interp *) iPtr), - (int *) NULL), - TCL_VOLATILE); - } - - /* - * Scan through all the arguments to see how much space is needed. - */ - - 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); - } - - /* - * Now 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 - * 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 " {". - * - * If the string result is empty, the object result is moved to the - * string result, then the object result is reset. - * - *---------------------------------------------------------------------- - */ - -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. */ -{ - Interp *iPtr = (Interp *) interp; - char *dst; - int size; - int flags; - - /* - * If the string result is empty, move the object result to the - * string result, then reset the object result. - * FAILS IF OBJECT RESULT'S STRING REPRESENTATION CONTAINS NULLS. - */ - - if (*(iPtr->result) == 0) { - Tcl_SetResult(interp, - TclGetStringFromObj(Tcl_GetObjResult(interp), (int *) NULL), - TCL_VOLATILE); - } - - /* - * 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, if necessary, from the interpreter's result, 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) - 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 - * 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((Tcl_Interp *) iPtr); - iPtr->result = iPtr->appendResult; -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_FreeResult -- - * - * This procedure frees up the memory associated with an interpreter's - * string result. It also resets the interpreter's result object. - * Tcl_FreeResult is most commonly used when a procedure is about to - * replace one result value with another. - * - * Results: - * None. - * - * Side effects: - * Frees the memory associated with interp's string result and sets - * interp->freeProc to zero, but does not change interp->result or - * clear error state. Resets interp's result object to an unshared - * empty object. - * - *---------------------------------------------------------------------- - */ - -void -Tcl_FreeResult(interp) - Tcl_Interp *interp; /* Interpreter for which to free result. */ -{ - Interp *iPtr = (Interp *) interp; - - if (iPtr->freeProc != NULL) { - if ((iPtr->freeProc == TCL_DYNAMIC) - || (iPtr->freeProc == (Tcl_FreeProc *) free)) { - ckfree(iPtr->result); - } else { - (*iPtr->freeProc)(iPtr->result); - } - iPtr->freeProc = 0; - } - - TclResetObjResult(iPtr); -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_ResetResult -- - * - * This procedure resets both the interpreter's string and object - * results. - * - * Results: - * None. - * - * Side effects: - * It resets the result object to an unshared empty object. It - * then restores the interpreter's string result area to its default - * initialized state, freeing up any memory that may have been - * allocated. It also clears any error information for the interpreter. - * - *---------------------------------------------------------------------- - */ - -void -Tcl_ResetResult(interp) - Tcl_Interp *interp; /* Interpreter for which to clear result. */ -{ - Interp *iPtr = (Interp *) interp; - - TclResetObjResult(iPtr); - - Tcl_FreeResult(interp); - 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; -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_SetObjErrorCode -- - * - * This procedure is called to record machine-readable information - * about an error that is about to be returned. The caller should - * build a list object up and pass it to this routine. - * - * Results: - * None. - * - * Side effects: - * The errorCode global variable is modified to be the new value. - * 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. - * - *---------------------------------------------------------------------- - */ - -void -Tcl_SetObjErrorCode(interp, errorObjPtr) - Tcl_Interp *interp; - Tcl_Obj *errorObjPtr; -{ - Tcl_Obj *namePtr; - Interp *iPtr; - - namePtr = Tcl_NewStringObj("errorCode", -1); - iPtr = (Interp *) interp; - Tcl_ObjSetVar2(interp, namePtr, (Tcl_Obj *) NULL, errorObjPtr, - TCL_GLOBAL_ONLY); - iPtr->flags |= ERROR_CODE_SET; - Tcl_DecrRefCount(namePtr); -} - -/* - *---------------------------------------------------------------------- - * - * 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. */ -{ - 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) - 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) - Tcl_DString *dsPtr; /* Structure describing dynamic string. */ - CONST 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; - CONST char *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) - Tcl_DString *dsPtr; /* Structure describing dynamic string. */ - CONST 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) - 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) - 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 string result. Afterwards, the dynamic string - * is reset to an empty string. - * - * Results: - * None. - * - * Side effects: - * The string is "moved" to interp's result, and any existing - * string result for interp is freed. 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 an interpreter's result into a dynamic string. - * - * Results: - * None. - * - * Side effects: - * The interpreter's string result is cleared, and the previous - * contents of dsPtr are freed. - * - * If the string result is empty, the object result is moved to the - * string result, then the object result is reset. - * - *---------------------------------------------------------------------- - */ - -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); - } - - /* - * If the string result is empty, move the object result to the - * string result, then reset the object result. - * FAILS IF OBJECT RESULT'S STRING REPRESENTATION CONTAINS NULLS. - */ - - if (*(iPtr->result) == 0) { - Tcl_SetResult(interp, - TclGetStringFromObj(Tcl_GetObjResult(interp), (int *) NULL), - TCL_VOLATILE); - } - - 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 used to be used to control - * printing. It's ignored now. */ - double value; /* Value to print as string. */ - char *dst; /* Where to store converted value; - * must have at least TCL_DOUBLE_SPACE - * characters. */ -{ - char *p; - - sprintf(dst, precisionFormat, 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. */ -{ - char *value, *end; - int prec; - - /* - * If the variable is unset, then recreate the trace. - */ - - if (flags & TCL_TRACE_UNSETS) { - if ((flags & TCL_TRACE_DESTROYED) && !(flags & TCL_INTERP_DESTROYED)) { - Tcl_TraceVar2(interp, name1, name2, - TCL_GLOBAL_ONLY|TCL_TRACE_READS|TCL_TRACE_WRITES - |TCL_TRACE_UNSETS, TclPrecTraceProc, clientData); - } - return (char *) NULL; - } - - /* - * When the variable is read, reset its value from our shared - * value. This is needed in case the variable was modified in - * some other interpreter so that this interpreter's value is - * out of date. - */ - - if (flags & TCL_TRACE_READS) { - Tcl_SetVar2(interp, name1, name2, precisionString, - flags & TCL_GLOBAL_ONLY); - return (char *) NULL; - } - - /* - * The variable is being written. Check the new value and disallow - * it if it isn't reasonable or if this is a safe interpreter (we - * don't want safe interpreters messing up the precision of other - * interpreters). - */ - - if (Tcl_IsSafe(interp)) { - Tcl_SetVar2(interp, name1, name2, precisionString, - flags & TCL_GLOBAL_ONLY); - return "can't modify precision from a safe interpreter"; - } - 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)) { - Tcl_SetVar2(interp, name1, name2, precisionString, - flags & TCL_GLOBAL_ONLY); - return "improper value for precision"; - } - TclFormatInt(precisionString, prec); - sprintf(precisionFormat, "%%.%dg", 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; -} - -/* - *---------------------------------------------------------------------- - * - * TclFormatInt -- - * - * This procedure formats an integer into a sequence of decimal digit - * characters in a buffer. If the integer is negative, a minus sign is - * inserted at the start of the buffer. A null character is inserted at - * the end of the formatted characters. It is the caller's - * responsibility to ensure that enough storage is available. This - * procedure has the effect of sprintf(buffer, "%d", n) but is faster. - * - * Results: - * An integer representing the number of characters formatted, not - * including the terminating \0. - * - * Side effects: - * The formatted characters are written into the storage pointer to - * by the "buffer" argument. - * - *---------------------------------------------------------------------- - */ - -int -TclFormatInt(buffer, n) - char *buffer; /* Points to the storage into which the - * formatted characters are written. */ - long n; /* The integer to format. */ -{ - long intVal; - int i; - int numFormatted, j; - char *digits = "0123456789"; - - /* - * Check first whether "n" is the maximum negative value. This is - * -2^(m-1) for an m-bit word, and has no positive equivalent; - * negating it produces the same value. - */ - - if (n == -n) { - sprintf(buffer, "%ld", n); - return strlen(buffer); - } - - /* - * Generate the characters of the result backwards in the buffer. - */ - - intVal = (n < 0? -n : n); - i = 0; - buffer[0] = '\0'; - do { - i++; - buffer[i] = digits[intVal % 10]; - intVal = intVal/10; - } while (intVal > 0); - if (n < 0) { - i++; - buffer[i] = '-'; - } - numFormatted = i; - - /* - * Now reverse the characters. - */ - - for (j = 0; j < i; j++, i--) { - char tmp = buffer[i]; - buffer[i] = buffer[j]; - buffer[j] = tmp; - } - return numFormatted; -} - -/* - *---------------------------------------------------------------------- - * - * TclLooksLikeInt -- - * - * 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. - * - *---------------------------------------------------------------------- - */ - -int -TclLooksLikeInt(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; -} - -/* - *---------------------------------------------------------------------- - * - * TclGetIntForIndex -- - * - * This procedure returns an integer corresponding to the list index - * held in a Tcl object. The Tcl object's value is expected to be - * either an integer or the string "end". - * - * Results: - * The return value is normally TCL_OK, which means that the index was - * successfully stored into the location referenced by "indexPtr". If - * the Tcl object referenced by "objPtr" has the value "end", the - * value stored is "endValue". If "objPtr"s values is not "end" and - * can not be converted to an integer, TCL_ERROR is returned and, if - * "interp" is non-NULL, an error message is left in the interpreter's - * result object. - * - * Side effects: - * The object referenced by "objPtr" might be converted to an - * integer object. - * - *---------------------------------------------------------------------- - */ - -int -TclGetIntForIndex(interp, objPtr, endValue, indexPtr) - Tcl_Interp *interp; /* Interpreter to use for error reporting. - * If NULL, then no error message is left - * after errors. */ - Tcl_Obj *objPtr; /* Points to an object containing either - * "end" or an integer. */ - int endValue; /* The value to be stored at "indexPtr" if - * "objPtr" holds "end". */ - int *indexPtr; /* Location filled in with an integer - * representing an index. */ -{ - Interp *iPtr = (Interp *) interp; - char *bytes; - int index, length, result; - - /* - * THIS FAILS IF THE INDEX OBJECT'S STRING REP CONTAINS NULLS. - */ - - if (objPtr->typePtr == &tclIntType) { - *indexPtr = (int)objPtr->internalRep.longValue; - return TCL_OK; - } - - bytes = TclGetStringFromObj(objPtr, &length); - if ((*bytes == 'e') - && (strncmp(bytes, "end", (unsigned) length) == 0)) { - index = endValue; - } else { - result = Tcl_GetIntFromObj((Tcl_Interp *) NULL, objPtr, &index); - if (result != TCL_OK) { - if (iPtr != NULL) { - Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), - "bad index \"", bytes, - "\": must be integer or \"end\"", (char *) NULL); - } - return result; - } - } - *indexPtr = index; - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_GetNameOfExecutable -- - * - * This procedure simply returns a pointer to the internal full - * path name of the executable file as computed by - * Tcl_FindExecutable. This procedure call is the C API - * equivalent to the "info nameofexecutable" command. - * - * Results: - * A pointer to the internal string or NULL if the internal full - * path name has not been computed or unknown. - * - * Side effects: - * The object referenced by "objPtr" might be converted to an - * integer object. - * - *---------------------------------------------------------------------- - */ - -CONST char * -Tcl_GetNameOfExecutable() -{ - return (tclExecutableName); -} diff --git a/mac/README b/mac/README deleted file mode 100644 index 956a0ec..0000000 --- a/mac/README +++ /dev/null @@ -1,195 +0,0 @@ -Tcl 8.0.5 for Macintosh - -by Ray Johnson -Scriptics Corporation -rjohnson@scriptics.com -with major help from -Jim Ingham -Cygnus Solutions -jingham@cygnus.com - -RCS: @(#) $Id: README,v 1.4 1999/01/04 19:25:03 rjohnson Exp $ - -1. Introduction ---------------- - -This is the README file for the Macintosh version of the Tcl -scripting language. The file consists of information specific -to the Macintosh version of Tcl. For more general information -please read the README file in the main Tcl directory. - -2. What's new? --------------- - -The main new feature is the Tcl compilier. You should certainly -notice the speed improvements. Any problems are probably -generic rather than Mac specific. If you have questions or -comments about the compilier feel free to forward them to the -author of the compilier: Brian Lewis <btlewis@eng.sun.com>. -Several things were fixed/changed since the a1 release so be -sure to check this out. - -The largest incompatible change on the Mac is the removal of the -following commands: "rm", "rmdir", "mkdir", "mv" and "cp". These -commands were never really supported and their functionality is -superceded by the file command. - -I've also added in a new "AppleScript" command. This was contributed -by Jim Ingham who is a new member of the Tcl group. It's very cool. -The command isn't actually in the core - you need to do a "package -require Tclapplescript" to get access to it. This code is officially -unsupported and will change in the next release. However, the core -functionality is there and is stable enough to use. Documentation -can be found in "AppleScript.html" in the mac subdirectory. - -The resource command has also been rewacked. You can now read and -write any Mac resource. Tcl now has the new (and VERY COOL) binary -command that will allow you to pack and unpack the resources into -useful Tcl code. We will eventually provide Tcl libraries for -accessing the most common resources. - -See the main Tcl README for other features new to Tcl 8.0. - -3. Mac specific features ------------------------- - -There are several features or enhancements in Tcl that are unique to -the Macintosh version of Tcl. Here is a list of those features and -pointers to where you can find more information about the feature. - -* The "resource" command allows you manipulate Macintosh resources. - A complete man page is available for this command. - -* The Mac version of the "source" command has an option to source from - a Macintosh resource. Check the man page from the source command - for details. - -* The only command NOT available on the Mac is the exec command. - However, we include a Mac only package called Tclapplescript that - provides access to Mac's AppleScript system. This command is still - under design & construction. Documentatin can be found in the mac - subdirectory in a file called "AppleScript.html". - -* The env variable on the Macintosh works rather differently than on - Windows or UNIX platforms. Check out the tclvars man page for - details. - -* The command "file volumes" returns the available volumes on your - Macintosh. Check out the file command for details. - -* The command "file attributes" has the Mac specific options of - -creator and -type which allow you to query and set the Macintosh - creator and type codes for Mac files. See file man page for details. - -* We have added a template for creating a Background-only Tcl application. - So you can use Tcl as a faceless server process. For more details, see - the file background.doc. - -If you are writing cross platform code but would still like to use -some of these Mac specific commands, please remember to use the -tcl_platform variable to special case your code. - -4. The Distribution -------------------- - -Macintosh Tcl is distributed in three different forms. This -should make it easier to only download what you need. The -packages are as follows: - -mactk8.0.5.sea.hqx - - This distribution is a "binary" only release. It contains an - installer program that will install a 68k, PowerPC, or Fat - version of the "Tcl Shell" and "Wish" applications. In addition, - it installs the Tcl & Tk libraries in the Extensions folder inside - your System Folder. - -mactcltk-full-8.0.5.sea.hqx - - This release contains the full release of Tcl and Tk for the - Macintosh plus the More Files packages which Macintosh Tcl and Tk - rely on. - -mactcl-source-8.0.5.sea.hqx - - This release contains the complete source for Tcl 8.0. In - addition, Metrowerks CodeWarrior libraries and project files - are included. However, you must already have the More Files - package to compile this code. - -5. Documentation ----------------- - -The "html" subdirectory contains reference documentation in -in the HTML format. You may also find these pages at: - - http://www.scriptics.com/man/tcl8.0/contents.html - -Other documentation and sample Tcl scripts can be found at -the Tcl archive site: - - ftp://ftp.neosoft.com/tcl/ - -and the Tcl resource center: - - http://www.scriptics.com/resource/ - -The internet news group comp.lang.tcl is also a valuable -source of information about Tcl. A mailing list is also -available (see below). - -6. Compiling Tcl ----------------- - -In order to compile Macintosh Tcl you must have the -following items: - - CodeWarrior Pro 2 or 3 - Mac Tcl 8.0 (source) - More Files 1.4.3 - -There are two sets of project files included with the package. The ones -we use for the release are for CodeWarrior Pro 3, and are not compatible -with CodeWarrior Gold release 11 and earlier. We have included the files -for earlier versions of CodeWarrior in the folder tcl8.0:mac:CW11 Projects, -but they are unsupported, and a little out of date. - -As of Tcl8.0p2, the code will also build under CW Pro 2. The only -change that needs to be made is that float.mac.c should be replaced by -float.c in the MacTcl MSL project file. - -However, there seems to be a bug in the CFM68K Linker in CW Pro 2, -which renders the CFM68K Version under CW Pro 2 very unstable. I am -working with MetroWerks to resolve this issue. The PPC version is -fine, as is the Traditional 68K Shell. But if you need to use the -CFM68K, then you must stay with CW Pro 1 for now. - -The project files included with the Mac Tcl source should work -fine. The only thing you may need to update are the access paths. -Unfortunantly, it's somewhat common for the project files to become -slightly corrupted. The most common problem is that the "Prefix file" -found in the "C/C++ Preference" panel is incorrect. This should be -set to MW_TclHeaderPPC, MW_TclHeader68K or MW_TclHeaderCFM68K. - -To build the fat version of TclShell, open the project file "TclShells.¼", -select the "TclShell" target, and build. All of the associated binaries will -be built automoatically. There are also targets for building static 68K -and Power PC builds, for building a CFM 68K build, and for building a -shared library Power PC only build. - -Special notes: - -* There is a small bug in More Files 1.4.3. Also you should not use - MoreFiles 1.4.4 - 1.4.6. Look in the file named morefiles.doc for - more details. - -* You may not have the libmoto library which will cause a compile - error. You don't REALLY need it - it can be removed. Look at the - file libmoto.doc for more details. - -* Check out the file bugs.doc for information about known bugs. - -If you have comments or Bug reports send them to: -Jim Ingham -jingham@cygnus.com - diff --git a/tests/README b/tests/README deleted file mode 100644 index 07915c9..0000000 --- a/tests/README +++ /dev/null @@ -1,96 +0,0 @@ -Tcl Test Suite --------------- - -RCS: @(#) $Id: README,v 1.2 1998/09/14 18:40:07 stanton Exp $ - -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/tests/env.test b/tests/env.test deleted file mode 100644 index c66812b..0000000 --- a/tests/env.test +++ /dev/null @@ -1,152 +0,0 @@ -# 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. -# -# RCS: @(#) $Id: env.test,v 1.3 1998/09/30 20:52:00 escoffon Exp $ - -if {[string compare test [info procs test]] == 1} then {source defs} - -# -# These tests will run on any platform (and indeed crashed -# on the Mac). So put them before you test for the existance -# of exec. -# -test env-1.1 {propagation of env values to child interpreters} { - catch {interp delete child} - catch {unset env(test)} - interp create child - set env(test) garbage - set return [child eval {set env(test)}] - interp delete child - unset env(test) - set return -} {garbage} -# -# This one crashed on Solaris under Tcl8.0, so we only -# want to make sure it runs. -# -test env-1.2 {lappend to env value} { - catch {unset env(test)} - set env(test) aaaaaaaaaaaaaaaa - append env(test) bbbbbbbbbbbbbb - unset env(test) -} {} -if {[info commands exec] == ""} { - puts "exec not implemented for this machine" - return -} - -if {$tcl_platform(os) == "Win32s"} { - puts "Cannot run multiple copies of tcl at the same time under Win32s" - return -} - -set f [open printenv w] -puts $f { - proc lrem {listname name} { - upvar $listname list - set i [lsearch $list $name] - if {$i >= 0} { - set list [lreplace $list $i $i] - } - return $list - } - - set names [lsort [array names env]] - if {$tcl_platform(platform) == "windows"} { - lrem names HOME - lrem names COMSPEC - lrem names ComSpec - lrem names "" - } - foreach name {TCL_LIBRARY PATH LD_LIBRARY_PATH SHLIB_PATH} { - lrem names $name - } - foreach p $names { - puts "$p=$env($p)" - } -} -close $f - -proc getenv {} { - global printenv tcltest - catch {exec $tcltest 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) -} - -# Added the following lines so that child tcltest can actually find its -# library if the initial tcltest is run from a non-standard place. -# ('saved' env vars) -foreach name {TCL_LIBRARY PATH LD_LIBRARY_PATH SHLIB_PATH} { - if {[info exists env2($name)]} { - set env($name) $env2($name); - } -} - -test env-2.1 {adding environment variables} { - getenv -} {} - -set env(NAME1) "test string" -test env-2.2 {adding environment variables} { - getenv -} {NAME1=test string} - -set env(NAME2) "more" -test env-2.3 {adding environment variables} { - getenv -} {NAME1=test string -NAME2=more} - -set env(XYZZY) "garbage" -test env-2.4 {adding environment variables} { - getenv -} {NAME1=test string -NAME2=more -XYZZY=garbage} - -set env(NAME2) "new value" -test env-3.1 {changing environment variables} { - getenv -} {NAME1=test string -NAME2=new value -XYZZY=garbage} - -unset env(NAME2) -test env-4.1 {unsetting environment variables} { - getenv -} {NAME1=test string -XYZZY=garbage} -unset env(NAME1) -test env-4.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) -} - -file delete printenv diff --git a/tests/event.test b/tests/event.test deleted file mode 100644 index 118bfc1..0000000 --- a/tests/event.test +++ /dev/null @@ -1,567 +0,0 @@ -# This file contains a collection of tests for the procedures in the file -# tclEvent.c, which includes the "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-1997 Sun Microsystems, Inc. -# -# See the file "license.terms" for information on usage and redistribution -# of this file, and for a DISCLAIMER OF ALL WARRANTIES. -# -# RCS: @(#) $Id: event.test,v 1.3 1998/09/14 18:40:08 stanton Exp $ - -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} {nonPortable} { - 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} {nonPortable} { - 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} {nonPortable} { - 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} {nonPortable} { - update - 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} {nonPortable} { - update - 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_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-5.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-6.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-7.1 {bgerror / regular} { - set errRes {} - proc bgerror {err} { - global errRes; - set errRes $err; - } - after 0 {error err1} - vwait errRes; - set errRes; -} err1 - -test event-7.2 {bgerror / accumulation} { - set errRes {} - proc bgerror {err} { - global errRes; - lappend errRes $err; - } - after 0 {error err1} - after 0 {error err2} - after 0 {error err3} - update - set errRes; -} {err1 err2 err3} - -test event-7.3 {bgerror / accumulation / break} { - set errRes {} - proc bgerror {err} { - global errRes; - lappend errRes $err; - return -code break "skip!"; - } - after 0 {error err1} - after 0 {error err2} - after 0 {error err3} - update - set errRes; -} err1 - -test event-7.4 {tkerror is nothing special anymore to tcl} { - set errRes {} - # we don't just rename bgerror to empty because it could then - # be autoloaded... - proc bgerror {err} { - global errRes; - lappend errRes "bg:$err"; - } - proc tkerror {err} { - global errRes; - lappend errRes "tk:$err"; - } - after 0 {error err1} - update - rename tkerror {} - set errRes -} bg:err1 - -# someday : add a test checking that -# when there is no bgerror, an error msg goes to stderr -# ideally one would use sub interp and transfer a fake stderr -# to it, unfortunatly the current interp tcl API does not allow -# that. the other option would be to use fork a test but it -# then becomes more a file/exec test than a bgerror test. - -# end of bgerror tests -catch {rename bgerror {}} - - -if {[info commands testexithandler] != ""} { - test event-8.1 {Tcl_CreateExitHandler procedure} {stdio} { - 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-9.1 {Tcl_DeleteExitHandler procedure} {stdio} { - 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-9.2 {Tcl_DeleteExitHandler procedure} {stdio} { - 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-9.3 {Tcl_DeleteExitHandler procedure} {stdio} { - 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-9.4 {Tcl_DeleteExitHandler procedure} {stdio} { - 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-10.1 {Tcl_Exit procedure} {stdio} { - 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-11.1 {Tcl_VwaitCmd procedure} { - list [catch {vwait} msg] $msg -} {1 {wrong # args: should be "vwait name"}} -test event-11.2 {Tcl_VwaitCmd procedure} { - list [catch {vwait a b} msg] $msg -} {1 {wrong # args: should be "vwait name"}} -test event-11.3 {Tcl_VwaitCmd procedure} { - catch {unset x} - set x 1 - list [catch {vwait x(1)} msg] $msg -} {1 {can't trace "x(1)": variable isn't array}} -test event-11.4 {Tcl_VwaitCmd procedure} { - foreach i [after info] { - after cancel $i - } - after 10; update; # On Mac make sure update won't take long - 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} - -foreach i [after info] { - after cancel $i -} - -test event-11.5 {Tcl_VwaitCmd procedure: round robin scheduling, 2 sources} {socket} { - set f1 [open test1 w] - proc accept {s args} { - puts $s foobar - close $s - } - set s1 [socket -server accept 5001] - set s2 [socket 127.0.0.1 5001] - close $s1 - set x 0 - set y 0 - set z 0 - fileevent $s2 readable { incr z } - vwait z - fileevent $f1 writable { incr x; if { $y == 3 } { set z done } } - fileevent $s2 readable { incr y; if { $x == 3 } { set z done } } - vwait z - close $f1 - close $s2 - file delete test1 test2 - list $x $y $z -} {3 3 done} -test event-11.6 {Tcl_VwaitCmd procedure: round robin scheduling, same source} { - file delete test1 test2 - set f1 [open test1 w] - set f2 [open test2 w] - set x 0 - set y 0 - set z 0 - update - fileevent $f1 writable { incr x; if { $y == 3 } { set z done } } - fileevent $f2 writable { incr y; if { $x == 3 } { set z done } } - vwait z - close $f1 - close $f2 - file delete test1 test2 - list $x $y $z -} {3 3 done} - - -test event-12.1 {Tcl_UpdateCmd procedure} { - list [catch {update a b} msg] $msg -} {1 {wrong # args: should be "update ?idletasks?"}} -test event-12.2 {Tcl_UpdateCmd procedure} { - list [catch {update bogus} msg] $msg -} {1 {bad option "bogus": must be idletasks}} -test event-12.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-12.4 {Tcl_UpdateCmd procedure} { - foreach i [after info] { - after cancel $i - } - after 10; update; # On Mac make sure update won't take long - after 200 {set x x-done} - after 600 {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-13.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-13.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-13.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-13.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-13.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-13.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-13.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}} -} - -if {[info commands testfilewait] != ""} { - test event-13.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/tests/http.test b/tests/http.test deleted file mode 100644 index c4ddbf8..0000000 --- a/tests/http.test +++ /dev/null @@ -1,417 +0,0 @@ -# Commands covered: http::config, http::geturl, http::wait, http::reset -# -# This file contains a collection of tests for the http script library. -# 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. -# -# -# RCS: @(#) $Id: http.test,v 1.3 1998/11/03 02:00:54 welch Exp $ - -if {[string compare test [info procs test]] == 1} then {source defs} - -if {[catch {package require http 2.0}]} { - if {[info exist http2]} { - catch {puts stderr "Cannot load http 2.0 package"} - return - } else { - catch {puts stderr "Running http 2.0 tests in slave interp"} - set interp [interp create http2] - $interp eval [list set http2 "running"] - $interp eval [list source [info script]] - interp delete $interp - return - } -} - -############### The httpd_ procedures implement a stub http server. ######## -proc httpd_init {{port 8015}} { - socket -server httpdAccept $port -} -proc httpd_log {args} { - global httpLog - if {[info exists httpLog] && $httpLog} { - puts stderr "httpd: [join $args { }]" - } -} -array set httpdErrors { - 204 {No Content} - 400 {Bad Request} - 404 {Not Found} - 503 {Service Unavailable} - 504 {Service Temporarily Unavailable} - } - -proc httpdError {sock code args} { - global httpdErrors - puts $sock "$code $httpdErrors($code)" - httpd_log "error: [join $args { }]" -} -proc httpdAccept {newsock ipaddr port} { - global httpd - upvar #0 httpd$newsock data - - fconfigure $newsock -blocking 0 -translation {auto crlf} - httpd_log $newsock Connect $ipaddr $port - set data(ipaddr) $ipaddr - fileevent $newsock readable [list httpdRead $newsock] -} - -# read data from a client request - -proc httpdRead { sock } { - upvar #0 httpd$sock data - - set readCount [gets $sock line] - if {![info exists data(state)]} { - if [regexp {(POST|GET|HEAD) ([^?]+)\??([^ ]*) HTTP/1.0} \ - $line x data(proto) data(url) data(query)] { - set data(state) mime - httpd_log $sock Query $line - } else { - httpdError $sock 400 - httpd_log $sock Error "bad first line:$line" - httpdSockDone $sock - } - return - } - - # string compare $readCount 0 maps -1 to -1, 0 to 0, and > 0 to 1 - - set state [string compare $readCount 0],$data(state),$data(proto) - httpd_log $sock $state - switch -- $state { - -1,mime,HEAD - - -1,mime,GET - - -1,mime,POST { - # gets would block - return - } - 0,mime,HEAD - - 0,mime,GET - - 0,query,POST { httpdRespond $sock } - 0,mime,POST { set data(state) query } - 1,mime,HEAD - - 1,mime,POST - - 1,mime,GET { - if [regexp {([^:]+):[ ]*(.*)} $line dummy key value] { - set data(mime,[string tolower $key]) $value - } - } - 1,query,POST { - append data(query) $line - httpdRespond $sock - } - default { - if [eof $sock] { - httpd_log $sock Error "unexpected eof on <$data(url)> request" - } else { - httpd_log $sock Error "unhandled state <$state> fetching <$data(url)>" - } - httpdError $sock 404 - httpdSockDone $sock - } - } -} -proc httpdSockDone { sock } { -upvar #0 httpd$sock data - unset data - close $sock -} - -# Respond to the query. - -set bindata "This is binary data\x0d\x0amore\x0dmore\x0amore\x00null" -proc httpdRespond { sock } { - global httpd bindata port - upvar #0 httpd$sock data - - if {[string match *binary* $data(url)]} { - set html "$bindata[info hostname]:$port$data(url)" - set type application/octet-stream - } else { - set type text/html - - set html "<html><head><title>HTTP/1.0 TEST</title></head><body> -<h1>Hello, World!</h1> -<h2>$data(proto) $data(url)</h2> -" - if {[info exists data(query)] && [string length $data(query)]} { - append html "<h2>Query</h2>\n<dl>\n" - foreach {key value} [split $data(query) &=] { - append html "<dt>$key<dd>$value\n" - if {[string compare $key timeout] == 0} { - # Simulate a timeout by not responding, - # but clean up our socket later. - - after 50 [list httpdSockDone $sock] - httpd_log $sock Noresponse "" - return - } - } - append html </dl>\n - } - append html </body></html> - } - - if {$data(proto) == "HEAD"} { - puts $sock "HTTP/1.0 200 OK" - } else { - puts $sock "HTTP/1.0 200 Data follows" - } - puts $sock "Date: [clock format [clock clicks]]" - puts $sock "Content-Type: $type" - puts $sock "Content-Length: [string length $html]" - puts $sock "" - if {$data(proto) != "HEAD"} { - fconfigure $sock -translation binary - puts -nonewline $sock $html - } - httpd_log $sock Done "" - httpdSockDone $sock -} -##################### end server ########################### - -set port 8010 -if [catch {httpd_init $port} listen] { - puts stderr "Cannot start http server, http test skipped" - unset port - return -} - -test http-1.1 {http::config} { - http::config -} {-accept */* -proxyfilter http::ProxyRequired -proxyhost {} -proxyport {} -useragent {Tcl http client package 2.0}} - -test http-1.2 {http::config} { - http::config -proxyfilter -} http::ProxyRequired - -test http-1.3 {http::config} { - catch {http::config -junk} -} 1 - -test http-1.4 {http::config} { - set savedconf [http::config] - http::config -proxyhost nowhere.come -proxyport 8080 -proxyfilter myFilter -useragent "Tcl Test Suite" - set x [http::config] - eval http::config $savedconf - set x -} {-accept */* -proxyfilter myFilter -proxyhost nowhere.come -proxyport 8080 -useragent {Tcl Test Suite}} - -test http-1.5 {http::config} { - catch {http::config -proxyhost {} -junk 8080} -} 1 - -test http-2.1 {http::reset} { - catch {http::reset http#1} -} 0 - -test http-3.1 {http::geturl} { - catch {http::geturl -bogus flag} -} 1 -test http-3.2 {http::geturl} { - catch {http::geturl http:junk} err - set err -} {Unsupported URL: http:junk} - -set url [info hostname]:$port -test http-3.3 {http::geturl} { - set token [http::geturl $url] - http::data $token -} "<html><head><title>HTTP/1.0 TEST</title></head><body> -<h1>Hello, World!</h1> -<h2>GET /</h2> -</body></html>" - -set tail /a/b/c -set url [info hostname]:$port/a/b/c -set binurl [info hostname]:$port/binary - -test http-3.4 {http::geturl} { - set token [http::geturl $url] - http::data $token -} "<html><head><title>HTTP/1.0 TEST</title></head><body> -<h1>Hello, World!</h1> -<h2>GET $tail</h2> -</body></html>" - -proc selfproxy {host} { - global port - return [list [info hostname] $port] -} -test http-3.5 {http::geturl} { - http::config -proxyfilter selfproxy - set token [http::geturl $url] - http::config -proxyfilter http::ProxyRequired - http::data $token -} "<html><head><title>HTTP/1.0 TEST</title></head><body> -<h1>Hello, World!</h1> -<h2>GET http://$url</h2> -</body></html>" - -test http-3.6 {http::geturl} { - http::config -proxyfilter bogus - set token [http::geturl $url] - http::config -proxyfilter http::ProxyRequired - http::data $token -} "<html><head><title>HTTP/1.0 TEST</title></head><body> -<h1>Hello, World!</h1> -<h2>GET $tail</h2> -</body></html>" - -test http-3.7 {http::geturl} { - set token [http::geturl $url -headers {Pragma no-cache}] - http::data $token -} "<html><head><title>HTTP/1.0 TEST</title></head><body> -<h1>Hello, World!</h1> -<h2>GET $tail</h2> -</body></html>" - -test http-3.8 {http::geturl} { - set token [http::geturl $url -query Name=Value&Foo=Bar] - http::data $token -} "<html><head><title>HTTP/1.0 TEST</title></head><body> -<h1>Hello, World!</h1> -<h2>POST $tail</h2> -<h2>Query</h2> -<dl> -<dt>Name<dd>Value -<dt>Foo<dd>Bar -</dl> -</body></html>" - -test http-3.9 {http::geturl} { - set token [http::geturl $url -validate 1] - http::code $token -} "HTTP/1.0 200 OK" - - -test http-4.1 {http::Event} { - set token [http::geturl $url] - upvar #0 $token data - array set meta $data(meta) - expr ($data(totalsize) == $meta(Content-Length)) -} 1 - -test http-4.2 {http::Event} { - set token [http::geturl $url] - upvar #0 $token data - array set meta $data(meta) - string compare $data(type) [string trim $meta(Content-Type)] -} 0 - -test http-4.3 {http::Event} { - set token [http::geturl $url] - http::code $token -} {HTTP/1.0 200 Data follows} - -test http-4.4 {http::Event} { - set out [open testfile w] - set token [http::geturl $url -channel $out] - close $out - set in [open testfile] - set x [read $in] - close $in - file delete testfile - set x -} "<html><head><title>HTTP/1.0 TEST</title></head><body> -<h1>Hello, World!</h1> -<h2>GET $tail</h2> -</body></html>" - -test http-4.5 {http::Event} { - set out [open testfile w] - set token [http::geturl $url -channel $out] - close $out - upvar #0 $token data - file delete testfile - expr $data(currentsize) == $data(totalsize) -} 1 - -test http-4.6 {http::Event} { - set out [open testfile w] - set token [http::geturl $binurl -channel $out] - close $out - set in [open testfile] - fconfigure $in -translation binary - set x [read $in] - close $in - file delete testfile - set x -} "$bindata$binurl" - -proc myProgress {token total current} { - global progress httpLog - if {[info exists httpLog] && $httpLog} { - puts "progress $total $current" - } - set progress [list $total $current] -} -if 0 { - # This test hangs on Windows95 because the client never gets EOF - set httpLog 1 - test http-4.6 {http::Event} { - set token [http::geturl $url -blocksize 50 -progress myProgress] - set progress - } {111 111} -} -test http-4.7 {http::Event} { - set token [http::geturl $url -progress myProgress] - set progress -} {111 111} -test http-4.8 {http::Event} { - set token [http::geturl $url] - http::status $token -} {ok} -test http-4.9 {http::Event} { - set token [http::geturl $url -progress myProgress] - http::code $token -} {HTTP/1.0 200 Data follows} -test http-4.10 {http::Event} { - set token [http::geturl $url -progress myProgress] - http::size $token -} {111} -test http-4.11 {http::Event} { - set token [http::geturl $url -timeout 1 -command {#}] - http::reset $token - http::status $token -} {reset} -test http-4.12 {http::Event} { - set token [http::geturl $url?timeout=10 -timeout 1 -command {#}] - http::wait $token - http::status $token -} {timeout} - -test http-5.1 {http::formatQuery} { - http::formatQuery name1 value1 name2 "value two" -} {name1=value1&name2=value+two} - -test http-5.2 {http::formatQuery} { - http::formatQuery name1 ~bwelch name2 \xa1\xa2\xa2 -} {name1=%7ebwelch&name2=%a1%a2%a2} - -test http-5.3 {http::formatQuery} { - http::formatQuery lines "line1\nline2\nline3" -} {lines=line1%0d%0aline2%0d%0aline3} - -test http-6.1 {http::ProxyRequired} { - http::config -proxyhost [info hostname] -proxyport $port - set token [http::geturl $url] - http::wait $token - http::config -proxyhost {} -proxyport {} - upvar #0 $token data - set data(body) -} "<html><head><title>HTTP/1.0 TEST</title></head><body> -<h1>Hello, World!</h1> -<h2>GET http://$url</h2> -</body></html>" - -unset url -unset port -close $listen diff --git a/tests/parse.test b/tests/parse.test deleted file mode 100644 index 7019b7a..0000000 --- a/tests/parse.test +++ /dev/null @@ -1,556 +0,0 @@ -# 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-1996 Sun Microsystems, Inc. -# -# See the file "license.terms" for information on usage and redistribution -# of this file, and for a DISCLAIMER OF ALL WARRANTIES. -# -# RCS: @(#) $Id: parse.test,v 1.2 1998/09/14 18:40:12 stanton Exp $ - -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 -test parse-4.4 {command substitution} { - set a 7.7 - if [catch {expr int($a)}] {set a foo} - set a -} 7.7 - -# 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 -} {quoted string doesn't terminate properly} -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 -} {quoted string doesn't terminate properly} -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 -} {argument word in braces doesn't terminate properly} -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 or close-brace} -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") - while compiling -"$x0000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000 ..." - ("eval" body line 1) - invoked from within -"eval \$x[format "%01000d" 0]("}} -test parse-9.15 {syntax errors, missplaced braces} { - catch { - proc misplaced_end_brace {} { - set what foo - set when [expr ${what}size - [set off$what]}] - } msg - set msg -} {wrong # args: should be "proc name args body"} -test parse-9.16 {syntax errors, missplaced braces} { - catch { - set a { - set what foo - set when [expr ${what}size - [set off$what]}] - } msg - set msg -} {argument word in braces doesn't terminate properly} - -# 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-10.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.4 {long values} { - set b "$a" - set b -} $a -test parse-10.5 {long values} { - set b [set a] - set b -} $a -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] - string length $b -} 214 -test parse-10.7 {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.8 {long values} { - set b -} $a -test parse-10.9 {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.10 {long values} { - set j - } $test -} -test parse-10.11 {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-13.17 {TclWordEnd procedure} { - testwordend "a\000bc" - } {c} - test parse-13.18 {TclWordEnd procedure} { - testwordend \[a\000\] - } {]} - test parse-13.19 {TclWordEnd procedure} { - testwordend \"a\000\" - } {"} - test parse-13.20 {TclWordEnd procedure} { - testwordend a{\000}b - } {b} - test parse-13.21 {TclWordEnd procedure} { - testwordend " \000b" - } {b} -} - -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/tests/pkgMkIndex.test b/tests/pkgMkIndex.test deleted file mode 100644 index 3251feb..0000000 --- a/tests/pkgMkIndex.test +++ /dev/null @@ -1,340 +0,0 @@ -# This file contains tests for the pkg_mkIndex command. -# Note that the tests are limited to Tcl scripts only, there are no shared -# libraries against which to test. -# -# Sourcing this file into Tcl runs the tests and generates output for -# errors. No output means no errors were found. -# -# Copyright (c) 1998 by Scriptics Corporation. -# All rights reserved. -# -# RCS: @(#) $Id: pkgMkIndex.test,v 1.4 1998/11/12 05:54:21 welch Exp $ - -if {[string compare test [info procs test]] == 1} then {source defs} - -# Add the pkg1 directory to auto_path, so that its packages can be found. -# packages in pkg1 are used to test indexing of packages in pkg. -# Make sure that the path to pkg1 is absolute. - -set scriptDir [file dirname [info script]] -set oldDir [pwd] -lappend auto_path [file join [pwd] $scriptDir pkg1] - -namespace eval pkgtest { - # Namespace for procs we can discard -} - -# pkgtest::parseArgs -- -# -# Parse an argument list. -# -# Arguments: -# <flags> (optional) arguments starting with a dash are collected -# as options to pkg_mkIndex and passed to pkg_mkIndex. -# dirPath the directory to index -# pattern0 pattern to index -# ... pattern to index -# patternN pattern to index -# -# Results: -# Returns a three element list: -# 0: the options -# 1: the directory to index -# 2: the patterns list - -proc pkgtest::parseArgs { args } { - set options "" - - set argc [llength $args] - for {set iarg 0} {$iarg < $argc} {incr iarg} { - set a [lindex $args $iarg] - if {[regexp {^-} $a]} { - lappend options $a - if {[string compare -load $a] == 0} { - incr iarg - lappend options [lindex $args $iarg] - } - } else { - break - } - } - - set dirPath [lindex $args $iarg] - incr iarg - set patternList [lrange $args $iarg end] - - return [list $options $dirPath $patternList] -} - -# pkgtest::parseIndex -- -# -# Loads a pkgIndex.tcl file, records all the calls to "package ifneeded". -# -# Arguments: -# filePath path to the pkgIndex.tcl file. -# -# Results: -# Returns a list, in "array set/get" format, where the keys are the package -# name and version (in the form "$name:$version"), and the values the rest -# of the command line. - -proc pkgtest::parseIndex { filePath } { - # create a slave interpreter, where we override "package ifneeded" - - set slave [interp create] - if {[catch { - $slave eval { - rename package package_original - proc package { args } { - if {[string compare [lindex $args 0] ifneeded] == 0} { - set pkg [lindex $args 1] - set ver [lindex $args 2] - set ::PKGS($pkg:$ver) [lindex $args 3] - } else { - return [eval package_original $args] - } - } - array set ::PKGS {} - } - - set dir [file dirname $filePath] - $slave eval {set curdir [pwd]} - $slave eval [list cd $dir] - $slave eval [list set dir $dir] - $slave eval [list source [file tail $filePath]] - $slave eval {cd $curdir} - - # Create the list in sorted order, so that we don't get spurious - # errors because the order has changed. - - array set P {} - foreach {k v} [$slave eval {array get ::PKGS}] { - set P($k) $v - } - - set PKGS "" - foreach k [lsort [array names P]] { - lappend PKGS $k $P($k) - } - } err]} { - set ei $::errorInfo - set ec $::errorCode - - catch {interp delete $slave} - - error $ei $ec - } - - interp delete $slave - - return $PKGS -} - -# pkgtest::createIndex -- -# -# Runs pkg_mkIndex for the given directory and set of patterns. -# This procedure deletes any pkgIndex.tcl file in the target directory, -# then runs pkg_mkIndex. -# -# Arguments: -# <flags> (optional) arguments starting with a dash are collected -# as options to pkg_mkIndex and passed to pkg_mkIndex. -# dirPath the directory to index -# pattern0 pattern to index -# ... pattern to index -# patternN pattern to index -# -# Results: -# Returns a two element list: -# 0: 1 if the procedure encountered an error, 0 otherwise. -# 1: the error result if element 0 was 1 - -proc pkgtest::createIndex { args } { - set parsed [eval parseArgs $args] - set options [lindex $parsed 0] - set dirPath [lindex $parsed 1] - set patternList [lindex $parsed 2] - - if {[catch { - file delete [file join $dirPath pkgIndex.tcl] - eval pkg_mkIndex $options $dirPath $patternList - } err]} { - return [list 1 $err] - } - - return [list 0 {}] -} - -# makePkgList -- -# -# Takes the output of a pkgtest::parseIndex call, filters it and returns a -# cleaned up list of packages and their actions. -# -# Arguments: -# inList output from a pkgtest::parseIndex. -# -# Results: -# Returns a list of two element lists: -# 0: the name:version -# 1: a list describing the package. -# For tclPkgSetup packages it consists of: -# 0: the keyword tclPkgSetup -# 1: the first file to source, with its exported procedures -# 2: the second file ... -# N: the N-1st file ... - -proc makePkgList { inList } { - set pkgList "" - - foreach {k v} $inList { - switch [lindex $v 0] { - tclPkgSetup { - set l tclPkgSetup - foreach s [lindex $v 4] { - lappend l $s - } - } - - source { - set l $v - } - - default { - error "can't handle $k $v" - } - } - - lappend pkgList [list $k $l] - } - - return $pkgList -} - -# pkgtest::runIndex -- -# -# Runs pkg_mkIndex, parses the generated index file. -# -# Arguments: -# <flags> (optional) arguments starting with a dash are collected -# as options to pkg_mkIndex and passed to pkg_mkIndex. -# dirPath the directory to index -# pattern0 pattern to index -# ... pattern to index -# patternN pattern to index -# -# Results: -# Returns a two element list: -# 0: 1 if the procedure encountered an error, 0 otherwise. -# 1: if no error, this is the parsed generated index file, in the format -# returned by pkgtest::parseIndex. -# If error, this is the error result. - -proc pkgtest::runIndex { args } { - set rv [eval createIndex $args] - if {[lindex $rv 0] == 0} { - set parsed [eval parseArgs $args] - set dirPath [lindex $parsed 1] - set idxFile [file join $dirPath pkgIndex.tcl] - - if {[catch { - set result [list 0 [makePkgList [parseIndex $idxFile]]] - } err]} { - set result [list 1 $err] - } - file delete $idxFile - } else { - set result $rv - } - - return $result -} - -# If there is no match to the patterns, make sure the directory hasn't -# changed on us - -test pkgMkIndex-1.1 {nothing matches pattern - current dir is the same} { - list [pkgtest::runIndex pkg nomatch.tcl] [pwd] -} [list {1 {no files matched glob pattern "nomatch.tcl"}} [pwd]] -cd $oldDir ;# 'cause 8.0.3 is left in the wrong place -test pkgMkIndex-2.1 {simple package} { - pkgtest::runIndex pkg simple.tcl -} {0 {{simple:1.0 {tclPkgSetup {simple.tcl source {::simple::lower ::simple::upper}}}}}} - -test pkgMkIndex-2.2 {simple package - use -direct} { - pkgtest::runIndex -direct pkg simple.tcl -} "0 {{simple:1.0 {source [file join pkg simple.tcl]}}}" - -test pkgMkIndex-3.1 {simple package with global symbols} { - pkgtest::runIndex pkg global.tcl -} {0 {{global:1.0 {tclPkgSetup {global.tcl source {global_lower global_upper}}}}}} - -test pkgMkIndex-4.1 {split package} { - pkgtest::runIndex pkg pkg2_a.tcl pkg2_b.tcl -} {0 {{pkg2:1.0 {tclPkgSetup {pkg2_a.tcl source ::pkg2::p2-1} {pkg2_b.tcl source ::pkg2::p2-2}}}}} - -test pkgMkIndex-4.2 {split package - direct loading} { - pkgtest::runIndex -direct pkg pkg2_a.tcl pkg2_b.tcl -} "0 {{pkg2:1.0 {source [file join pkg pkg2_a.tcl] -source [file join pkg pkg2_b.tcl]}}}" - -# This will fail, with "direct1" procedures in the list of procedures -# provided by std. -# It may also fail, if tclblend is in the auto_path, with an additional -# command "loadJava" which comes from the tclblend pkgIndex.tcl file. -# Both failures are caused by Tcl code executed in pkgIndex.tcl. - -test pkgMkIndex-5.1 {requires -direct package} { - pkgtest::runIndex pkg std.tcl -} {0 {{std:1.0 {tclPkgSetup {std.tcl source {::std::p1 ::std::p2}}}}}} - -test pkgMkIndex-6.1 {pkg1 requires pkg3} { - pkgtest::runIndex pkg pkg1.tcl pkg3.tcl -} {0 {{pkg1:1.0 {tclPkgSetup {pkg1.tcl source {::pkg1::p1-1 ::pkg1::p1-2}}}} {pkg3:1.0 {tclPkgSetup {pkg3.tcl source {::pkg3::p3-1 ::pkg3::p3-2}}}}}} - -test pkgMkIndex-6.2 {pkg1 requires pkg3 - use -direct} { - pkgtest::runIndex -direct pkg pkg1.tcl pkg3.tcl -} "0 {{pkg1:1.0 {source [file join pkg pkg1.tcl]}} {pkg3:1.0 {source [file join pkg pkg3.tcl]}}}" - -test pkgMkIndex-7.1 {pkg4 uses pkg3} { - pkgtest::runIndex pkg pkg4.tcl pkg3.tcl -} {0 {{pkg3:1.0 {tclPkgSetup {pkg3.tcl source {::pkg3::p3-1 ::pkg3::p3-2}}}} {pkg4:1.0 {tclPkgSetup {pkg4.tcl source {::pkg4::p4-1 ::pkg4::p4-2}}}}}} - -test pkgMkIndex-7.2 {pkg4 uses pkg3 - use -direct} { - pkgtest::runIndex -direct pkg pkg4.tcl pkg3.tcl -} "0 {{pkg3:1.0 {source [file join pkg pkg3.tcl]}} {pkg4:1.0 {source [file join pkg pkg4.tcl]}}}" - -test pkgMkIndex-8.1 {pkg5 uses pkg2} { - pkgtest::runIndex pkg pkg5.tcl pkg2_a.tcl pkg2_b.tcl -} {0 {{pkg2:1.0 {tclPkgSetup {pkg2_a.tcl source ::pkg2::p2-1} {pkg2_b.tcl source ::pkg2::p2-2}}} {pkg5:1.0 {tclPkgSetup {pkg5.tcl source {::pkg5::p5-1 ::pkg5::p5-2}}}}}} - -test pkgMkIndex-8.2 {pkg5 uses pkg2 - use -direct} { - pkgtest::runIndex -direct pkg pkg5.tcl pkg2_a.tcl pkg2_b.tcl -} "0 {{pkg2:1.0 {source [file join pkg pkg2_a.tcl] -source [file join pkg pkg2_b.tcl]}} {pkg5:1.0 {source [file join pkg pkg5.tcl]}}}" - -test pkgMkIndex-9.1 {circular packages} { - pkgtest::runIndex pkg circ1.tcl circ2.tcl circ3.tcl -} {0 {{circ1:1.0 {tclPkgSetup {circ1.tcl source {::circ1::c1-1 ::circ1::c1-2 ::circ1::c1-3 ::circ1::c1-4}}}} {circ2:1.0 {tclPkgSetup {circ2.tcl source {::circ2::c2-1 ::circ2::c2-2}}}} {circ3:1.0 {tclPkgSetup {circ3.tcl source ::circ3::c3-1}}}}} - -# Try to find one of the DLLs in the dltest directory -set x [file join [pwd] [file dirname [info script]]] -set x [file join $x ../unix/dltest/pkga[info sharedlibextension]] -if {[file exists $x]} { - file copy -force $x pkg - test pkgMkIndex-10.1 {package in DLL and script} { - pkgtest::runIndex pkg pkga[info sharedlibextension] pkga.tcl - } {0 {{Pkga:1.0 {tclPkgSetup {pkga.so load {pkga_eq pkga_quote}} {pkga.tcl source pkga_neq}}}}} - test pkgMkIndex-10.2 {package in DLL hidden by -load} { - pkgtest::runIndex -load Pkg* -- pkg pkga[info sharedlibextension] - } {0 {}} -} else { - puts "Skipping pkgMkIndex-10.1 (index of DLL and script)" -} - -# -# cleanup -# -if {![info exist TESTS]} { - file delete [file join pkg pkgIndex.tcl] - namespace delete pkgtest -} diff --git a/tests/socket.test b/tests/socket.test deleted file mode 100644 index 5ff563a..0000000 --- a/tests/socket.test +++ /dev/null @@ -1,1593 +0,0 @@ -# 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. -# -# RCS: @(#) $Id: socket.test,v 1.6 1998/12/04 01:01:55 stanton Exp $ - -if {[string compare test [info procs test]] == 1} then {source defs} - -if {$testConfig(socket) == 0} { - return -} - -# -# 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 remoteProcChan "" -set commandSocket "" -if {$doTestsWithRemoteServer} { - catch {close $commandSocket} - if {[catch {set commandSocket [socket $remoteServerIP \ - $remoteServerPort]}] != 0} { - if {[info commands exec] == ""} { - set noRemoteTestReason "can't exec" - set doTestsWithRemoteServer 0 - } elseif {$testConfig(win32s)} { - set noRemoteTestReason "\ncan't run multiple instances of tcltest under win32s." - set doTestsWithRemoteServer 0 - } else { - set remoteServerIP localhost - if {[catch {set remoteProcChan \ - [open "|[list $tcltest remote.tcl \ - -serverIsSilent \ - -port $remoteServerPort \ - -address $remoteServerIP]" \ - w+]} \ - msg] == 0} { - after 1000 - if {[catch {set commandSocket [socket $remoteServerIP \ - $remoteServerPort]} msg] == 0} { - fconfigure $commandSocket -translation crlf -buffering line - } else { - set noRemoteTestReason $msg - set doTestsWithRemoteServer 0 - } - } else { - set noRemoteTestReason "$msg $tcltest" - 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 {[info exists VERBOSE] && ($VERBOSE != 0)} { - puts "Reason for not doing remote tests: $noRemoteTestReason" - } -} - -# -# 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} {stdio} { - removeFile script - set f [open script w] - puts $f { - set timer [after 2000 "set x timed_out"] - set f [socket -server accept 2828] - proc accept {file addr port} { - global x - set x done - close $file - } - puts ready - vwait x - after cancel $timer - close $f - puts $x - } - close $f - set f [open "|[list $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} {stdio} { - removeFile script - set f [open script w] - puts $f { - set timer [after 2000 "set x done"] - 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 - after cancel $timer - close $f - } - close $f - set f [open "|[list $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} {stdio} { - removeFile script - set f [open script w] - puts $f { - set timer [after 2000 "set x done"] - 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 - after cancel $timer - close $f - } - close $f - set f [open "|[list $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} {stdio} { - removeFile script - set f [open script w] - puts $f { - set timer [after 2000 "set x done"] - 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 - after cancel $timer - close $f - } - close $f - set f [open "|[list $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} {stdio} { - removeFile script - set f [open script w] - puts $f { - set timer [after 2000 "set x done"] - 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 - after cancel $timer - close $f - } - close $f - set f [open "|[list $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} {} { - 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} {stdio} { - removeFile script - set f [open script w] - puts $f { - set timer [after 2000 "set x done"] - 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 - after cancel $timer - close $f - puts done - } - close $f - set f [open "|[list $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} {stdio} { - 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 - set timer [after 20000 "set x done"] - vwait x - after cancel $timer - close $f - puts "done $i" - } - close $f - set f [open "|[list $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} {stdio} { - 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 "|[list $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" - (file "script" line 1)}} -test socket-2.10 {close on accept, accepted socket lives} { - set done 0 - set timer [after 20000 "set done timed_out"] - set ss [socket -server accept 2830] - proc accept {s a p} { - global ss - close $ss - fileevent $s readable "readit $s" - fconfigure $s -trans lf - } - proc readit {s} { - global done - gets $s - close $s - set done 1 - } - set cs [socket [info hostname] 2830] - puts $cs hello - close $cs - vwait done - after cancel $timer - set done -} 1 -test socket-2.11 {detecting new data} { - proc accept {s a p} { - global sock - set sock $s - } - - set s [socket -server accept 2400] - set sock "" - set s2 [socket localhost 2400] - vwait sock - puts $s2 one - flush $s2 - after 500 - fconfigure $sock -blocking 0 - set result [gets $sock] - lappend result [gets $sock] - fconfigure $sock -blocking 1 - puts $s2 two - flush $s2 - fconfigure $sock -blocking 0 - lappend result [gets $sock] - fconfigure $sock -blocking 1 - close $s2 - close $s - close $sock - set result -} {one {} two} - - -test socket-3.1 {socket conflict} {stdio} { - 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 "|[list $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} {stdio} { - removeFile script - set f [open script w] - puts $f { - set t1 [after 30000 "set x timed_out"] - set t2 [after 31000 "set x timed_out"] - set t3 [after 32000 "set x timed_out"] - set counter 0 - set s [socket -server accept 2828] - 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 - after cancel $t1 - vwait x - after cancel $t2 - vwait x - after cancel $t3 - close $s - puts $x - } - close $f - set f [open "|[list $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} {stdio} { - 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 "|[list $tcltest script]" r+] - fconfigure $p1 -buffering line - set p2 [open "|[list $tcltest script]" r+] - fconfigure $p2 -buffering line - set p3 [open "|[list $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 t1 [after 30000 "set x timed_out"] - set t2 [after 31000 "set x timed_out"] - set t3 [after 32000 "set x timed_out"] - set s [socket -server accept 2828] - puts $p1 open - puts $p2 open - puts $p3 open - vwait x - vwait x - vwait x - after cancel $t1 - after cancel $t2 - after cancel $t3 - close $s - set l "" - lappend l [list p1 [gets $p1] $x] - lappend l [list p2 [gets $p2] $x] - lappend l [list p3 [gets $p3] $x] - puts $p1 bye - puts $p2 bye - puts $p3 bye - close $p1 - close $p2 - close $p3 - set l -} {{p1 bye done} {p2 bye done} {p3 bye done}} -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} {stdio} { - removeFile script - set f [open script w] - puts $f { - gets stdin - socket localhost 2848 - } - close $f - set f [open "|[list $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 - set timer [after 10000 "set x timed_out"] - vwait x - after cancel $timer - close $s - rename bgerror {} - set x -} {{divide by zero}} - -test socket-7.1 {testing socket specific options} {stdio} { - removeFile script - set f [open script w] - puts $f { - socket -server accept 2820 - proc accept args { - global x - set x done - } - puts ready - set timer [after 10000 "set x timed_out"] - vwait x - after cancel $timer - } - close $f - set f [open "|[list $tcltest script]" r] - gets $f - set s [socket localhost 2820] - set p [fconfigure $s -peername] - close $s - close $f - set l "" - lappend l [string compare [lindex $p 0] 127.0.0.1] - lappend l [string compare [lindex $p 2] 2820] - lappend l [llength $p] -} {0 0 3} -test socket-7.2 {testing socket specific options} {stdio} { - removeFile script - set f [open script w] - puts $f { - socket -server accept 2821 - proc accept args { - global x - set x done - } - puts ready - set timer [after 10000 "set x timed_out"] - vwait x - after cancel $timer - } - close $f - set f [open "|[list $tcltest script]" r] - gets $f - set s [socket localhost 2821] - set p [fconfigure $s -sockname] - close $s - close $f - set l "" - lappend l [llength $p] - lappend l [lindex $p 0] - lappend l [expr [lindex $p 2] == 2821] -} {3 127.0.0.1 0} -test socket-7.3 {testing socket specific options} { - set s [socket -server accept 2822] - set l [fconfigure $s] - close $s - update - llength $l -} 10 -test socket-7.4 {testing socket specific options} { - set s [socket -server accept 2823] - proc accept {s a p} { - global x - set x [fconfigure $s -sockname] - close $s - } - set s1 [socket [info hostname] 2823] - set timer [after 10000 "set x timed_out"] - vwait x - after cancel $timer - close $s - close $s1 - set l "" - lappend l [lindex $x 2] [llength $x] -} {2823 3} -test socket-7.5 {testing socket specific options} {unixOrPc} { - set s [socket -server accept 2829] - proc accept {s a p} { - global x - set x [fconfigure $s -sockname] - close $s - } - set s1 [socket localhost 2829] - set timer [after 10000 "set x timed_out"] - vwait x - after cancel $timer - close $s - close $s1 - set l "" - lappend l [lindex $x 0] [lindex $x 2] [llength $x] -} {127.0.0.1 2829 3} - -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 2830] - proc accept {s a p} { - global x - puts $s bye - close $s - set x done - } - set s1 [socket -async [info hostname] 2830] - vwait x - set z [gets $s1] - close $s - close $s1 - set z -} bye - -test socket-9.1 {testing spurious events} { - set len 0 - set spurious 0 - set done 0 - proc readlittle {s} { - global spurious done len - set l [read $s 1] - if {[string length $l] == 0} { - if {![eof $s]} { - incr spurious - } else { - close $s - set done 1 - } - } else { - incr len [string length $l] - } - } - proc accept {s a p} { - fconfigure $s -buffering none -blocking off - fileevent $s readable [list readlittle $s] - } - set s [socket -server accept 2831] - set c [socket [info hostname] 2831] - puts -nonewline $c 01234567890123456789012345678901234567890123456789 - close $c - set timer [after 10000 "set done timed_out"] - vwait done - after cancel $timer - close $s - list $spurious $len -} {0 50} -test socket-9.2 {testing async write, fileevents, flush on close} {} { - set firstblock "" - for {set i 0} {$i < 5} {incr i} {set firstblock "a$firstblock$firstblock"} - set secondblock "" - for {set i 0} {$i < 16} {incr i} { - set secondblock "b$secondblock$secondblock" - } - set l [socket -server accept 2832] - proc accept {s a p} { - fconfigure $s -blocking 0 -translation lf -buffersize 16384 \ - -buffering line - fileevent $s readable "readable $s" - } - proc readable {s} { - set l [gets $s] - fileevent $s readable {} - after 1000 respond $s - } - proc respond {s} { - global firstblock - puts -nonewline $s $firstblock - after 1000 writedata $s - } - proc writedata {s} { - global secondblock - puts -nonewline $s $secondblock - close $s - } - set s [socket [info hostname] 2832] - fconfigure $s -blocking 0 -trans lf -buffering line - set count 0 - puts $s hello - proc readit {s} { - global count done - set l [read $s] - incr count [string length $l] - if {[eof $s]} { - close $s - set done 1 - } - } - fileevent $s readable "readit $s" - set timer [after 10000 "set done timed_out"] - vwait done - after cancel $timer - close $l - set count -} 65566 -test socket-9.3 {testing EOF stickyness} { - proc count_to_eof {s} { - global count done timer - set l [gets $s] - if {[eof $s]} { - incr count - if {$count > 9} { - close $s - set done true - set count {eof is sticky} - after cancel $timer - } - } - } - proc timerproc {} { - global done count c - set done true - set count {timer went off, eof is not sticky} - close $c - } - set count 0 - set done false - proc write_then_close {s} { - puts $s bye - close $s - } - proc accept {s a p} { - fconfigure $s -buffering line -translation lf - fileevent $s writable "write_then_close $s" - } - set s [socket -server accept 2833] - set c [socket [info hostname] 2833] - fconfigure $c -blocking off -buffering line -translation lf - fileevent $c readable "count_to_eof $c" - set timer [after 1000 timerproc] - vwait done - close $s - set count -} {eof is sticky} - -test socket-10.1 {testing socket accept callback error handling} { - set goterror 0 - proc bgerror args {global goterror; set goterror 1} - set s [socket -server accept 2898] - proc accept {s a p} {close $s; error} - set c [socket localhost 2898] - vwait goterror - close $s - close $c - set goterror -} 1 - -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-11.1 {tcp connection} { - sendCommand { - set socket9_1_test_server [socket -server accept 2834] - proc accept {s a p} { - puts $s done - close $s - } - } - set s [socket $remoteServerIP 2834] - set r [gets $s] - close $s - sendCommand {close $socket9_1_test_server} - set r -} done -test socket-11.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 2835] - proc accept {s a p} { - puts $s $p - close $s - } - } - set s [socket -myport $port $remoteServerIP 2835] - 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 -test socket-11.3 {trying to connect, no server} { - set status ok - if {![catch {set s [socket $remoteServerIp 2836]}]} { - if {![catch {gets $s}]} { - set status broken - } - close $s - } - set status -} ok -test socket-11.4 {remote echo, one line} { - sendCommand { - set socket10_6_test_server [socket -server accept 2836] - 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 2836] - fconfigure $f -translation crlf -buffering line - puts $f hello - set r [gets $f] - close $f - sendCommand {close $socket10_6_test_server} - set r -} hello -test socket-11.5 {remote echo, 50 lines} { - sendCommand { - set socket10_7_test_server [socket -server accept 2836] - 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 2836] - 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 $socket10_7_test_server} - set cnt -} 50 -# Macintosh sockets can have more than one server per port -if {$tcl_platform(platform) == "macintosh"} { - set conflictResult {0 2836} -} else { - set conflictResult {1 {couldn't open socket: address already in use}} -} -test socket-11.6 {socket conflict} { - set s1 [socket -server accept 2836] - if {[catch {set s2 [socket -server accept 2836]} 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-11.7 {server with several clients} { - sendCommand { - set socket10_9_test_server [socket -server accept 2836] - 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 2836] - fconfigure $s1 -buffering line - set s2 [socket $remoteServerIP 2836] - fconfigure $s2 -buffering line - set s3 [socket $remoteServerIP 2836] - 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 $socket10_9_test_server} - set i -} 100 -test socket-11.8 {client with several servers} { - sendCommand { - set s1 [socket -server "accept 4003" 4003] - set s2 [socket -server "accept 4004" 4004] - set s3 [socket -server "accept 4005" 4005] - proc accept {mp s a p} { - puts $s $mp - close $s - } - } - set s1 [socket $remoteServerIP 4003] - set s2 [socket $remoteServerIP 4004] - set s3 [socket $remoteServerIP 4005] - 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 -} {4003 {} 1 4004 {} 1 4005 {} 1} -test socket-11.9 {accept callback error} { - set s [socket -server accept 2836] - 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] 2836] - close $s - }} msg]} { - close $s - error $msg - } - set timer [after 10000 "set x timed_out"] - vwait x - after cancel $timer - close $s - rename bgerror {} - set x -} {{divide by zero}} -test socket-11.10 {testing socket specific options} { - sendCommand { - set socket10_12_test_server [socket -server accept 2836] - proc accept {s a p} {close $s} - } - set s [socket $remoteServerIP 2836] - 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 $socket10_12_test_server} - set l -} {2836 3 3} -test socket-11.11 {testing spurious events} { - sendCommand { - set socket10_13_test_server [socket -server accept 2836] - proc accept {s a p} { - fconfigure $s -translation "auto lf" - after 100 writesome $s - } - proc writesome {s} { - for {set i 0} {$i < 100} {incr i} { - puts $s "line $i from remote server" - } - close $s - } - } - set len 0 - set spurious 0 - set done 0 - proc readlittle {s} { - global spurious done len - set l [read $s 1] - if {[string length $l] == 0} { - if {![eof $s]} { - incr spurious - } else { - close $s - set done 1 - } - } else { - incr len [string length $l] - } - } - set c [socket $remoteServerIP 2836] - fileevent $c readable "readlittle $c" - set timer [after 10000 "set done timed_out"] - vwait done - after cancel $timer - sendCommand {close $socket10_13_test_server} - list $spurious $len -} {0 2690} -test socket-11.12 {testing EOF stickyness} { - set counter 0 - set done 0 - proc count_up {s} { - global counter done after_id - set l [gets $s] - if {[eof $s]} { - incr counter - if {$counter > 9} { - set done {EOF is sticky} - after cancel $after_id - close $s - } - } - } - proc timed_out {} { - global c done - set done {timed_out, EOF is not sticky} - close $c - } - sendCommand { - set socket10_14_test_server [socket -server accept 2836] - proc accept {s a p} { - after 100 close $s - } - } - set c [socket $remoteServerIP 2836] - fileevent $c readable "count_up $c" - set after_id [after 1000 timed_out] - vwait done - sendCommand {close $socket10_14_test_server} - set done -} {EOF is sticky} -test socket-11.13 {testing async write, async flush, async close} { - proc readit {s} { - global count done - set l [read $s] - incr count [string length $l] - if {[eof $s]} { - close $s - set done 1 - } - } - sendCommand { - set firstblock "" - for {set i 0} {$i < 5} {incr i} { - set firstblock "a$firstblock$firstblock" - } - set secondblock "" - for {set i 0} {$i < 16} {incr i} { - set secondblock "b$secondblock$secondblock" - } - set l [socket -server accept 2845] - proc accept {s a p} { - fconfigure $s -blocking 0 -translation lf -buffersize 16384 \ - -buffering line - fileevent $s readable "readable $s" - } - proc readable {s} { - set l [gets $s] - fileevent $s readable {} - after 1000 respond $s - } - proc respond {s} { - global firstblock - puts -nonewline $s $firstblock - after 1000 writedata $s - } - proc writedata {s} { - global secondblock - puts -nonewline $s $secondblock - close $s - } - } - set s [socket $remoteServerIP 2845] - fconfigure $s -blocking 0 -trans lf -buffering line - set count 0 - puts $s hello - fileevent $s readable "readit $s" - set timer [after 10000 "set done timed_out"] - vwait done - after cancel $timer - sendCommand {close $l} - set count -} 65566 - -test socket-12.1 {testing inheritance of server sockets} { - removeFile script1 - removeFile script2 - - # Script1 is just a 10 second delay. If the server socket - # is inherited, it will be held open for 10 seconds - - set f [open script1 w] - puts $f { - after 10000 exit - vwait forever - } - close $f - - # Script2 creates the server socket, launches script1, - # waits a second, and exits. The server socket will now - # be closed unless script1 inherited it. - - set f [open script2 w] - puts $f [list set tcltest $tcltest] - puts $f { - set f [socket -server accept 2828] - proc accept { file addr port } { - close $file - } - exec $tcltest script1 & - close $f - after 1000 exit - vwait forever - } - close $f - - # Launch script2 and wait 5 seconds - - exec $tcltest script2 & - after 5000 { set ok_to_proceed 1 } - vwait ok_to_proceed - - # If we can still connect to the server, the socket got inherited. - - if {[catch {socket localhost 2828} msg]} { - set x {server socket was not inherited} - } else { - close $msg - set x {server socket was inherited} - } - - removeFile script1 - removeFile script2 - set x -} {server socket was not inherited} -test socket-12.2 {testing inheritance of client sockets} { - removeFile script1 - removeFile script2 - - # Script1 is just a 10 second delay. If the server socket - # is inherited, it will be held open for 10 seconds - - set f [open script1 w] - puts $f { - after 10000 exit - vwait forever - } - close $f - - # Script2 opens the client socket and writes to it. It then - # launches script1 and exits. If the child process inherited the - # client socket, the socket will still be open. - - set f [open script2 w] - puts $f [list set tcltest $tcltest] - puts $f { - set f [socket localhost 2829] - exec $tcltest script1 & - puts $f testing - flush $f - after 1000 exit - vwait forever - } - close $f - - # Create the server socket - - set server [socket -server accept 2829] - proc accept { file host port } { - - # When the client connects, establish the read handler - global server - close $server - fileevent $file readable [list getdata $file] - fconfigure $file -buffering line -blocking 0 - return - } - proc getdata { file } { - - # Read handler on the accepted socket. - global x - global failed - set status [catch {read $file} data] - if {$status != 0} { - set x {read failed, error was $data} - catch { close $file } - } elseif {[string compare {} $data]} { - } elseif {[fblocked $file]} { - } elseif {[eof $file]} { - if {$failed} { - set x {client socket was inherited} - } else { - set x {client socket was not inherited} - } - catch { close $file } - } else { - set x {impossible case} - catch { close $file } - } - return - } - - # If the socket doesn't hit end-of-file in 5 seconds, the - # script1 process must have inherited the client. - - set failed 0 - after 5000 [list set failed 1] - - # Launch the script2 process - - exec $tcltest script2 & - - vwait x - if {!$failed} { - vwait failed - } - removeFile script1 - removeFile script2 - set x -} {client socket was not inherited} -test socket-12.3 {testing inheritance of accepted sockets} { - removeFile script1 - removeFile script2 - - set f [open script1 w] - puts $f { - after 10000 exit - vwait forever - } - close $f - - set f [open script2 w] - puts $f [list set tcltest $tcltest] - puts $f { - set server [socket -server accept 2930] - proc accept { file host port } { - global tcltest - puts $file {test data on socket} - exec $tcltest script1 & - after 1000 exit - } - vwait forever - } - close $f - - # Launch the script2 process and connect to it. See how long - # the socket stays open - - exec $tcltest script2 & - - after 1000 set ok_to_proceed 1 - vwait ok_to_proceed - - set f [socket localhost 2930] - fconfigure $f -buffering full -blocking 0 - fileevent $f readable [list getdata $f] - - # If the socket is still open after 5 seconds, the script1 process - # must have inherited the accepted socket. - - set failed 0 - after 5000 set failed 1 - - proc getdata { file } { - - # Read handler on the client socket. - global x - global failed - set status [catch {read $file} data] - if {$status != 0} { - set x {read failed, error was $data} - catch { close $file } - } elseif {[string compare {} $data]} { - } elseif {[fblocked $file]} { - } elseif {[eof $file]} { - if {$failed} { - set x {accepted socket was inherited} - } else { - set x {accepted socket was not inherited} - } - catch { close $file } - } else { - set x {impossible case} - catch { close $file } - } - return - } - - vwait x - - removeFile script1 - removeFile script2 - set x -} {accepted socket was not inherited} - - -if {[string match sock* $commandSocket] == 1} { - puts $commandSocket exit - flush $commandSocket -} -catch {close $commandSocket} -catch {close $remoteProcChan} - -set x "" -unset x diff --git a/tools/README b/tools/README deleted file mode 100644 index 67cac12..0000000 --- a/tools/README +++ /dev/null @@ -1,4 +0,0 @@ - - This directory contains unsupported tools that are used - during the release engineering process. - diff --git a/tools/configure.in b/tools/configure.in deleted file mode 100644 index f5fa48d..0000000 --- a/tools/configure.in +++ /dev/null @@ -1,34 +0,0 @@ -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(man2tcl.c) -# RCS: @(#) $Id: configure.in,v 1.2.2.1 1999/02/19 02:17:04 stanton Exp $ - -# Recover information that Tcl computed with its configure script. - -#-------------------------------------------------------------------- -# See if there was a command-line option for where Tcl is; if -# not, assume that its top-level directory is a sibling of ours. -#-------------------------------------------------------------------- - -AC_ARG_WITH(tcl, [ --with-tcl=DIR use Tcl 8.0 binaries from DIR], TCL_BIN_DIR=$withval, TCL_BIN_DIR=`cd ../../tcl8.0$TK_PATCH_LEVEL/unix; pwd`) -if test ! -d $TCL_BIN_DIR; then - AC_MSG_ERROR(Tcl directory $TCL_BIN_DIR doesn't exist) -fi -if test ! -f $TCL_BIN_DIR/tclConfig.sh; then - AC_MSG_ERROR(There's no tclConfig.sh in $TCL_BIN_DIR; perhaps you didn't specify the Tcl *build* directory (not the toplevel Tcl directory) or you forgot to configure Tcl?) -fi - -. $TCL_BIN_DIR/tclConfig.sh - -TCL_WIN_VERSION=$TCL_MAJOR_VERSION$TCL_MINOR_VERSION -AC_SUBST(TCL_WIN_VERSION) -CC=$TCL_CC -AC_SUBST(CC) -AC_SUBST(TCL_VERSION) -AC_SUBST(TCL_PATCH_LEVEL) -AC_SUBST(TCL_SRC_DIR) -AC_SUBST(TCL_BIN_DIR) - -AC_OUTPUT(Makefile) -AC_OUTPUT(tcl.hpj) diff --git a/tools/tcl.hpj b/tools/tcl.hpj.in index 15eb1e5..15eb1e5 100644 --- a/tools/tcl.hpj +++ b/tools/tcl.hpj.in diff --git a/unix/Makefile.in b/unix/Makefile.in deleted file mode 100644 index b0c688c..0000000 --- a/unix/Makefile.in +++ /dev/null @@ -1,1049 +0,0 @@ -# -# 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. -# -# RCS: @(#) $Id: Makefile.in,v 1.17 1999/02/02 23:00:07 stanton Exp $ - -# 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) - -# Package search path. -TCL_PACKAGE_PATH = @TCL_PACKAGE_PATH@ - -# 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 - -# Path to use at runtime to refer to LIB_INSTALL_DIR: -LIB_RUNTIME_DIR = $(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 - -# Libraries built with optimization switches have this additional extension -TCL_DBGX = @TCL_DBGX@ - -# warning flags -CFLAGS_WARNING = @CFLAGS_WARNING@ - -# The default switches for optimization or debugging -CFLAGS_DEBUG = @CFLAGS_DEBUG@ -CFLAGS_OPTIMIZE = @CFLAGS_OPTIMIZE@ - -# To change the compiler switches, for example to change from optimization to -# debugging symbols, change the following line: -#CFLAGS = $(CFLAGS_DEBUG) -#CFLAGS = $(CFLAGS_OPTIMIZE) -#CFLAGS = $(CFLAGS_DEBUG) $(CFLAGS_OPTIMIZE) -CFLAGS = $(@CFLAGS_DEFAULT@) - -# 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 tclUnixEvent.o tclUnixFCmd.o \ - tclUnixFile.o tclUnixPipe.o tclUnixSock.o \ - tclUnixTime.o tclUnixInit.o -#UNIX_OBJS = -NOTIFY_OBJS = tclUnixNotfy.o -#NOTIFY_OBJS = - -# To enable memory debugging reverse the comment characters on the following -# lines. Warning: if you enable memory debugging, you must do it -# *everywhere*, including all the code that calls Tcl, and you must use -# ckalloc and ckfree everywhere instead of malloc and free. -MEM_DEBUG_FLAGS = -#MEM_DEBUG_FLAGS = -DTCL_MEM_DEBUG - -# To enable compilation debugging reverse the comment characters on -# one of the following lines. -COMPILE_DEBUG_FLAGS = -#COMPILE_DEBUG_FLAGS = -DTCL_COMPILE_STATS -#COMPILE_DEBUG_FLAGS = -DTCL_COMPILE_DEBUG -DTCL_COMPILE_STATS - -# 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 - -TCL_LIB_FLAG = @TCL_LIB_FLAG@ -#TCL_LIB_FLAG = -ltcl - -#---------------------------------------------------------------- -# 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 = @EXTRA_CFLAGS@ @DEFS@ -RANLIB = @RANLIB@ -SRC_DIR = @srcdir@ -TOP_DIR = @srcdir@/.. -GENERIC_DIR = $(TOP_DIR)/generic -COMPAT_DIR = $(TOP_DIR)/compat -TOOL_DIR = $(TOP_DIR)/tools -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} ${CFLAGS_WARNING} ${TCL_SHLIB_CFLAGS} \ --I${GENERIC_DIR} -I${SRC_DIR} \ -${AC_FLAGS} ${MATH_FLAGS} ${GENERIC_FLAGS} ${PROTO_FLAGS} ${MEM_DEBUG_FLAGS} \ -${COMPILE_DEBUG_FLAGS} ${ENV_FLAGS} -DTCL_SHLIB_EXT=\"${SHLIB_SUFFIX}\" - -LIBS = @DL_LIBS@ @LIBS@ $(MATH_LIBS) -lc - -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 tclTestObj.o tclTestProcBodyObj.o \ - tclUnixTest.o - -XTTEST_OBJS = tclTest.o tclTestObj.o tclUnixTest.o tclXtNotify.o \ - tclXtTest.o xtTestInit.o - -GENERIC_OBJS = panic.o regexp.o tclAsync.o tclBasic.o tclBinary.o tclCkalloc.o \ - tclClock.o tclCmdAH.o tclCmdIL.o tclCmdMZ.o tclCompExpr.o \ - tclCompile.o tclDate.o tclEnv.o tclEvent.o tclExecute.o \ - tclFCmd.o tclFileName.o tclGet.o tclHash.o tclHistory.o \ - tclIndexObj.o tclInterp.o tclIO.o tclIOCmd.o tclIOSock.o \ - tclIOUtil.o tclLink.o tclListObj.o tclLoad.o tclMain.o tclNamesp.o \ - tclNotify.o tclObj.o tclParse.o tclPipe.o tclPkg.o tclPosixStr.o \ - tclPreserve.o tclProc.o tclStringObj.o tclTimer.o tclUtil.o tclVar.o \ - tclResolve.o - -OBJS = ${GENERIC_OBJS} ${UNIX_OBJS} ${NOTIFY_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)/tclPatch.h - -GENERIC_SRCS = \ - $(GENERIC_DIR)/regexp.c \ - $(GENERIC_DIR)/tclAsync.c \ - $(GENERIC_DIR)/tclBasic.c \ - $(GENERIC_DIR)/tclBinary.c \ - $(GENERIC_DIR)/tclCkalloc.c \ - $(GENERIC_DIR)/tclClock.c \ - $(GENERIC_DIR)/tclCmdAH.c \ - $(GENERIC_DIR)/tclCmdIL.c \ - $(GENERIC_DIR)/tclCmdMZ.c \ - $(GENERIC_DIR)/tclCompExpr.c \ - $(GENERIC_DIR)/tclCompile.c \ - $(GENERIC_DIR)/tclDate.c \ - $(GENERIC_DIR)/tclEnv.c \ - $(GENERIC_DIR)/tclEvent.c \ - $(GENERIC_DIR)/tclExecute.c \ - $(GENERIC_DIR)/tclFCmd.c \ - $(GENERIC_DIR)/tclFileName.c \ - $(GENERIC_DIR)/tclGet.c \ - $(GENERIC_DIR)/tclHash.c \ - $(GENERIC_DIR)/tclHistory.c \ - $(GENERIC_DIR)/tclIndexObj.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)/tclListObj.c \ - $(GENERIC_DIR)/tclLoad.c \ - $(GENERIC_DIR)/tclMain.c \ - $(GENERIC_DIR)/tclNamesp.c \ - $(GENERIC_DIR)/tclNotify.c \ - $(GENERIC_DIR)/tclObj.c \ - $(GENERIC_DIR)/tclParse.c \ - $(GENERIC_DIR)/tclPipe.c \ - $(GENERIC_DIR)/tclPkg.c \ - $(GENERIC_DIR)/tclPosixStr.c \ - $(GENERIC_DIR)/tclPreserve.c \ - $(GENERIC_DIR)/tclProc.c \ - $(GENERIC_DIR)/tclResolve.c \ - $(GENERIC_DIR)/tclStringObj.c \ - $(GENERIC_DIR)/tclTest.c \ - $(GENERIC_DIR)/tclTestObj.c \ - $(GENERIC_DIR)/tclTestProcBodyObj.c \ - $(GENERIC_DIR)/tclTimer.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)/tclUnixEvent.c \ - $(UNIX_DIR)/tclUnixFCmd.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} - -# Make target which outputs the list of the .o contained in the Tcl lib -# usefull to build a single big shared library containing Tcl and other -# extensions. used for the Tcl Plugin. -- dl -# The dependency on OBJS is not there because we just want the list -# of objects here, not actually building them -tclLibObjs: - @echo ${OBJS} -# This targets actually build the objects needed for the lib in the above -# case -objs: ${OBJS} - - -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 - -xttest: ${XTTEST_OBJS} ${GENERIC_OBJS} ${UNIX_OBJS} ${COMPAT_OBJS} \ - @DL_OBJS@ ${BUILD_DLTEST} - ${CC} ${XTTEST_OBJS} ${GENERIC_OBJS} ${UNIX_OBJS} ${COMPAT_OBJS} \ - @DL_OBJS@ @TCL_BUILD_LIB_SPEC@ ${LIBS} \ - @TCL_LD_SEARCH_FLAGS@ -lXt -o xttest - - -# 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; \ - SHLIB_PATH=`pwd`:${SHLIB_PATH}; export SHLIB_PATH; \ - TCL_LIBRARY=${TOP_DIR}/library; export TCL_LIBRARY; \ - ( echo cd $(TOP_DIR)/tests\; source all ) | ./tcltest - -# Useful target to launch a built tcltest with the proper path,... -runtest: tcltest - LD_LIBRARY_PATH=`pwd`:${LD_LIBRARY_PATH}; export LD_LIBRARY_PATH; \ - SHLIB_PATH=`pwd`:${SHLIB_PATH}; export SHLIB_PATH; \ - TCL_LIBRARY=${TOP_DIR}/library; export TCL_LIBRARY; \ - ./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". -# Note: this target is now obsolete (use the autoconf variable -# TCL_SRC_DIR from tclConfig.sh instead). - -.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/RCS: @(#) $Id: Makefile.in,v 1.17 1999/02/02 23:00:07 stanton Exp $' - -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 - -# Note: before running ranlib below, must cd to target directory because -# some ranlibs write to current directory, and this might not always be -# possible (e.g. if installing as root). - -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 -p $$i; \ - chmod 755 $$i; \ - else true; \ - fi; \ - done; - @echo "Installing $(TCL_LIB_FILE)" - @$(INSTALL_DATA) $(TCL_LIB_FILE) $(LIB_INSTALL_DIR)/$(TCL_LIB_FILE) - @(cd $(LIB_INSTALL_DIR); $(RANLIB) $(TCL_LIB_FILE)) - @chmod 555 $(LIB_INSTALL_DIR)/$(TCL_LIB_FILE) - @echo "Installing tclsh" - @$(INSTALL_PROGRAM) tclsh $(BIN_INSTALL_DIR)/tclsh$(VERSION) - @echo "Installing tclConfig.sh" - @$(INSTALL_DATA) tclConfig.sh $(LIB_INSTALL_DIR)/tclConfig.sh - -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 -p $$i; \ - chmod 755 $$i; \ - else true; \ - fi; \ - done; - @for i in http2.0 http1.0 opt0.1; \ - do \ - if [ ! -d $(SCRIPT_INSTALL_DIR)/$$i ] ; then \ - echo "Making directory $(SCRIPT_INSTALL_DIR)/$$i"; \ - mkdir -p $(SCRIPT_INSTALL_DIR)/$$i; \ - chmod 755 $(SCRIPT_INSTALL_DIR)/$$i; \ - else true; \ - fi; \ - done; - @echo "Installing tcl.h" - @$(INSTALL_DATA) $(GENERIC_DIR)/tcl.h $(INCLUDE_INSTALL_DIR)/tcl.h - @for i in $(TOP_DIR)/library/*.tcl $(TOP_DIR)/library/tclIndex $(UNIX_DIR)/tclAppInit.c $(UNIX_DIR)/ldAix; \ - do \ - echo "Installing $$i"; \ - $(INSTALL_DATA) $$i $(SCRIPT_INSTALL_DIR); \ - done; - @for i in http2.0 http1.0 opt0.1; \ - do \ - for j in $(TOP_DIR)/library/$$i/*.tcl ; \ - do \ - echo "Installing $$j"; \ - $(INSTALL_DATA) $$j $(SCRIPT_INSTALL_DIR)/$$i; \ - done; \ - 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 -p $$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 -rf Makefile config.status config.cache config.log tclConfig.sh \ - $(PACKAGE).* prototype - 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 rules for tclTestInit.o and xtTestInit.o are -# complicated because they are compiled from tclAppInit.c. Can't use -# the "-o" option because this doesn't work on some strange compilers -# (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; - -xtTestInit.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 -DTCL_XT_TEST \ - $(UNIX_DIR)/tclAppInit.c - rm -f xtTestInit.o - mv tclAppInit.o xtTestInit.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 - -tclBinary.o: $(GENERIC_DIR)/tclBinary.c - $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclBinary.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 - -tclCompExpr.o: $(GENERIC_DIR)/tclCompExpr.c - $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclCompExpr.c - -tclCompile.o: $(GENERIC_DIR)/tclCompile.c - $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclCompile.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 - -tclExecute.o: $(GENERIC_DIR)/tclExecute.c - $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclExecute.c - -tclFCmd.o: $(GENERIC_DIR)/tclFCmd.c - $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclFCmd.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 - -tclIndexObj.o: $(GENERIC_DIR)/tclIndexObj.c - $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclIndexObj.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 - -tclListObj.o: $(GENERIC_DIR)/tclListObj.c - $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclListObj.c - -tclObj.o: $(GENERIC_DIR)/tclObj.c - $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclObj.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 - -tclNamesp.o: $(GENERIC_DIR)/tclNamesp.c - $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclNamesp.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 - -tclPipe.o: $(GENERIC_DIR)/tclPipe.c - $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclPipe.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 - -tclResolve.o: $(GENERIC_DIR)/tclResolve.c - $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclResolve.c - -tclStringObj.o: $(GENERIC_DIR)/tclStringObj.c - $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclStringObj.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 - -tclTestObj.o: $(GENERIC_DIR)/tclTestObj.c - $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclTestObj.c - -tclTestProcBodyObj.o: $(GENERIC_DIR)/tclTestProcBodyObj.c - $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclTestProcBodyObj.c - -tclTimer.o: $(GENERIC_DIR)/tclTimer.c - $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclTimer.c - -tclUnixChan.o: $(UNIX_DIR)/tclUnixChan.c - $(CC) -c $(CC_SWITCHES) $(UNIX_DIR)/tclUnixChan.c - -tclUnixEvent.o: $(UNIX_DIR)/tclUnixEvent.c - $(CC) -c $(CC_SWITCHES) $(UNIX_DIR)/tclUnixEvent.c - -tclUnixFCmd.o: $(UNIX_DIR)/tclUnixFCmd.c - $(CC) -c $(CC_SWITCHES) $(UNIX_DIR)/tclUnixFCmd.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}\" \ - -DTCL_PACKAGE_PATH="\"${TCL_PACKAGE_PATH}\"" \ - $(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. -# - -DISTROOT = /tmp/dist -DISTNAME = tcl@TCL_VERSION@@TCL_PATCH_LEVEL@ -ZIPNAME = tcl@TCL_MAJOR_VERSION@@TCL_MINOR_VERSION@@TCL_PATCH_LEVEL@.zip -DISTDIR = $(DISTROOT)/$(DISTNAME) -$(UNIX_DIR)/configure: $(UNIX_DIR)/configure.in - autoconf $(UNIX_DIR)/configure.in > $(UNIX_DIR)/configure -dist: $(UNIX_DIR)/configure - rm -rf $(DISTDIR) - mkdir $(DISTDIR) - mkdir $(DISTDIR)/unix - cp -p $(UNIX_DIR)/*.c $(UNIX_DIR)/*.h $(DISTDIR)/unix - rm -f $(DISTDIR)/unix/bp.c - cp $(UNIX_DIR)/Makefile.in $(DISTDIR)/unix - chmod 664 $(DISTDIR)/unix/Makefile.in - cp $(UNIX_DIR)/configure $(UNIX_DIR)/configure.in \ - $(UNIX_DIR)/tclConfig.sh.in $(UNIX_DIR)/install-sh \ - $(UNIX_DIR)/porting.notes $(UNIX_DIR)/porting.old \ - $(UNIX_DIR)/README $(UNIX_DIR)/ldAix \ - $(DISTDIR)/unix - chmod 775 $(DISTDIR)/unix/configure $(DISTDIR)/unix/configure.in - chmod 775 $(DISTDIR)/unix/ldAix - chmod +x $(DISTDIR)/unix/install-sh - tclsh $(UNIX_DIR)/mkLinks.tcl \ - $(UNIX_DIR)/../doc/*.[13n] > $(DISTDIR)/unix/mkLinks - chmod +x $(DISTDIR)/unix/mkLinks - mkdir $(DISTDIR)/generic - cp -p $(GENERIC_DIR)/*.c $(GENERIC_DIR)/*.h $(DISTDIR)/generic - cp -p $(GENERIC_DIR)/README $(DISTDIR)/generic - cp -p $(GENERIC_DIR)/tclGetDate.y $(DISTDIR)/generic - cp -p $(TOP_DIR)/changes $(TOP_DIR)/README* $(TOP_DIR)/license.terms \ - $(DISTDIR) - mkdir $(DISTDIR)/library - cp -p $(TOP_DIR)/license.terms $(TOP_DIR)/library/*.tcl \ - $(TOP_DIR)/library/tclIndex $(DISTDIR)/library - for i in http2.0 http1.0 opt0.1; \ - do \ - mkdir $(DISTDIR)/library/$$i ;\ - cp -p $(TOP_DIR)/library/$$i/*.tcl $(DISTDIR)/library/$$i; \ - done; - mkdir $(DISTDIR)/doc - cp -p $(TOP_DIR)/license.terms $(TOP_DIR)/doc/*.[13n] \ - $(TOP_DIR)/doc/man.macros $(DISTDIR)/doc - mkdir $(DISTDIR)/compat - cp -p $(TOP_DIR)/license.terms $(TOP_DIR)/compat/*.c \ - $(TOP_DIR)/compat/*.h $(TOP_DIR)/compat/README \ - $(DISTDIR)/compat - mkdir $(DISTDIR)/tests - cp -p $(TOP_DIR)/license.terms $(DISTDIR)/tests - cp -p $(TOP_DIR)/tests/*.test $(TOP_DIR)/tests/README \ - $(TOP_DIR)/tests/all $(TOP_DIR)/tests/*.tcl \ - $(TOP_DIR)/tests/defs $(DISTDIR)/tests - mkdir $(DISTDIR)/tests/pkg - cp -p $(TOP_DIR)/license.terms $(DISTDIR)/tests/pkg - cp -p $(TOP_DIR)/tests/pkg/*.tcl $(DISTDIR)/tests/pkg - mkdir $(DISTDIR)/win - cp -p $(TOP_DIR)/win/*.c $(TOP_DIR)/win/*.h $(TOP_DIR)/win/*.rc \ - $(DISTDIR)/win - cp -p $(TOP_DIR)/win/*.bat $(DISTDIR)/win - cp -p $(TOP_DIR)/win/makefile.* $(DISTDIR)/win - cp -p $(TOP_DIR)/win/README $(DISTDIR)/win - cp -p $(TOP_DIR)/win/pkgIndex.tcl $(DISTDIR)/win - cp -p $(TOP_DIR)/license.terms $(DISTDIR)/win - mkdir $(DISTDIR)/mac - cp -p $(TOP_DIR)/mac/tclMacProjects.sea.hqx $(DISTDIR)/mac - cp -p $(TOP_DIR)/mac/*.c $(TOP_DIR)/mac/*.h $(TOP_DIR)/mac/*.r \ - $(DISTDIR)/mac - cp -p $(TOP_DIR)/mac/porting.notes $(TOP_DIR)/mac/README $(DISTDIR)/mac - cp -p $(TOP_DIR)/mac/*.exp $(TOP_DIR)/mac/*.pch $(DISTDIR)/mac - cp -p $(TOP_DIR)/mac/*.doc $(DISTDIR)/mac - cp -p $(TOP_DIR)/mac/*.html $(DISTDIR)/mac - cp -p $(TOP_DIR)/license.terms $(DISTDIR)/mac - mkdir $(DISTDIR)/unix/dltest - cp -p $(UNIX_DIR)/dltest/*.c $(UNIX_DIR)/dltest/Makefile.in \ - $(DISTDIR)/unix/dltest - cp -p $(UNIX_DIR)/dltest/configure.in $(UNIX_DIR)/dltest/configure \ - $(UNIX_DIR)/dltest/README $(DISTDIR)/unix/dltest - -# -# The following target can only be used for non-patch releases. Use -# the "allpatch" target below for patch releases. -# - -alldist: dist - rm -f $(DISTROOT)/$(DISTNAME).tar.Z \ - $(DISTROOT)/$(DISTNAME).tar.gz \ - $(DISTROOT)/$(ZIPNAME) - cd $(DISTROOT); tar cf $(DISTNAME).tar $(DISTNAME); \ - gzip -9 -c $(DISTNAME).tar > $(DISTNAME).tar.gz; \ - compress $(DISTNAME).tar; zip -r8 $(ZIPNAME) $(DISTNAME) - -# -# The target below is similar to "alldist" except it works for patch -# releases. It is needed because patch releases are peculiar: the -# patch designation appears in the name of the compressed file -# (e.g. tcl8.0p1.tar.gz) but the extracted source directory doesn't -# include the patch designation (e.g. tcl8.0). -# - -allpatch: dist - rm -f $(DISTROOT)/$(DISTNAME).tar.Z \ - $(DISTROOT)/$(DISTNAME).tar.gz \ - $(DISTROOT)/$(ZIPNAME) - mv $(DISTROOT)/tcl${VERSION} $(DISTROOT)/old - mv $(DISTROOT)/$(DISTNAME) $(DISTROOT)/tcl${VERSION} - cd $(DISTROOT); tar cf $(DISTNAME).tar tcl${VERSION}; \ - gzip -9 -c $(DISTNAME).tar > $(DISTNAME).tar.gz; \ - compress $(DISTNAME).tar; zip -r8 $(ZIPNAME) tcl${VERSION} - mv $(DISTROOT)/tcl${VERSION} $(DISTROOT)/$(DISTNAME) - mv $(DISTROOT)/old $(DISTROOT)/tcl${VERSION} - -# -# 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 group's tool workspace. -# - -macdist: dist machtml - -machtml: - rm -f $(DISTDIR)/mac/tclMacProjects.sea.hqx - tclsh $(TOOL_DIR)/man2html.tcl $(DISTDIR)/tmp ../.. tcl$(VERSION) - mv $(DISTDIR)/tmp/tcl$(VERSION) $(DISTDIR)/html - rm -rf $(DISTDIR)/doc - rm -rf $(DISTDIR)/tmp - tclsh $(TOOL_DIR)/cvtEOL.tcl $(DISTDIR) - -# -# Targets to build Solaris package of the distribution for the current -# architecture. To build stream packages for both sun4 and i86pc -# architectures: -# -# On the sun4 machine, execute the following: -# make distclean; ./configure -# make DISTDIR=<distdir> package -# -# Once the build is complete, execute the following on the i86pc -# machine: -# make DISTDIR=<distdir> package-quick -# -# <distdir> is the absolute path to a directory where the build should -# take place. These steps will generate the $(PACKAGE).sun4 and -# $(PACKAGE).i86pc stream packages. It is important that the packages be -# built in this fashion in order to ensure that the architecture -# independent files are exactly the same, including timestamps, in -# both packages. -# - -PACKAGE=SCRPtcl - -package: dist package-config package-common package-binaries package-generate -package-quick: package-config package-binaries package-generate - -# -# Configure for the current architecture in the dist directory. -# -package-config: - mkdir -p $(DISTDIR)/unix/`arch` - cd $(DISTDIR)/unix/`arch`; \ - ../configure --prefix=/opt/$(PACKAGE)/$(VERSION) \ - --exec_prefix=/opt/$(PACKAGE)/$(VERSION)/`arch` \ - --enable-shared - mkdir -p $(DISTDIR)/$(PACKAGE)/$(VERSION) - mkdir -p $(DISTDIR)/$(PACKAGE)/$(VERSION)/`arch` - -# -# Build and install the architecture independent files in the dist directory. -# - -package-common: - cd $(DISTDIR)/unix/`arch`;\ - $(MAKE); \ - $(MAKE) prefix=$(DISTDIR)/$(PACKAGE)/$(VERSION) \ - exec_prefix=$(DISTDIR)/$(PACKAGE)/$(VERSION)/`arch` \ - install-libraries install-man - mkdir -p $(DISTDIR)/$(PACKAGE)/$(VERSION)/bin - sed -e "s/TCLVERSION/$(VERSION)/g" < $(UNIX_DIR)/tclsh.sh \ - > $(DISTDIR)/$(PACKAGE)/$(VERSION)/bin/tclsh$(VERSION) - chmod 755 $(DISTDIR)/$(PACKAGE)/$(VERSION)/bin/tclsh$(VERSION) - -# -# Build and install the architecture specific files in the dist directory. -# - -package-binaries: - cd $(DISTDIR)/unix/`arch`; \ - $(MAKE); \ - $(MAKE) install-binaries prefix=$(DISTDIR)/$(PACKAGE)/$(VERSION) \ - exec_prefix=$(DISTDIR)/$(PACKAGE)/$(VERSION)/`arch` - -# -# Generate a package from the installed files in the dist directory for the -# current architecture. -# - -package-generate: - pkgproto $(DISTDIR)/$(PACKAGE)/$(VERSION)/bin=bin \ - $(DISTDIR)/$(PACKAGE)/$(VERSION)/include=include \ - $(DISTDIR)/$(PACKAGE)/$(VERSION)/lib=lib \ - $(DISTDIR)/$(PACKAGE)/$(VERSION)/man=man \ - $(DISTDIR)/$(PACKAGE)/$(VERSION)/`arch`=`arch` \ - | tclsh $(UNIX_DIR)/mkProto.tcl \ - $(VERSION) $(UNIX_DIR) > prototype - pkgmk -o -d . -f prototype -a `arch` - pkgtrans -s . $(PACKAGE).`arch` $(PACKAGE) - rm -rf $(PACKAGE) - -# DO NOT DELETE THIS LINE -- make depend depends on it. diff --git a/unix/README b/unix/README deleted file mode 100644 index 5d30ab9..0000000 --- a/unix/README +++ /dev/null @@ -1,103 +0,0 @@ -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. - -RCS: @(#) $Id: README,v 1.3 1999/02/09 03:31:55 stanton Exp $ - -How To Compile And Install Tcl: -------------------------------- - -(a) Check for patches as described in ../README. - -(b) If you have already compiled Tcl once in this directory and are now - preparing to compile again in the same directory but for a different - platform, or if you have applied patches, type "make distclean" to - discard all the configuration information computed previously. - -(c) Type "./configure". This runs a configuration script created by GNU - autoconf, which configures Tcl for your system and creates a - Makefile. The configure script allows you to customize the Tcl - configuration for your site; for details on how you can do this, - type "./configure -help" or refer to the autoconf documentation (not - included here). Tcl's "configure" supports the following special - switches in addition to the standard ones: - --enable-gcc If this switch is set, Tcl will configure - itself to use gcc if it is available on your - system. Note: it is not safe to modify the - Makefile to use gcc after configure is run; - if you do this, then information related to - dynamic linking will be incorrect. - --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. - -(d) 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. - -(e) If the make fails then you'll have to personalize the Makefile - for your site or possibly modify the distribution in other ways. - First check the 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. - -(f) Type "make install" to install Tcl binaries and script files in - standard places. You'll need write permission on the installation - directories to do this. The installation directories are - determined by the "configure" script and may be specified with - the --prefix and --exec_prefix options to "configure". See the - Makefile for information on what directories were chosen; you - can override these choices by modifying the "prefix" and - "exec_prefix" variables in the Makefile. - -(g) At this point you can play with Tcl by invoking the "tclsh" - program and typing Tcl commands. However, if you haven't installed - Tcl then you'll first need to set your TCL_LIBRARY variable to - hold the full path name of the "library" subdirectory. Note that - the installed versions of tclsh, libtcl.a, and libtcl.so have a - version number in their names, such as "tclsh8.0" or "libtcl8.0.so"; - to use the installed versions, either specify the version number - or create a symbolic link (e.g. from "tclsh" to "tclsh8.0"). - -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. 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/unix/configure.in b/unix/configure.in deleted file mode 100644 index 67b3f6e..0000000 --- a/unix/configure.in +++ /dev/null @@ -1,1307 +0,0 @@ -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) -# RCS: @(#) $Id: configure.in,v 1.28 1999/02/03 18:37:42 stanton Exp $ - -TCL_VERSION=8.0 -TCL_MAJOR_VERSION=8 -TCL_MINOR_VERSION=0 -TCL_PATCH_LEVEL=".5" -VERSION=${TCL_VERSION} - -if test "${prefix}" = "NONE"; then - prefix=/usr/local -fi -if test "${exec_prefix}" = "NONE"; then - exec_prefix=$prefix -fi -TCL_SRC_DIR=`cd $srcdir/..; pwd` - -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 - -# set the warning flags depending on whether or not we are using gcc -if test "${GCC}" = "yes" ; then - CFLAGS_WARNING="-Wall -Wconversion" -else - CFLAGS_WARNING="" -fi - -#------------------------------------------------------------------------------ -# If we're using GCC, see if the compiler understands -pipe. If so, use it. -# It makes compiling go faster. (This is only a performance feature.) -#------------------------------------------------------------------------------ - -if test -z "$no_pipe"; then -if test -n "$GCC"; then - AC_MSG_CHECKING([if the compiler understands -pipe]) - OLDCC="$CC" - CC="$CC -pipe" - AC_TRY_COMPILE(,, - AC_MSG_RESULT(yes), - CC="$OLDCC" - AC_MSG_RESULT(no)) -fi -fi - -#-------------------------------------------------------------------- -# Supply substitutes for missing POSIX library procedures, or -# set flags so Tcl uses alternate procedures. -#-------------------------------------------------------------------- - -# Check if Posix compliant getcwd exists, if not we'll use getwd. -AC_CHECK_FUNCS(getcwd, , AC_DEFINE(USEGETWD)) -# Nb: if getcwd uses popen and pwd(1) (like SunOS 4) we should really -# define USEGETWD even if the posix getcwd exists. Add a test ? - -AC_REPLACE_FUNCS(opendir strstr) - -AC_REPLACE_FUNCS(strtol tmpnam waitpid) -AC_CHECK_FUNC(strerror, , AC_DEFINE(NO_STRERROR)) -AC_CHECK_FUNC(getwd, , AC_DEFINE(NO_GETWD)) -AC_CHECK_FUNC(wait3, , AC_DEFINE(NO_WAIT3)) -AC_CHECK_FUNC(uname, , AC_DEFINE(NO_UNAME)) - -#-------------------------------------------------------------------- -# 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"]) - -#-------------------------------------------------------------------- -# On AIX systems, libbsd.a has to be linked in to support -# non-blocking file IO. This library has to be linked in after -# the MATH_LIBS or it breaks the pow() function. The way to -# insure proper sequencing, is to add it to the tail of MATH_LIBS. -# This library also supplies gettimeofday. -#-------------------------------------------------------------------- -libbsd=no -if test "`uname -s`" = "AIX" ; then - AC_CHECK_LIB(bsd, gettimeofday, libbsd=yes) - if test $libbsd = yes; then - MATH_LIBS="$MATH_LIBS -lbsd" - fi -fi - -#-------------------------------------------------------------------- -# 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(values.h, , AC_DEFINE(NO_VALUES_H)) -AC_CHECK_HEADER(limits.h, , AC_DEFINE(NO_LIMITS_H)) -AC_CHECK_HEADER(stdlib.h, tcl_ok=1, tcl_ok=0) -AC_EGREP_HEADER(strtol, stdlib.h, , tcl_ok=0) -AC_EGREP_HEADER(strtoul, stdlib.h, , tcl_ok=0) -AC_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_CHECK_HEADER(dlfcn.h, , AC_DEFINE(NO_DLFCN_H)) -AC_HAVE_HEADERS(unistd.h) - -#--------------------------------------------------------------------------- -# Determine which interface to use to talk to the serial port. -# Note that #include lines must begin in leftmost column for -# some compilers to recognize them as preprocessor directives. -#--------------------------------------------------------------------------- - -AC_MSG_CHECKING([termios vs. termio vs. sgtty]) -AC_TRY_RUN([ -#include <termios.h> - -main() -{ - struct termios t; - if (tcgetattr(0, &t) == 0) { - cfsetospeed(&t, 0); - t.c_cflag |= PARENB | PARODD | CSIZE | CSTOPB; - return 0; - } - return 1; -}], tk_ok=termios, tk_ok=no, tk_ok=no) -if test $tk_ok = termios; then - AC_DEFINE(USE_TERMIOS) -else -AC_TRY_RUN([ -#include <termio.h> - -main() -{ - struct termio t; - if (ioctl(0, TCGETA, &t) == 0) { - t.c_cflag |= CBAUD | PARENB | PARODD | CSIZE | CSTOPB; - return 0; - } - return 1; -}], tk_ok=termio, tk_ok=no, tk_ok=no) -if test $tk_ok = termio; then - AC_DEFINE(USE_TERMIO) -else -AC_TRY_RUN([ -#include <sgtty.h> - -main() -{ - struct sgttyb t; - if (ioctl(0, TIOCGETP, &t) == 0) { - t.sg_ospeed = 0; - t.sg_flags |= ODDP | EVENP | RAW; - return 0; - } - return 1; -}], tk_ok=sgtty, tk_ok=none, tk_ok=none) -if test $tk_ok = sgtty; then - AC_DEFINE(USE_SGTTY) -fi -fi -fi -AC_MSG_RESULT($tk_ok) - -#-------------------------------------------------------------------- -# 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. -# -have_timezone=no -AC_MSG_CHECKING([long timezone variable]) -AC_TRY_COMPILE([#include <time.h>], - [extern long timezone; - timezone += 1; - exit (0);], - [have_timezone=yes - AC_DEFINE(HAVE_TIMEZONE_VAR) - AC_MSG_RESULT(yes)], - AC_MSG_RESULT(no)) - -# -# On some systems (eg IRIX 6.2), timezone is a time_t and not a long. -# -if test "$have_timezone" = no; then - AC_MSG_CHECKING([time_t timezone variable]) - AC_TRY_COMPILE([#include <time.h>], - [extern time_t timezone; - timezone += 1; - exit (0);], - [AC_DEFINE(HAVE_TIMEZONE_VAR) - AC_MSG_RESULT(yes)], - AC_MSG_RESULT(no)) -fi - -# -# AIX does not have a timezone field in struct tm. When the AIX bsd -# library is used, the timezone global and the gettimeofday methods are -# to be avoided for timezone deduction instead, we deduce the timezone -# by comparing the localtime result on a known GMT value. -# -if test $libbsd = yes; then - AC_DEFINE(USE_DELTA_FOR_TZ) -fi - -#-------------------------------------------------------------------- -# Some systems (e.g., IRIX 4.0.5) lack the st_blksize field -# in struct stat. -#-------------------------------------------------------------------- -AC_STRUCT_ST_BLKSIZE - -#-------------------------------------------------------------------- -# 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_TYPE_SIGNAL() -AC_CHECK_FUNC(vfork, tcl_ok=1, tcl_ok=0) -if test "$tcl_ok" = 1; then - AC_MSG_CHECKING([vfork/signal bug]); - AC_TRY_RUN([ -#include <stdio.h> -#include <signal.h> -#include <sys/wait.h> -int gotSignal = 0; -sigProc(sig) - int sig; -{ - gotSignal = 1; -} -main() -{ - int pid, sts; - (void) signal(SIGCHLD, sigProc); - pid = vfork(); - if (pid < 0) { - exit(1); - } else if (pid == 0) { - (void) signal(SIGCHLD, SIG_DFL); - _exit(0); - } else { - (void) wait(&sts); - } - exit((gotSignal) ? 0 : 1); -}], tcl_ok=1, tcl_ok=0, tcl_ok=0) - if test "$tcl_ok" = 1; then - AC_MSG_RESULT(ok) - else - AC_MSG_RESULT([buggy, using fork instead]) - fi -fi -rm -f core -if test "$tcl_ok" = 0; then - AC_DEFINE(vfork, fork) -fi - -#-------------------------------------------------------------------- -# Check whether there is an strncasecmp function on this system. -# This is a bit tricky because under SCO it's in -lsocket and -# under Sequent Dynix it's in -linet. -#-------------------------------------------------------------------- - -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)) - -#-------------------------------------------------------------------- -# The following code checks to see whether it is possible to get -# signed chars on this platform. This is needed in order to -# properly generate sign-extended ints from character values. -#-------------------------------------------------------------------- - -AC_C_CHAR_UNSIGNED -AC_MSG_CHECKING([signed char declarations]) -AC_TRY_COMPILE(, [ -signed char *p; -p = 0; -], tcl_ok=yes, tcl_ok=no) -AC_MSG_RESULT($tcl_ok) -if test $tcl_ok = yes; then - AC_DEFINE(HAVE_SIGNED_CHAR) -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 -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_RUNTIME_DIR in the Makefile. -# MAKE_LIB - Command to execute to build the Tcl library; -# differs depending on whether or not Tcl is being -# compiled as a shared library. -# 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.8.so or libtcl7.8.a. -# TCL_LIB_SUFFIX -Specifies everything that comes after the "libtcl" -# in the shared library name, using the $VERSION variable -# 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: set configuration options based on system name and version. - -fullSrcDir=`cd $srcdir; pwd` -EXTRA_CFLAGS="" -TCL_UNSHARED_LIB_SUFFIX="" -TCL_TRIM_DOTS='`echo ${VERSION} | tr -d .`' -ECHO_VERSION='`echo ${VERSION}`' -TCL_LIB_VERSIONS_OK=ok -CFLAGS_DEBUG=-g -CFLAGS_OPTIMIZE=-O -case $system in - AIX-4.[[2-9]]) - SHLIB_CFLAGS="" - SHLIB_LD="$fullSrcDir/ldAix /bin/ld -bhalt:4 -bM:SRE -bE:lib.exp -H512 -T512 -bnoentry" - SHLIB_LD_LIBS='${LIBS}' - SHLIB_SUFFIX=".so" - DL_OBJS="tclLoadDl.o" - DL_LIBS="-ldl" - LD_FLAGS="" - LD_SEARCH_FLAGS='-L${LIB_RUNTIME_DIR}' - AIX=yes - TCL_SHARED_LIB_SUFFIX='${VERSION}\$\{DBGX\}.a' - ;; - AIX-*) - SHLIB_CFLAGS="" - SHLIB_LD="$fullSrcDir/ldAix /bin/ld -bhalt:4 -bM:SRE -bE:lib.exp -H512 -T512 -bnoentry" - SHLIB_LD_LIBS='${LIBS}' - SHLIB_SUFFIX=".so" - DL_OBJS="tclLoadDl.o tclLoadAix.o" - DL_LIBS="-lld" - LD_FLAGS="" - LD_SEARCH_FLAGS='-L${LIB_RUNTIME_DIR}' - TCL_SHARED_LIB_SUFFIX='${VERSION}\$\{DBGX\}.a' - ;; - BSD/OS-2.1*|BSD/OS-3*|BSD/OS-4*) - SHLIB_CFLAGS="" - SHLIB_LD="shlicc -r" - SHLIB_LD_LIBS='${LIBS}' - SHLIB_SUFFIX=".so" - DL_OBJS="tclLoadDl.o" - DL_LIBS="-ldl" - LD_FLAGS="" - LD_SEARCH_FLAGS="" - ;; - dgux*) - 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="" - ;; - HP-UX-*.08.*|HP-UX-*.09.*|HP-UX-*.10.*) - SHLIB_SUFFIX=".sl" - AC_CHECK_LIB(dld, shl_load, tcl_ok=yes, tcl_ok=no) - if test "$tcl_ok" = yes; then - SHLIB_CFLAGS="+z" - SHLIB_LD="ld -b" - SHLIB_LD_LIBS="" - DL_OBJS="tclLoadShl.o" - DL_LIBS="-ldld" - LD_FLAGS="-Wl,-E" - LD_SEARCH_FLAGS='-Wl,+s,+b,${LIB_RUNTIME_DIR}:.' - fi - ;; - IRIX-4.*) - SHLIB_CFLAGS="-G 0" - SHLIB_SUFFIX=".a" - SHLIB_LD="echo tclLdAout $CC \{$SHLIB_CFLAGS\} | `pwd`/tclsh -r -G 0" - SHLIB_LD_LIBS='${LIBS}' - DL_OBJS="tclLoadAout.o" - DL_LIBS="" - LD_FLAGS="-Wl,-D,08000000" - LD_SEARCH_FLAGS='-L${LIB_RUNTIME_DIR}' - TCL_SHARED_LIB_SUFFIX='${VERSION}\$\{DBGX\}.a' - ;; - IRIX-5.*|IRIX-6.*|IRIX64-6.5*) - SHLIB_CFLAGS="" - SHLIB_LD="ld -n32 -shared -rdata_shared" - SHLIB_LD_LIBS='${LIBS}' - SHLIB_SUFFIX=".so" - DL_OBJS="tclLoadDl.o" - DL_LIBS="" - LD_SEARCH_FLAGS='-Wl,-rpath,${LIB_RUNTIME_DIR}' - if test "$CC" = "gcc" -o `$CC -v 2>&1 | grep -c gcc` != "0" ; then - EXTRA_CFLAGS="-mabi=n32" - LD_FLAGS="-mabi=n32" - else - case $system in - IRIX-6.3) - # Use to build 6.2 compatible binaries on 6.3. - EXTRA_CFLAGS="-n32 -D_OLD_TERMIOS" - ;; - *) - EXTRA_CFLAGS="-n32" - ;; - esac - LD_FLAGS="-n32" - fi - ;; - IRIX64-6.*) - SHLIB_CFLAGS="" - SHLIB_LD="ld -32 -shared -rdata_shared -rpath /usr/local/lib" - SHLIB_LD_LIBS="" - SHLIB_SUFFIX=".so" - DL_OBJS="tclLoadDl.o" - DL_LIBS="" - LD_FLAGS="" - LD_SEARCH_FLAGS='-Wl,-rpath,${LIB_RUNTIME_DIR}' - ;; - Linux*) - SHLIB_CFLAGS="-fPIC" - SHLIB_LD_LIBS='${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-*|OpenBSD-*) - # Not available on all versions: check for include file. - AC_CHECK_HEADER(dlfcn.h, [ - SHLIB_CFLAGS="-fpic" - SHLIB_LD="ld -Bshareable -x" - SHLIB_LD_LIBS="" - SHLIB_SUFFIX=".so" - DL_OBJS="tclLoadDl.o" - DL_LIBS="" - LD_FLAGS="" - LD_SEARCH_FLAGS="" - TCL_SHARED_LIB_SUFFIX='${TCL_TRIM_DOTS}\$\{DBGX\}.so.1.0' - ], [ - SHLIB_CFLAGS="" - SHLIB_LD="echo tclLdAout $CC \{$SHLIB_CFLAGS\} | `pwd`/tclsh -r" - SHLIB_LD_LIBS='${LIBS}' - SHLIB_SUFFIX=".a" - DL_OBJS="tclLoadAout.o" - DL_LIBS="" - LD_FLAGS="" - LD_SEARCH_FLAGS='-L${LIB_RUNTIME_DIR}' - TCL_SHARED_LIB_SUFFIX='${TCL_TRIM_DOTS}\$\{DBGX\}.a' - ]) - - # FreeBSD doesn't handle version numbers with dots. - - TCL_UNSHARED_LIB_SUFFIX='${TCL_TRIM_DOTS}\$\{DBGX\}.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.0|OSF1-1.1|OSF1-1.2) - # 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_RUNTIME_DIR}' - ;; - RISCos-*) - SHLIB_CFLAGS="-G 0" - SHLIB_LD="echo tclLdAout $CC \{$SHLIB_CFLAGS\} | `pwd`/tclsh -r -G 0" - SHLIB_LD_LIBS='${LIBS}' - SHLIB_SUFFIX=".a" - DL_OBJS="tclLoadAout.o" - DL_LIBS="" - LD_FLAGS="-Wl,-D,08000000" - LD_SEARCH_FLAGS='-L${LIB_RUNTIME_DIR}' - ;; - 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_RUNTIME_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='${TCL_TRIM_DOTS}\$\{DBGX\}.so.1.0' - TCL_UNSHARED_LIB_SUFFIX='${TCL_TRIM_DOTS}\$\{DBGX\}.a' - TCL_LIB_VERSIONS_OK=nodots - ;; - SunOS-5*) - SHLIB_CFLAGS="-KPIC" - SHLIB_LD="/usr/ccs/bin/ld -G -z text" - - # Note: need the LIBS below, otherwise Tk won't find Tcl's - # symbols when dynamically loaded into tclsh. - - SHLIB_LD_LIBS='${LIBS}' - SHLIB_SUFFIX=".so" - DL_OBJS="tclLoadDl.o" - DL_LIBS="-ldl" - LD_FLAGS="" - LD_SEARCH_FLAGS='-R ${LIB_RUNTIME_DIR}' - ;; - ULTRIX-4.*) - SHLIB_CFLAGS="-G 0" - SHLIB_SUFFIX=".a" - SHLIB_LD="echo tclLdAout $CC \{$SHLIB_CFLAGS\} | `pwd`/tclsh -r -G 0" - SHLIB_LD_LIBS='${LIBS}' - DL_OBJS="tclLoadAout.o" - DL_LIBS="" - LD_FLAGS="-Wl,-D,08000000" - LD_SEARCH_FLAGS='-L${LIB_RUNTIME_DIR}' - ;; - UNIX_SV* | UnixWare-5*) - SHLIB_CFLAGS="-KPIC" - SHLIB_LD="cc -G" - SHLIB_LD_LIBS="" - SHLIB_SUFFIX=".so" - DL_OBJS="tclLoadDl.o" - DL_LIBS="-ldl" - # Some UNIX_SV* systems (unixware 1.1.2 for example) have linkers - # that don't grok the -Bexport option. Test that it does. - hold_ldflags=$LDFLAGS - AC_MSG_CHECKING(for ld accepts -Bexport flag) - LDFLAGS="${LDFLAGS} -Wl,-Bexport" - AC_TRY_LINK(, [int i;], found=yes, found=no) - LDFLAGS=$hold_ldflags - AC_MSG_RESULT($found) - if test $found = yes; then - LD_FLAGS="-Wl,-Bexport" - else - LD_FLAGS="" - fi - LD_SEARCH_FLAGS="" - ;; -esac - -# Step 4: 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 - -# Step 5: 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 - DL_OBJS="" -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 - case $system in - AIX-*) - ;; - BSD/OS*) - ;; - IRIX*) - ;; - NetBSD-*|FreeBSD-*|OpenBSD-*) - ;; - RISCos-*) - ;; - ULTRIX-4.*) - ;; - *) - SHLIB_CFLAGS="-fPIC" - ;; - esac - fi -fi - -# Set the default compiler switches based on the --enable-symbols option - -AC_ARG_ENABLE(symbols, [ --enable-symbols build with debugging symbols], - [tcl_ok=$enableval], [tcl_ok=no]) -if test "$tcl_ok" = "yes"; then - CFLAGS_DEFAULT=CFLAGS_DEBUG - TCL_DBGX=g -else - CFLAGS_DEFAULT=CFLAGS_OPTIMIZE - TCL_DBGX="" -fi - -#-------------------------------------------------------------------- -# The statements below check for systems where POSIX-style -# non-blocking I/O (O_NONBLOCK) doesn't work or is unimplemented. -# On these systems (mostly older ones), use the old BSD-style -# FIONBIO approach instead. -#-------------------------------------------------------------------- - -AC_CHECK_HEADERS(sys/ioctl.h) -AC_CHECK_HEADERS(sys/filio.h) -AC_MSG_CHECKING([FIONBIO vs. O_NONBLOCK for nonblocking I/O]) -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 - 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 - fi -fi -case $system in - # There used to be code here to use FIONBIO under AIX. However, it - # was reported that FIONBIO doesn't work under AIX 3.2.5. Since - # using O_NONBLOCK seems fine under AIX 4.*, I removed the FIONBIO - # code (JO, 5/31/97). - - OSF*) - AC_DEFINE(USE_FIONBIO) - AC_MSG_RESULT(FIONBIO) - ;; - SunOS-4*) - AC_DEFINE(USE_FIONBIO) - AC_MSG_RESULT(FIONBIO) - ;; - ULTRIX-4.*) - AC_DEFINE(USE_FIONBIO) - AC_MSG_RESULT(FIONBIO) - ;; - *) - AC_MSG_RESULT(O_NONBLOCK) - ;; -esac - -#-------------------------------------------------------------------- -# 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}\$\{DBGX\}${SHLIB_SUFFIX}' -fi -if test "$TCL_UNSHARED_LIB_SUFFIX" = "" ; then - TCL_UNSHARED_LIB_SUFFIX='${VERSION}\$\{DBGX\}.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}" != "" ; then - TCL_SHARED_BUILD=1 - TCL_SHLIB_CFLAGS="${SHLIB_CFLAGS}" - TCL_LD_SEARCH_FLAGS="${LD_SEARCH_FLAGS}" - eval "TCL_LIB_FILE=libtcl${TCL_SHARED_LIB_SUFFIX}" - if test "x$DL_OBJS" = "xtclLoadAout.o"; then - MAKE_LIB="ar cr \${TCL_LIB_FILE} \${OBJS}" - else - MAKE_LIB="\${SHLIB_LD} -o \${TCL_LIB_FILE} \${OBJS} ${SHLIB_LD_LIBS}" - RANLIB=":" - fi -else - TCL_SHARED_BUILD=0 - case $system in - BSD/OS*) - ;; - - AIX-*) - ;; - - *) - SHLIB_LD_LIBS="" - ;; - esac - 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_LIB_FLAG="-ltcl${TCL_VERSION}\${TCL_DBGX}" -else - TCL_LIB_FLAG="-ltcl`echo ${TCL_VERSION} | tr -d .`\${TCL_DBGX}" -fi -TCL_BUILD_LIB_SPEC="-L`pwd` ${TCL_LIB_FLAG}" -TCL_LIB_SPEC="-L${exec_prefix}/lib ${TCL_LIB_FLAG}" - -# tclConfig.sh needs a version of the _LIB_SUFFIX that has been eval'ed -# so that the backslashes quoting the DBX braces are dropped. - -# Trick to replace DBGX with TCL_DBGX -DBGX='${TCL_DBGX}' -eval "TCL_LIB_FILE=${TCL_LIB_FILE}" - -VERSION='${VERSION}' -eval "CFG_TCL_SHARED_LIB_SUFFIX=${TCL_SHARED_LIB_SUFFIX}" -eval "CFG_TCL_UNSHARED_LIB_SUFFIX=${TCL_UNSHARED_LIB_SUFFIX}" - -#-------------------------------------------------------------------- -# The statements below define the symbol TCL_PACKAGE_PATH, which -# gives a list of directories that may contain packages. The list -# consists of one directory for machine-dependent binaries and -# another for platform-independent scripts. -#-------------------------------------------------------------------- - -if test "$prefix" != "$exec_prefix"; then - TCL_PACKAGE_PATH="${exec_prefix}/lib ${prefix}/lib" -else - TCL_PACKAGE_PATH="${prefix}/lib" -fi - -AC_SUBST(BUILD_DLTEST) -AC_SUBST(CFLAGS_DEBUG) -AC_SUBST(CFLAGS_DEFAULT) -AC_SUBST(CFLAGS_OPTIMIZE) -AC_SUBST(CFLAGS_WARNING) -AC_SUBST(CFG_TCL_SHARED_LIB_SUFFIX) -AC_SUBST(CFG_TCL_UNSHARED_LIB_SUFFIX) -AC_SUBST(TCL_DBGX) -AC_SUBST(DL_LIBS) -AC_SUBST(DL_OBJS) -AC_SUBST(EXTRA_CFLAGS) -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_FLAG) -AC_SUBST(TCL_LIB_SPEC) -AC_SUBST(TCL_LIB_VERSIONS_OK) -AC_SUBST(TCL_MAJOR_VERSION) -AC_SUBST(TCL_MINOR_VERSION) -AC_SUBST(TCL_PACKAGE_PATH) -AC_SUBST(TCL_PATCH_LEVEL) -AC_SUBST(TCL_SHARED_LIB_SUFFIX) -AC_SUBST(TCL_SHARED_BUILD) -AC_SUBST(TCL_SHLIB_CFLAGS) -AC_SUBST(TCL_SRC_DIR) -AC_SUBST(TCL_UNSHARED_LIB_SUFFIX) -AC_SUBST(TCL_VERSION) - -AC_OUTPUT(Makefile tclConfig.sh) diff --git a/win/README b/win/README deleted file mode 100644 index 383cf7e..0000000 --- a/win/README +++ /dev/null @@ -1,189 +0,0 @@ -Tcl 8.0.5 for Windows - -by Scott Stanton -Scriptics Corporation -scott.stanton@scriptics.com - -RCS: @(#) $Id: README,v 1.9 1999/02/09 03:31:55 stanton Exp $ - -1. Introduction ---------------- - -This is the directory where you configure and compile the Windows -version of Tcl. This directory also contains source files for Tcl -that are specific to Microsoft Windows. The rest of this file -contains information specific to the Windows version of Tcl. - -2. Distribution notes ---------------------- - -Tcl 8.0 for Windows is distributed in binary form in addition to the -common source release. The binary distribution is a self-extracting -archive with a built-in installation script. - -Look for the binary release in the same location as the source release -(http://www.scriptics.com/software/8.0.html or any of the mirror -sites). For most users, the binary release will be much easier to -install and use. You only need the source release if you plan to -modify the core of Tcl, or if you need to compile with a different -compiler. With the addition of the dynamic loading interface, it is -no longer necessary to have the source distribution in order to build -and use extensions. - -3. Compiling Tcl ----------------- - -In order to compile Tcl for Windows, you need the following items: - - Tcl 8.0 Source Distribution (plus any patches) - - Borland C++ 4.52 (both 16-bit and 32-bit compilers) - or - Visual C++ 2.x/4.x/5.x - -In practice, the 8.0.5 release is built with Visual C++ 5.0 - -In the "win" subdirectory of the source release, you will find two -files called "makefile.bc" and "makefile.vc". These are the makefiles -for the Borland and Visual C++ compilers respectively. You should -copy the appropriate one to "makefile" and update the paths at the -top of the file to reflect your system configuration. Now you can use -"make" (or "nmake" for VC++) to build the tcl libraries and the tclsh -executable. - -In order to use the binaries generated by these makefiles, you will -need to place the Tcl script library files someplace where Tcl can -find them. Tcl looks in one of three places for the library files: - - 1) The path specified in the environment variable "TCL_LIBRARY". - - 2) In the lib\tcl8.0 directory under the installation directory - as specified in the registry: - - HKEY_LOCAL_MACHINE\SOFTWARE\Scriptics\Tcl\8.0 - - 3) Relative to the directory containing the current .exe. - Tcl will look for a directory "..\lib\tcl8.0" relative to the - directory containing the currently running .exe. - -Note that in order to run tclsh80.exe, you must ensure that tcl80.dll -and tclpip80.dll are on your path, in the system directory, or in the -directory containing tclsh80.exe. - -4. Building Extensions ----------------------- - -With the Windows compilers you have to worry about how you export symbols -from DLLs. tcl.h defines a few macros to help solve this problem: - -EXTERN - all Tcl_ function prototypes use this macro, which implies - they are exported. You'll see this used in tcl.h and tk.h. - You should use this in your exported procedures. - However, this is not the whole story. -TCL_STORAGE_CLASS - this is really an import/export flag, depending on if you are - importing symbols from a DLL (i.e., a user of the DLL), or if - you are exporting symbols from the DLL (i.e., you are building it.) - The EXTERN macro includes TCL_STORAGE_CLASS. - TCL_STORAGE_CLASS is defined to be either DLLIMPORT or DLLEXPORT as - described below. -STATIC_BUILD - define this if you are *not* building a DLL - (e.g., a main program) -DLL_BUILD - define this if you *are* building a DLL -DLLIMPORT - If STATIC_BUILD is defined, this becomes nothing. - (On UNIX, DLLIMPORT is defined to be empty) - Otherwise, this this expands to __declspec(dllimport) -DLLEXPORT - If STATIC_BUILD is defined, this becomes nothing. - (On UNIX, DLLEXPORT is defined to be empty) - Otherwise, this this expands to __declspec(dllexport) - -EXPORT(type, func) - For the Borland compiler, you need to export functions differently. - The DLLEXPORT macro is empty, and instead you need to use - EXPORT because they had a different order. Your declaration will - look like - EXTERN EXPORT(int, Foo_Init)(Tcl_Interp *interp); - -We have not defined EXPORT anywhere. You can paste this into your C file: - -#ifndef STATIC_BUILD -#if defined(_MSC_VER) -# define EXPORT(a,b) __declspec(dllexport) a b -# define DllEntryPoint DllMain -#else -# if defined(__BORLANDC__) -# define EXPORT(a,b) a _export b -# else -# define EXPORT(a,b) a b -# endif -#endif -#endif - - -How to use these: - -Assume your extension is named Foo. In its Makefile, define -BUILD_Foo so that you know you are building Foo and not using it. -Then, in your main header file, foo.h, conditionally define -EXPORT to be either DLLIMPORT or DLLEXPORT based on the -presense of BUILD_Foo, like this: - -#ifndef _FOO -#define _FOO -#include "tcl.h" -/* Additional includes go here */ -/* - * if the BUILD_foo macro is defined, the assumption is that we are - * building the dynamic library. - */ -#ifdef BUILD_Foo -# undef TCL_STORAGE_CLASS -# define TCL_STORAGE_CLASS DLLEXPORT -#endif -/* - * Function prototypes for this module. - */ -EXTERN int Foo_Init _ANSI_ARGS_((Tcl_Interp *interp)); -EXTERN int Foo_SafeInit _ANSI_ARGS_((Tcl_Interp *interp)); -/* Additional prototypes go here */ -/* - * end of foo.h - * reset TCL_STORAGE_CLASS to DLLIMPORT. - */ -# undef TCL_STORAGE_CLASS -# define TCL_STORAGE_CLASS DLLIMPORT -#endif /* _FOO */ - -In your C file, put EXTERN before then functions you need to export. -If you use Borland, you'll need to use the old EXPORT macro, too. - -5. Test suite -------------- - -This distribution contains an extensive test suite for Tcl. Some of -the tests are timing dependent and will fail from time to time. If a -test is failing consistently, please send us a bug report with as much -detail as you can manage. - -In order to run the test suite, you build the "test" target using the -appropriate makefile for your compiler. - - -6. Known Bugs -------------- - -Here is the current list of known bugs/missing features for the -Windows version of Tcl: - -- Blocking "after" commands (e.g. "after 3000") don't work on Win32s. -- Clock command fails to handle daylight savings time boundaries for - things like "last week". -- Background processes aren't properly detached on NT. -- File events only work on sockets. -- Pipes/files/console/serial ports don't support nonblocking I/O. - -If you have comments or bug reports for the Windows version of Tcl, -please direct them to: - -<bugs@scriptics.com> - -or post them to the comp.lang.tcl newsgroup. diff --git a/win/README.binary b/win/README.binary deleted file mode 100644 index fc8d4a1..0000000 --- a/win/README.binary +++ /dev/null @@ -1,518 +0,0 @@ -Tcl/Tk 8.0.5 for Windows, Binary Distribution
-
-%Z% $Id: README.binary,v 1.3 1999/01/04 19:25:05 rjohnson Exp $
-
-1. Introduction
----------------
-
-This directory contains the binary distribution of Tcl/Tk 8.0.5 for
-Windows. It was compiled with Microsoft Visual C++ 5.0 using Win32
-API, so that it will run under Windows NT and Windows 95. The
-information here corresponds to release 8.0. This patch provides
-compatibility with [incr Tcl] 3.0. Tcl 8.0 is a major new release
-that replaces the core of the interpreter with an on-the-fly bytecode
-compiler to improve execution speed. It also includes several other
-new features such as namespaces and binary I/O, plus many bug fixes.
-The compiler introduces a few incompatibilities that may affect
-existing Tcl scripts; the incompatibilities are relatively obscure but
-may require modifications to some old scripts before they can run with
-this version. The compiler introduces many new C-level APIs, but the
-old APIs are still supported. See below for more details. This patch
-release fixes various bugs in Tcl 8.0, plus it adds a few minor
-features to support the TclPro 1.0 tool set and [incr Tcl] 3.0.
-Please check the changes file in the source release for details.
-
-This release also corresponds to Tk 8.0.5. This is a major release with
-significant new features such as native look and feel on Macintoshes
-and PCs, a new font mechanism, application embedding, and proper
-support for Safe-Tcl. See below for details. There should be no
-backward incompatibilities in Tk 8.0.5 that affect scripts.
-
-Note: with this release the Tk version number skips from 4.2 to 8.0.
-The jump was made in order to synchronize the Tcl and Tk version
-numbers.
-
-2. Documentation
-----------------
-
-The best way to get started with Tcl is to read one of the introductory
-books on Tcl:
-
- Practical Programming in Tcl and Tk, 2nd Edition, by Brent Welch,
- Prentice-Hall, 1997, ISBN 0-13-616830-2
-
- Tcl and the Tk Toolkit, by John Ousterhout,
- Addison-Wesley, 1994, ISBN 0-201-63337-X
-
- Exploring Expect, by Don Libes,
- O'Reilly and Associates, 1995, ISBN 1-56592-090-2
-
-Other books are listed at
-http://www.scriptics.com/resource/doc/books/
-http://www.tclconsortium.org/resources/books.html
-
-There is also an official home for Tcl and Tk on the Web:
- http://www.scriptics.com
-These Web pages include information about the latest releases, products
-related to Tcl and Tk, 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. Installation
----------------
-
-The binary release is distributed as a self-extracting archive called
-tcl80.exe. The setup program which will prompt you for an
-installation directory. It will create the installation heirarchy
-under the specified directory, and install a wish application icon
-under the program manager group of your choice.
-
-With the 8.0.3 patch release, we are no longer supporting use of
-Tcl with 16-bit versions of Windows. Microsoft has completely dropped
-support of the Win32s subsystem. If you still need 16-bit support,
-you can get win32s and the 16-bit thunking dll (tcl1680.dll) from the
-Scriptics web site at ftp://ftp.scriptics.com/pub/tcl/misc.
-
-4. Summary of changes in Tcl 8.0
---------------------------------
-
-Here are the most significant changes in Tcl 8.0. In addition to these
-changes, there are several smaller changes and bug fixes. See the file
-"changes" for a complete list of all changes.
-
- 1. Bytecode compiler. The core of the Tcl interpreter has been
- replaced with an on-the-fly compiler that translates Tcl scripts to
- byte codes; a new interpreter then executes the byte codes. In
- earlier versions of Tcl, strings were used as a universal
- representation; in Tcl 8.0 strings are replaced with Tcl_Obj
- structures ("objects") that can hold both a string value and an
- internal form such as a binary integer or compiled bytecodes. The
- new objects make it possible to store information in efficient
- internal forms and avoid the constant translations to and from
- strings that occurred with the old interpreter. We have not yet
- converted all of Tcl to take full advantage of the compiler and
- objects and have not converted any of Tk yet, but even so you
- should see speedups of 2-3x on many programs and you may see
- speedups as much as 10-20x in some cases (such as code that
- manipulates long lists). Future releases should achieve even
- greater speedups. The compiler introduces only a few minor changes
- at the level of Tcl scripts, but it introduces many new C APIs for
- managing objects. See, for example, the manual entries doc/*Obj*.3.
-
- 2. Namespaces. There is a new namespace mechanism based on the
- namespace implementation by Michael McLennan of Lucent Technologies.
- This includes new "namespace" and "variable" commands. There are
- many new C APIs associated with namespaces, but they will not be
- exported until Tcl 8.1. Note: the syntax of the namespace command
- has been changed slightly since the b1 release. See the changes
- file for details.
-
- 3. Binary I/O. The new object system in Tcl 8.0 supports binary
- strings (internally, strings are counted in addition to being null
- terminated). There is a new "binary" command for inserting and
- extracting data to/from binary strings. Commands such as "puts",
- "gets", and "read" commands now operate correctly on binary data.
- There is a new variable tcl_platform(byteOrder) to identify the
- native byte order for the current host.
-
- 4. Random numbers. The "expr" command now contains a random number
- generator, which can be accessed via the "rand()" and "srand()" math
- functions.
-
- 5. Safe-Tcl enhancements. There is a new "hidden command"
- mechanism, implemented with the Tcl commands "interp hide", "interp
- expose", "interp invokehidden", and "interp hidden" and the C APIs
- Tcl_HideCommand and Tcl_ExposeCommand. There is now support for
- loadable security policies, including new library procedures such as
- tcl_safeCreateInterp.
-
- 6. There is a new package "registry" available under Windows for
- accessing the Windows registry.
-
- 7. There is a new command "file attributes" for getting and setting
- things like permissions and owner. There is also a new command
- "file nativename" for getting back the platform-specific name for a
- particular file.
-
- 8. There is a new "fcopy" command to copy data between channels.
- This replaces and improves upon the not-so-secret unsupported old
- command "unsupported0".
-
- 9. There is a new package "http" for doing GET, POST, and HEAD
- requests via the HTTP/1.0 protocol. See the manual entry http.n
- for details.
-
- 10. There are new library procedures for finding word breaks in
- strings. See the manual entry library.n for details.
-
- 11. There are new C APIs Tcl_Finalize (for cleaning up before
- unloading the Tcl DLL) and Tcl_Ungets for pushing bytes back into a
- channel's input buffer.
-
- 12. Tcl now supports serial I/O devices on Windows and Unix, with a
- new fconfigure -mode option. The Windows driver does not yet
- support event-driven I/O.
-
- 13. The lsort command has new options -dictionary and -index. The
- -index option allows for very rapid sorting based on an element
- of a list.
-
- 14. The event notifier has been completely rewritten (again). It
- should now allow Tcl to use an external event loop (like Motif's)
- when it is embedded in other applications. No script-level
- interfaces have changed, but many of the C APIs have.
-
-Tcl 8.0 introduces the following incompatibilities that may affect Tcl
-scripts that worked under Tcl 7.6 and earlier releases:
-
- 1. Variable and command names may not include the character sequence
- "::" anymore: this sequence is now used as a namespace separator.
-
- 2. The semantics of some Tcl commands have been changed slightly to
- maximize performance under the compiler. These incompatibilities
- are documented on the Web so that we can keep the list up-to-date.
- See the URL http://www.sunlabs.com/research/tcl/compiler.html.
-
- 3. 2-digit years are now parsed differently by the "clock" command
- to handle year 2000 issues better (years 00-38 are treated as
- 2000-2038 instead of 1900-1938).
-
- 4. The old Macintosh commands "cp", "mkdir", "mv", "rm", and "rmdir"
- are no longer supported; all of these features are now available on
- all platforms via the "file" command.
-
- 5. The variable tcl_precision is now shared between interpreters
- and defaults to 12 digits instead of 6; safe interpreters cannot
- modify tcl_precision. The new object system in Tcl 8.0 causes
- floating-to-string conversions (and the associated rounding) to
- occur much less often than in Tcl 7.6, which can sometimes cause
- behavioral changes.
-
- 6. The C APIs associated with the notifier have changed substantially.
-
- 7. The procedures Tcl_CreateModalTimeout and Tcl_DeleteModalTimeout
- have been removed.
-
- 8. Tcl_CreateFileHandler and Tcl_DeleteFileHandler now take Unix
- fd's and are only supported on the Unix platform. Please use the
- Tcl_CreateChannelHandler interface instead.
-
- 9. The C APIs for creating channel drivers have changed as part of
- the new notifier implementation. The Tcl_File interfaces have been
- removed. Tcl_GetChannelFile has been replaced with
- Tcl_GetChannelHandle. Tcl_MakeFileChannel now takes a platform-
- specific file handle. Tcl_DriverGetOptionProc procedures now take
- an additional interp argument.
-
-5. Summary of changes in Tk 8.0
--------------------------------
-
-Here is a list of the most important new features in Tk 8.0. The
-release also includes several smaller feature changes and bug fixes.
-See the "changes" file for a complete list of all changes.
-
- 1. Native look and feel. The widgets have been rewritten to provide
- (nearly?) native look and feel on the Macintosh and PC. Many
- widgets, including scrollbars, menus, and the button family, are
- implemented with native platform widgets. Others, such as entries
- and texts, have been modified to emulate native look and feel.
- These changes are backwards compatible except that (a) some
- configuration options are now ignored on some platforms and (b) you
- must use the new menu mechanism described below to native look and
- feel for menus.
-
- 2. There is a new interface for creating menus, where a menubar is
- implemented as a menu widget instead of a frame containing menubuttons.
- The -menu option for a toplevel is used to specify the name of the
- menubar; the menu will be displayed *outside* the toplevel using
- different mechanisms on each platform (e.g. on the Macintosh the menu
- will appear at the top of the screen). See the menu demos in the
- widget demo for examples. The old style of menu still works, but
- does not provide native look and feel. Menus have several new
- features:
- - New "-columnbreak" and "-hideMargin" options make it possible
- to create multi-column menus.
- - It is now possible to manipulate the Apple and Help menus on
- the Macintosh, and the system menu on Windows. It is also
- possible to have a right justified Help menu on Unix.
- - Menus now issue the virtual event <<MenuSelect>> whenever the
- current item changes. Applications can use this to generate
- help messages.
- - There is a new "-direction" option for menubuttons, which
- controls where the menu pops up revenues to the button.
-
- 3. The font mechanism in Tk has been completely reworked:
- - Font names need not be nasty X LFDs: more intuitive names
- like {Times 12 Bold} can also be used. See the manual entry
- font.n for details.
- - Font requests always succeed now. If the requested font is
- not available, Tk finds the closest available font and uses
- that one.
- - Tk now supports named fonts whose precise attributes can be
- changed dynamically. If a named font is changed, any widget
- using that font updates itself to reflect the change.
- - There is a new command "font" for creating named fonts and
- querying various information about fonts.
- - There are now officially supported C APIs for measuring and
- displaying text. If you use these APIs now, your code will
- automatically handle international text when internationalization
- is added to Tk in a future release. See the manual entries
- MeasureChar.3, TextLayout.3, and FontId.3.
- - The old C procedures Tk_GetFontStruct, Tk_NameOfFontStruct,
- and Tk_FreeFontStruct have been replaced with more portable
- procedures Tk_GetFont, Tk_NameOfFont, and Tk_FreeFont.
-
- 4. Application embedding. It is now possible to embedded one Tcl/Tk
- application inside another, using the -container option on frame
- widgets and the -use option for toplevel widgets or on the command
- line for wish. Embedding should be fully functional under Unix,
- but the implementation is incomplete on the Macintosh and PC.
-
- 5. Tk now works correctly with Safe-Tcl: it can be loaded into
- safe interpreters.
-
- 6. Text widgets now allow images to be embedded directly in the
- text without using embedded windows. This is more efficient and
- provides smoother scrolling.
-
- 7. Buttons have a new -default option for drawing default rings in
- a platform-specific manner.
-
- 8. There is a new "gray75" bitmap, and the "gray25" bitmap is now
- really 25% on (due to an ancient mistake, it had been only 12% on).
- The Macintosh now supports native bitmaps, including new builtin
- bitmaps "stop", "caution", and "note", plus the ability to use
- bitmaps in the application's resource fork.
-
- 9. The "destroy" command now ignores windows that don't exist
- instead of generating an error.
-
-Tk 8.0 introduces the following incompatibilities that may affect Tcl/Tk
-scripts that worked under Tk 4.2 and earlier releases:
-
- 1. Font specifications such as "Times 12" now interpret the size
- as points, whereas it used to be pixels (this was actually a bug,
- since the behavior was documented as points). To get pixels now,
- use a negative size such as "Times -12".
-
- 2. The -transient option for menus is no longer supported. You can
- achieve the same effect with the -type field.
-
- 3. In the canvas "coords" command, polygons now return only the
- points that were explicitly specified when the polygon was created
- (they used to return an extra point if the polygon wasn't originally
- closed). Internally, polygons are still closed automatically for
- purposes of display and hit detection; the extra point just isn't
- returned by the "coords" command.
-
- 4. The photo image mechanism now uses Tcl_Channels instead of FILEs,
- in order to make it portable. FILEs are no longer used anywhere
- in Tk.
-
- 5. The procedures Tk_GetFontStruct, Tk_NameOfFontStruct,
- and Tk_FreeFontStruct have been removed.
-
-Note: the new compiler in Tcl 8.0 may also affect Tcl/Tk scripts; check
-the Tcl documentation for information on incompatibilities introduced by
-Tcl 8.0.
-
-6. Known Bugs/Missing Features
-------------------------------
-
-- Blocking "after" commands (e.g. "after 3000") don't work on Win32s.
-- Clock command fails to handle daylight savings time boundaries for
- things like "last week".
-- Background processes aren't properly detached on NT.
-- File events only work on sockets.
-- Pipes/files/console/serial ports don't support nonblocking I/O.
-- The library cannot be used by two processes at the same time under
- Win32s.
-- There is no support for custom cursors/application icons. The core
- set of X cursors is supported, although you cannot change their color.
-- Stippling of arcs isn't implemented yet.
-- Some "wm" functions don't map to Windows and aren't implemented;
- others should map, but just aren't implemented. The worst offenders
- are the icon manipulation routines.
-- Under Win32s, you can only start one instance of Wish at a time.
-- Color management on some displays doesn't work properly resulting in
- Tk switching to monochrome mode.
-- Tk seems to fail to draw anything on some Matrox Millenium cards.
-- Send and winfo interps are not currently supported
-- Printing does not work for images (e.g. GIF) on a canvas.
-- Tk_dialog appears in the upper left corner. This is a symptom of a
- larger problem with "wm geometry" when applied to unmapped or
- iconified windows.
-- Some keys don't work on international keyboards.
-- Grabs do not affect native menus or the title bar.
-- PPM images are using the wrong translation mode for writing to
- files, resulting in CR/LF terminated PPM files.
-- Tk crashes if the display depth changes while it is running. Tk
- also doesn't consistently track changes in the system colors.
-
-There may be more that we don't know about, so be sure to submit bug
-reports when you run into problems. If you have comments or bug
-reports for the Windows version of Tcl, please direct them to:
-
-Scott Stanton
-scott.stanton@eng.sun.com
-
-or post them to the newsgroup comp.lang.tcl.
-
-7. 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.
-
-8. 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.
-
-9. Tcl Resource Center
-----------------------
-Visit http://www.scritics.com/resource/ to see an annotated index of
-many Tcl resources available on the World Wide Web. This includes
-papers, books, and FAQs, as well as extensions, applications, binary
-releases, and patches. You can contribute patches by sending them
-to <patches@scriptics.com>. You can also recommend more URLs for the
-resource center using the forms labeled "Add a Resource".
-
-10. Mailing lists
-----------------
-
-A couple of Mailing List have been set up to discuss Macintosh or
-Windows related Tcl issues. In order to use these Mailing Lists you
-must have access to the internet. To subscribe send a message to:
-
- wintcl-request@tclconsortium.org
- mactcl-request@tclconsortium.org
-
-In the body of the message (the subject will be ignored) put:
-
- subscribe mactcl Joe Blow
-
-Replacing Joe Blow with your real name, of course. (Use wintcl
-instead of mactcl if your interested in the Windows list.) If you
-would just like to receive more information about the list without
-subscribing put the line:
-
- information mactcl
-
-in the body instead (or wintcl).
-
-10. 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
-comp.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).
-
-11. 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 b1 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.
-
-Patch releases have a suffix such as p1 or p2. These releases contain
-bug fixes only. A patch release (e.g Tcl 7.6p2) should be completely
-compatible with the base release from which it is derived (e.g. Tcl
-7.6), and you should normally use the highest available patch release.
-
-As of 8.0.3, the patch releases use a second . instead of 'p'. So, the
-8.0 release went to 8.0p1, 8.0p2, and 8.0.3. The alphas and betas will
-still use the 'a' and 'b' letters in their tcl_patchLevel.
-
-12. Linking against the binary release
---------------------------------------
-
-In order to link your applications against the .dll files shipped with
-this release, you will need to use the appropriate .lib file for your
-compiler. In the lib directory of the installation directory, there
-are library files for the Microsoft Visual C++ compiler:
-
- tcl80vc.lib
- tk80vc.lib
-
-13. Building dynamically loadable extensions
---------------------------------------------
-
-Please refer to the example dynamically loadable extension provided on
-our ftp site:
-
- ftp://ftp.scriptics.com/pub/tcl/misc/example.zip
-
-This archive contains a template that you can use for building
-extensions that will be loadable on Unix, Windows, and Macintosh
-systems.
diff --git a/win/makefile.vc b/win/makefile.vc deleted file mode 100644 index c054590..0000000 --- a/win/makefile.vc +++ /dev/null @@ -1,488 +0,0 @@ -# Visual C++ 2.x and 4.0 makefile -# -# See the file "license.terms" for information on usage and redistribution -# of this file, and for a DISCLAIMER OF ALL WARRANTIES. -# -# Copyright (c) 1995-1996 Sun Microsystems, Inc. -# Copyright (c) 1998-1999 by Scriptics Corporation. -# -# RCS: @(#) $Id: makefile.vc,v 1.24 1999/02/03 02:59:17 stanton Exp $ - -# Does not depend on the presence of any environment variables in -# order to compile tcl; all needed information is derived from -# location of the compiler directories. - -# -# Project directories -# -# ROOT = top of source tree -# -# TOOLS32 = location of VC++ 32-bit development tools. Note that the -# VC++ 2.0 header files are broken, so you need to use the -# ones that come with the developer network CD's, or later -# versions of VC++. -# -# TOOLS16 = location of VC++ 1.5 16-bit tools, needed to build thunking -# library. This information is optional; if the 16-bit compiler -# is not available, then the 16-bit code will not be built. -# Tcl will still run without the 16-bit code, but... -# A. Under Windows 3.X you will any calls to the exec command -# will return an error. -# B. A 16-bit program to test the behavior of the exec -# command under NT and 95 will not be built. -# INSTALLDIR = where the install- targets should copy the binaries and -# support files -# - -ROOT = .. -TOOLS32 = c:\program files\devstudio\vc -TOOLS32_rc = c:\program files\devstudio\sharedide -TOOLS16 = c:\msvc - -INSTALLDIR = c:\programa files\Tcl - -# Set this to the appropriate value of /MACHINE: for your platform -MACHINE = IX86 - -# Set NODEBUG to 0 to compile with symbols -NODEBUG = 1 - -# The following defines can be used to control the amount of debugging -# code that is added to the compilation. -# -# -DTCL_MEM_DEBUG Enables the debugging memory allocator. -# -DTCL_COMPILE_DEBUG Enables byte compilation logging. -# -DTCL_COMPILE_STATS Enables byte compilation statistics gathering. -# -DUSE_NATIVEMALLOC Disables the Tcl memory allocator in favor -# of the native malloc implementation. This is -# needed when using Purify. -# -#DEBUGDEFINES = -DTCL_MEM_DEBUG -#DEBUGDEFINES = -DTCL_MEM_DEBUG -DTCL_COMPILE_DEBUG -#DEBUGDEFINES = -DTCL_MEM_DEBUG -DTCL_COMPILE_DEBUG -DTCL_COMPILE_STATS -#DEBUGDEFINES = -DUSE_NATIVEMALLOC - -###################################################################### -# Do not modify below this line -###################################################################### - -NAMEPREFIX = tcl -DOTVERSION = 8.0 -VERSION = 80 - -BINROOT = . -!IF "$(NODEBUG)" == "1" -TMPDIRNAME = Release -DBGX = -!ELSE -TMPDIRNAME = Debug -DBGX = d -!ENDIF -TMPDIR = $(BINROOT)\$(TMPDIRNAME) -OUTDIRNAME = $(TMPDIRNAME) -OUTDIR = $(TMPDIR) - -TCLLIB = $(OUTDIR)\$(NAMEPREFIX)$(VERSION)$(DBGX).lib -TCLDLLNAME = $(NAMEPREFIX)$(VERSION)$(DBGX).dll -TCLDLL = $(OUTDIR)\$(TCLDLLNAME) -TCLPLUGINLIB = $(OUTDIR)\$(NAMEPREFIX)$(VERSION)p$(DBGX).lib -TCLPLUGINDLLNAME= $(NAMEPREFIX)$(VERSION)p$(DBGX).dll -TCLPLUGINDLL = $(OUTDIR)\$(TCLPLUGINDLLNAME) -TCL16DLL = $(OUTDIR)\$(NAMEPREFIX)16$(VERSION)$(DBGX).dll -TCLSH = $(OUTDIR)\$(NAMEPREFIX)sh$(VERSION)$(DBGX).exe -TCLSHP = $(OUTDIR)\$(NAMEPREFIX)shp$(VERSION)$(DBGX).exe -TCLPIPEDLLNAME = $(NAMEPREFIX)pip$(VERSION)$(DBGX).dll -TCLPIPEDLL = $(OUTDIR)\$(TCLPIPEDLLNAME) -TCLREGDLLNAME = $(NAMEPREFIX)reg$(VERSION)$(DBGX).dll -TCLREGDLL = $(OUTDIR)\$(TCLREGDLLNAME) -TCLTEST = $(OUTDIR)\$(NAMEPREFIX)test.exe -DUMPEXTS = $(TMPDIR)\dumpexts.exe -CAT16 = $(TMPDIR)\cat16.exe -CAT32 = $(TMPDIR)\cat32.exe - -LIB_INSTALL_DIR = $(INSTALLDIR)\lib -BIN_INSTALL_DIR = $(INSTALLDIR)\bin -SCRIPT_INSTALL_DIR = $(INSTALLDIR)\lib\tcl$(DOTVERSION) -INCLUDE_INSTALL_DIR = $(INSTALLDIR)\include - -TCLSHOBJS = \ - $(TMPDIR)\tclAppInit.obj - -TCLTESTOBJS = \ - $(TMPDIR)\tclTest.obj \ - $(TMPDIR)\tclTestObj.obj \ - $(TMPDIR)\tclTestProcBodyObj.obj \ - $(TMPDIR)\tclWinTest.obj \ - $(TMPDIR)\testMain.obj - -TCLOBJS = \ - $(TMPDIR)\panic.obj \ - $(TMPDIR)\regexp.obj \ - $(TMPDIR)\strftime.obj \ - $(TMPDIR)\tclAlloc.obj \ - $(TMPDIR)\tclAsync.obj \ - $(TMPDIR)\tclBasic.obj \ - $(TMPDIR)\tclBinary.obj \ - $(TMPDIR)\tclCkalloc.obj \ - $(TMPDIR)\tclClock.obj \ - $(TMPDIR)\tclCmdAH.obj \ - $(TMPDIR)\tclCmdIL.obj \ - $(TMPDIR)\tclCmdMZ.obj \ - $(TMPDIR)\tclCompExpr.obj \ - $(TMPDIR)\tclCompile.obj \ - $(TMPDIR)\tclDate.obj \ - $(TMPDIR)\tclEnv.obj \ - $(TMPDIR)\tclEvent.obj \ - $(TMPDIR)\tclExecute.obj \ - $(TMPDIR)\tclFCmd.obj \ - $(TMPDIR)\tclFileName.obj \ - $(TMPDIR)\tclGet.obj \ - $(TMPDIR)\tclHash.obj \ - $(TMPDIR)\tclHistory.obj \ - $(TMPDIR)\tclIndexObj.obj \ - $(TMPDIR)\tclInterp.obj \ - $(TMPDIR)\tclIO.obj \ - $(TMPDIR)\tclIOCmd.obj \ - $(TMPDIR)\tclIOSock.obj \ - $(TMPDIR)\tclIOUtil.obj \ - $(TMPDIR)\tclLink.obj \ - $(TMPDIR)\tclListObj.obj \ - $(TMPDIR)\tclLoad.obj \ - $(TMPDIR)\tclMain.obj \ - $(TMPDIR)\tclNamesp.obj \ - $(TMPDIR)\tclNotify.obj \ - $(TMPDIR)\tclObj.obj \ - $(TMPDIR)\tclParse.obj \ - $(TMPDIR)\tclPipe.obj \ - $(TMPDIR)\tclPkg.obj \ - $(TMPDIR)\tclPosixStr.obj \ - $(TMPDIR)\tclPreserve.obj \ - $(TMPDIR)\tclResolve.obj \ - $(TMPDIR)\tclProc.obj \ - $(TMPDIR)\tclStringObj.obj \ - $(TMPDIR)\tclTimer.obj \ - $(TMPDIR)\tclUtil.obj \ - $(TMPDIR)\tclVar.obj \ - $(TMPDIR)\tclWin32Dll.obj \ - $(TMPDIR)\tclWinChan.obj \ - $(TMPDIR)\tclWinError.obj \ - $(TMPDIR)\tclWinFCmd.obj \ - $(TMPDIR)\tclWinFile.obj \ - $(TMPDIR)\tclWinInit.obj \ - $(TMPDIR)\tclWinLoad.obj \ - $(TMPDIR)\tclWinMtherr.obj \ - $(TMPDIR)\tclWinNotify.obj \ - $(TMPDIR)\tclWinPipe.obj \ - $(TMPDIR)\tclWinSock.obj \ - $(TMPDIR)\tclWinTime.obj - -cc32 = "$(TOOLS32)\bin\cl.exe" -link32 = "$(TOOLS32)\bin\link.exe" -rc32 = "$(TOOLS32_rc)\bin\rc.exe" -include32 = -I"$(TOOLS32)\include" - -cc16 = "$(TOOLS16)\bin\cl.exe" -link16 = "$(TOOLS16)\bin\link.exe" -rc16 = "$(TOOLS16)\bin\rc.exe" -include16 = -I"$(TOOLS16)\include" - -WINDIR = $(ROOT)\win -GENERICDIR = $(ROOT)\generic - -TCL_INCLUDES = -I$(WINDIR) -I$(GENERICDIR) -TCL_DEFINES = -D__WIN32__ $(DEBUGDEFINES) - -TCL_CFLAGS = $(cdebug) $(cflags) $(cvarsdll) $(include32) \ - $(TCL_INCLUDES) $(TCL_DEFINES) -CON_CFLAGS = $(cdebug) $(cflags) $(cvars) $(include32) -DCONSOLE -DOS_CFLAGS = $(cdebug) $(cflags) $(include16) -AL -DLL16_CFLAGS = $(cdebug) $(cflags) $(include16) -ALw - -###################################################################### -# Link flags -###################################################################### - -!IF "$(NODEBUG)" == "1" -ldebug = /RELEASE -!ELSE -ldebug = -debug:full -debugtype:cv -!ENDIF - -# declarations common to all linker options -lcommon = /NODEFAULTLIB /RELEASE /NOLOGO - -# declarations for use on Intel i386, i486, and Pentium systems -!IF "$(MACHINE)" == "IX86" -DLLENTRY = @12 -lflags = $(lcommon) /MACHINE:$(MACHINE) -!ELSE -lflags = $(lcommon) /MACHINE:$(MACHINE) -!ENDIF - -conlflags = $(lflags) -subsystem:console -entry:mainCRTStartup -guilflags = $(lflags) -subsystem:windows -entry:WinMainCRTStartup -dlllflags = $(lflags) -entry:_DllMainCRTStartup$(DLLENTRY) -dll - -!IF "$(MACHINE)" == "PPC" -libc = libc$(DBGX).lib -libcdll = crtdll$(DBGX).lib -!ELSE -libc = libc$(DBGX).lib oldnames.lib -libcdll = msvcrt$(DBGX).lib oldnames.lib -!ENDIF - -baselibs = kernel32.lib $(optlibs) advapi32.lib user32.lib -winlibs = $(baselibs) gdi32.lib comdlg32.lib winspool.lib - -guilibs = $(libc) $(winlibs) -conlibs = $(libc) $(baselibs) -guilibsdll = $(libcdll) $(winlibs) -conlibsdll = $(libcdll) $(baselibs) - -###################################################################### -# Compile flags -###################################################################### - -!IF "$(NODEBUG)" == "1" -# This cranks the optimization level to maximize speed -cdebug = -O2 -Gs -GD -!ELSE -cdebug = -Z7 -Od -WX -!ENDIF - -# declarations common to all compiler options -ccommon = -c -W3 -nologo -YX -Fp$(TMPDIR)\ -Dtry=__try -Dexcept=__except - -!IF "$(MACHINE)" == "IX86" -cflags = $(ccommon) -D_X86_=1 -!ELSE -!IF "$(MACHINE)" == "MIPS" -cflags = $(ccommon) -D_MIPS_=1 -!ELSE -!IF "$(MACHINE)" == "PPC" -cflags = $(ccommon) -D_PPC_=1 -!ELSE -!IF "$(MACHINE)" == "ALPHA" -cflags = $(ccommon) -D_ALPHA_=1 -!ENDIF -!ENDIF -!ENDIF -!ENDIF - -cvars = -DWIN32 -D_WIN32 -cvarsmt = $(cvars) -D_MT -cvarsdll = $(cvarsmt) -D_DLL - -!IF "$(NODEBUG)" == "1" -cvarsdll = $(cvars) -MD -!ELSE -cvarsdll = $(cvars) -MDd -!ENDIF - -###################################################################### -# Project specific targets -###################################################################### - -release: setup $(TCLSH) dlls -dlls: setup $(TCL16DLL) $(TCLPIPEDLL) $(TCLREGDLL) -all: setup $(TCLSH) dlls $(CAT16) $(CAT32) -tcltest: setup $(TCLTEST) dlls $(CAT16) $(CAT32) -plugin: setup $(TCLPLUGINDLL) $(TCLSHP) -install: install-binaries install-libraries -test: setup $(TCLTEST) dlls $(CAT16) $(CAT32) - copy $(WINDIR)\pkgIndex.tcl $(OUTDIR) - set TCL_LIBRARY=$(ROOT)/library - $(TCLTEST) << "$(TCLREGDLL)" - load [lindex $$argv 0] registry - cd ../tests - source all -<< - -setup: - @mkd $(TMPDIR) - @mkd $(OUTDIR) - -$(DUMPEXTS): $(WINDIR)\winDumpExts.c - $(cc32) $(CON_CFLAGS) -Fo$(TMPDIR)\ $? - set LIB="$(TOOLS32)\lib" - $(link32) $(ldebug) $(conlflags) $(guilibs) -out:$@ \ - $(TMPDIR)\winDumpExts.obj - -$(TCLLIB): $(TCLDLL) - -$(TCLDLL): $(TCLOBJS) $(TMPDIR)\tcl.def $(TMPDIR)\tcl.res - set LIB="$(TOOLS32)\lib" - $(link32) $(ldebug) $(dlllflags) -def:$(TMPDIR)\tcl.def \ - -out:$@ $(TMPDIR)\tcl.res $(guilibsdll) @<< -$(TCLOBJS) -<< - -$(TCLPLUGINLIB): $(TCLPLUGINDLL) - -$(TCLPLUGINDLL): $(TCLOBJS) $(TMPDIR)\plugin.def $(TMPDIR)\tcl.res - set LIB="$(TOOLS32)\lib" - $(link32) $(ldebug) $(dlllflags) -def:$(TMPDIR)\plugin.def \ - -out:$@ $(TMPDIR)\tcl.res $(guilibsdll) @<< -$(TCLOBJS) -<< - -$(TCLSH): $(TCLSHOBJS) $(TCLLIB) $(TMPDIR)\tclsh.res - set LIB="$(TOOLS32)\lib" - $(link32) $(ldebug) $(conlflags) $(TMPDIR)\tclsh.res -stack:2300000 \ - -out:$@ $(conlibsdll) $(TCLLIB) $(TCLSHOBJS) - -$(TCLSHP): $(TCLSHOBJS) $(TCLPLUGINLIB) $(TMPDIR)\tclsh.res - set LIB="$(TOOLS32)\lib" - $(link32) $(ldebug) $(conlflags) $(TMPDIR)\tclsh.res -stack:2300000 \ - -out:$@ $(conlibsdll) $(TCLPLUGINLIB) $(TCLSHOBJS) - -$(TCLTEST): $(TCLTESTOBJS) $(TCLLIB) $(TMPDIR)\tclsh.res - set LIB="$(TOOLS32)\lib" - $(link32) $(ldebug) $(conlflags) $(TMPDIR)\tclsh.res -stack:2300000 \ - -out:$@ $(conlibsdll) $(TCLLIB) $(TCLTESTOBJS) - -$(TCL16DLL): $(WINDIR)\tcl16.rc $(WINDIR)\tclWin16.c - if exist $(cc16) $(cc16) @<< -$(DLL16_CFLAGS) -Fo$(TMPDIR)\ $(WINDIR)\tclWin16.c -<< - @copy << $(TMPDIR)\tclWin16.def > nul -LIBRARY $(@B);dll -EXETYPE WINDOWS -CODE PRELOAD MOVEABLE DISCARDABLE -DATA PRELOAD MOVEABLE SINGLE -HEAPSIZE 1024 -EXPORTS - WEP @1 RESIDENTNAME - UTPROC @2 -<< - if exist $(cc16) $(link16) /NOLOGO /ONERROR:NOEXE /NOE @<< -$(TMPDIR)\tclWin16.obj -$@ -nul -$(TOOLS16)\lib\ ldllcew oldnames libw toolhelp -$(TMPDIR)\tclWin16.def -<< - if exist $(cc16) $(rc16) -i $(GENERICDIR) $(TCL_DEFINES) $(WINDIR)\tcl16.rc $@ - -$(TCLPIPEDLL): $(WINDIR)\stub16.c - $(cc32) $(CON_CFLAGS) -Fo$(TMPDIR)\ $(WINDIR)\stub16.c - set LIB="$(TOOLS32)\lib" - $(link32) $(ldebug) $(conlflags) -out:$@ $(TMPDIR)\stub16.obj $(guilibs) - -$(TCLREGDLL): $(TMPDIR)\tclWinReg.obj - set LIB="$(TOOLS32)\lib" - $(link32) $(ldebug) $(dlllflags) -out:$@ $(TMPDIR)\tclWinReg.obj \ - $(conlibsdll) $(TCLLIB) - -$(CAT32): $(WINDIR)\cat.c - $(cc32) $(CON_CFLAGS) -Fo$(TMPDIR)\ $? - set LIB="$(TOOLS32)\lib" - $(link32) $(conlflags) -out:$@ -stack:16384 $(TMPDIR)\cat.obj $(conlibs) - -$(CAT16): $(WINDIR)\cat.c - if exist $(cc16) $(cc16) $(DOS_CFLAGS) -Fo$(TMPDIR)\ $? - set LIB="$(TOOLS16)\lib" - if exist $(cc16) $(link16) /NOLOGO /ONERROR:NOEXE /NOI /STACK:16384 \ - $(TMPDIR)\cat.obj,$@,nul,llibce.lib,nul - -$(TMPDIR)\tcl.def: $(DUMPEXTS) $(TCLOBJS) - $(DUMPEXTS) -o $@ $(TCLDLLNAME) @<< -$(TCLOBJS) -<< - -$(TMPDIR)\plugin.def: $(DUMPEXTS) $(TCLOBJS) - $(DUMPEXTS) -o $@ $(TCLPLUGINDLLNAME) @<< -$(TCLOBJS) -<< - -install-binaries: $(TCLSH) - @mkd $(BIN_INSTALL_DIR) - @mkd $(LIB_INSTALL_DIR) - @echo installing $(TCLDLLNAME) - @copy $(TCLDLL) $(BIN_INSTALL_DIR) - @copy $(TCLLIB) $(LIB_INSTALL_DIR) - @echo installing $(TCLSH) - @copy $(TCLSH) $(BIN_INSTALL_DIR) - @echo installing $(TCLPIPEDLLNAME) - @copy $(TCLPIPEDLL) $(BIN_INSTALL_DIR) - @echo installing $(TCLREGDLLNAME) - @copy $(TCLREGDLL) $(LIB_INSTALL_DIR) - -install-libraries: - -@mkd $(LIB_INSTALL_DIR) - -@mkd $(INCLUDE_INSTALL_DIR) - -@mkd $(SCRIPT_INSTALL_DIR) - -@mkd $(SCRIPT_INSTALL_DIR)\http1.0 - @copy << "$(SCRIPT_INSTALL_DIR)\pkgIndex.tcl" -package ifneeded registry 1.0 "load [list [file join $$dir .. $(TCLREGDLLNAME)]] registry" -<< - -@copy $(ROOT)\library\http1.0\http.tcl $(SCRIPT_INSTALL_DIR)\http1.0 - -@copy $(ROOT)\library\http1.0\pkgIndex.tcl $(SCRIPT_INSTALL_DIR)\http1.0 - -@mkd $(SCRIPT_INSTALL_DIR)\http2.0 - -@copy $(ROOT)\library\http2.0\http.tcl $(SCRIPT_INSTALL_DIR)\http2.0 - -@copy $(ROOT)\library\http2.0\pkgIndex.tcl $(SCRIPT_INSTALL_DIR)\http2.0 - -@mkd $(SCRIPT_INSTALL_DIR)\opt0.1 - -@copy $(ROOT)\library\opt0.1\optparse.tcl $(SCRIPT_INSTALL_DIR)\opt0.1 - -@copy $(ROOT)\library\opt0.1\pkgIndex.tcl $(SCRIPT_INSTALL_DIR)\opt0.1 - -@copy $(GENERICDIR)\tcl.h $(INCLUDE_INSTALL_DIR) - -@copy $(ROOT)\library\history.tcl $(SCRIPT_INSTALL_DIR) - -@copy $(ROOT)\library\init.tcl $(SCRIPT_INSTALL_DIR) - -@copy $(ROOT)\library\ldAout.tcl $(SCRIPT_INSTALL_DIR) - -@copy $(ROOT)\library\parray.tcl $(SCRIPT_INSTALL_DIR) - -@copy $(ROOT)\library\safe.tcl $(SCRIPT_INSTALL_DIR) - -@copy $(ROOT)\library\tclIndex $(SCRIPT_INSTALL_DIR) - -@copy $(ROOT)\library\word.tcl $(SCRIPT_INSTALL_DIR) - -# -# Special case object file targets -# - -$(TMPDIR)\tclWinInit.obj: $(WINDIR)\tclWinInit.c - $(cc32) -DDLL_BUILD -DBUILD_tcl $(TCL_CFLAGS) $(EXTFLAGS) \ - -Fo$(TMPDIR)\ $? - -$(TMPDIR)\testMain.obj: $(WINDIR)\tclAppInit.c - $(cc32) $(TCL_CFLAGS) -DTCL_TEST -Fo$(TMPDIR)\testMain.obj $? - -$(TMPDIR)\tclTest.obj: $(GENERICDIR)\tclTest.c - $(cc32) $(TCL_CFLAGS) -Fo$@ $? - -$(TMPDIR)\tclTestObj.obj: $(GENERICDIR)\tclTestObj.c - $(cc32) $(TCL_CFLAGS) -Fo$@ $? - -$(TMPDIR)\tclWinTest.obj: $(WINDIR)\tclWinTest.c - $(cc32) $(TCL_CFLAGS) -Fo$@ $? - -$(TMPDIR)\tclAppInit.obj : $(WINDIR)\tclAppInit.c - $(cc32) $(TCL_CFLAGS) -Fo$@ $? - -# -# Implicit rules -# - -{$(WINDIR)}.c{$(TMPDIR)}.obj: - $(cc32) -DDLL_BUILD -DBUILD_tcl $(TCL_CFLAGS) -Fo$(TMPDIR)\ $< - -{$(GENERICDIR)}.c{$(TMPDIR)}.obj: - $(cc32) -DDLL_BUILD -DBUILD_tcl $(TCL_CFLAGS) -Fo$(TMPDIR)\ $< - -{$(ROOT)\compat}.c{$(TMPDIR)}.obj: - $(cc32) -DDLL_BUILD -DBUILD_tcl $(TCL_CFLAGS) -Fo$(TMPDIR)\ $< - -{$(WINDIR)}.rc{$(TMPDIR)}.res: - $(rc32) -fo $@ -r -i $(GENERICDIR) -i $(WINDIR) -D__WIN32__ \ - $(TCL_DEFINES) $< - -clean: - -@del $(OUTDIR)\*.exp - -@del $(OUTDIR)\*.lib - -@del $(OUTDIR)\*.dll - -@del $(OUTDIR)\*.exe - -@del $(OUTDIR)\*.pdb - -@del $(TMPDIR)\*.pch - -@del $(TMPDIR)\*.obj - -@del $(TMPDIR)\*.res - -@del $(TMPDIR)\*.def - -@del $(TMPDIR)\*.exe - -@rmd $(OUTDIR) - -@rmd $(TMPDIR) diff --git a/win/pkgIndex.tcl b/win/pkgIndex.tcl deleted file mode 100644 index 3a9465c..0000000 --- a/win/pkgIndex.tcl +++ /dev/null @@ -1,11 +0,0 @@ -# Tcl package index file, version 1.0 -# This file contains package information for Windows-specific extensions. -# -# Copyright (c) 1997 by Sun Microsystems, Inc. -# -# See the file "license.terms" for information on usage and redistribution -# of this file, and for a DISCLAIMER OF ALL WARRANTIES. -# -# RCS: @(#) $Id: pkgIndex.tcl,v 1.2 1998/09/14 18:40:19 stanton Exp $ - -package ifneeded registry 1.0 [list tclPkgSetup $dir registry 1.0 {{tclreg80.dll load registry}}] diff --git a/win/stub16.c b/win/stub16.c deleted file mode 100644 index 44e18d6..0000000 --- a/win/stub16.c +++ /dev/null @@ -1,198 +0,0 @@ -/* - * stub16.c - * - * A helper program used for running 16-bit DOS applications under - * Windows 95. - * - * 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. - * - * RCS: @(#) $Id: stub16.c,v 1.2 1998/09/14 18:40:19 stanton Exp $ - */ - -#define STRICT - -#include <windows.h> -#include <stdio.h> - -static HANDLE CreateTempFile(void); - -/* - *--------------------------------------------------------------------------- - * - * main - * - * Entry point for the 32-bit console mode app used by Windows 95 to - * help run the 16-bit program specified on the command line. - * - * 1. EOF on a pipe that connects a detached 16-bit process and a - * 32-bit process is never seen. So, this process runs the 16-bit - * process _attached_, and then it is run detached from the calling - * 32-bit process. - * - * 2. If a 16-bit process blocks reading from or writing to a pipe, - * it never wakes up, and eventually brings the whole system down - * with it if you try to kill the process. This app simulates - * pipes. If any of the stdio handles is a pipe, this program - * accumulates information into temp files and forwards it to or - * from the DOS application as appropriate. This means that this - * program must receive EOF from a stdin pipe before it will actually - * start the DOS app, and the DOS app must finish generating stdout - * or stderr before the data will be sent to the next stage of the - * pipe. If the stdio handles are not pipes, no accumulation occurs - * and the data is passed straight through to and from the DOS - * application. - * - * Results: - * None. - * - * Side effects: - * The child process is created and this process waits for it to - * complete. - * - *--------------------------------------------------------------------------- - */ - -int -main() -{ - DWORD dwRead, dwWrite; - char *cmdLine; - HANDLE hStdInput, hStdOutput, hStdError; - HANDLE hFileInput, hFileOutput, hFileError; - STARTUPINFO si; - PROCESS_INFORMATION pi; - char buf[8192]; - DWORD result; - - hFileInput = INVALID_HANDLE_VALUE; - hFileOutput = INVALID_HANDLE_VALUE; - hFileError = INVALID_HANDLE_VALUE; - result = 1; - - /* - * Don't get command line from argc, argv, because the command line - * tokenizer will have stripped off all the escape sequences needed - * for quotes and backslashes, and then we'd have to put them all - * back in again. Get the raw command line and parse off what we - * want ourselves. The command line should be of the form: - * - * stub16.exe program arg1 arg2 ... - */ - - cmdLine = strchr(GetCommandLine(), ' '); - if (cmdLine == NULL) { - return 1; - } - cmdLine++; - - hStdInput = GetStdHandle(STD_INPUT_HANDLE); - hStdOutput = GetStdHandle(STD_OUTPUT_HANDLE); - hStdError = GetStdHandle(STD_ERROR_HANDLE); - - if (GetFileType(hStdInput) == FILE_TYPE_PIPE) { - hFileInput = CreateTempFile(); - if (hFileInput == INVALID_HANDLE_VALUE) { - goto cleanup; - } - while (ReadFile(hStdInput, buf, sizeof(buf), &dwRead, NULL) != FALSE) { - if (dwRead == 0) { - break; - } - if (WriteFile(hFileInput, buf, dwRead, &dwWrite, NULL) == FALSE) { - goto cleanup; - } - } - SetFilePointer(hFileInput, 0, 0, FILE_BEGIN); - SetStdHandle(STD_INPUT_HANDLE, hFileInput); - } - if (GetFileType(hStdOutput) == FILE_TYPE_PIPE) { - hFileOutput = CreateTempFile(); - if (hFileOutput == INVALID_HANDLE_VALUE) { - goto cleanup; - } - SetStdHandle(STD_OUTPUT_HANDLE, hFileOutput); - } - if (GetFileType(hStdError) == FILE_TYPE_PIPE) { - hFileError = CreateTempFile(); - if (hFileError == INVALID_HANDLE_VALUE) { - goto cleanup; - } - SetStdHandle(STD_ERROR_HANDLE, hFileError); - } - - ZeroMemory(&si, sizeof(si)); - si.cb = sizeof(si); - if (CreateProcess(NULL, cmdLine, NULL, NULL, TRUE, 0, NULL, NULL, &si, - &pi) == FALSE) { - goto cleanup; - } - - WaitForInputIdle(pi.hProcess, 5000); - WaitForSingleObject(pi.hProcess, INFINITE); - CloseHandle(pi.hProcess); - CloseHandle(pi.hThread); - result = 0; - - if (hFileOutput != INVALID_HANDLE_VALUE) { - SetFilePointer(hFileOutput, 0, 0, FILE_BEGIN); - while (ReadFile(hFileOutput, buf, sizeof(buf), &dwRead, NULL) != FALSE) { - if (dwRead == 0) { - break; - } - if (WriteFile(hStdOutput, buf, dwRead, &dwWrite, NULL) == FALSE) { - break; - } - } - } - if (hFileError != INVALID_HANDLE_VALUE) { - SetFilePointer(hFileError, 0, 0, FILE_BEGIN); - while (ReadFile(hFileError, buf, sizeof(buf), &dwRead, NULL) != FALSE) { - if (dwRead == 0) { - break; - } - if (WriteFile(hStdError, buf, dwRead, &dwWrite, NULL) == FALSE) { - break; - } - } - } - -cleanup: - if (hFileInput != INVALID_HANDLE_VALUE) { - CloseHandle(hFileInput); - } - if (hFileOutput != INVALID_HANDLE_VALUE) { - CloseHandle(hFileOutput); - } - if (hFileError != INVALID_HANDLE_VALUE) { - CloseHandle(hFileError); - } - CloseHandle(hStdInput); - CloseHandle(hStdOutput); - CloseHandle(hStdError); - ExitProcess(result); - return 1; -} - -static HANDLE -CreateTempFile() -{ - char name[MAX_PATH]; - SECURITY_ATTRIBUTES sa; - - if (GetTempPath(sizeof(name), name) == 0) { - return INVALID_HANDLE_VALUE; - } - if (GetTempFileName(name, "tcl", 0, name) == 0) { - return INVALID_HANDLE_VALUE; - } - - sa.nLength = sizeof(sa); - sa.lpSecurityDescriptor = NULL; - sa.bInheritHandle = TRUE; - return CreateFile(name, GENERIC_READ | GENERIC_WRITE, 0, &sa, - CREATE_ALWAYS, FILE_ATTRIBUTE_TEMPORARY | FILE_FLAG_DELETE_ON_CLOSE, - NULL); -} diff --git a/win/tcl.rc b/win/tcl.rc deleted file mode 100644 index f6dab40..0000000 --- a/win/tcl.rc +++ /dev/null @@ -1,42 +0,0 @@ -// RCS: @(#) $Id: tcl.rc,v 1.2 1998/09/14 18:40:19 stanton Exp $ -// -// Version -// - -#define RESOURCE_INCLUDED -#include <tcl.h> - -VS_VERSION_INFO VERSIONINFO - FILEVERSION TCL_MAJOR_VERSION,TCL_MINOR_VERSION,TCL_RELEASE_LEVEL,TCL_RELEASE_SERIAL - PRODUCTVERSION TCL_MAJOR_VERSION,TCL_MINOR_VERSION,TCL_RELEASE_LEVEL,TCL_RELEASE_SERIAL - FILEFLAGSMASK 0x3fL - FILEFLAGS 0x0L - FILEOS 0x4L - FILETYPE 0x2L - FILESUBTYPE 0x0L -BEGIN - BLOCK "StringFileInfo" - BEGIN - BLOCK "040904b0" - BEGIN - VALUE "FileDescription", "Tcl DLL\0" - VALUE "OriginalFilename", "tcl" STRINGIFY(TCL_MAJOR_VERSION) STRINGIFY(TCL_MINOR_VERSION) ".dll\0" - VALUE "CompanyName", "Sun Microsystems, Inc\0" - VALUE "FileVersion", TCL_PATCH_LEVEL - VALUE "LegalCopyright", "Copyright \251 1995-1997\0" - VALUE "ProductName", "Tcl " TCL_VERSION " for Windows\0" - VALUE "ProductVersion", TCL_PATCH_LEVEL - END - END - BLOCK "VarFileInfo" - BEGIN - VALUE "Translation", 0x409, 1200 - END -END - - - - - - - diff --git a/win/tcl16.rc b/win/tcl16.rc deleted file mode 100644 index 5c44d95..0000000 --- a/win/tcl16.rc +++ /dev/null @@ -1,37 +0,0 @@ -// RCS: @(#) $Id: tcl16.rc,v 1.2 1998/09/14 18:40:19 stanton Exp $ -// -// Version -// - -#define RESOURCE_INCLUDED -#include <tcl.h> - -VS_VERSION_INFO VERSIONINFO - FILEVERSION TCL_MAJOR_VERSION,TCL_MINOR_VERSION,TCL_RELEASE_LEVEL,TCL_RELEASE_SERIAL - PRODUCTVERSION TCL_MAJOR_VERSION,TCL_MINOR_VERSION,TCL_RELEASE_LEVEL,TCL_RELEASE_SERIAL - FILEFLAGSMASK 0x3fL - FILEFLAGS 0x0L - FILEOS 0x1L - FILETYPE 0x2L - FILESUBTYPE 0x0L -BEGIN - BLOCK "StringFileInfo" - BEGIN - BLOCK "040904b0" - BEGIN - VALUE "FileDescription", "Tcl16 DLL, 16-bit thunking module\0" - VALUE "OriginalFilename", "tcl16" STRINGIFY(TCL_MAJOR_VERSION) STRINGIFY(TCL_MINOR_VERSION) ".dll\0" - VALUE "CompanyName", "Sun Microsystems, Inc\0" - VALUE "FileVersion", TCL_PATCH_LEVEL - VALUE "LegalCopyright", "Copyright \251 1995-1996\0" - VALUE "ProductName", "Tcl " TCL_VERSION " for Windows\0" - VALUE "ProductVersion", TCL_PATCH_LEVEL - END - END - BLOCK "VarFileInfo" - BEGIN - VALUE "Translation", 0x409, 1200 - END -END - - diff --git a/win/tclWinFCmd.c b/win/tclWinFCmd.c deleted file mode 100644 index 8eb836f..0000000 --- a/win/tclWinFCmd.c +++ /dev/null @@ -1,1401 +0,0 @@ -/* - * tclWinFCmd.c - * - * This file implements the Windows specific portion of file manipulation - * subcommands of the "file" command. - * - * Copyright (c) 1996-1997 Sun Microsystems, Inc. - * - * See the file "license.terms" for information on usage and redistribution - * of this file, and for a DISCLAIMER OF ALL WARRANTIES. - * - * RCS: @(#) $Id: tclWinFCmd.c,v 1.2 1998/09/14 18:40:19 stanton Exp $ - */ - -#include "tclWinInt.h" - -/* - * The following constants specify the type of callback when - * TraverseWinTree() calls the traverseProc() - */ - -#define DOTREE_PRED 1 /* pre-order directory */ -#define DOTREE_POSTD 2 /* post-order directory */ -#define DOTREE_F 3 /* regular file */ - -/* - * Callbacks for file attributes code. - */ - -static int GetWinFileAttributes _ANSI_ARGS_((Tcl_Interp *interp, - int objIndex, char *fileName, - Tcl_Obj **attributePtrPtr)); -static int GetWinFileLongName _ANSI_ARGS_((Tcl_Interp *interp, - int objIndex, char *fileName, - Tcl_Obj **attributePtrPtr)); -static int GetWinFileShortName _ANSI_ARGS_((Tcl_Interp *interp, - int objIndex, char *fileName, - Tcl_Obj **attributePtrPtr)); -static int SetWinFileAttributes _ANSI_ARGS_((Tcl_Interp *interp, - int objIndex, char *fileName, - Tcl_Obj *attributePtr)); -static int CannotSetAttribute _ANSI_ARGS_((Tcl_Interp *interp, - int objIndex, char *fileName, - Tcl_Obj *attributePtr)); - -/* - * Constants and variables necessary for file attributes subcommand. - */ - -enum { - WIN_ARCHIVE_ATTRIBUTE, - WIN_HIDDEN_ATTRIBUTE, - WIN_LONGNAME_ATTRIBUTE, - WIN_READONLY_ATTRIBUTE, - WIN_SHORTNAME_ATTRIBUTE, - WIN_SYSTEM_ATTRIBUTE -}; - -static int attributeArray[] = {FILE_ATTRIBUTE_ARCHIVE, FILE_ATTRIBUTE_HIDDEN, - 0, FILE_ATTRIBUTE_READONLY, 0, FILE_ATTRIBUTE_SYSTEM}; - - -char *tclpFileAttrStrings[] = {"-archive", "-hidden", "-longname", "-readonly", - "-shortname", "-system", (char *) NULL}; -CONST TclFileAttrProcs tclpFileAttrProcs[] = { - {GetWinFileAttributes, SetWinFileAttributes}, - {GetWinFileAttributes, SetWinFileAttributes}, - {GetWinFileLongName, CannotSetAttribute}, - {GetWinFileAttributes, SetWinFileAttributes}, - {GetWinFileShortName, CannotSetAttribute}, - {GetWinFileAttributes, SetWinFileAttributes}}; - -/* - * Prototype for the TraverseWinTree callback function. - */ - -typedef int (TraversalProc)(char *src, char *dst, DWORD attr, int type, - Tcl_DString *errorPtr); - -/* - * Declarations for local procedures defined in this file: - */ - -static void AttributesPosixError _ANSI_ARGS_((Tcl_Interp *interp, - int objIndex, char *fileName, int getOrSet)); -static int ConvertFileNameFormat _ANSI_ARGS_((Tcl_Interp *interp, - int objIndex, char *fileName, int longShort, - Tcl_Obj **attributePtrPtr)); -static int TraversalCopy(char *src, char *dst, DWORD attr, - int type, Tcl_DString *errorPtr); -static int TraversalDelete(char *src, char *dst, DWORD attr, - int type, Tcl_DString *errorPtr); -static int TraverseWinTree(TraversalProc *traverseProc, - Tcl_DString *sourcePtr, Tcl_DString *destPtr, - Tcl_DString *errorPtr); - - -/* - *--------------------------------------------------------------------------- - * - * TclpRenameFile -- - * - * Changes the name of an existing file or directory, from src to dst. - * If src and dst refer to the same file or directory, does nothing - * and returns success. Otherwise if dst already exists, it will be - * deleted and replaced by src subject to the following conditions: - * If src is a directory, dst may be an empty directory. - * If src is a file, dst may be a file. - * In any other situation where dst already exists, the rename will - * fail. - * - * Results: - * If the directory was successfully created, returns TCL_OK. - * Otherwise the return value is TCL_ERROR and errno is set to - * indicate the error. Some possible values for errno are: - * - * EACCES: src or dst parent directory can't be read and/or written. - * EEXIST: dst is a non-empty directory. - * EINVAL: src is a root directory or dst is a subdirectory of src. - * EISDIR: dst is a directory, but src is not. - * ENOENT: src doesn't exist. src or dst is "". - * ENOTDIR: src is a directory, but dst is not. - * EXDEV: src and dst are on different filesystems. - * - * EACCES: exists an open file already referring to src or dst. - * EACCES: src or dst specify the current working directory (NT). - * EACCES: src specifies a char device (nul:, com1:, etc.) - * EEXIST: dst specifies a char device (nul:, com1:, etc.) (NT) - * EACCES: dst specifies a char device (nul:, com1:, etc.) (95) - * - * Side effects: - * The implementation supports cross-filesystem renames of files, - * but the caller should be prepared to emulate cross-filesystem - * renames of directories if errno is EXDEV. - * - *--------------------------------------------------------------------------- - */ - -int -TclpRenameFile( - char *src, /* Pathname of file or dir to be renamed. */ - char *dst) /* New pathname for file or directory. */ -{ - DWORD srcAttr, dstAttr; - - /* - * Would throw an exception under NT if one of the arguments is a - * char block device. - */ - - try { - if (MoveFile(src, dst) != FALSE) { - return TCL_OK; - } - } except (-1) {} - - TclWinConvertError(GetLastError()); - - srcAttr = GetFileAttributes(src); - dstAttr = GetFileAttributes(dst); - if (srcAttr == (DWORD) -1) { - srcAttr = 0; - } - if (dstAttr == (DWORD) -1) { - dstAttr = 0; - } - - if (errno == EBADF) { - errno = EACCES; - return TCL_ERROR; - } - if ((errno == EACCES) && (TclWinGetPlatformId() == VER_PLATFORM_WIN32s)) { - if ((srcAttr != 0) && (dstAttr != 0)) { - /* - * Win32s reports trying to overwrite an existing file or directory - * as EACCES. - */ - - errno = EEXIST; - } - } - if (errno == EACCES) { - decode: - if (srcAttr & FILE_ATTRIBUTE_DIRECTORY) { - char srcPath[MAX_PATH], dstPath[MAX_PATH]; - int srcArgc, dstArgc; - char **srcArgv, **dstArgv; - char *srcRest, *dstRest; - int size; - - size = GetFullPathName(src, sizeof(srcPath), srcPath, &srcRest); - if ((size == 0) || (size > sizeof(srcPath))) { - return TCL_ERROR; - } - size = GetFullPathName(dst, sizeof(dstPath), dstPath, &dstRest); - if ((size == 0) || (size > sizeof(dstPath))) { - return TCL_ERROR; - } - if (srcRest == NULL) { - srcRest = srcPath + strlen(srcPath); - } - if (strnicmp(srcPath, dstPath, srcRest - srcPath) == 0) { - /* - * Trying to move a directory into itself. - */ - - errno = EINVAL; - return TCL_ERROR; - } - Tcl_SplitPath(srcPath, &srcArgc, &srcArgv); - Tcl_SplitPath(dstPath, &dstArgc, &dstArgv); - if (srcArgc == 1) { - /* - * They are trying to move a root directory. Whether - * or not it is across filesystems, this cannot be - * done. - */ - - errno = EINVAL; - } else if ((srcArgc > 0) && (dstArgc > 0) && - (stricmp(srcArgv[0], dstArgv[0]) != 0)) { - /* - * If src is a directory and dst filesystem != src - * filesystem, errno should be EXDEV. It is very - * important to get this behavior, so that the caller - * can respond to a cross filesystem rename by - * simulating it with copy and delete. The MoveFile - * system call already handles the case of moving a - * file between filesystems. - */ - - errno = EXDEV; - } - - ckfree((char *) srcArgv); - ckfree((char *) dstArgv); - } - - /* - * Other types of access failure is that dst is a read-only - * filesystem, that an open file referred to src or dest, or that - * src or dest specified the current working directory on the - * current filesystem. EACCES is returned for those cases. - */ - - } else if (errno == EEXIST) { - /* - * Reports EEXIST any time the target already exists. If it makes - * sense, remove the old file and try renaming again. - */ - - if (srcAttr & FILE_ATTRIBUTE_DIRECTORY) { - if (dstAttr & FILE_ATTRIBUTE_DIRECTORY) { - /* - * Overwrite empty dst directory with src directory. The - * following call will remove an empty directory. If it - * fails, it's because it wasn't empty. - */ - - if (TclpRemoveDirectory(dst, 0, NULL) == TCL_OK) { - /* - * Now that that empty directory is gone, we can try - * renaming again. If that fails, we'll put this empty - * directory back, for completeness. - */ - - if (MoveFile(src, dst) != FALSE) { - return TCL_OK; - } - - /* - * Some new error has occurred. Don't know what it - * could be, but report this one. - */ - - TclWinConvertError(GetLastError()); - CreateDirectory(dst, NULL); - SetFileAttributes(dst, dstAttr); - if (errno == EACCES) { - /* - * Decode the EACCES to a more meaningful error. - */ - - goto decode; - } - } - } else { /* (dstAttr & FILE_ATTRIBUTE_DIRECTORY) == 0 */ - errno = ENOTDIR; - } - } else { /* (srcAttr & FILE_ATTRIBUTE_DIRECTORY) == 0 */ - if (dstAttr & FILE_ATTRIBUTE_DIRECTORY) { - errno = EISDIR; - } else { - /* - * Overwrite existing file by: - * - * 1. Rename existing file to temp name. - * 2. Rename old file to new name. - * 3. If success, delete temp file. If failure, - * put temp file back to old name. - */ - - char tempName[MAX_PATH]; - int result, size; - char *rest; - - size = GetFullPathName(dst, sizeof(tempName), tempName, &rest); - if ((size == 0) || (size > sizeof(tempName)) || (rest == NULL)) { - return TCL_ERROR; - } - *rest = '\0'; - result = TCL_ERROR; - if (GetTempFileName(tempName, "tclr", 0, tempName) != 0) { - /* - * Strictly speaking, need the following DeleteFile and - * MoveFile to be joined as an atomic operation so no - * other app comes along in the meantime and creates the - * same temp file. - */ - - DeleteFile(tempName); - if (MoveFile(dst, tempName) != FALSE) { - if (MoveFile(src, dst) != FALSE) { - SetFileAttributes(tempName, FILE_ATTRIBUTE_NORMAL); - DeleteFile(tempName); - return TCL_OK; - } else { - DeleteFile(dst); - MoveFile(tempName, dst); - } - } - - /* - * Can't backup dst file or move src file. Return that - * error. Could happen if an open file refers to dst. - */ - - TclWinConvertError(GetLastError()); - if (errno == EACCES) { - /* - * Decode the EACCES to a more meaningful error. - */ - - goto decode; - } - } - return result; - } - } - } - return TCL_ERROR; -} - -/* - *--------------------------------------------------------------------------- - * - * TclpCopyFile -- - * - * Copy a single file (not a directory). If dst already exists and - * is not a directory, it is removed. - * - * Results: - * If the file was successfully copied, returns TCL_OK. Otherwise - * the return value is TCL_ERROR and errno is set to indicate the - * error. Some possible values for errno are: - * - * EACCES: src or dst parent directory can't be read and/or written. - * EISDIR: src or dst is a directory. - * ENOENT: src doesn't exist. src or dst is "". - * - * EACCES: exists an open file already referring to dst (95). - * EACCES: src specifies a char device (nul:, com1:, etc.) (NT) - * ENOENT: src specifies a char device (nul:, com1:, etc.) (95) - * - * Side effects: - * It is not an error to copy to a char device. - * - *--------------------------------------------------------------------------- - */ - -int -TclpCopyFile( - char *src, /* Pathname of file to be copied. */ - char *dst) /* Pathname of file to copy to. */ -{ - /* - * Would throw an exception under NT if one of the arguments is a char - * block device. - */ - - try { - if (CopyFile(src, dst, 0) != FALSE) { - return TCL_OK; - } - } except (-1) {} - - TclWinConvertError(GetLastError()); - if (errno == EBADF) { - errno = EACCES; - return TCL_ERROR; - } - if (errno == EACCES) { - DWORD srcAttr, dstAttr; - - srcAttr = GetFileAttributes(src); - dstAttr = GetFileAttributes(dst); - if (srcAttr != (DWORD) -1) { - if (dstAttr == (DWORD) -1) { - dstAttr = 0; - } - if ((srcAttr & FILE_ATTRIBUTE_DIRECTORY) || - (dstAttr & FILE_ATTRIBUTE_DIRECTORY)) { - errno = EISDIR; - } - if (dstAttr & FILE_ATTRIBUTE_READONLY) { - SetFileAttributes(dst, dstAttr & ~FILE_ATTRIBUTE_READONLY); - if (CopyFile(src, dst, 0) != FALSE) { - return TCL_OK; - } - /* - * Still can't copy onto dst. Return that error, and - * restore attributes of dst. - */ - - TclWinConvertError(GetLastError()); - SetFileAttributes(dst, dstAttr); - } - } - } - return TCL_ERROR; -} - -/* - *--------------------------------------------------------------------------- - * - * TclpDeleteFile -- - * - * Removes a single file (not a directory). - * - * Results: - * If the file was successfully deleted, returns TCL_OK. Otherwise - * the return value is TCL_ERROR and errno is set to indicate the - * error. Some possible values for errno are: - * - * EACCES: a parent directory can't be read and/or written. - * EISDIR: path is a directory. - * ENOENT: path doesn't exist or is "". - * - * EACCES: exists an open file already referring to path. - * EACCES: path is a char device (nul:, com1:, etc.) - * - * Side effects: - * The file is deleted, even if it is read-only. - * - *--------------------------------------------------------------------------- - */ - -int -TclpDeleteFile( - char *path) /* Pathname of file to be removed. */ -{ - DWORD attr; - - if (DeleteFile(path) != FALSE) { - return TCL_OK; - } - TclWinConvertError(GetLastError()); - if (path[0] == '\0') { - /* - * Win32s thinks that "" is the same as "." and then reports EISDIR - * instead of ENOENT. - */ - - errno = ENOENT; - } else if (errno == EACCES) { - attr = GetFileAttributes(path); - if (attr != (DWORD) -1) { - if (attr & FILE_ATTRIBUTE_DIRECTORY) { - /* - * Windows NT reports removing a directory as EACCES instead - * of EISDIR. - */ - - errno = EISDIR; - } else if (attr & FILE_ATTRIBUTE_READONLY) { - SetFileAttributes(path, attr & ~FILE_ATTRIBUTE_READONLY); - if (DeleteFile(path) != FALSE) { - return TCL_OK; - } - TclWinConvertError(GetLastError()); - SetFileAttributes(path, attr); - } - } - } else if (errno == ENOENT) { - attr = GetFileAttributes(path); - if (attr != (DWORD) -1) { - if (attr & FILE_ATTRIBUTE_DIRECTORY) { - /* - * Windows 95 reports removing a directory as ENOENT instead - * of EISDIR. - */ - - errno = EISDIR; - } - } - } else if (errno == EINVAL) { - /* - * Windows NT reports removing a char device as EINVAL instead of - * EACCES. - */ - - errno = EACCES; - } - - return TCL_ERROR; -} - -/* - *--------------------------------------------------------------------------- - * - * TclpCreateDirectory -- - * - * Creates the specified directory. All parent directories of the - * specified directory must already exist. The directory is - * automatically created with permissions so that user can access - * the new directory and create new files or subdirectories in it. - * - * Results: - * If the directory was successfully created, returns TCL_OK. - * Otherwise the return value is TCL_ERROR and errno is set to - * indicate the error. Some possible values for errno are: - * - * EACCES: a parent directory can't be read and/or written. - * EEXIST: path already exists. - * ENOENT: a parent directory doesn't exist. - * - * Side effects: - * A directory is created. - * - *--------------------------------------------------------------------------- - */ - -int -TclpCreateDirectory( - char *path) /* Pathname of directory to create */ -{ - int error; - - if (CreateDirectory(path, NULL) == 0) { - error = GetLastError(); - if (TclWinGetPlatformId() == VER_PLATFORM_WIN32s) { - if ((error == ERROR_ACCESS_DENIED) - && (GetFileAttributes(path) != (DWORD) -1)) { - error = ERROR_FILE_EXISTS; - } - } - TclWinConvertError(error); - return TCL_ERROR; - } - return TCL_OK; -} - -/* - *--------------------------------------------------------------------------- - * - * TclpCopyDirectory -- - * - * Recursively copies a directory. The target directory dst must - * not already exist. Note that this function does not merge two - * directory hierarchies, even if the target directory is an an - * empty directory. - * - * Results: - * If the directory was successfully copied, returns TCL_OK. - * Otherwise the return value is TCL_ERROR, errno is set to indicate - * the error, and the pathname of the file that caused the error - * is stored in errorPtr. See TclpCreateDirectory and TclpCopyFile - * for a description of possible values for errno. - * - * Side effects: - * An exact copy of the directory hierarchy src will be created - * with the name dst. If an error occurs, the error will - * be returned immediately, and remaining files will not be - * processed. - * - *--------------------------------------------------------------------------- - */ - -int -TclpCopyDirectory( - char *src, /* Pathname of directory to be copied. */ - char *dst, /* Pathname of target directory. */ - Tcl_DString *errorPtr) /* If non-NULL, initialized DString for - * error reporting. */ -{ - int result; - Tcl_DString srcBuffer; - Tcl_DString dstBuffer; - - Tcl_DStringInit(&srcBuffer); - Tcl_DStringInit(&dstBuffer); - Tcl_DStringAppend(&srcBuffer, src, -1); - Tcl_DStringAppend(&dstBuffer, dst, -1); - result = TraverseWinTree(TraversalCopy, &srcBuffer, &dstBuffer, - errorPtr); - Tcl_DStringFree(&srcBuffer); - Tcl_DStringFree(&dstBuffer); - return result; -} - -/* - *---------------------------------------------------------------------- - * - * TclpRemoveDirectory -- - * - * Removes directory (and its contents, if the recursive flag is set). - * - * Results: - * If the directory was successfully removed, returns TCL_OK. - * Otherwise the return value is TCL_ERROR, errno is set to indicate - * the error, and the pathname of the file that caused the error - * is stored in errorPtr. Some possible values for errno are: - * - * EACCES: path directory can't be read and/or written. - * EEXIST: path is a non-empty directory. - * EINVAL: path is root directory or current directory. - * ENOENT: path doesn't exist or is "". - * ENOTDIR: path is not a directory. - * - * EACCES: path is a char device (nul:, com1:, etc.) (95) - * EINVAL: path is a char device (nul:, com1:, etc.) (NT) - * - * Side effects: - * Directory removed. If an error occurs, the error will be returned - * immediately, and remaining files will not be deleted. - * - *---------------------------------------------------------------------- - */ - -int -TclpRemoveDirectory( - char *path, /* Pathname of directory to be removed. */ - int recursive, /* If non-zero, removes directories that - * are nonempty. Otherwise, will only remove - * empty directories. */ - Tcl_DString *errorPtr) /* If non-NULL, initialized DString for - * error reporting. */ -{ - int result; - Tcl_DString buffer; - DWORD attr; - - if (RemoveDirectory(path) != FALSE) { - return TCL_OK; - } - TclWinConvertError(GetLastError()); - if (path[0] == '\0') { - /* - * Win32s thinks that "" is the same as "." and then reports EACCES - * instead of ENOENT. - */ - - errno = ENOENT; - } - if (errno == EACCES) { - attr = GetFileAttributes(path); - if (attr != (DWORD) -1) { - if ((attr & FILE_ATTRIBUTE_DIRECTORY) == 0) { - /* - * Windows 95 reports calling RemoveDirectory on a file as an - * EACCES, not an ENOTDIR. - */ - - errno = ENOTDIR; - goto end; - } - - if (attr & FILE_ATTRIBUTE_READONLY) { - attr &= ~FILE_ATTRIBUTE_READONLY; - if (SetFileAttributes(path, attr) == FALSE) { - goto end; - } - if (RemoveDirectory(path) != FALSE) { - return TCL_OK; - } - TclWinConvertError(GetLastError()); - SetFileAttributes(path, attr | FILE_ATTRIBUTE_READONLY); - } - - /* - * Windows 95 and Win32s report removing a non-empty directory - * as EACCES, not EEXIST. If the directory is not empty, - * change errno so caller knows what's going on. - */ - - if (TclWinGetPlatformId() != VER_PLATFORM_WIN32_NT) { - HANDLE handle; - WIN32_FIND_DATA data; - Tcl_DString buffer; - char *find; - int len; - - Tcl_DStringInit(&buffer); - find = Tcl_DStringAppend(&buffer, path, -1); - len = Tcl_DStringLength(&buffer); - if ((len > 0) && (find[len - 1] != '\\')) { - Tcl_DStringAppend(&buffer, "\\", 1); - } - find = Tcl_DStringAppend(&buffer, "*.*", 3); - handle = FindFirstFile(find, &data); - if (handle != INVALID_HANDLE_VALUE) { - while (1) { - if ((strcmp(data.cFileName, ".") != 0) - && (strcmp(data.cFileName, "..") != 0)) { - /* - * Found something in this directory. - */ - - errno = EEXIST; - break; - } - if (FindNextFile(handle, &data) == FALSE) { - break; - } - } - FindClose(handle); - } - Tcl_DStringFree(&buffer); - } - } - } - if (errno == ENOTEMPTY) { - /* - * The caller depends on EEXIST to signify that the directory is - * not empty, not ENOTEMPTY. - */ - - errno = EEXIST; - } - if ((recursive != 0) && (errno == EEXIST)) { - /* - * The directory is nonempty, but the recursive flag has been - * specified, so we recursively remove all the files in the directory. - */ - - Tcl_DStringInit(&buffer); - Tcl_DStringAppend(&buffer, path, -1); - result = TraverseWinTree(TraversalDelete, &buffer, NULL, errorPtr); - Tcl_DStringFree(&buffer); - return result; - } - - end: - if (errorPtr != NULL) { - Tcl_DStringAppend(errorPtr, path, -1); - } - return TCL_ERROR; -} - -/* - *--------------------------------------------------------------------------- - * - * TraverseWinTree -- - * - * Traverse directory tree specified by sourcePtr, calling the function - * traverseProc for each file and directory encountered. If destPtr - * is non-null, each of name in the sourcePtr directory is appended to - * the directory specified by destPtr and passed as the second argument - * to traverseProc() . - * - * Results: - * Standard Tcl result. - * - * Side effects: - * None caused by TraverseWinTree, however the user specified - * traverseProc() may change state. If an error occurs, the error will - * be returned immediately, and remaining files will not be processed. - * - *--------------------------------------------------------------------------- - */ - -static int -TraverseWinTree( - TraversalProc *traverseProc,/* Function to call for every file and - * directory in source hierarchy. */ - Tcl_DString *sourcePtr, /* Pathname of source directory to be - * traversed. */ - Tcl_DString *targetPtr, /* Pathname of directory to traverse in - * parallel with source directory. */ - Tcl_DString *errorPtr) /* If non-NULL, an initialized DString for - * error reporting. */ -{ - DWORD sourceAttr; - char *source, *target, *errfile; - int result, sourceLen, targetLen, sourceLenOriginal, targetLenOriginal; - HANDLE handle; - WIN32_FIND_DATA data; - - result = TCL_OK; - source = Tcl_DStringValue(sourcePtr); - sourceLenOriginal = Tcl_DStringLength(sourcePtr); - if (targetPtr != NULL) { - target = Tcl_DStringValue(targetPtr); - targetLenOriginal = Tcl_DStringLength(targetPtr); - } else { - target = NULL; - targetLenOriginal = 0; - } - - errfile = NULL; - - sourceAttr = GetFileAttributes(source); - if (sourceAttr == (DWORD) -1) { - errfile = source; - goto end; - } - if ((sourceAttr & FILE_ATTRIBUTE_DIRECTORY) == 0) { - /* - * Process the regular file - */ - - return (*traverseProc)(source, target, sourceAttr, DOTREE_F, errorPtr); - } - - /* - * When given the pathname of the form "c:\" (one that already ends - * with a backslash), must make sure not to add another "\" to the end - * otherwise it will try to access a network drive. - */ - - sourceLen = sourceLenOriginal; - if ((sourceLen > 0) && (source[sourceLen - 1] != '\\')) { - Tcl_DStringAppend(sourcePtr, "\\", 1); - sourceLen++; - } - source = Tcl_DStringAppend(sourcePtr, "*.*", 3); - handle = FindFirstFile(source, &data); - Tcl_DStringSetLength(sourcePtr, sourceLen); - if (handle == INVALID_HANDLE_VALUE) { - /* - * Can't read directory - */ - - TclWinConvertError(GetLastError()); - errfile = source; - goto end; - } - - result = (*traverseProc)(source, target, sourceAttr, DOTREE_PRED, errorPtr); - if (result != TCL_OK) { - FindClose(handle); - return result; - } - - if (targetPtr != NULL) { - targetLen = targetLenOriginal; - if ((targetLen > 0) && (target[targetLen - 1] != '\\')) { - target = Tcl_DStringAppend(targetPtr, "\\", 1); - targetLen++; - } - } - - while (1) { - if ((strcmp(data.cFileName, ".") != 0) - && (strcmp(data.cFileName, "..") != 0)) { - /* - * Append name after slash, and recurse on the file. - */ - - Tcl_DStringAppend(sourcePtr, data.cFileName, -1); - if (targetPtr != NULL) { - Tcl_DStringAppend(targetPtr, data.cFileName, -1); - } - result = TraverseWinTree(traverseProc, sourcePtr, targetPtr, - errorPtr); - if (result != TCL_OK) { - break; - } - - /* - * Remove name after slash. - */ - - Tcl_DStringSetLength(sourcePtr, sourceLen); - if (targetPtr != NULL) { - Tcl_DStringSetLength(targetPtr, targetLen); - } - } - if (FindNextFile(handle, &data) == FALSE) { - break; - } - } - FindClose(handle); - - /* - * Strip off the trailing slash we added - */ - - Tcl_DStringSetLength(sourcePtr, sourceLenOriginal); - source = Tcl_DStringValue(sourcePtr); - if (targetPtr != NULL) { - Tcl_DStringSetLength(targetPtr, targetLenOriginal); - target = Tcl_DStringValue(targetPtr); - } - - if (result == TCL_OK) { - /* - * Call traverseProc() on a directory after visiting all the - * files in that directory. - */ - - result = (*traverseProc)(source, target, sourceAttr, - DOTREE_POSTD, errorPtr); - } - end: - if (errfile != NULL) { - TclWinConvertError(GetLastError()); - if (errorPtr != NULL) { - Tcl_DStringAppend(errorPtr, errfile, -1); - } - result = TCL_ERROR; - } - - return result; -} - -/* - *---------------------------------------------------------------------- - * - * TraversalCopy - * - * Called from TraverseUnixTree in order to execute a recursive - * copy of a directory. - * - * Results: - * Standard Tcl result. - * - * Side effects: - * Depending on the value of type, src may be copied to dst. - * - *---------------------------------------------------------------------- - */ - -static int -TraversalCopy( - char *src, /* Source pathname to copy. */ - char *dst, /* Destination pathname of copy. */ - DWORD srcAttr, /* File attributes for src. */ - int type, /* Reason for call - see TraverseWinTree() */ - Tcl_DString *errorPtr) /* If non-NULL, initialized DString for - * error return. */ -{ - switch (type) { - case DOTREE_F: - if (TclpCopyFile(src, dst) == TCL_OK) { - return TCL_OK; - } - break; - - case DOTREE_PRED: - if (TclpCreateDirectory(dst) == TCL_OK) { - if (SetFileAttributes(dst, srcAttr) != FALSE) { - return TCL_OK; - } - TclWinConvertError(GetLastError()); - } - break; - - case DOTREE_POSTD: - return TCL_OK; - - } - - /* - * There shouldn't be a problem with src, because we already - * checked it to get here. - */ - - if (errorPtr != NULL) { - Tcl_DStringAppend(errorPtr, dst, -1); - } - return TCL_ERROR; -} - -/* - *---------------------------------------------------------------------- - * - * TraversalDelete -- - * - * Called by procedure TraverseWinTree for every file and - * directory that it encounters in a directory hierarchy. This - * procedure unlinks files, and removes directories after all the - * containing files have been processed. - * - * Results: - * Standard Tcl result. - * - * Side effects: - * Files or directory specified by src will be deleted. If an - * error occurs, the windows error is converted to a Posix error - * and errno is set accordingly. - * - *---------------------------------------------------------------------- - */ - -static int -TraversalDelete( - char *src, /* Source pathname. */ - char *ignore, /* Destination pathname (not used). */ - DWORD srcAttr, /* File attributes for src (not used). */ - int type, /* Reason for call - see TraverseWinTree(). */ - Tcl_DString *errorPtr) /* If non-NULL, initialized DString for - * error return. */ -{ - switch (type) { - case DOTREE_F: - if (TclpDeleteFile(src) == TCL_OK) { - return TCL_OK; - } - break; - - case DOTREE_PRED: - return TCL_OK; - - case DOTREE_POSTD: - if (TclpRemoveDirectory(src, 0, NULL) == TCL_OK) { - return TCL_OK; - } - break; - - } - - if (errorPtr != NULL) { - Tcl_DStringAppend(errorPtr, src, -1); - } - return TCL_ERROR; -} - -/* - *---------------------------------------------------------------------- - * - * AttributesPosixError -- - * - * Sets the object result with the appropriate error. - * - * Results: - * None. - * - * Side effects: - * The interp's object result is set with an error message - * based on the objIndex, fileName and errno. - * - *---------------------------------------------------------------------- - */ - -static void -AttributesPosixError( - Tcl_Interp *interp, /* The interp that has the error */ - int objIndex, /* The attribute which caused the problem. */ - char *fileName, /* The name of the file which caused the - * error. */ - int getOrSet) /* 0 for get; 1 for set */ -{ - TclWinConvertError(GetLastError()); - Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), - "cannot ", getOrSet ? "set" : "get", " attribute \"", - tclpFileAttrStrings[objIndex], "\" for file \"", fileName, - "\": ", Tcl_PosixError(interp), (char *) NULL); -} - -/* - *---------------------------------------------------------------------- - * - * GetWinFileAttributes -- - * - * Returns a Tcl_Obj containing the value of a file attribute. - * This routine gets the -hidden, -readonly or -system attribute. - * - * Results: - * Standard Tcl result and a Tcl_Obj in attributePtrPtr. The object - * will have ref count 0. If the return value is not TCL_OK, - * attributePtrPtr is not touched. - * - * Side effects: - * A new object is allocated if the file is valid. - * - *---------------------------------------------------------------------- - */ - -static int -GetWinFileAttributes( - Tcl_Interp *interp, /* The interp we are using for errors. */ - int objIndex, /* The index of the attribute. */ - char *fileName, /* The name of the file. */ - Tcl_Obj **attributePtrPtr) /* A pointer to return the object with. */ -{ - DWORD result = GetFileAttributes(fileName); - - if (result == 0xFFFFFFFF) { - AttributesPosixError(interp, objIndex, fileName, 0); - return TCL_ERROR; - } - - *attributePtrPtr = Tcl_NewBooleanObj(result & attributeArray[objIndex]); - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * - * ConvertFileNameFormat -- - * - * Returns a Tcl_Obj containing either the long or short version of the - * file name. - * - * Results: - * Standard Tcl result and a Tcl_Obj in attributePtrPtr. The object - * will have ref count 0. If the return value is not TCL_OK, - * attributePtrPtr is not touched. - * - * Side effects: - * A new object is allocated if the file is valid. - * - *---------------------------------------------------------------------- - */ - -static int -ConvertFileNameFormat( - Tcl_Interp *interp, /* The interp we are using for errors. */ - int objIndex, /* The index of the attribute. */ - char *fileName, /* The name of the file. */ - int longShort, /* 0 to short name, 1 to long name. */ - Tcl_Obj **attributePtrPtr) /* A pointer to return the object with. */ -{ - HANDLE findHandle; - WIN32_FIND_DATA findData; - int pathArgc, i; - char **pathArgv, **newPathArgv; - char *currentElement, *resultStr; - Tcl_DString resultDString; - int result = TCL_OK; - - Tcl_SplitPath(fileName, &pathArgc, &pathArgv); - newPathArgv = (char **) ckalloc(pathArgc * sizeof(char *)); - - i = 0; - if ((pathArgv[0][0] == '/') - || ((strlen(pathArgv[0]) == 3) && (pathArgv[0][1] == ':'))) { - newPathArgv[0] = (char *) ckalloc(strlen(pathArgv[0]) + 1); - strcpy(newPathArgv[0], pathArgv[0]); - i = 1; - } - for ( ; i < pathArgc; i++) { - if (strcmp(pathArgv[i], ".") == 0) { - currentElement = ckalloc(2); - strcpy(currentElement, "."); - } else if (strcmp(pathArgv[i], "..") == 0) { - currentElement = ckalloc(3); - strcpy(currentElement, ".."); - } else { - int useLong; - - Tcl_DStringInit(&resultDString); - resultStr = Tcl_JoinPath(i + 1, pathArgv, &resultDString); - findHandle = FindFirstFile(resultStr, &findData); - if (findHandle == INVALID_HANDLE_VALUE) { - pathArgc = i - 1; - AttributesPosixError(interp, objIndex, fileName, 0); - result = TCL_ERROR; - Tcl_DStringFree(&resultDString); - goto cleanup; - } - if (longShort) { - if (findData.cFileName[0] != '\0') { - useLong = 1; - } else { - useLong = 0; - } - } else { - if (findData.cAlternateFileName[0] == '\0') { - useLong = 1; - } else { - useLong = 0; - } - } - if (useLong) { - currentElement = ckalloc(strlen(findData.cFileName) + 1); - strcpy(currentElement, findData.cFileName); - } else { - currentElement = ckalloc(strlen(findData.cAlternateFileName) - + 1); - strcpy(currentElement, findData.cAlternateFileName); - } - Tcl_DStringFree(&resultDString); - FindClose(findHandle); - } - newPathArgv[i] = currentElement; - } - - Tcl_DStringInit(&resultDString); - resultStr = Tcl_JoinPath(pathArgc, newPathArgv, &resultDString); - *attributePtrPtr = Tcl_NewStringObj(resultStr, Tcl_DStringLength(&resultDString)); - Tcl_DStringFree(&resultDString); - -cleanup: - for (i = 0; i < pathArgc; i++) { - ckfree(newPathArgv[i]); - } - ckfree((char *) newPathArgv); - return result; -} - -/* - *---------------------------------------------------------------------- - * - * GetWinFileLongName -- - * - * Returns a Tcl_Obj containing the short version of the file - * name. - * - * Results: - * Standard Tcl result and a Tcl_Obj in attributePtrPtr. The object - * will have ref count 0. If the return value is not TCL_OK, - * attributePtrPtr is not touched. - * - * Side effects: - * A new object is allocated if the file is valid. - * - *---------------------------------------------------------------------- - */ - -static int -GetWinFileLongName( - Tcl_Interp *interp, /* The interp we are using for errors. */ - int objIndex, /* The index of the attribute. */ - char *fileName, /* The name of the file. */ - Tcl_Obj **attributePtrPtr) /* A pointer to return the object with. */ -{ - return ConvertFileNameFormat(interp, objIndex, fileName, 1, attributePtrPtr); -} - -/* - *---------------------------------------------------------------------- - * - * GetWinFileShortName -- - * - * Returns a Tcl_Obj containing the short version of the file - * name. - * - * Results: - * Standard Tcl result and a Tcl_Obj in attributePtrPtr. The object - * will have ref count 0. If the return value is not TCL_OK, - * attributePtrPtr is not touched. - * - * Side effects: - * A new object is allocated if the file is valid. - * - *---------------------------------------------------------------------- - */ - -static int -GetWinFileShortName( - Tcl_Interp *interp, /* The interp we are using for errors. */ - int objIndex, /* The index of the attribute. */ - char *fileName, /* The name of the file. */ - Tcl_Obj **attributePtrPtr) /* A pointer to return the object with. */ -{ - return ConvertFileNameFormat(interp, objIndex, fileName, 0, attributePtrPtr); -} - -/* - *---------------------------------------------------------------------- - * - * SetWinFileAttributes -- - * - * Set the file attributes to the value given by attributePtr. - * This routine sets the -hidden, -readonly, or -system attributes. - * - * Results: - * Standard TCL error. - * - * Side effects: - * The file's attribute is set. - * - *---------------------------------------------------------------------- - */ - -static int -SetWinFileAttributes( - Tcl_Interp *interp, /* The interp we are using for errors. */ - int objIndex, /* The index of the attribute. */ - char *fileName, /* The name of the file. */ - Tcl_Obj *attributePtr) /* The new value of the attribute. */ -{ - DWORD fileAttributes = GetFileAttributes(fileName); - int yesNo; - int result; - - if (fileAttributes == 0xFFFFFFFF) { - AttributesPosixError(interp, objIndex, fileName, 1); - return TCL_ERROR; - } - - result = Tcl_GetBooleanFromObj(interp, attributePtr, &yesNo); - if (result != TCL_OK) { - return result; - } - - if (yesNo) { - fileAttributes |= (attributeArray[objIndex]); - } else { - fileAttributes &= ~(attributeArray[objIndex]); - } - - if (!SetFileAttributes(fileName, fileAttributes)) { - AttributesPosixError(interp, objIndex, fileName, 1); - return TCL_ERROR; - } - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * - * SetWinFileLongName -- - * - * The attribute in question is a readonly attribute and cannot - * be set. - * - * Results: - * TCL_ERROR - * - * Side effects: - * The object result is set to a pertinant error message. - * - *---------------------------------------------------------------------- - */ - -static int -CannotSetAttribute( - Tcl_Interp *interp, /* The interp we are using for errors. */ - int objIndex, /* The index of the attribute. */ - char *fileName, /* The name of the file. */ - Tcl_Obj *attributePtr) /* The new value of the attribute. */ -{ - Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), - "cannot set attribute \"", tclpFileAttrStrings[objIndex], - "\" for file \"", fileName, "\" : attribute is readonly", - (char *) NULL); - return TCL_ERROR; -} - - -/* - *--------------------------------------------------------------------------- - * - * TclpListVolumes -- - * - * Lists the currently mounted volumes - * - * Results: - * A standard Tcl result. Will always be TCL_OK, since there is no way - * that this command can fail. Also, the interpreter's result is set to - * the list of volumes. - * - * Side effects: - * None - * - *--------------------------------------------------------------------------- - */ - -int -TclpListVolumes( - Tcl_Interp *interp) /* Interpreter to which to pass the volume list */ -{ - Tcl_Obj *resultPtr, *elemPtr; - char buf[4]; - int i; - - resultPtr = Tcl_GetObjResult(interp); - - buf[1] = ':'; - buf[2] = '/'; - buf[3] = '\0'; - - /* - * On Win32s: - * GetLogicalDriveStrings() isn't implemented. - * GetLogicalDrives() returns incorrect information. - */ - - for (i = 0; i < 26; i++) { - buf[0] = (char) ('a' + i); - if (GetVolumeInformation(buf, NULL, 0, NULL, NULL, NULL, NULL, 0) - || (GetLastError() == ERROR_NOT_READY)) { - elemPtr = Tcl_NewStringObj(buf, -1); - Tcl_ListObjAppendElement(NULL, resultPtr, elemPtr); - } - } - return TCL_OK; -} diff --git a/win/tclWinFile.c b/win/tclWinFile.c deleted file mode 100644 index 4f0f26d..0000000 --- a/win/tclWinFile.c +++ /dev/null @@ -1,647 +0,0 @@ -/* - * tclWinFile.c -- - * - * This file contains temporary wrappers around UNIX file handling - * functions. These wrappers map the UNIX functions to Win32 HANDLE-style - * files, which can be manipulated through the Win32 console redirection - * interfaces. - * - * 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. - * - * RCS: @(#) $Id: tclWinFile.c,v 1.3 1998/09/14 18:40:20 stanton Exp $ - */ - -#include "tclWinInt.h" -#include <sys/stat.h> -#include <shlobj.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; - - -/* - *---------------------------------------------------------------------- - * - * 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]. */ -{ - Tcl_DString buffer; - int length; - - Tcl_DStringInit(&buffer); - - if (tclExecutableName != NULL) { - ckfree(tclExecutableName); - tclExecutableName = NULL; - } - - /* - * Under Windows we ignore argv0, and return the path for the file used to - * create this process. - */ - - Tcl_DStringSetLength(&buffer, MAX_PATH+1); - length = GetModuleFileName(NULL, Tcl_DStringValue(&buffer), MAX_PATH+1); - if (length > 0) { - tclExecutableName = (char *) ckalloc((unsigned) (length + 1)); - strcpy(tclExecutableName, Tcl_DStringValue(&buffer)); - } - Tcl_DStringFree(&buffer); -} - -/* - *---------------------------------------------------------------------- - * - * 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; /* Directory separators to pass to TclDoGlob. */ - Tcl_DString *dirPtr; /* Contains path to directory to search. */ - char *pattern; /* Pattern to match against. */ - char *tail; /* Pointer to end of pattern. Tail must - * point to a location in pattern. */ -{ - char drivePattern[4] = "?:\\"; - char *newPattern, *p, *dir, *root, c; - char *src, *dest; - int length, matchDotFiles; - int result = TCL_OK; - int baseLength = Tcl_DStringLength(dirPtr); - Tcl_DString buffer; - DWORD atts, volFlags; - HANDLE handle; - WIN32_FIND_DATA data; - BOOL found; - - /* - * Convert the path to normalized form since some interfaces only - * accept backslashes. Also, ensure that the directory ends with a - * separator character. - */ - - Tcl_DStringInit(&buffer); - if (baseLength == 0) { - Tcl_DStringAppend(&buffer, ".", 1); - } else { - Tcl_DStringAppend(&buffer, Tcl_DStringValue(dirPtr), - Tcl_DStringLength(dirPtr)); - } - for (p = Tcl_DStringValue(&buffer); *p != '\0'; p++) { - if (*p == '/') { - *p = '\\'; - } - } - p--; - if (*p != '\\' && *p != ':') { - Tcl_DStringAppend(&buffer, "\\", 1); - } - dir = Tcl_DStringValue(&buffer); - - /* - * First verify that the specified path is actually a directory. - */ - - atts = GetFileAttributes(dir); - if ((atts == 0xFFFFFFFF) || ((atts & FILE_ATTRIBUTE_DIRECTORY) == 0)) { - Tcl_DStringFree(&buffer); - return TCL_OK; - } - - /* - * Next check the volume information for the directory to see whether - * comparisons should be case sensitive or not. If the root is null, then - * we use the root of the current directory. If the root is just a drive - * specifier, we use the root directory of the given drive. - */ - - switch (Tcl_GetPathType(dir)) { - case TCL_PATH_RELATIVE: - found = GetVolumeInformation(NULL, NULL, 0, NULL, - NULL, &volFlags, NULL, 0); - break; - case TCL_PATH_VOLUME_RELATIVE: - if (*dir == '\\') { - root = NULL; - } else { - root = drivePattern; - *root = *dir; - } - found = GetVolumeInformation(root, NULL, 0, NULL, - NULL, &volFlags, NULL, 0); - break; - case TCL_PATH_ABSOLUTE: - if (dir[1] == ':') { - root = drivePattern; - *root = *dir; - found = GetVolumeInformation(root, NULL, 0, NULL, - NULL, &volFlags, NULL, 0); - } else if (dir[1] == '\\') { - p = strchr(dir+2, '\\'); - p = strchr(p+1, '\\'); - p++; - c = *p; - *p = 0; - found = GetVolumeInformation(dir, NULL, 0, NULL, - NULL, &volFlags, NULL, 0); - *p = c; - } - break; - } - - if (!found) { - Tcl_DStringFree(&buffer); - TclWinConvertError(GetLastError()); - Tcl_ResetResult(interp); - Tcl_AppendResult(interp, "couldn't read volume information for \"", - dirPtr->string, "\": ", Tcl_PosixError(interp), (char *) NULL); - return TCL_ERROR; - } - - /* - * In Windows, although some volumes may support case sensitivity, Windows - * doesn't honor case. So in globbing we need to ignore the case - * of file names. - */ - - length = tail - pattern; - newPattern = ckalloc(length+1); - for (src = pattern, dest = newPattern; src < tail; src++, dest++) { - *dest = (char) tolower(*src); - } - *dest = '\0'; - - /* - * We need to check all files in the directory, so append a *.* - * to the path. - */ - - - dir = Tcl_DStringAppend(&buffer, "*.*", 3); - - /* - * Now open the directory for reading and iterate over the contents. - */ - - handle = FindFirstFile(dir, &data); - Tcl_DStringFree(&buffer); - - if (handle == INVALID_HANDLE_VALUE) { - TclWinConvertError(GetLastError()); - Tcl_ResetResult(interp); - Tcl_AppendResult(interp, "couldn't read directory \"", - dirPtr->string, "\": ", Tcl_PosixError(interp), (char *) NULL); - ckfree(newPattern); - return TCL_ERROR; - } - - /* - * Clean up the tail pointer. Leave the tail pointing to the - * first character after the path separator or NULL. - */ - - if (*tail == '\\') { - tail++; - } - if (*tail == '\0') { - tail = NULL; - } else { - tail++; - } - - /* - * Check to see if the pattern needs to compare with dot files. - */ - - if ((newPattern[0] == '.') - || ((pattern[0] == '\\') && (pattern[1] == '.'))) { - matchDotFiles = 1; - } else { - matchDotFiles = 0; - } - - /* - * Now iterate over all of the files in the directory. - */ - - Tcl_DStringInit(&buffer); - for (found = 1; found; found = FindNextFile(handle, &data)) { - char *matchResult; - - /* - * Ignore hidden files. - */ - - if (!matchDotFiles && (data.cFileName[0] == '.')) { - continue; - } - - /* - * Check to see if the file matches the pattern. We need to convert - * the file name to lower case for comparison purposes. Note that we - * are ignoring the case sensitivity flag because Windows doesn't honor - * case even if the volume is case sensitive. If the volume also - * doesn't preserve case, then we return the lower case form of the - * name, otherwise we return the system form. - */ - - matchResult = NULL; - Tcl_DStringSetLength(&buffer, 0); - Tcl_DStringAppend(&buffer, data.cFileName, -1); - for (p = buffer.string; *p != '\0'; p++) { - *p = (char) tolower(*p); - } - if (Tcl_StringMatch(buffer.string, newPattern)) { - if (volFlags & FS_CASE_IS_PRESERVED) { - matchResult = data.cFileName; - } else { - matchResult = buffer.string; - } - } - - if (matchResult == NULL) { - continue; - } - - /* - * If the file matches, then we need to process the remainder of the - * path. If there are more characters to process, then ensure matching - * files are directories and call TclDoGlob. Otherwise, just add the - * file to the result. - */ - - Tcl_DStringSetLength(dirPtr, baseLength); - Tcl_DStringAppend(dirPtr, matchResult, -1); - if (tail == NULL) { - Tcl_AppendElement(interp, dirPtr->string); - } else { - atts = GetFileAttributes(dirPtr->string); - if (atts & FILE_ATTRIBUTE_DIRECTORY) { - Tcl_DStringAppend(dirPtr, "/", 1); - result = TclDoGlob(interp, separators, dirPtr, tail); - if (result != TCL_OK) { - break; - } - } - } - } - - Tcl_DStringFree(&buffer); - FindClose(handle); - ckfree(newPattern); - return result; -} - -/* - *---------------------------------------------------------------------- - * - * 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 (!SetCurrentDirectory(dirName)) { - TclWinConvertError(GetLastError()); - 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. 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. */ -{ - static char buffer[MAXPATHLEN+1]; - char *bufPtr, *p; - - if (currentDir == NULL) { - if (GetCurrentDirectory(MAXPATHLEN+1, buffer) == 0) { - TclWinConvertError(GetLastError()); - if (interp != NULL) { - if (errno == ERANGE) { - Tcl_SetResult(interp, - "working directory name is too long", - TCL_STATIC); - } else { - Tcl_AppendResult(interp, - "error getting working directory name: ", - Tcl_PosixError(interp), (char *) NULL); - } - } - return NULL; - } - /* - * Watch for the wierd Windows '95 c:\\UNC syntax. - */ - - if (buffer[0] != '\0' && buffer[1] == ':' && buffer[2] == '\\' - && buffer[3] == '\\') { - bufPtr = &buffer[2]; - } else { - bufPtr = buffer; - } - - /* - * Convert to forward slashes for easier use in scripts. - */ - - for (p = bufPtr; *p != '\0'; p++) { - if (*p == '\\') { - *p = '/'; - } - } - } - return bufPtr; -} - -#if 0 -/* - *------------------------------------------------------------------------- - * - * TclWinResolveShortcut -- - * - * Resolve a potential Windows shortcut to get the actual file or - * directory in question. - * - * Results: - * Returns 1 if the shortcut could be resolved, or 0 if there was - * an error or if the filename was not a shortcut. - * If bufferPtr did hold the name of a shortcut, it is modified to - * hold the resolved target of the shortcut instead. - * - * Side effects: - * Loads and unloads OLE package to determine if filename refers to - * a shortcut. - * - *------------------------------------------------------------------------- - */ - -int -TclWinResolveShortcut(bufferPtr) - Tcl_DString *bufferPtr; /* Holds name of file to resolve. On - * return, holds resolved file name. */ -{ - HRESULT hres; - IShellLink *psl; - IPersistFile *ppf; - WIN32_FIND_DATA wfd; - WCHAR wpath[MAX_PATH]; - char *path, *ext; - char realFileName[MAX_PATH]; - - /* - * Windows system calls do not automatically resolve - * shortcuts like UNIX automatically will with symbolic links. - */ - - path = Tcl_DStringValue(bufferPtr); - ext = strrchr(path, '.'); - if ((ext == NULL) || (stricmp(ext, ".lnk") != 0)) { - return 0; - } - - CoInitialize(NULL); - path = Tcl_DStringValue(bufferPtr); - realFileName[0] = '\0'; - hres = CoCreateInstance(&CLSID_ShellLink, NULL, CLSCTX_INPROC_SERVER, - &IID_IShellLink, &psl); - if (SUCCEEDED(hres)) { - hres = psl->lpVtbl->QueryInterface(psl, &IID_IPersistFile, &ppf); - if (SUCCEEDED(hres)) { - MultiByteToWideChar(CP_ACP, 0, path, -1, wpath, sizeof(wpath)); - hres = ppf->lpVtbl->Load(ppf, wpath, STGM_READ); - if (SUCCEEDED(hres)) { - hres = psl->lpVtbl->Resolve(psl, NULL, - SLR_ANY_MATCH | SLR_NO_UI); - if (SUCCEEDED(hres)) { - hres = psl->lpVtbl->GetPath(psl, realFileName, MAX_PATH, - &wfd, 0); - } - } - ppf->lpVtbl->Release(ppf); - } - psl->lpVtbl->Release(psl); - } - CoUninitialize(); - - if (realFileName[0] != '\0') { - Tcl_DStringSetLength(bufferPtr, 0); - Tcl_DStringAppend(bufferPtr, realFileName, -1); - return 1; - } - return 0; -} -#endif - -/* - *---------------------------------------------------------------------- - * - * TclpStat, TclpLstat -- - * - * These functions replace the library versions of stat and lstat. - * - * The stat and lstat functions provided by some Windows compilers - * are incomplete. Ideally, a complete rewrite of stat would go - * here; now, the only fix is that stat("c:") used to return an - * error instead infor for current dir on specified drive. - * - * Results: - * See stat documentation. - * - * Side effects: - * See stat documentation. - * - *---------------------------------------------------------------------- - */ - -int -TclpStat(path, buf) - CONST char *path; /* Path of file to stat (in current CP). */ - struct stat *buf; /* Filled with results of stat call. */ -{ - char name[4]; - int result; - - if ((strlen(path) == 2) && (path[1] == ':')) { - strcpy(name, path); - name[2] = '.'; - name[3] = '\0'; - path = name; - } - -#undef stat - - result = stat(path, buf); - -#ifndef _MSC_VER - - /* - * Borland's stat doesn't take into account localtime. - */ - - if ((result == 0) && (buf->st_mtime != 0)) { - TIME_ZONE_INFORMATION tz; - int time, bias; - - time = GetTimeZoneInformation(&tz); - bias = tz.Bias; - if (time == TIME_ZONE_ID_DAYLIGHT) { - bias += tz.DaylightBias; - } - bias *= 60; - buf->st_atime -= bias; - buf->st_ctime -= bias; - buf->st_mtime -= bias; - } - -#endif - - return result; -} - -/* - *--------------------------------------------------------------------------- - * - * TclpAccess -- - * - * This function replaces the library version of access. - * - * The library version of access returns that all files have execute - * permission. - * - * Results: - * See access documentation. - * - * Side effects: - * See access documentation. - * - *--------------------------------------------------------------------------- - */ - -int -TclpAccess( - CONST char *path, /* Path of file to access (in current CP). */ - int mode) /* Permission setting. */ -{ - int result; - CONST char *p; - -#undef access - - result = access(path, mode); - - if (result == 0) { - if (mode & 1) { - if (GetFileAttributes(path) & FILE_ATTRIBUTE_DIRECTORY) { - /* - * Directories are always executable. - */ - - return 0; - } - p = strrchr(path, '.'); - if (p != NULL) { - p++; - if ((stricmp(p, "exe") == 0) - || (stricmp(p, "com") == 0) - || (stricmp(p, "bat") == 0)) { - /* - * File that ends with .exe, .com, or .bat is executable. - */ - - return 0; - } - } - errno = EACCES; - return -1; - } - } - return result; -} - diff --git a/win/tclsh.rc b/win/tclsh.rc deleted file mode 100644 index 098ec86..0000000 --- a/win/tclsh.rc +++ /dev/null @@ -1,36 +0,0 @@ -// RCS: @(#) $Id: tclsh.rc,v 1.2 1998/09/14 18:40:20 stanton Exp $ -// -// Version -// - -#define RESOURCE_INCLUDED -#include <tcl.h> - -VS_VERSION_INFO VERSIONINFO - FILEVERSION TCL_MAJOR_VERSION,TCL_MINOR_VERSION,TCL_RELEASE_LEVEL,TCL_RELEASE_SERIAL - PRODUCTVERSION TCL_MAJOR_VERSION,TCL_MINOR_VERSION,TCL_RELEASE_LEVEL,TCL_RELEASE_SERIAL - FILEFLAGSMASK 0x3fL - FILEFLAGS 0x0L - FILEOS 0x4L - FILETYPE 0x1L - FILESUBTYPE 0x0L -BEGIN - BLOCK "StringFileInfo" - BEGIN - BLOCK "040904b0" - BEGIN - VALUE "FileDescription", "Tclsh Application\0" - VALUE "OriginalFilename", "tclsh" STRINGIFY(TCL_MAJOR_VERSION) STRINGIFY(TCL_MINOR_VERSION) ".exe\0" - VALUE "CompanyName", "Sun Microsystems, Inc\0" - VALUE "FileVersion", TCL_PATCH_LEVEL - VALUE "LegalCopyright", "Copyright \251 1995-1996\0" - VALUE "ProductName", "Tcl " TCL_VERSION " for Windows\0" - VALUE "ProductVersion", TCL_PATCH_LEVEL - END - END - BLOCK "VarFileInfo" - BEGIN - VALUE "Translation", 0x409, 1200 - END -END - |