d/freebsd-dev
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

Import tcl7.5p1

Browse Source
This commit is contained in:
phk 1996-09-18 14:12:34 +00:00
parent 00febf6009
commit 4170733a21
62 changed files with 2365 additions and 1043 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

74
contrib/tcl/README
View File

@ -1,23 +1,22 @@
Tcl
by John Ousterhout (and many others at Sun Microsystems and elsewhere)
john.ousterhout@eng.sun.com
SCCS: @(#) README 1.29 96/04/19 11:42:58
SCCS: @(#) README 1.32 96/07/31 16:29:01
1. Introduction
---------------
This directory and its descendants contain the sources and documentation
for Tcl, an embeddable scripting language. The information here corresponds
to release 7.5. The most important new feature in this release is support
for the PC and Mac platforms. In addition, there are major new facilities
for dynamic loading, package and version management, multiple interpreters,
safe execution of untrusted scripts, and a new I/O system that supports
for Tcl, an embeddable scripting language. The information here
corresponds to release 7.5p1, the first patch release for Tcl 7.5. The
most important new feature in Tcl 7.5 is support for the PC and Mac
platforms. In addition, there are major new facilities for dynamic
loading, package and version management, multiple interpreters, safe
execution of untrusted scripts, and a new I/O system that supports
nonblocking I/O and sockets. This release also contains many bug fixes.
Tcl 7.5 should be backwards compatible with Tcl 7.4 scripts (there are two
small incompatibilities described below, but they are relatively insignificant
and shouldn't affect most existing Tcl code and extensions).
Tcl 7.5 should be backwards compatible with Tcl 7.4 scripts (there are
two small incompatibilities described below, but they are relatively
insignificant and shouldn't affect most existing Tcl code and
extensions).
2. Documentation
----------------
@ -66,22 +65,38 @@ or Win 3.1 with Win32s).
Before trying to compile Tcl you should do the following things:
(a) Check for a binary release. Pre-compiled binary releases are
available now for PCs and Macintoshes, and they may be available
in the future for some flavors of UNIX. Binary releases are much
easier to install than source releases. To find out whether a
binary release is available for your platform, check the home page
for the Sun Tcl/Tk project (http://www.sunlabs.com/research/tcl)
and also check in the FTP directory from which you retrieved the
base distribution.
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 home page for the Sun Tcl/Tk project
(http://www.sunlabs.com/research/tcl) and also check in the FTP
directory from which you retrieved the base distribution. Some
of the binary releases are available freely, while others are for
sale.
(b) Check for patches. Look in the FTP directory from which you
retrieved the base distribution and see if there are files with
names like tcl7.5p1.patch, tcl7.5p2.patch, etc. These files may
also have .gz or .Z extensions to indicate compression. If you find
any patch files, apply them to the source directory in order
from "p1" up. To apply an uncompressed patch file such as
tcl7.5p1.patch, invoke a shell command like the following from
the directory containing this file:
(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
tcl7.5p1.tar.Z is a complete release for patch level 1 of Tcl
version 7.5. 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.
Patches are also available in the form of patch files that just
contain the changes from one patch level to another. These
files have names like tcl7.5p1.patch, tcl7.5p2.patch, etc. They
may also have .gz or .Z extensions to indicate compression. To
use one of these files, you apply it to an existing release with
the "patch" program. Patches must be applied in order:
tcl7.5p1.patch must be applied to an unpatched Tcl 7.5 release
to produce a Tcl 7.5p1 release; tcl7.5p2.patch can then be
applied to Tcl7.5 p1 to produce Tcl 7.5 p2, and so on. To apply an
uncompressed patch file such as tcl7.5p1.patch, invoke a shell
command like the following from the directory containing this
file:
patch -p < tcl7.5p1.patch
If the patch file has a .gz extension, invoke a command like the
following:
@ -329,3 +344,8 @@ 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.5p2) should be completely
compatible with the base release from which it is derived (e.g. Tcl
7.5), and you should normally use the highest available patch release.

152
contrib/tcl/changes
View File

@ -1,6 +1,6 @@
Recent user-visible changes to Tcl:
SCCS: @(#) changes 1.115 96/04/18 16:43:36
SCCS: @(#) changes 1.142 96/08/01 17:00:22
1. No more [command1] [command2] construct for grouping multiple
commands on a single command line.
@ -2029,3 +2029,153 @@ are not run if these commands are not present. (JL)
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 -----------------------

52
contrib/tcl/doc/Alloc.3 Normal file
View File

@ -0,0 +1,52 @@
'\"
'\" Copyright (c) 1995-1996 Sun Microsystems, Inc.
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\"
'\" SCCS: @(#) Alloc.3 1.2 96/06/05 18:00:19
'\"
.so man.macros
.TH Tcl_Alloc 3 7.5 Tcl "Tcl Library Procedures"
.BS
.SH NAME
Tcl_Alloc, Tcl_Free, Tcl_Realloc \- allocate or free heap memory
.SH SYNOPSIS
.nf
\fB#include <tcl.h>\fR
.sp
char *
\fBTcl_Alloc\fR(\fIsize\fR)
.sp
\fBTcl_Free\fR(\fIptr\fR)
.sp
char *
\fBTcl_Realloc\fR(\fIptr, size\fR)
.SH ARGUMENTS
.AS char *size
.AP int size in
Size in bytes of the memory block to allocate.
.AP char *ptr in
Pointer to memory block to free or realloc.
.BE
.SH DESCRIPTION
.PP
These procedures provide a platform and compiler independent interface
for memory allocation. Programs that need to transfer ownership of
memory blocks between Tcl and other modules should use these routines
rather than the native \fBmalloc()\fR and \fBfree()\fR routines
provided by the C run-time library.
.PP
\fBTcl_Alloc\fR returns a pointer to a block of at least \fIsize\fR
bytes suitably aligned for any use.
.PP
\fBTcl_Free\fR makes the space referred to by \fIptr\fR available for
further allocation.
.PP
\fBTcl_Realloc\fR changes the size of the block pointed to by
\fIptr\fR to \fIsize\fR bytes and returns a pointer to the new block.
The contents will be unchanged up to the lesser of the new and old
sizes. The returned location may be different from \fIptr\fR.
.SH KEYWORDS
alloc, allocation, free, malloc, memory, realloc

10
contrib/tcl/doc/Concat.3
View File

@ -5,10 +5,10 @@
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\"
'\" SCCS: @(#) Concat.3 1.10 96/03/25 19:58:01
'\" SCCS: @(#) Concat.3 1.11 96/06/05 18:00:12
'\"
.so man.macros
.TH Tcl_Concat 3 "" Tcl "Tcl Library Procedures"
.TH Tcl_Concat 3 7.5 Tcl "Tcl Library Procedures"
.BS
.SH NAME
Tcl_Concat \- concatenate a collection of strings
@ -43,9 +43,11 @@ copies strings from \fBargv\fR to the result. If an element of
is ignored entirely. This white-space removal was added to make
the output of the \fBconcat\fR command cleaner-looking.
.PP
.VS
The result string is dynamically allocated
using \fBmalloc()\fR; the caller must eventually release the space
by calling \fBfree()\fR.
using \fBTcl_Alloc\fR; the caller must eventually release the space
by calling \fBTcl_Free\fR.
.VE
.SH KEYWORDS
concatenate, strings

16
contrib/tcl/doc/Interp.3
View File

@ -5,10 +5,10 @@
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\"
'\" SCCS: @(#) Interp.3 1.14 96/03/25 20:04:19
'\" SCCS: @(#) Interp.3 1.16 96/06/06 13:48:02
'\"
.so man.macros
.TH Tcl_Interp 3 "" Tcl "Tcl Library Procedures"
.TH Tcl_Interp 3 7.5 Tcl "Tcl Library Procedures"
.BS
.SH NAME
Tcl_Interp \- client-visible fields of interpreter structures
@ -57,12 +57,16 @@ should point to an empty string.
Normally, results are assumed to be statically allocated,
which means that the contents will not change before the next time
\fBTcl_Eval\fR is called or some other command procedure is invoked.
.VS
In this case, the \fIfreeProc\fR field must be zero.
Alternatively, a command procedure may dynamically
allocate its return value (e.g. using \fBmalloc\fR)
allocate its return value (e.g. using \fBTcl_Alloc\fR)
and store a pointer to it in \fIinterp->result\fR.
In this case, the command procedure must also set \fIinterp->freeProc\fR
to the address of a procedure that can free the value (usually \fBfree\fR).
to the address of a procedure that can free the value, or \fBTCL_DYNAMIC\fR
if the storage was allocated directly by Tcl or by a call to
\fBTcl_Alloc\fR.
.VE
If \fIinterp->freeProc\fR is non-zero, then Tcl will call \fIfreeProc\fR
to free the space pointed to by \fIinterp->result\fR before it
invokes the next command.
@ -74,8 +78,10 @@ macro should be used for this purpose).
\fIFreeProc\fR should have arguments and result that match the
\fBTcl_FreeProc\fR declaration above: it receives a single
argument which is a pointer to the result value to free.
In most applications \fBfree\fR is the only non-zero value ever
.VS
In most applications \fBTCL_DYNAMIC\fR is the only non-zero value ever
used for \fIfreeProc\fR.
.VE
However, an application may store a different procedure address
in \fIfreeProc\fR in order to use an alternate memory allocator
or in order to do other cleanup when the result memory is freed.

6
contrib/tcl/doc/LinkVar.3
View File

@ -5,7 +5,7 @@
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\"
'\" SCCS: @(#) LinkVar.3 1.12 96/03/25 20:04:31
'\" SCCS: @(#) LinkVar.3 1.13 96/06/05 18:00:14
'\"
.so man.macros
.TH Tcl_LinkVar 3 7.5 Tcl "Tcl Library Procedures"
@ -83,8 +83,10 @@ Tcl errors.
.TP
\fBTCL_LINK_STRING\fR
The C variable is of type \fBchar *\fR.
.VS
If its value is not null then it must be a pointer to a string
allocated with \fBmalloc\fR.
allocated with \fBTcl_Alloc\fR.
.VE
Whenever the Tcl variable is modified the current C string will be
freed and new memory will be allocated to hold a copy of the variable's
new value.

10
contrib/tcl/doc/Notifier.3
View File

@ -4,7 +4,7 @@
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\"
'\" SCCS: @(#) Notifier.3 1.10 96/03/28 09:38:26
'\" SCCS: @(#) Notifier.3 1.11 96/06/05 18:00:17
'\"
.so man.macros
.TH Tcl_CreateEventSource 3 7.5 Tcl "Tcl Library Procedures"
@ -53,7 +53,9 @@ is NULL, it means there is no maximum wait time: wait forever if
necessary.
.AP Tcl_Event *evPtr in
An event to add to the event queue. The storage for the event must
have been allocated by the caller using \fBmalloc\fR or \fBckalloc\fR.
.VS
have been allocated by the caller using \fBTcl_Alloc\fR or \fBckalloc\fR.
.VE
.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.
@ -319,7 +321,9 @@ of window events.
When \fIproc\fR returns 1, \fBTcl_DoOneEvent\fR will remove the
event from the event queue and free its storage.
Note that the storage for an event must be allocated by
the event source (using \fBmalloc\fR or the Tcl macro \fBckalloc\fR)
.VS
the event source (using \fBTcl_Alloc\fR or the Tcl macro \fBckalloc\fR)
.VE
before calling \fBTcl_QueueEvent\fR, but it
will be freed by \fBTcl_DoOneEvent\fR, not by the event source.

9
contrib/tcl/doc/Preserve.3
View File

@ -5,7 +5,7 @@
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\"
'\" SCCS: @(#) Preserve.3 1.12 96/03/25 20:05:27
'\" SCCS: @(#) Preserve.3 1.13 96/05/28 09:26:12
'\"
.so man.macros
.TH Tcl_Preserve 3 7.5 Tcl "Tcl Library Procedures"
@ -81,10 +81,13 @@ All the work of freeing the object is carried out by \fIfreeProc\fR.
\fIFreeProc\fR must have arguments and result that match the
type \fBTcl_FreeProc\fR:
.CS
typedef void Tcl_FreeProc(ClientData \fIclientData\fR);
typedef void Tcl_FreeProc(char *\fIblockPtr\fR);
.CE
The \fIclientData\fR argument to \fIfreeProc\fR will be the
The \fIblockPtr\fR argument to \fIfreeProc\fR will be the
same as the \fIclientData\fR argument to \fBTcl_EventuallyFree\fR.
The type of \fIblockPtr\fR (\fBchar *\fR) is different than the type of the
\fIclientData\fR argument to \fBTcl_EventuallyFree\fR for historical
reasons, but the value is the same.
.PP
This mechanism can be used to solve the problem described above
by placing \fBTcl_Preserve\fR and \fBTcl_Release\fR calls around

10
contrib/tcl/doc/SetResult.3
View File

@ -5,10 +5,10 @@
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\"
'\" SCCS: @(#) SetResult.3 1.18 96/03/25 20:06:54
'\" SCCS: @(#) SetResult.3 1.19 96/06/05 18:00:15
'\"
.so man.macros
.TH Tcl_SetResult 3 7.0 Tcl "Tcl Library Procedures"
.TH Tcl_SetResult 3 7.5 Tcl "Tcl Library Procedures"
.BS
.SH NAME
Tcl_SetResult, Tcl_AppendResult, Tcl_AppendElement, Tcl_ResetResult \- manipulate Tcl result string
@ -51,11 +51,13 @@ command in \fIinterp\fR, replacing any existing result.
If \fIfreeProc\fR is \fBTCL_STATIC\fR it means that \fIstring\fR
refers to an area of static storage that is guaranteed not to be
modified until at least the next call to \fBTcl_Eval\fR.
.VS
If \fIfreeProc\fR
is \fBTCL_DYNAMIC\fR it means that \fIstring\fR was allocated with a call
to \fBmalloc()\fR and is now the property of the Tcl system.
to \fBTcl_Alloc\fR and is now the property of the Tcl system.
\fBTcl_SetResult\fR will arrange for the string's storage to be
released by calling \fBfree()\fR when it is no longer needed.
released by calling \fBTcl_Free\fR when it is no longer needed.
.VE
If \fIfreeProc\fR is \fBTCL_VOLATILE\fR it means that \fIstring\fR
points to an area of memory that is likely to be overwritten when
\fBTcl_SetResult\fR returns (e.g. it points to something in a stack frame).

14
contrib/tcl/doc/SplitList.3
View File

@ -5,10 +5,10 @@
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\"
'\" SCCS: @(#) SplitList.3 1.19 96/03/25 20:07:46
'\" SCCS: @(#) SplitList.3 1.20 96/06/05 18:00:16
'\"
.so man.macros
.TH Tcl_SplitList 3 7.4 Tcl "Tcl Library Procedures"
.TH Tcl_SplitList 3 7.5 Tcl "Tcl Library Procedures"
.BS
.SH NAME
Tcl_SplitList, Tcl_Merge, Tcl_ScanElement, Tcl_ConvertElement \- manipulate Tcl lists
@ -85,9 +85,11 @@ code = Tcl_SplitList(interp, string, &argc, &argv);
.CE
Then you should eventually free the storage with a call like the
following:
.VS
.CS
free((char *) argv);
Tcl_Free((char *) argv);
.CE
.VE
.PP
\fBTcl_SplitList\fR normally returns \fBTCL_OK\fR, which means the list was
successfully parsed.
@ -110,9 +112,11 @@ it will be parsed into \fIargc\fR words whose values will
be the same as the \fIargv\fR strings passed to \fBTcl_Merge\fR.
\fBTcl_Merge\fR will modify the list elements with braces and/or
backslashes in order to produce proper Tcl list structure.
.VS
The result string is dynamically allocated
using \fBmalloc()\fR; the caller must eventually release the space
using \fBfree()\fR.
using \fBTcl_Alloc\fR; the caller must eventually release the space
using \fBTcl_Free\fR.
.VE
.PP
If the result of \fBTcl_Merge\fR is passed to \fBTcl_SplitList\fR,
the elements returned by \fBTcl_SplitList\fR will be identical to

93
contrib/tcl/doc/SplitPath.3 Normal file
View File

@ -0,0 +1,93 @@
'\"
'\" Copyright (c) 1996 Sun Microsystems, Inc.
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\"
'\" SCCS: @(#) SplitPath.3 1.3 96/07/31 17:04:33
'\"
.so man.macros
.TH Tcl_SplitPath 3 7.5 Tcl "Tcl Library Procedures"
.BS
.SH NAME
Tcl_SplitPath, Tcl_JoinPath, Tcl_GetPathType \- manipulate platform-dependent file paths
.SH SYNOPSIS
.nf
\fB#include <tcl.h>\fR
.sp
\fBTcl_SplitPath\fR(\fIpath, argcPtr, argvPtr\fR)
.sp
char *
\fBTcl_JoinPath\fR(\fIargc, argv, resultPtr\fR)
.sp
Tcl_PathType
\fBTcl_GetPathType\fR(\fIpath\fR)
.SH ARGUMENTS
.AS Tcl_DString ***argvPtr
.AP char *path in
File path in a form appropriate for the current platform (see the
\fBfilename\fR manual entry for acceptable forms for path names).
.AP int *argcPtr out
Filled in with number of path elements in \fIpath\fR.
.AP char ***argvPtr out
\fI*argvPtr\fR will be filled in with the address of an array of
pointers to the strings that are the extracted elements of \fIpath\fR.
There will be \fI*argcPtr\fR valid entries in the array, followed by
a NULL entry.
.AP int argc in
Number of elements in \fIargv\fR.
.AP char **argv in
Array of path elements to merge together into a single path.
.AP Tcl_DString *resultPtr in/out
A pointer to an initialized \fBTcl_DString\fR to which the result of
\fBTcl_JoinPath\fR will be appended.
.BE
.SH DESCRIPTION
.PP
These procedures may be used to disassemble and reassemble file
paths in a platform independent manner: they provide C-level access to
the same functionality as the \fBfile split\fR, \fBfile join\fR, and
\fBfile pathtype\fR commands.
.PP
\fBTcl_SplitPath\fR breaks a path into its constituent elements,
returning an array of pointers to the elements using \fIargcPtr\fR and
\fIargvPtr\fR. The area of memory pointed to by \fI*argvPtr\fR is
dynamically allocated; in addition to the array of pointers, it also
holds copies of all the path elements. It is the caller's
responsibility to free all of this storage.
For example, suppose that you have called \fBTcl_SplitPath\fR with the
following code:
.CS
int argc, code;
char *path;
char **argv;
\&...
code = Tcl_SplitPath(interp, string, &argc, &argv);
.CE
Then you should eventually free the storage with a call like the
following:
.CS
Tcl_Free((char *) argv);
.CE
.PP
\fBTcl_JoinPath\fR is the inverse of \fBTcl_SplitPath\fR: it takes a
collection of path elements given by \fIargc\fR and \fIargv\fR and
generates a result string that is a properly constructed path. The
result string is appended to \fIresultPtr\fR. \fIResultPtr\fR must
refer to an initialized \fBTcl_DString\fR.
.PP
If the result of \fBTcl_SplitPath\fR is passed to \fBTcl_JoinPath\fR,
the result will refer to the same location, but may not be in the same
form. This is because \fBTcl_SplitPath\fR and \fBTcl_JoinPath\fR
eliminate duplicate path separators and return a normalized form for
each platform.
.PP
\fBTcl_GetPathType\fR returns the type of the specified \fIpath\fR,
where \fBTcl_PathType\fR is one of \fBTCL_PATH_ABSOLUTE\fR,
\fBTCL_PATH_RELATIVE\fR, or \fBTCL_PATH_VOLUME_RELATIVE\fR. See the
\fBfilename\fR manual entry for a description of the path types for
each platform.
.SH KEYWORDS
file, filename, join, path, split, type

75
contrib/tcl/doc/clock.n
View File

@ -8,7 +8,7 @@
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\"
'\" SCCS: @(#) clock.n 1.12 96/04/16 08:20:08
'\" SCCS: @(#) clock.n 1.13 96/05/03 14:40:37
'\"
.so man.macros
.TH clock n 7.4 Tcl "Tcl Built-In Commands"
@ -48,61 +48,68 @@ Valid field descriptors are:
.IP \fB%%\fR
Insert a %.
.IP \fB%a\fR
Abbreviated weekday name. (Mon, Tue, etc.)
Abbreviated weekday name (Mon, Tue, etc.).
.IP \fB%A\fR
Full weekday name. (Monday, Tuesday, etc.)
Full weekday name (Monday, Tuesday, etc.).
.IP \fB%b\fR
Abbreviated month name. (Jan, Feb, etc.)
Abbreviated month name (Jan, Feb, etc.).
.IP \fB%B\fR
Full month name.
.IP \fB%c\fR
Locale specific date and time.
.IP \fB%d\fR
Day of month (01 - 31).
.IP \fB%H\fR
Hour in 24-hour format (00 - 23).
.IP \fB%I\fR
Hour in 12-hour format (00 - 12).
.IP \fB%j\fR
Day of year (001 - 366).
.IP \fB%m\fR
Month number (01 - 12).
.IP \fB%M\fR
Minute (00 - 59).
.IP \fB%p\fR
AM/PM indicator.
.IP \fB%S\fR
Seconds (00 - 59).
.IP \fB%U\fR
Week of year (01 - 52), Sunday is the first day of the week.
.IP \fB%w\fR
Weekday number (Sunday = 0).
.IP \fB%W\fR
Week of year (01 - 52), Monday is the first day of the week.
.IP \fB%x\fR
Locale specific date format.
.IP \fB%X\fR
Locale specific time format.
.IP \fB%y\fR
Year without century (00 - 99).
.IP \fB%Y\fR
Year with century (e.g. 1990)
.IP \fB%Z\fR
Time zone name.
.RE
.sp
.RS
In addition, the following field descriptors may be supported on some
systems (e.g. Unix but not Windows):
.IP \fB%D\fR
Date as %m/%d/%y.
.IP \fB%e\fR
Day of month (1 - 31), no leading zeros.
.IP \fB%h\fR
Abbreviated month name.
.IP \fB%H\fR
Hour (00 - 23).
.IP \fB%I\fR
Hour (00 - 12).
.IP \fB%j\fR
Day number of year (001 - 366).
.IP \fB%m\fR
Month number (01 - 12).
.IP \fB%M\fR
Minute (00 - 59).
.IP \fB%n\fR
Insert a newline.
.IP \fB%p\fR
AM or PM.
.IP \fB%r\fR
Time as %I:%M:%S %p.
.IP \fB%R\fR
Time as %H:%M.
.IP \fB%S\fR
Seconds (00 - 59).
.IP \fB%t\fR
Insert a tab.
.IP \fB%T\fR
Time as %H:%M:%S.
.IP \fB%U\fR
Week number of year (01 - 52), Sunday is the first day of the week.
.IP \fB%w\fR
Weekday number (Sunday = 0).
.IP \fB%W\fR
Week number of year (01 - 52), Monday is the first day of the week.
.IP \fB%x\fR
Local specific date format.
.IP \fB%X\fR
Local specific time format.
.IP \fB%y\fR
Year within century (00 - 99).
.IP \fB%Y\fR
Year as ccyy (e.g. 1990)
.IP \fB%Z\fR
Time zone name.
.RE
.sp
.RS

7
contrib/tcl/doc/info.n
View File

@ -5,7 +5,7 @@
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\"
'\" SCCS: @(#) info.n 1.12 96/03/25 20:17:12
'\" SCCS: @(#) info.n 1.13 96/07/20 16:07:40
'\"
.so man.macros
.TH info n 7.5 Tcl "Tcl Built-In Commands"
@ -106,7 +106,10 @@ Each list element is a sub-list with two elements consisting of the
name of the file from which the package was loaded and the name of
the package.
For statically-loaded packages the file name will be an empty string.
\fIInterp\fR defaults to the current interpreter.
If \fIinterp\fR is omitted then information is returned for all packages
loaded in any interpreter in the process.
To get a list of just the packages in the current interpreter, specify
an empty string for the \fIinterp\fR argument.
.VE
.TP
\fBinfo locals \fR?\fIpattern\fR?

33
contrib/tcl/doc/interp.n
View File

@ -4,7 +4,7 @@
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\"
'\" SCCS: @(#) interp.n 1.15 96/03/25 20:17:28
'\" SCCS: @(#) interp.n 1.19 96/05/10 16:36:44
'\"
.so man.macros
.TH interp n 7.5 Tcl "Tcl Built-In Commands"
@ -305,18 +305,21 @@ A safe interpreter is created with exactly the following set of
built-in commands:
.DS
.ta 1.2i 2.4i 3.6i
\fBappend array break case
catch clock close concat
continue eof error eval
expr fblocked flush for
foreach format gets global
history if incr info
interp join lappend lindex
list llength lrange lreplace
pid proc puts read
regexp regsub rename return
scan set seek split
string switch tell trace\fR
\fBafter append array break
case catch clock close
concat continue eof error
eval expr fblocked fileevent
flush for foreach format
gets global history if
incr info interp join
lappend lindex linsert list
llength lower lrange lreplace
lsearch lsort package pid
proc puts read rename
return scan seek set
split string subst switch
tell trace unset update
uplevel upvar vwait while\fR
.DE
All commands not on this list are removed from the interpreter by
the \fBinterp create\fR command. Of course, the missing commands
@ -332,8 +335,8 @@ to untrusted code executing in a safe interpreter would incur a
security risk.
.PP
If extensions are loaded into a safe interpreter, they may also restrict
their own functionality to eliminate unsafe commands. The management of
extensions for safety will be explained in the manual entries for the
their own functionality to eliminate unsafe commands. For a discussion of
management of extensions for safety see the manual entries for the
\fBpackage\fR and \fBload\fR Tcl commands.
.SH CREDITS
.PP

15
contrib/tcl/doc/license.terms
View File

@ -26,7 +26,14 @@ IS PROVIDED ON AN "AS IS" BASIS, AND THE AUTHORS AND DISTRIBUTORS HAVE
NO OBLIGATION TO PROVIDE MAINTENANCE, SUPPORT, UPDATES, ENHANCEMENTS, OR
MODIFICATIONS.
RESTRICTED RIGHTS: Use, duplication or disclosure by the government
is subject to the restrictions as set forth in subparagraph (c) (1) (ii)
of the Rights in Technical Data and Computer Software Clause as DFARS
252.227-7013 and FAR 52.227-19.
GOVERNMENT USE: If you are acquiring this software on behalf of the
U.S. government, the Government shall have only "Restricted Rights"
in the software and related documentation as defined in the Federal
Acquisition Regulations (FARs) in Clause 52.227.19 (c) (2). If you
are acquiring the software on behalf of the Department of Defense, the
software shall be classified as "Commercial Computer Software" and the
Government shall have only "Restricted Rights" as defined in Clause
252.227-7013 (c) (1) of DFARs. Notwithstanding the foregoing, the
authors grant the U.S. Government and others acting in its behalf
permission to use and distribute the software in accordance with the
terms specified in this license.

4
contrib/tcl/generic/patchlevel.h
View File

@ -17,7 +17,7 @@
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
* SCCS: @(#) patchlevel.h 1.17 96/04/08 14:15:07
* SCCS: @(#) patchlevel.h 1.18 96/07/17 14:17:33
*/
#define TCL_PATCH_LEVEL "7.5"
#define TCL_PATCH_LEVEL "7.5p1"

52
contrib/tcl/generic/tcl.h
View File

@ -10,7 +10,7 @@
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
* SCCS: @(#) tcl.h 1.266 96/04/10 11:25:19
* SCCS: @(#) tcl.h 1.269 96/06/13 16:36:48
*/
#ifndef _TCL
@ -21,16 +21,26 @@
* compilers. We use this method because there is no autoconf equivalent.
*/
#if defined(_WIN32) && !defined(__WIN32__)
# define __WIN32__
#ifndef __WIN32__
# if defined(_WIN32) || defined(WIN32)
# define __WIN32__
# endif
#endif
#ifdef __WIN32__
# undef USE_PROTOTYPE
# undef HAS_STDARG
# define USE_PROTOTYPE
# define HAS_STDARG
#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
# ifndef USE_TCLALLOC
# define USE_TCLALLOC 1
# endif
#endif /* __WIN32__ */
#ifndef BUFSIZ
#include <stdio.h>
@ -343,8 +353,16 @@ typedef struct Tcl_DString {
* 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__)
@ -355,10 +373,15 @@ EXTERN void Tcl_ValidateAllMemory _ANSI_ARGS_((char *file,
#else
# define ckalloc(x) malloc(x)
# define ckfree(x) free(x)
# define ckrealloc(x,y) realloc(x,y)
# 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)
@ -695,8 +718,9 @@ EXTERN void Tcl_CallWhenDeleted _ANSI_ARGS_((Tcl_Interp *interp,
ClientData clientData));
EXTERN void Tcl_CancelIdleCall _ANSI_ARGS_((Tcl_IdleProc *idleProc,
ClientData clientData));
EXTERN VOID * Tcl_Ckalloc _ANSI_ARGS_((unsigned int size));
EXTERN void Tcl_Ckfree _ANSI_ARGS_((char *ptr));
#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));

28
contrib/tcl/generic/tclBasic.c
View File

@ -11,7 +11,7 @@
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
* SCCS: @(#) tclBasic.c 1.210 96/03/25 17:17:54
* SCCS: @(#) tclBasic.c 1.211 96/05/10 17:48:04
*/
#include "tclInt.h"
@ -20,6 +20,16 @@
#endif
#include "patchlevel.h"
/*
* This variable indicates to the close procedures of channel drivers that
* we are in the middle of an interpreter deletion, and hence in "implicit"
* close mode. In that mode, the close procedures should not close the
* OS handle for standard IO channels. Since interpreter deletion may be
* recursive, this variable is actually a counter of the levels of nesting.
*/
int tclInInterpreterDeletion = 0;
/*
* Static procedures in this file:
*/
@ -569,6 +579,13 @@ DeleteInterpProc(interp)
panic("DeleteInterpProc called on interpreter not marked deleted");
}
/*
* Increment the interp deletion counter, so that close procedures
* for channel drivers can notice that we are in "implicit" close mode.
*/
tclInInterpreterDeletion++;
/*
* First delete all the commands. There's a special hack here
* because "tkerror" is just a synonym for "bgerror" (they share
@ -676,6 +693,15 @@ DeleteInterpProc(interp)
iPtr->tracePtr = nextPtr;
}
/*
* Finally decrement the nested interpreter deletion counter.
*/
tclInInterpreterDeletion--;
if (tclInInterpreterDeletion < 0) {
tclInInterpreterDeletion = 0;
}
ckfree((char *) iPtr);
}

88
contrib/tcl/generic/tclCkalloc.c
View File

@ -13,7 +13,7 @@
* This code contributed by Karl Lehenbauer and Mark Diekhans
*
*
* SCCS: @(#) tclCkalloc.c 1.17 96/03/14 13:05:56
* SCCS: @(#) tclCkalloc.c 1.20 96/06/06 13:48:27
*/
#include "tclInt.h"
@ -471,6 +471,50 @@ Tcl_DbCkrealloc(ptr, size, file, line)
Tcl_DbCkfree(ptr, file, line);
return(new);
}
/*
*----------------------------------------------------------------------
*
* Tcl_Alloc, et al. --
*
* These functions are defined in terms of the debugging versions
* when TCL_MEM_DEBUG is set.
*
* Results:
* Same as the debug versions.
*
* Side effects:
* Same as the debug versions.
*
*----------------------------------------------------------------------
*/
#undef Tcl_Alloc
#undef Tcl_Free
#undef Tcl_Realloc
char *
Tcl_Alloc(size)
unsigned int size;
{
return Tcl_DbCkalloc(size, "unknown", 0);
}
void
Tcl_Free(ptr)
char *ptr;
{
Tcl_DbCkfree(ptr, "unknown", 0);
}
char *
Tcl_Realloc(ptr, size)
char *ptr;
unsigned int size;
{
return Tcl_DbCkrealloc(ptr, size, "unknown", 0);
}
/*
*----------------------------------------------------------------------
@ -606,8 +650,8 @@ void
Tcl_InitMemory(interp)
Tcl_Interp *interp;
{
Tcl_CreateCommand (interp, "memory", MemoryCmd, (ClientData) NULL,
(Tcl_CmdDeleteProc *) NULL);
Tcl_CreateCommand (interp, "memory", MemoryCmd, (ClientData) NULL,
(Tcl_CmdDeleteProc *) NULL);
}
#else
@ -616,14 +660,15 @@ Tcl_CreateCommand (interp, "memory", MemoryCmd, (ClientData) NULL,
/*
*----------------------------------------------------------------------
*
* Tcl_Ckalloc --
* Tcl_Alloc --
* Interface to malloc when TCL_MEM_DEBUG is disabled. It does check
* that memory was actually allocated.
*
*----------------------------------------------------------------------
*/
VOID *
Tcl_Ckalloc (size)
char *
Tcl_Alloc (size)
unsigned int size;
{
char *result;
@ -633,7 +678,6 @@ Tcl_Ckalloc (size)
panic("unable to alloc %d bytes", size);
return result;
}
char *
Tcl_DbCkalloc(size, file, line)
@ -653,6 +697,30 @@ Tcl_DbCkalloc(size, file, line)
return result;
}
/*
*----------------------------------------------------------------------
*
* Tcl_Realloc --
* Interface to realloc when TCL_MEM_DEBUG is disabled. It does check
* that memory was actually allocated.
*
*----------------------------------------------------------------------
*/
char *
Tcl_Realloc(ptr, size)
char *ptr;
unsigned int size;
{
char *result;
result = realloc(ptr, size);
if (result == NULL)
panic("unable to realloc %d bytes", size);
return result;
}
char *
Tcl_DbCkrealloc(ptr, size, file, line)
char *ptr;
@ -671,18 +739,20 @@ Tcl_DbCkrealloc(ptr, size, file, line)
}
return result;
}
/*
*----------------------------------------------------------------------
*
* TckCkfree --
* Tcl_Free --
* Interface to free when TCL_MEM_DEBUG is disabled. Done here rather
* in the macro to keep some modules from being compiled with
* TCL_MEM_DEBUG enabled and some with it disabled.
*
*----------------------------------------------------------------------
*/
void
Tcl_Ckfree (ptr)
Tcl_Free (ptr)
char *ptr;
{
free (ptr);

36
contrib/tcl/generic/tclClock.c
View File

@ -11,7 +11,7 @@
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
* SCCS: @(#) tclClock.c 1.19 96/03/13 11:28:45
* SCCS: @(#) tclClock.c 1.20 96/07/23 16:14:45
*/
#include "tcl.h"
@ -71,7 +71,7 @@ Tcl_ClockCmd (dummy, interp, argc, argv)
argv[0], " clicks\"", (char *) NULL);
return TCL_ERROR;
}
sprintf(interp->result, "%lu", TclGetClicks());
sprintf(interp->result, "%lu", TclpGetClicks());
return TCL_OK;
} else if ((c == 'f') && (strncmp(argv[1], "format", length) == 0)) {
char *format = "%a %b %d %X %Z %Y";
@ -148,13 +148,13 @@ Tcl_ClockCmd (dummy, interp, argc, argv)
if (ParseTime(interp, baseStr, &baseClock) != TCL_OK)
return TCL_ERROR;
} else {
baseClock = TclGetSeconds();
baseClock = TclpGetSeconds();
}
if (useGMT) {
zone = -50000; /* Force GMT */
} else {
zone = TclGetTimeZone(baseClock);
zone = TclpGetTimeZone(baseClock);
}
if (TclGetDate(argv[2], baseClock, zone, &clockVal) < 0) {
@ -171,7 +171,7 @@ Tcl_ClockCmd (dummy, interp, argc, argv)
argv[0], " seconds\"", (char *) NULL);
return TCL_ERROR;
}
sprintf(interp->result, "%lu", TclGetSeconds());
sprintf(interp->result, "%lu", TclpGetSeconds());
return TCL_OK;
} else {
Tcl_AppendResult(interp, "unknown option \"", argv[1],
@ -276,6 +276,7 @@ FormatClock(interp, clockVal, useGMT, format)
struct tm *timeDataPtr;
Tcl_DString buffer;
int bufSize;
char *p;
#ifdef TCL_USE_TIMEZONE_VAR
int savedTimeZone;
char *savedTZEnv;
@ -315,23 +316,28 @@ FormatClock(interp, clockVal, useGMT, format)
}
#endif
if (useGMT) {
timeDataPtr = gmtime((time_t *) &clockVal);
} else {
timeDataPtr = localtime((time_t *) &clockVal);
}
timeDataPtr = TclpGetDate((time_t *) &clockVal, useGMT);
/*
* Format the time, increasing the buffer size until strftime succeeds.
* Make a guess at the upper limit on the substituted string size
* based on the number of percents in the string.
*/
bufSize = TCL_DSTRING_STATIC_SIZE - 1;
for (bufSize = 0, p = format; *p != '\0'; p++) {
if (*p == '%') {
bufSize += 40;
} else {
bufSize++;
}
}
Tcl_DStringInit(&buffer);
Tcl_DStringSetLength(&buffer, bufSize);
while (strftime(buffer.string, (unsigned int) bufSize, format,
if (TclStrftime(buffer.string, (unsigned int) bufSize, format,
timeDataPtr) == 0) {
bufSize *= 2;
Tcl_DStringSetLength(&buffer, bufSize);
Tcl_DStringFree(&buffer);
Tcl_AppendResult(interp, "bad format string", (char *)NULL);
return TCL_ERROR;
}
#ifdef TCL_USE_TIMEZONE_VAR

33
contrib/tcl/generic/tclCmdAH.c
View File

@ -11,7 +11,7 @@
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
* SCCS: @(#) tclCmdAH.c 1.107 96/04/09 17:14:39
* SCCS: @(#) tclCmdAH.c 1.111 96/07/30 09:33:59
*/
#include "tclInt.h"
@ -650,7 +650,30 @@ Tcl_FileCmd(dummy, interp, argc, argv)
goto not3Args;
}
Tcl_SplitPath(argv[2], &pargc, &pargv);
fileName = argv[2];
/*
* If there is only one element, and it starts with a tilde,
* perform tilde substitution and resplit the path.
*/
Tcl_SplitPath(fileName, &pargc, &pargv);
if ((pargc == 1) && (*fileName == '~')) {
ckfree((char*) pargv);
fileName = Tcl_TranslateFileName(interp, fileName, &buffer);
if (fileName == NULL) {
result = TCL_ERROR;
goto done;
}
Tcl_SplitPath(fileName, &pargc, &pargv);
Tcl_DStringSetLength(&buffer, 0);
}
/*
* Return the last component, unless it is the only component, and it
* is the root of an absolute path.
*/
if (pargc > 0) {
if ((pargc > 1)
|| (Tcl_GetPathType(pargv[0]) == TCL_PATH_RELATIVE)) {
@ -727,7 +750,7 @@ Tcl_FileCmd(dummy, interp, argc, argv)
Tcl_DStringResult(interp, &buffer);
goto done;
}
/*
* Next, handle operations that can be satisfied with the "access"
* kernel call.
@ -1499,14 +1522,14 @@ Tcl_FormatCmd(dummy, interp, argc, argv)
argIndex++;
format++;
}
if (width > 1000) {
if (width > 100000) {
/*
* Don't allow arbitrarily large widths: could cause core
* dump when we try to allocate a zillion bytes of memory
* below.
*/
width = 1000;
width = 100000;
} else if (width < 0) {
width = 0;
}

14
contrib/tcl/generic/tclCmdIL.c
View File

@ -12,7 +12,7 @@
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
* SCCS: @(#) tclCmdIL.c 1.119 96/03/22 12:10:14
* SCCS: @(#) tclCmdIL.c 1.120 96/07/10 17:16:03
*/
#include "tclInt.h"
@ -1041,7 +1041,8 @@ Tcl_LrangeCmd(notUsed, interp, argc, argv)
* Chop off trailing spaces.
*/
while (isspace(UCHAR(end[-1]))) {
while ((end != begin) && (isspace(UCHAR(end[-1])))
&& (((end-1) == begin) || (end[-2] != '\\'))) {
end--;
}
c = *end;
@ -1146,11 +1147,14 @@ Tcl_LreplaceCmd(notUsed, interp, argc, argv)
}
/*
* Add the elements before "first" to the result. Drop any terminating
* white space, since a separator will be added below, if needed.
* Add the elements before "first" to the result. Remove any
* trailing white space, to make the result look as clean as
* possible (this matters primarily if the replacement string is
* empty).
*/
while ((p1 != argv[1]) && (isspace(UCHAR(p1[-1])))) {
while ((p1 != argv[1]) && (isspace(UCHAR(p1[-1])))
&& (((p1-1) == argv[1]) || (p1[-2] != '\\'))) {
p1--;
}
savedChar = *p1;

6
contrib/tcl/generic/tclCmdMZ.c
View File

@ -12,7 +12,7 @@
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
* SCCS: @(#) tclCmdMZ.c 1.65 96/02/09 14:59:52
* SCCS: @(#) tclCmdMZ.c 1.66 96/07/23 16:15:55
*/
#include "tclInt.h"
@ -1748,7 +1748,7 @@ Tcl_TimeCmd(dummy, interp, argc, argv)
" command ?count?\"", (char *) NULL);
return TCL_ERROR;
}
TclGetTime(&start);
TclpGetTime(&start);
for (i = count ; i > 0; i--) {
result = Tcl_Eval(interp, argv[1]);
if (result != TCL_OK) {
@ -1761,7 +1761,7 @@ Tcl_TimeCmd(dummy, interp, argc, argv)
return result;
}
}
TclGetTime(&stop);
TclpGetTime(&stop);
timePer = (stop.sec - start.sec)*1000000 + (stop.usec - start.usec);
Tcl_ResetResult(interp);
sprintf(interp->result, "%.0f microseconds per iteration",

20
contrib/tcl/generic/tclDate.c
View File

@ -1,8 +1,8 @@
/*
* tclGetdate.c --
* tclDate.c --
*
* This file is generated from a yacc grammar defined in
* the file tclGetdate.y
* the file tclGetDate.y
*
* Copyright (c) 1992-1995 Karl Lehenbauer and Mark Diekhans.
* Copyright (c) 1995-1996 Sun Microsystems, Inc.
@ -10,7 +10,7 @@
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
* @(#) tclDate.c 1.24 96/04/18 16:53:56
* @(#) tclDate.c 1.25 96/07/23 16:10:50
*/
#include "tclInt.h"
@ -24,8 +24,6 @@
# define EPOCH 1970
# define START_OF_TIME 1902
# define END_OF_TIME 2037
extern struct tm *localtime();
#endif
#define HOUR(x) ((int) (60 * x))
@ -463,7 +461,7 @@ Convert(Month, Day, Year, Hours, Minutes, Seconds, Meridian, DSTmode, TimePtr)
return -1;
Julian += tod;
if (DSTmode == DSTon
|| (DSTmode == DSTmaybe && localtime(&Julian)->tm_isdst))
|| (DSTmode == DSTmaybe && TclpGetDate(&Julian, 0)->tm_isdst))
Julian -= 60 * 60;
*TimePtr = Julian;
return 0;
@ -478,8 +476,8 @@ DSTcorrect(Start, Future)
time_t StartDay;
time_t FutureDay;
StartDay = (localtime(&Start)->tm_hour + 1) % 24;
FutureDay = (localtime(&Future)->tm_hour + 1) % 24;
StartDay = (TclpGetDate(&Start, 0)->tm_hour + 1) % 24;
FutureDay = (TclpGetDate(&Future, 0)->tm_hour + 1) % 24;
return (Future - Start) + (StartDay - FutureDay) * 60L * 60L;
}
@ -494,7 +492,7 @@ RelativeDate(Start, DayOrdinal, DayNumber)
time_t now;
now = Start;
tm = localtime(&now);
tm = TclpGetDate(&now, 0);
now += SECSPERDAY * ((DayNumber - tm->tm_wday + 7) % 7);
now += 7 * SECSPERDAY * (DayOrdinal <= 0 ? DayOrdinal : DayOrdinal - 1);
return DSTcorrect(Start, now);
@ -516,7 +514,7 @@ RelativeMonth(Start, RelMonth, TimePtr)
*TimePtr = 0;
return 0;
}
tm = localtime(&Start);
tm = TclpGetDate(&Start, 0);
Month = 12 * tm->tm_year + tm->tm_mon + RelMonth;
Year = Month / 12;
Month = Month % 12 + 1;
@ -728,7 +726,7 @@ TclGetDate(p, now, zone, timePtr)
time_t tod;
TclDateInput = p;
tm = localtime((time_t *) &now);
tm = TclpGetDate((time_t *) &now, 0);
TclDateYear = tm->tm_year;
TclDateMonth = tm->tm_mon + 1;
TclDateDay = tm->tm_mday;

22
contrib/tcl/generic/tclEnv.c
View File

@ -10,7 +10,7 @@
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
* SCCS: @(#) tclEnv.c 1.34 96/04/15 18:18:36
* SCCS: @(#) tclEnv.c 1.37 96/07/23 16:28:26
*/
/*
@ -211,12 +211,17 @@ TclGetEnv(name)
char *name; /* Name of desired environment variable. */
{
int i;
size_t len;
size_t len, nameLen;
char *equal;
nameLen = strlen(name);
for (i = 0; environ[i] != NULL; i++) {
len = (size_t) ((char *) strchr(environ[i], '=') - environ[i]);
if ((len > 0 && !strncmp(name, environ[i], len))
|| (*name == '\0')) {
equal = strchr(environ[i], '=');
if (equal == NULL) {
continue;
}
len = (size_t) (equal - environ[i]);
if ((len == nameLen) && (strncmp(name, environ[i], len) == 0)) {
/*
* The caller of this function should regard this
* as static memory.
@ -601,4 +606,11 @@ EnvExitProc(clientData)
ckfree(*p);
}
ckfree((char *) environ);
/*
* Note that we need to reset the environ global so the Borland C run-time
* doesn't choke on exit.
*/
environ = NULL;
}

16
contrib/tcl/generic/tclEvent.c
View File

@ -14,7 +14,7 @@
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
* SCCS: @(#) tclEvent.c 1.127 96/03/22 12:12:33
* SCCS: @(#) tclEvent.c 1.128 96/07/23 16:12:34
*/
#include "tclInt.h"
@ -633,7 +633,7 @@ Tcl_CreateTimerHandler(milliseconds, proc, clientData)
* Compute when the event should fire.
*/
TclGetTime(&timerHandlerPtr->time);
TclpGetTime(&timerHandlerPtr->time);
timerHandlerPtr->time.sec += milliseconds/1000;
timerHandlerPtr->time.usec += (milliseconds%1000)*1000;
if (timerHandlerPtr->time.usec >= 1000000) {
@ -755,7 +755,7 @@ Tcl_CreateModalTimeout(milliseconds, proc, clientData)
* of the handler.
*/
TclGetTime(&timerHandlerPtr->time);
TclpGetTime(&timerHandlerPtr->time);
timerHandlerPtr->time.sec += milliseconds/1000;
timerHandlerPtr->time.usec += (milliseconds%1000)*1000;
if (timerHandlerPtr->time.usec >= 1000000) {
@ -860,7 +860,7 @@ TimerHandlerSetupProc(clientData, flags)
return;
}
TclGetTime(&blockTime);
TclpGetTime(&blockTime);
blockTime.sec = timerHandlerPtr->time.sec - blockTime.sec;
blockTime.usec = timerHandlerPtr->time.usec - blockTime.usec;
if (blockTime.usec < 0) {
@ -910,7 +910,7 @@ TimerHandlerCheckProc(clientData, flags)
gotTime = 0;
timerHandlerPtr = firstTimerHandlerPtr;
if ((flags & TCL_TIMER_EVENTS) && (timerHandlerPtr != NULL)) {
TclGetTime(&curTime);
TclpGetTime(&curTime);
gotTime = 1;
if ((timerHandlerPtr->time.sec < curTime.sec)
|| ((timerHandlerPtr->time.sec == curTime.sec)
@ -921,7 +921,7 @@ TimerHandlerCheckProc(clientData, flags)
timerHandlerPtr = firstModalHandlerPtr;
if (timerHandlerPtr != NULL) {
if (!gotTime) {
TclGetTime(&curTime);
TclpGetTime(&curTime);
}
if ((timerHandlerPtr->time.sec < curTime.sec)
|| ((timerHandlerPtr->time.sec == curTime.sec)
@ -2134,7 +2134,7 @@ TclWaitForFile(file, mask, timeout)
*/
if (timeout > 0) {
TclGetTime(&now);
TclpGetTime(&now);
abortTime.sec = now.sec + timeout/1000;
abortTime.usec = now.usec + (timeout%1000)*1000;
if (abortTime.usec >= 1000000) {
@ -2176,7 +2176,7 @@ TclWaitForFile(file, mask, timeout)
if (timeout == 0) {
break;
}
TclGetTime(&now);
TclpGetTime(&now);
if ((abortTime.sec < now.sec)
|| ((abortTime.sec == now.sec)
&& (abortTime.usec <= now.usec))) {

37
contrib/tcl/generic/tclFHandle.c
View File

@ -8,10 +8,11 @@
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
* SCCS: @(#) tclFHandle.c 1.6 96/02/13 16:29:55
* SCCS: @(#) tclFHandle.c 1.8 96/06/27 15:31:34
*/
#include "tcl.h"
#include "tclInt.h"
#include "tclPort.h"
/*
@ -112,7 +113,7 @@ Tcl_FreeFile(handle)
{
Tcl_HashEntry *entryPtr;
FileHandle *handlePtr = (FileHandle *) handle;
/*
* Invoke free procedure, then delete the handle.
*/
@ -121,11 +122,24 @@ Tcl_FreeFile(handle)
(*handlePtr->proc)(handlePtr->data);
}
entryPtr = Tcl_FindHashEntry(&fileTable, (char *) &handlePtr->key);
if (entryPtr) {
Tcl_DeleteHashEntry(entryPtr);
ckfree((char *) handlePtr);
/*
* Tcl_File structures may be freed as a result of running the
* channel table exit handler. The file table is freed by the file
* table exit handler, which may run before the channel table exit
* handler. The file table exit handler sets the "initialized"
* variable back to zero, so that the Tcl_FreeFile (when invoked
* from the channel table exit handler) can notice that the file
* table has already been destroyed. Otherwise, accessing a
* deleted hash table would cause a panic.
*/
if (initialized) {
entryPtr = Tcl_FindHashEntry(&fileTable, (char *) &handlePtr->key);
if (entryPtr) {
Tcl_DeleteHashEntry(entryPtr);
}
}
ckfree((char *) handlePtr);
}
/*
@ -240,15 +254,6 @@ static void
FileExitProc(clientData)
ClientData clientData; /* Not used. */
{
Tcl_HashSearch search;
Tcl_HashEntry *entryPtr;
entryPtr = Tcl_FirstHashEntry(&fileTable, &search);
while (entryPtr) {
ckfree(Tcl_GetHashValue(entryPtr));
entryPtr = Tcl_NextHashEntry(&search);
}
Tcl_DeleteHashTable(&fileTable);
initialized = 0;
}

22
contrib/tcl/generic/tclGetDate.y
View File

@ -1,5 +1,5 @@
/*
* tclGetdate.y --
* tclGetDate.y --
*
* Contains yacc grammar for parsing date and time strings
* based on getdate.y.
@ -10,15 +10,15 @@
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
* SCCS: @(#) tclGetDate.y 1.25 96/02/15 20:04:06
* SCCS: @(#) tclGetDate.y 1.26 96/07/23 16:09:45
*/
%{
/*
* tclGetdate.c --
* tclDate.c --
*
* This file is generated from a yacc grammar defined in
* the file tclGetdate.y
* the file tclGetDate.y
*
* Copyright (c) 1992-1995 Karl Lehenbauer and Mark Diekhans.
* Copyright (c) 1995-1996 Sun Microsystems, Inc.
@ -40,8 +40,6 @@
# define EPOCH 1970
# define START_OF_TIME 1902
# define END_OF_TIME 2037
extern struct tm *localtime();
#endif
#define HOUR(x) ((int) (60 * x))
@ -617,7 +615,7 @@ Convert(Month, Day, Year, Hours, Minutes, Seconds, Meridian, DSTmode, TimePtr)
return -1;
Julian += tod;
if (DSTmode == DSTon
|| (DSTmode == DSTmaybe && localtime(&Julian)->tm_isdst))
|| (DSTmode == DSTmaybe && TclpGetDate(&Julian, 0)->tm_isdst))
Julian -= 60 * 60;
*TimePtr = Julian;
return 0;
@ -632,8 +630,8 @@ DSTcorrect(Start, Future)
time_t StartDay;
time_t FutureDay;
StartDay = (localtime(&Start)->tm_hour + 1) % 24;
FutureDay = (localtime(&Future)->tm_hour + 1) % 24;
StartDay = (TclpGetDate(&Start, 0)->tm_hour + 1) % 24;
FutureDay = (TclpGetDate(&Future, 0)->tm_hour + 1) % 24;
return (Future - Start) + (StartDay - FutureDay) * 60L * 60L;
}
@ -648,7 +646,7 @@ RelativeDate(Start, DayOrdinal, DayNumber)
time_t now;
now = Start;
tm = localtime(&now);
tm = TclpGetDate(&now, 0);
now += SECSPERDAY * ((DayNumber - tm->tm_wday + 7) % 7);
now += 7 * SECSPERDAY * (DayOrdinal <= 0 ? DayOrdinal : DayOrdinal - 1);
return DSTcorrect(Start, now);
@ -670,7 +668,7 @@ RelativeMonth(Start, RelMonth, TimePtr)
*TimePtr = 0;
return 0;
}
tm = localtime(&Start);
tm = TclpGetDate(&Start, 0);
Month = 12 * tm->tm_year + tm->tm_mon + RelMonth;
Year = Month / 12;
Month = Month % 12 + 1;
@ -882,7 +880,7 @@ TclGetDate(p, now, zone, timePtr)
time_t tod;
yyInput = p;
tm = localtime((time_t *) &now);
tm = TclpGetDate((time_t *) &now, 0);
yyYear = tm->tm_year;
yyMonth = tm->tm_mon + 1;
yyDay = tm->tm_mday;

350
contrib/tcl/generic/tclIO.c
View File

@ -9,7 +9,7 @@
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
* SCCS: @(#) tclIO.c 1.211 96/04/18 09:59:06
* SCCS: @(#) tclIO.c 1.227 96/07/30 09:26:30
*/
#include "tclInt.h"
@ -203,6 +203,13 @@ typedef struct Channel {
#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. */
/*
* For each channel handler registered in a call to Tcl_CreateChannelHandler,
@ -281,13 +288,6 @@ typedef struct ChannelHandlerEvent {
int readyMask; /* Events that have occurred. */
} ChannelHandlerEvent;
/*
* Static buffer used to sprintf channel option values and return
* them to the caller.
*/
static char optionVal[128];
/*
* Static variables to hold channels for stdin, stdout and stderr.
*/
@ -315,6 +315,8 @@ static void ChannelHandlerSetupProc _ANSI_ARGS_((
ClientData clientData, int flags));
static void ChannelEventScriptInvoker _ANSI_ARGS_((
ClientData clientData, int flags));
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));
@ -349,6 +351,50 @@ static int ScanBufferForEOL _ANSI_ARGS_((Channel *chanPtr,
static int ScanInputForEOL _ANSI_ARGS_((Channel *chanPtr,
int *bytesQueuedPtr));
/*
*----------------------------------------------------------------------
*
* TclFindChannel --
*
* Finds a channel given two Tcl_Files.
*
* Results:
* The Tcl_Channel found. Also returns nonzero in fileUsedPtr output
* parameter if it finds that the Tcl_File is already used in another
* channel.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
Tcl_Channel
TclFindFileChannel(inFile, outFile, fileUsedPtr)
Tcl_File inFile, outFile; /* Channel has these Tcl_Files. */
int *fileUsedPtr;
{
Channel *chanPtr;
*fileUsedPtr = 0;
for (chanPtr = firstChanPtr;
chanPtr != (Channel *) NULL;
chanPtr = chanPtr->nextChanPtr) {
if ((chanPtr->inFile == inFile) && (chanPtr->outFile == outFile)) {
return (Tcl_Channel) chanPtr;
}
if ((inFile != (Tcl_File) NULL) && (chanPtr->inFile == inFile)) {
*fileUsedPtr = 1;
return (Tcl_Channel) NULL;
}
if ((outFile != (Tcl_File) NULL) && (chanPtr->outFile == outFile)) {
*fileUsedPtr = 1;
return (Tcl_Channel) NULL;
}
}
return (Tcl_Channel) NULL;
}
/*
*----------------------------------------------------------------------
*
@ -373,7 +419,7 @@ Tcl_SetStdChannel(channel, type)
{
switch (type) {
case TCL_STDIN:
stdinInitialized = 1;
stdinInitialized = 1;
stdinChannel = channel;
break;
case TCL_STDOUT:
@ -564,22 +610,48 @@ CloseChannelsOnExit(clientData)
nextChanPtr = chanPtr->nextChanPtr;
/*
* Close it only if the refcount indicates that the channel is not
* referenced from any interpreter. If it is, that interpreter will
* close the channel when it gets destroyed.
* 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->refCount <= 0) {
/*
* Switch the channel back into synchronous mode to ensure that it
* gets flushed now.
/*
* 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_SetChannelOption(NULL, (Tcl_Channel) chanPtr,
"-blocking", "on");
Tcl_Close((Tcl_Interp *) NULL, (Tcl_Channel) chanPtr);
} else {
/*
* The refcount is greater than zero, so flush the channel.
*/
Tcl_Flush((Tcl_Channel) chanPtr);
/*
* And close the OS level handles using the driver function:
*/
(chanPtr->typePtr->closeProc) (chanPtr->instanceData,
(Tcl_Interp *) NULL, chanPtr->inFile, chanPtr->outFile);
/*
* 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->inFile = (Tcl_File) NULL;
chanPtr->outFile = (Tcl_File) NULL;
chanPtr->instanceData = (ClientData) NULL;
chanPtr->flags |= CHANNEL_DEAD;
}
}
}
@ -609,7 +681,7 @@ GetChannelTable(interp)
Tcl_Interp *interp;
{
Tcl_HashTable *hTblPtr; /* Hash table of channels. */
Tcl_Channel stdinChannel, stdoutChannel, stderrChannel;
Tcl_Channel stdinChan, stdoutChan, stderrChan;
hTblPtr = (Tcl_HashTable *) Tcl_GetAssocData(interp, "tclIO", NULL);
if (hTblPtr == (Tcl_HashTable *) NULL) {
@ -627,17 +699,17 @@ GetChannelTable(interp)
*/
if (Tcl_IsSafe(interp) == 0) {
stdinChannel = Tcl_GetStdChannel(TCL_STDIN);
if (stdinChannel != NULL) {
Tcl_RegisterChannel(interp, stdinChannel);
stdinChan = Tcl_GetStdChannel(TCL_STDIN);
if (stdinChan != NULL) {
Tcl_RegisterChannel(interp, stdinChan);
}
stdoutChannel = Tcl_GetStdChannel(TCL_STDOUT);
if (stdoutChannel != NULL) {
Tcl_RegisterChannel(interp, stdoutChannel);
stdoutChan = Tcl_GetStdChannel(TCL_STDOUT);
if (stdoutChan != NULL) {
Tcl_RegisterChannel(interp, stdoutChan);
}
stderrChannel = Tcl_GetStdChannel(TCL_STDERR);
if (stderrChannel != NULL) {
Tcl_RegisterChannel(interp, stderrChannel);
stderrChan = Tcl_GetStdChannel(TCL_STDERR);
if (stderrChan != NULL) {
Tcl_RegisterChannel(interp, stderrChan);
}
}
@ -776,8 +848,29 @@ Tcl_UnregisterChannel(interp, chan)
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--;
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) {
@ -995,7 +1088,7 @@ Tcl_CreateChannel(typePtr, chanName, inFile, outFile, instanceData)
channelExitHandlerCreated = 1;
Tcl_CreateExitHandler(CloseChannelsOnExit, (ClientData) NULL);
}
/*
* Install this channel in the first empty standard channel slot.
*/
@ -1272,6 +1365,18 @@ FlushChannel(interp, chanPtr, calledFromAsyncFlush)
* 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 (chanPtr->flags & CHANNEL_DEAD) {
Tcl_SetErrno(EINVAL);
return -1;
}
/*
* Loop over the queued buffers and attempt to flush as
@ -1342,6 +1447,7 @@ FlushChannel(interp, chanPtr, calledFromAsyncFlush)
*/
if (errorCode == EINTR) {
errorCode = 0;
continue;
}
@ -1370,6 +1476,7 @@ FlushChannel(interp, chanPtr, calledFromAsyncFlush)
*/
TclWaitForFile(chanPtr->outFile, TCL_WRITABLE, -1);
errorCode = 0;
continue;
}
}
@ -1464,12 +1571,25 @@ CloseChannel(interp, chanPtr, errorCode)
Channel *chanPtr; /* The channel to close. */
int errorCode; /* Status of operation so far. */
{
int result; /* Of calling driver close
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. */
/*
* Remove the channel from the standard channel table.
*/
if (Tcl_GetStdChannel(TCL_STDIN) == (Tcl_Channel) chanPtr) {
Tcl_SetStdChannel(NULL, TCL_STDIN);
} else if (Tcl_GetStdChannel(TCL_STDOUT) == (Tcl_Channel) chanPtr) {
Tcl_SetStdChannel(NULL, TCL_STDOUT);
} else if (Tcl_GetStdChannel(TCL_STDERR) == (Tcl_Channel) chanPtr) {
Tcl_SetStdChannel(NULL, TCL_STDERR);
}
/*
* No more input can be consumed so discard any leftover input.
*/
@ -1504,8 +1624,10 @@ CloseChannel(interp, chanPtr, errorCode)
char c;
c = (char) chanPtr->outEofChar;
(chanPtr->typePtr->outputProc) (chanPtr->instanceData,
chanPtr->outFile, &c, 1, &dummy);
if (!(chanPtr->flags & CHANNEL_DEAD)) {
(chanPtr->typePtr->outputProc) (chanPtr->instanceData,
chanPtr->outFile, &c, 1, &dummy);
}
}
/*
@ -1537,16 +1659,17 @@ CloseChannel(interp, chanPtr, errorCode)
prevChanPtr->nextChanPtr = chanPtr->nextChanPtr;
}
if (chanPtr->channelName != (char *) NULL) {
ckfree(chanPtr->channelName);
}
/*
* OK, close the channel itself.
*/
result = (chanPtr->typePtr->closeProc) (chanPtr->instanceData, interp,
chanPtr->inFile, chanPtr->outFile);
if (!(chanPtr->flags & CHANNEL_DEAD)) {
result = (chanPtr->typePtr->closeProc) (chanPtr->instanceData, interp,
chanPtr->inFile, chanPtr->outFile);
}
if (chanPtr->channelName != (char *) NULL) {
ckfree(chanPtr->channelName);
}
/*
* If we are being called synchronously, report either
@ -1610,18 +1733,6 @@ Tcl_Close(interp, chan)
if (chanPtr->refCount > 0) {
panic("called Tcl_Close on channel with refcount > 0");
}
/*
* Remove the channel from the standard channel table.
*/
if (Tcl_GetStdChannel(TCL_STDIN) == chan) {
Tcl_SetStdChannel(NULL, TCL_STDIN);
} else if (Tcl_GetStdChannel(TCL_STDOUT) == chan) {
Tcl_SetStdChannel(NULL, TCL_STDOUT);
} else if (Tcl_GetStdChannel(TCL_STDERR) == chan) {
Tcl_SetStdChannel(NULL, TCL_STDERR);
}
/*
* Remove all the channel handler records attached to the channel
@ -2065,6 +2176,18 @@ GetInput(chanPtr)
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 (chanPtr->flags & CHANNEL_DEAD) {
Tcl_SetErrno(EINVAL);
return -1;
}
/*
* 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,
@ -2893,6 +3016,18 @@ Tcl_Seek(chan, offset, mode)
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 (chanPtr->flags & CHANNEL_DEAD) {
Tcl_SetErrno(EINVAL);
return -1;
}
/*
* Disallow seek on channels whose type does not have a seek procedure
* defined. This means that the channel does not support seeking.
@ -3069,6 +3204,18 @@ Tcl_Tell(chan)
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 (chanPtr->flags & CHANNEL_DEAD) {
Tcl_SetErrno(EINVAL);
return -1;
}
/*
* Disallow tell on channels that are open for neither
* writing nor reading (e.g. socket server channels).
@ -3316,9 +3463,22 @@ Tcl_GetChannelOption(chan, optionName, dsPtr)
{
Channel *chanPtr; /* The real IO channel. */
size_t len; /* Length of optionName string. */
char optionVal[128]; /* Buffer for sprintf. */
chanPtr = (Channel *) chan;
/*
* 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 (chanPtr->flags & CHANNEL_DEAD) {
Tcl_SetErrno(EINVAL);
return TCL_ERROR;
}
/*
* If the optionName is NULL it means that we want a list of all
* options and values.
@ -3374,8 +3534,8 @@ Tcl_GetChannelOption(chan, optionName, dsPtr)
if (len == 0) {
Tcl_DStringAppendElement(dsPtr, "-eofchar");
}
if ((chanPtr->flags & (TCL_READABLE|TCL_WRITABLE)) ==
(TCL_READABLE|TCL_WRITABLE)) {
if (((chanPtr->flags & (TCL_READABLE|TCL_WRITABLE)) ==
(TCL_READABLE|TCL_WRITABLE)) && (len == 0)) {
Tcl_DStringStartSublist(dsPtr);
}
if (chanPtr->flags & TCL_READABLE) {
@ -3398,8 +3558,8 @@ Tcl_GetChannelOption(chan, optionName, dsPtr)
Tcl_DStringAppendElement(dsPtr, buf);
}
}
if ((chanPtr->flags & (TCL_READABLE|TCL_WRITABLE)) ==
(TCL_READABLE|TCL_WRITABLE)) {
if (((chanPtr->flags & (TCL_READABLE|TCL_WRITABLE)) ==
(TCL_READABLE|TCL_WRITABLE)) && (len == 0)) {
Tcl_DStringEndSublist(dsPtr);
}
if (len > 0) {
@ -3412,8 +3572,8 @@ Tcl_GetChannelOption(chan, optionName, dsPtr)
if (len == 0) {
Tcl_DStringAppendElement(dsPtr, "-translation");
}
if ((chanPtr->flags & (TCL_READABLE|TCL_WRITABLE)) ==
(TCL_READABLE|TCL_WRITABLE)) {
if (((chanPtr->flags & (TCL_READABLE|TCL_WRITABLE)) ==
(TCL_READABLE|TCL_WRITABLE)) && (len == 0)) {
Tcl_DStringStartSublist(dsPtr);
}
if (chanPtr->flags & TCL_READABLE) {
@ -3438,8 +3598,8 @@ Tcl_GetChannelOption(chan, optionName, dsPtr)
Tcl_DStringAppendElement(dsPtr, "lf");
}
}
if ((chanPtr->flags & (TCL_READABLE|TCL_WRITABLE)) ==
(TCL_READABLE|TCL_WRITABLE)) {
if (((chanPtr->flags & (TCL_READABLE|TCL_WRITABLE)) ==
(TCL_READABLE|TCL_WRITABLE)) && (len == 0)) {
Tcl_DStringEndSublist(dsPtr);
}
if (len > 0) {
@ -3489,6 +3649,18 @@ Tcl_SetChannelOption(interp, chan, optionName, newValue)
char **argv;
chanPtr = (Channel *) chan;
/*
* 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 (chanPtr->flags & CHANNEL_DEAD) {
Tcl_SetErrno(EINVAL);
return -1;
}
len = strlen(optionName);
@ -3767,6 +3939,61 @@ Tcl_SetChannelOption(interp, chan, optionName, newValue)
return TCL_ERROR;
}
/*
*----------------------------------------------------------------------
*
* 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);
Tcl_EventuallyFree((ClientData) sPtr->script, TCL_DYNAMIC);
ckfree((char *) sPtr);
} else {
prevPtr = sPtr;
}
}
}
/*
*----------------------------------------------------------------------
*
@ -4464,11 +4691,14 @@ ChannelEventScriptInvoker(clientData, mask)
/*
* 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) {
Tcl_BackgroundError(interp);
DeleteScriptRecord(interp, chanPtr, mask);
Tcl_BackgroundError(interp);
}
Tcl_Release((ClientData) chanPtr);
Tcl_Release((ClientData) script);

2
contrib/tcl/generic/tclIOCmd.c
View File

@ -8,7 +8,7 @@
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
* SCCS: @(#) tclIOCmd.c 1.94 96/04/15 06:40:02
* SCCS: @(#) tclIOCmd.c 1.96 96/05/10 15:20:56
*/
#include "tclInt.h"

6
contrib/tcl/generic/tclIOUtil.c
View File

@ -13,7 +13,7 @@
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
* SCCS: @(#) tclIOUtil.c 1.122 96/04/02 18:46:40
* SCCS: @(#) tclIOUtil.c 1.123 96/04/29 14:08:24
*/
#include "tclInt.h"
@ -497,10 +497,10 @@ Tcl_ReapDetachedProcs()
register Detached *detPtr;
Detached *nextPtr, *prevPtr;
int status;
pid_t pid;
int pid;
for (detPtr = detList, prevPtr = NULL; detPtr != NULL; ) {
pid = Tcl_WaitPid(detPtr->pid, &status, WNOHANG);
pid = (int) Tcl_WaitPid(detPtr->pid, &status, WNOHANG);
if ((pid == 0) || ((pid == -1) && (errno != ECHILD))) {
prevPtr = detPtr;
detPtr = detPtr->nextPtr;

20
contrib/tcl/generic/tclInt.h
View File

@ -9,7 +9,7 @@
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
* SCCS: @(#) tclInt.h 1.200 96/04/11 17:24:12
* SCCS: @(#) tclInt.h 1.203 96/07/23 16:15:24
*/
#ifndef _TCLINT
@ -760,6 +760,7 @@ extern TclEventSource * tclFirstEventSourcePtr;
extern Tcl_ChannelType tclFileChannelType;
extern char * tclMemDumpFileName;
extern TclPlatformType tclPlatform;
extern int tclInInterpreterDeletion;
/*
*----------------------------------------------------------------
@ -804,11 +805,12 @@ EXTERN void TclExprFloatError _ANSI_ARGS_((Tcl_Interp *interp,
EXTERN int TclFindElement _ANSI_ARGS_((Tcl_Interp *interp,
char *list, char **elementPtr, char **nextPtr,
int *sizePtr, int *bracePtr));
EXTERN Tcl_Channel TclFindFileChannel _ANSI_ARGS_((Tcl_File inFile,
Tcl_File outFile, int *fileUsedPtr));
EXTERN Proc * TclFindProc _ANSI_ARGS_((Interp *iPtr,
char *procName));
EXTERN void TclFreePackageInfo _ANSI_ARGS_((Interp *iPtr));
EXTERN char * TclGetCwd _ANSI_ARGS_((Tcl_Interp *interp));
EXTERN unsigned long TclGetClicks _ANSI_ARGS_((void));
EXTERN char * TclGetExtension _ANSI_ARGS_((char *name));
EXTERN void TclGetAndDetachPids _ANSI_ARGS_((Tcl_Interp *interp,
Tcl_Channel chan));
@ -819,17 +821,12 @@ EXTERN Tcl_Channel TclGetDefaultStdChannel _ANSI_ARGS_((int type));
EXTERN char * TclGetEnv _ANSI_ARGS_((char *name));
EXTERN int TclGetFrame _ANSI_ARGS_((Tcl_Interp *interp,
char *string, CallFrame **framePtrPtr));
EXTERN int TclGetOpenMode _ANSI_ARGS_((Tcl_Interp *interp,
char *string, int *seekFlagPtr));
EXTERN unsigned long TclGetSeconds _ANSI_ARGS_((void));
EXTERN void TclGetTime _ANSI_ARGS_((Tcl_Time *time));
EXTERN int TclGetTimeZone _ANSI_ARGS_((unsigned long time));
EXTERN char * TclGetUserHome _ANSI_ARGS_((char *name,
Tcl_DString *bufferPtr));
EXTERN int TclGetListIndex _ANSI_ARGS_((Tcl_Interp *interp,
char *string, int *indexPtr));
EXTERN int TclGetLoadedPackages _ANSI_ARGS_((Tcl_Interp *interp,
char *targetName));
EXTERN int TclGetOpenMode _ANSI_ARGS_((Tcl_Interp *interp,
char *string, int *seekFlagPtr));
EXTERN char * TclGetUserHome _ANSI_ARGS_((char *name,
Tcl_DString *bufferPtr));
EXTERN int TclGuessPackageName _ANSI_ARGS_((char *fileName,
@ -862,6 +859,11 @@ EXTERN int TclParseWords _ANSI_ARGS_((Tcl_Interp *interp,
char *string, int flags, int maxWords,
char **termPtr, int *argcPtr, char **argv,
ParseValue *pvPtr));
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 void TclPlatformExit _ANSI_ARGS_((int status));
EXTERN void TclPlatformInit _ANSI_ARGS_((Tcl_Interp *interp));
EXTERN char * TclPrecTraceProc _ANSI_ARGS_((ClientData clientData,

14
contrib/tcl/generic/tclInterp.c
View File

@ -9,7 +9,7 @@
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
* SCCS: @(#) tclInterp.c 1.66 96/04/15 17:26:10
* SCCS: @(#) tclInterp.c 1.73 96/06/11 18:14:22
*/
#include <stdio.h>
@ -169,18 +169,18 @@ static char *TclCommandsToKeep[] = {
"break",
"case", "catch", "clock", "close", "concat", "continue",
"eof", "error", "eval", "expr",
"fblocked", "fconfigure", "flush", "for", "foreach", "format",
"fblocked", "fileevent", "flush", "for", "foreach", "format",
"gets", "global",
"history",
"if", "incr", "info", "interp",
"join",
"lappend", "lindex", "linsert", "list", "llength", "lower", "lrange",
"lreplace", "lsearch", "lsort",
"lappend", "lindex", "linsert", "list", "llength",
"lower", "lrange", "lreplace", "lsearch", "lsort",
"package", "pid", "proc", "puts",
"read", "regexp", "regsub", "rename", "return",
"scan", "seek", "set", "split", "string", "switch",
"tell", "trace",
"unset", "update", "uplevel", "upvar",
"scan", "seek", "set", "split", "string", "subst", "switch",
"tell", "time", "trace",
"unset", "unsupported0", "update", "uplevel", "upvar",
"vwait",
"while",
NULL};

9
contrib/tcl/generic/tclLoad.c
View File

@ -9,7 +9,7 @@
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
* SCCS: @(#) tclLoad.c 1.10 96/04/02 18:44:22
* SCCS: @(#) tclLoad.c 1.11 96/07/29 08:39:29
*/
#include "tclInt.h"
@ -373,6 +373,13 @@ Tcl_LoadCmd(dummy, interp, argc, argv)
*/
if (code == TCL_OK) {
/*
* Refetch ipFirstPtr: loading the package may have introduced
* additional static packages at the head of the linked list!
*/
ipFirstPtr = (InterpPackage *) Tcl_GetAssocData(target, "tclLoad",
(Tcl_InterpDeleteProc **) NULL);
ipPtr = (InterpPackage *) ckalloc(sizeof(InterpPackage));
ipPtr->pkgPtr = pkgPtr;
ipPtr->nextPtr = ipFirstPtr;

6
contrib/tcl/generic/tclPosixStr.c
View File

@ -11,7 +11,7 @@
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
* SCCS: @(#) tclPosixStr.c 1.30 96/02/08 16:33:34
* SCCS: @(#) tclPosixStr.c 1.31 96/07/28 16:25:29
*/
#include "tclInt.h"
@ -117,7 +117,7 @@ Tcl_ErrnoId()
#if defined(EDEADLK) && (!defined(EWOULDBLOCK) || (EDEADLK != EWOULDBLOCK))
case EDEADLK: return "EDEADLK";
#endif
#ifdef EDEADLOCK
#if defined(EDEADLOCK) && (!defined(EDEADLK) || (EDEADLOCK != EDEADLK))
case EDEADLOCK: return "EDEADLOCK";
#endif
#ifdef EDESTADDRREQ
@ -563,7 +563,7 @@ Tcl_ErrnoMsg(err)
#if defined(EDEADLK) && (!defined(EWOULDBLOCK) || (EDEADLK != EWOULDBLOCK))
case EDEADLK: return "resource deadlock avoided";
#endif
#ifdef EDEADLOCK
#if defined(EDEADLOCK) && (!defined(EDEADLK) || (EDEADLOCK != EDEADLK))
case EDEADLOCK: return "resource deadlock avoided";
#endif
#ifdef EDESTADDRREQ

6
contrib/tcl/generic/tclPreserve.c
View File

@ -12,7 +12,7 @@
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
* SCCS: @(#) tclPreserve.c 1.14 96/03/20 08:24:37
* SCCS: @(#) tclPreserve.c 1.17 96/07/23 16:15:34
*/
#include "tclInt.h"
@ -148,6 +148,7 @@ Tcl_Preserve(clientData)
refPtr->clientData = clientData;
refPtr->refCount = 1;
refPtr->mustFree = 0;
refPtr->freeProc = TCL_STATIC;
inUse += 1;
}
@ -267,7 +268,8 @@ Tcl_EventuallyFree(clientData, freeProc)
* No reference for this block. Free it now.
*/
if ((freeProc == TCL_DYNAMIC) || (freeProc == (Tcl_FreeProc *) free)) {
if ((freeProc == TCL_DYNAMIC)
|| (freeProc == (Tcl_FreeProc *) free)) {
ckfree((char *) clientData);
} else {
(*freeProc)((char *)clientData);

5
contrib/tcl/generic/tclUtil.c
View File

@ -10,7 +10,7 @@
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
* SCCS: @(#) tclUtil.c 1.112 96/02/15 11:42:52
* SCCS: @(#) tclUtil.c 1.114 96/06/06 13:48:58
*/
#include "tclInt.h"
@ -977,9 +977,6 @@ Tcl_SetResult(interp, string, freeProc)
iPtr->resultSpace[0] = 0;
iPtr->result = iPtr->resultSpace;
iPtr->freeProc = 0;
} else if (freeProc == TCL_DYNAMIC) {
iPtr->result = string;
iPtr->freeProc = TCL_DYNAMIC;
} else if (freeProc == TCL_VOLATILE) {
length = strlen(string);
if (length > TCL_RESULT_SIZE) {

68
contrib/tcl/library/init.tcl
View File

@ -3,7 +3,7 @@
# Default system startup file for Tcl-based applications. Defines
# "unknown" procedure and auto-load facilities.
#
# SCCS: @(#) init.tcl 1.54 96/04/21 13:55:08
# SCCS: @(#) init.tcl 1.57 96/07/23 08:53:03
#
# Copyright (c) 1991-1993 The Regents of the University of California.
# Copyright (c) 1994-1996 Sun Microsystems, Inc.
@ -24,7 +24,10 @@ if {[lsearch -exact $auto_path [info library]] < 0} {
}
package unknown tclPkgUnknown
if {[info commands exec] == ""} {
# Some machines, such as the Macintosh, do not have exec
# Some machines, such as the Macintosh, do not have exec. Also, on all
# platforms, safe interpreters do not have exec.
set auto_noexec 1
}
set errorCode ""
@ -228,7 +231,7 @@ proc auto_execok name {
}
set auto_execs($name) 0
if {[file pathtype $name] != "relative"} {
foreach ext {.exe .bat .cmd} {
foreach ext {{} .exe .bat .cmd} {
if {[file exists ${name}${ext}]
&& ![file isdirectory ${name}${ext}]} {
set auto_execs($name) 1
@ -249,7 +252,7 @@ proc auto_execok name {
if {$dir == ""} {
set dir .
}
foreach ext {.exe .bat .cmd} {
foreach ext {{} .exe .bat .cmd} {
set file [file join $dir ${name}${ext}]
if {[file exists $file] && ![file isdirectory $file]} {
set auto_execs($name) 1
@ -295,7 +298,7 @@ proc auto_execok name {
# Destroy all cached information for auto-loading and auto-execution,
# so that the information gets recomputed the next time it's needed.
# Also delete any procedures that are listed in the auto-load index
# except those related to auto-loading.
# except those defined in this file.
#
# Arguments:
# None.
@ -303,8 +306,9 @@ proc auto_execok name {
proc auto_reset {} {
global auto_execs auto_index auto_oldpath
foreach p [info procs] {
if {[info exists auto_index($p)] && ($p != "unknown")
&& ![string match auto_* $p]} {
if {[info exists auto_index($p)] && ![string match auto_* $p]
&& ([lsearch -exact {unknown pkg_mkIndex tclPkgSetup
tclPkgUnknown} $p] < 0)} {
rename $p {}
}
}
@ -411,6 +415,17 @@ proc pkg_mkIndex {dir args} {
# that there are no recursive package inclusions.
set c [interp create]
# If Tk is loaded in the parent interpreter, load it into the
# child also, in case the extension depends on it.
foreach pkg [info loaded] {
if {[lindex $pkg 1] == "Tk"} {
$c eval {set argv {-geometry +0+0}}
load [lindex $pkg 0] Tk $c
break
}
}
$c eval [list set file $file]
if [catch {
$c eval {
@ -420,20 +435,25 @@ proc pkg_mkIndex {dir args} {
set dir "" ;# in case file is pkgIndex.tcl
set pkgs ""
# The "file join ." command below is necessary. Without it,
# if the file name has no \'s and we're on UNIX, the
# LD_LIBRARY_PATH search mechanism will be invoked, which
# could cause the wrong file to be used.
# Try to load the file if it has the shared library extension,
# otherwise source it. It's important not to try to load
# files that aren't shared libraries, because on some systems
# (like SunOS) the loader will abort the whole application
# when it gets an error.
if [catch {load [file join . $file]}] {
if [catch {source $file}] {
puts $errorInfo
error "can't either load or source $file"
} else {
set type source
}
} else {
if {[string compare [file extension $file] \
[info sharedlibextension]] == 0} {
# The "file join ." command below is necessary. Without
# it, if the file name has no \'s and we're on UNIX, the
# load command will invoke the LD_LIBRARY_PATH search
# mechanism, which could cause the wrong file to be used.
load [file join . $file]
set type load
} else {
source $file
set type source
}
foreach i [info commands] {
set cmds($i) 1
@ -443,14 +463,14 @@ proc pkg_mkIndex {dir args} {
}
foreach i [package names] {
if {([string compare [package provide $i] ""] != 0)
&& ([string compare $i Tcl] != 0)} {
&& ([string compare $i Tcl] != 0)
&& ([string compare $i Tk] != 0)} {
lappend pkgs [list $i [package provide $i]]
}
}
}
} msg] {
interp delete $c
error $msg $errorInfo $errorCode
puts "error while loading or sourcing $file: $msg"
}
foreach pkg [$c eval set pkgs] {
lappend files($pkg) [list $file [$c eval set type] \
@ -460,8 +480,8 @@ proc pkg_mkIndex {dir args} {
}
foreach pkg [lsort [array names files]] {
append index "\npackage ifneeded $pkg\
\"tclPkgSetup \$dir [lrange $pkg 0 0] [lrange $pkg 1 1]\
[list $files($pkg)]\""
\[list tclPkgSetup \$dir [lrange $pkg 0 0] [lrange $pkg 1 1]\
[list $files($pkg)]\]"
}
set f [open pkgIndex.tcl w]
puts $f $index

13
contrib/tcl/library/ldAout.tcl
View File

@ -18,7 +18,7 @@
# its .o file placed before all others in the command; then
# "ld" is executed to bind the objects together.
#
# SCCS: @(#) ldAout.tcl 1.9 96/04/11 10:03:24
# SCCS: @(#) ldAout.tcl 1.10 96/05/18 16:40:42
#
# Copyright (c) 1995, by General Electric Company. All rights reserved.
#
@ -144,9 +144,14 @@ proc tclLdAout {{cc {}} {shlib_suffix {}} {shlib_cflags none}} {
if [string compare [string range $m $l end] $shlib_suffix] {
error "Output file does not appear to have a $shlib_suffix suffix"
}
set modName [string toupper [string index $m 0]]
append modName [string tolower [string range $m 1 [expr $l-1]]]
regsub -all \\. $modName _ modName
set modName [string tolower [string range $m 0 [expr $l-1]]]
if [regexp {^lib} $modName] {
set modName [string range $modName 3 end]
}
if [regexp {[0-9\.]*(_g0)?$} $modName match] {
set modName [string range $modName 0 [expr [string length $modName]-[string length $match]-1]]
}
set modName "[string toupper [string index $modName 0]][string range $modName 1 end]"
# Catalog initialization entry points found in the module

15
contrib/tcl/library/license.terms
View File

@ -26,7 +26,14 @@ IS PROVIDED ON AN "AS IS" BASIS, AND THE AUTHORS AND DISTRIBUTORS HAVE
NO OBLIGATION TO PROVIDE MAINTENANCE, SUPPORT, UPDATES, ENHANCEMENTS, OR
MODIFICATIONS.
RESTRICTED RIGHTS: Use, duplication or disclosure by the government
is subject to the restrictions as set forth in subparagraph (c) (1) (ii)
of the Rights in Technical Data and Computer Software Clause as DFARS
252.227-7013 and FAR 52.227-19.
GOVERNMENT USE: If you are acquiring this software on behalf of the
U.S. government, the Government shall have only "Restricted Rights"
in the software and related documentation as defined in the Federal
Acquisition Regulations (FARs) in Clause 52.227.19 (c) (2). If you
are acquiring the software on behalf of the Department of Defense, the
software shall be classified as "Commercial Computer Software" and the
Government shall have only "Restricted Rights" as defined in Clause
252.227-7013 (c) (1) of DFARs. Notwithstanding the foregoing, the
authors grant the U.S. Government and others acting in its behalf
permission to use and distribute the software in accordance with the
terms specified in this license.

15
contrib/tcl/license.terms
View File

@ -26,7 +26,14 @@ IS PROVIDED ON AN "AS IS" BASIS, AND THE AUTHORS AND DISTRIBUTORS HAVE
NO OBLIGATION TO PROVIDE MAINTENANCE, SUPPORT, UPDATES, ENHANCEMENTS, OR
MODIFICATIONS.
RESTRICTED RIGHTS: Use, duplication or disclosure by the government
is subject to the restrictions as set forth in subparagraph (c) (1) (ii)
of the Rights in Technical Data and Computer Software Clause as DFARS
252.227-7013 and FAR 52.227-19.
GOVERNMENT USE: If you are acquiring this software on behalf of the
U.S. government, the Government shall have only "Restricted Rights"
in the software and related documentation as defined in the Federal
Acquisition Regulations (FARs) in Clause 52.227.19 (c) (2). If you
are acquiring the software on behalf of the Department of Defense, the
software shall be classified as "Commercial Computer Software" and the
Government shall have only "Restricted Rights" as defined in Clause
252.227-7013 (c) (1) of DFARs. Notwithstanding the foregoing, the
authors grant the U.S. Government and others acting in its behalf
permission to use and distribute the software in accordance with the
terms specified in this license.

11
contrib/tcl/tests/clock.test
View File

@ -9,7 +9,7 @@
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# SCCS: @(#) clock.test 1.5 96/04/05 15:30:36
# SCCS: @(#) clock.test 1.6 96/07/23 16:16:43
if {[string compare test [info procs test]] == 1} then {source defs}
@ -46,10 +46,17 @@ test clock-3.2 {clock format tests} {
test clock-3.3 {clock format tests} {
list [catch {clock format foo} msg] $msg
} {1 {expected unsigned time but got "foo"}}
test clock-3.4 {clock format tests} {unixOnly} {
test clock-3.4 {clock format tests} {unixOrPc} {
set clockval 657687766
clock format $clockval -format "%a %b %d %I:%M:%S %p %Y" -gmt true
} "Sun Nov 04 03:02:46 AM 1990"
test clock-3.5 {clock format tests} {
list [catch {clock format a b c d e g} msg] $msg
} {1 {wrong # args: clock format clockval ?-format string? ?-gmt boolean?}}
test clock-3.6 {clock format tests} {unixOrPc} {
set clockval -1
clock format $clockval -format "%a %b %d %I:%M:%S %p %Y" -gmt true
} "Wed Dec 31 11:59:59 PM 1969"
# clock scan
test clock-4.1 {clock scan tests} {

14
contrib/tcl/tests/cmdAH.test
View File

@ -9,7 +9,7 @@
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# SCCS: @(#) cmdah.test 1.7 96/04/12 10:49:01
# SCCS: @(#) cmdAH.test 1.9 96/07/01 14:38:19
if {[string compare test [info procs test]] == 1} then {source defs}
@ -404,7 +404,7 @@ test cmdah-3.42 {Tcl_FileCmd: tail} {
set result [file tail ~]
set env(HOME) $temp
set result
} {}
} test
test cmdah-3.43 {Tcl_FileCmd: tail} {
global env
set temp $env(HOME)
@ -422,7 +422,7 @@ test cmdah-3.44 {Tcl_FileCmd: tail} {
set result [file tail ~]
set env(HOME) $temp
set result
} {}
} test
test cmdah-3.45 {Tcl_FileCmd: tail} {
global env
set temp $env(HOME)
@ -431,7 +431,7 @@ test cmdah-3.45 {Tcl_FileCmd: tail} {
set result [file tail ~]
set env(HOME) $temp
set result
} {}
} test
test cmdah-3.46 {Tcl_FileCmd: tail} {
testsetplatform unix
file tail {f.oo\bar/baz.bat}
@ -1016,7 +1016,11 @@ test cmdah-19.3 {Tcl_FileCmd: readlink errors} {unixOnly nonPortable} {
list [catch {file readlink _bogus_} msg] [string tolower $msg] \
[string tolower $errorCode]
} {1 {couldn't readlink "_bogus_": no such file or directory} {posix enoent {no such file or directory}}}
test cmdah-19.4 {Tcl_FileCmd: readlink errors} {macOrPc nonPortable} {
test cmdah-19.4 {Tcl_FileCmd: readlink errors} {macOnly nonPortable} {
list [catch {file readlink _bogus_} msg] [string tolower $msg] \
[string tolower $errorCode]
} {1 {couldn't readlink "_bogus_": no such file or directory} {posix enoent {no such file or directory}}}
test cmdah-19.5 {Tcl_FileCmd: readlink errors} {pcOnly nonPortable} {
list [catch {file readlink _bogus_} msg] [string tolower $msg] \
[string tolower $errorCode]
} {1 {couldn't readlink "_bogus_": invalid argument} {posix einval {invalid argument}}}

4
contrib/tcl/tests/defs
View File

@ -9,7 +9,7 @@
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# SCCS: @(#) defs 1.37 96/04/12 13:45:04
# SCCS: @(#) defs 1.38 96/07/24 17:18:20
if ![info exists VERBOSE] {
set VERBOSE 0
@ -55,6 +55,7 @@ if {[info commands memory] == ""} {
# run tests that only work on PCs.
# unixOrPc - 1 means this is a UNIX or PC platform.
# macOrPc - 1 means this is a Mac or PC platform.
# macOrUnix - 1 means this is a Mac or UNIX platform.
# nonPortable - 1 means this the tests are being running in
# the master Tcl/Tk development environment;
# Some tests are inherently non-portable because
@ -93,6 +94,7 @@ if {$tcl_platform(platform) == "windows"} {
}
set testConfig(unixOrPc) [expr $testConfig(unixOnly) || $testConfig(pcOnly)]
set testConfig(macOrPc) [expr $testConfig(macOnly) || $testConfig(pcOnly)]
set testConfig(macOrUnix) [expr $testConfig(macOnly) || $testConfig(unixOnly)]
set testConfig(nonPortable) [file exists doAllTests]
set f [open defs r]

6
contrib/tcl/tests/fileName.test
View File

@ -9,7 +9,7 @@
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# SCCS: @(#) fileName.test 1.20 96/04/19 12:36:13
# SCCS: @(#) fileName.test 1.23 96/07/31 11:46:11
if {[string compare test [info procs test]] == 1} then {source defs}
@ -1086,8 +1086,8 @@ test filename-11.12 {Tcl_GlobCmd} {
testsetplatform $platform
test filename-11.13 {Tcl_GlobCmd} {
list [catch {glob ~} msg] $msg
} [list 0 [list $env(HOME)]]
list [catch {file join [lindex [glob ~] 0]} msg] $msg
} [list 0 [file join $env(HOME)]]
# The following tests will work on Windows platforms only if MKS
# toolkit is installed.

10
contrib/tcl/tests/format.test
View File

@ -10,7 +10,7 @@
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# SCCS: @(#) format.test 1.22 96/02/16 08:55:56
# SCCS: @(#) format.test 1.23 96/07/31 16:54:50
if {[string compare test [info procs test]] == 1} then {source defs}
@ -355,12 +355,6 @@ test format-10.12 {XPG3 %$n specifiers} {
list [catch {format {%2$*d} 4 5 6} msg] $msg
} {0 { 6}}
test format-11.1 {enormous width specifiers} {
format "%077777777d" 77777777
} {0000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000077777777}
test format-11.2 {enormous width specifiers} {
format "%*d" 123456789 77777777
} { 77777777}
test format-11.3 {negative width specifiers} {
test format-11.1 {negative width specifiers} {
format "%*d" -47 25
} {25}

197
contrib/tcl/tests/io.test
View File

@ -11,13 +11,24 @@
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# "@(#) io.test 1.75 96/04/18 09:58:51"
# "@(#) io.test 1.87 96/07/30 11:59:00"
if {[string compare test [info procs test]] == 1} then {source defs}
removeFile test1
removeFile pipe
# set up a long data file for some of the following tests
set f [open longfile w]
fconfigure $f -eofchar {} -translation lf
for { set i 0 } { $i < 100 } { incr i} {
puts $f "#123456789abcdef0123456789abcdef0123456789abcdef0123456789abcdef0123456789abcdef
\#123456789abcdef01
\#"
}
close $f
# These tests are disabled until we decide what to do with "unsupported0".
#
#test io-1.7 {unsupported0 command} {
@ -339,14 +350,18 @@ test io-4.2 {Tcl_GetChannelType} {
string compare $t file
} 0
test io-4.3 {Tcl_GetChannelFile, input} {
set f [open io.test r]
set f [open test1 w]
fconfigure $f -translation lf -eofchar {}
puts $f "1234567890\n098765432"
close $f
set f [open test1 r]
gets $f
set l ""
lappend l [testchannel inputbuffered $f]
lappend l [tell $f]
close $f
set l
} {4022 74}
} {10 11}
test io-4.4 {Tcl_GetChannelFile, output} {
removeFile test1
set f [open test1 w]
@ -678,39 +693,39 @@ test io-7.10 {Tcl_Write, looping and buffering} {
removeFile test1
set f1 [open test1 w]
fconfigure $f1 -translation lf -eofchar {}
set f2 [open io.test r]
set f2 [open longfile r]
for {set x 0} {$x < 10} {incr x} {
puts $f1 [gets $f2]
}
close $f2
close $f1
file size test1
} 439
} 387
test io-7.11 {Tcl_Write, no newline, implicit flush} {
removeFile test1
set f1 [open test1 w]
fconfigure $f1 -eofchar {}
set f2 [open io.test r]
set f2 [open longfile r]
for {set x 0} {$x < 10} {incr x} {
puts -nonewline $f1 [gets $f2]
}
close $f1
close $f2
file size test1
} 429
} 377
test io-7.12 {Tcl_Write on a pipe} {unixOrPc} {
removeFile test1
removeFile pipe
set f1 [open pipe w]
puts $f1 {
set f1 [open io.test r]
set f1 [open longfile r]
for {set x 0} {$x < 10} {incr x} {
puts [gets $f1]
}
}
close $f1
set f1 [open "|$tcltest pipe" r]
set f2 [open io.test r]
set f2 [open longfile r]
set y ok
for {set x 0} {$x < 10} {incr x} {
set l1 [gets $f1]
@ -735,7 +750,7 @@ test io-7.13 {Tcl_Write to a pipe, line buffered} {unixOrPc} {
set y ok
set f1 [open "|$tcltest pipe" r+]
fconfigure $f1 -buffering line
set f2 [open io.test r]
set f2 [open longfile r]
set line [gets $f2]
puts $f1 $line
set backline [gets $f1]
@ -775,7 +790,7 @@ test io-7.15 {Tcl_Flush, channel not open for writing} {
[list 1 "channel \"$fd\" wasn't opened for writing"]
} 0
test io-7.16 {Tcl_Flush on pipe opened only for reading} {unixOrPc unixExecs} {
set fd [open "|cat io.test" r]
set fd [open "|cat longfile" r]
set x [list [catch {flush $fd} msg] $msg]
catch {close $fd}
string compare $x \
@ -1070,6 +1085,99 @@ test io-7.32 {Tcl_Write, background flush to slow reader} {unixOrPc asyncPipeClo
set result ok
}
} ok
test io-7.33 {Tcl_Flush, implicit flush on exit} {unixOrPc} {
set f [open script w]
puts $f {
set f [open test1 w]
fconfigure $f -translation lf
puts $f hello
puts $f bye
puts $f strange
}
close $f
eval exec $tcltest script
set f [open test1 r]
set r [read $f]
close $f
set r
} {hello
bye
strange
}
test io-7.34 {Tcl_Close, async flush on close, using sockets} {
set c 0
set x running
set l abcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyz
proc writelots {s l} {
for {set i 0} {$i < 2000} {incr i} {
puts $s $l
}
}
proc accept {s a p} {
global x
fileevent $s readable [list readit $s]
fconfigure $s -blocking off
set x accepted
}
proc readit {s} {
global c x
set l [gets $s]
if {[eof $s]} {
close $s
set x done
} elseif {([string length $l] > 0) || ![fblocked $s]} {
incr c
}
}
set ss [socket -server accept 2828]
set cs [socket [info hostname] 2828]
vwait x
fconfigure $cs -blocking off
writelots $cs $l
close $cs
close $ss
vwait x
set c
} 2000
test io-7.35 {Tcl_Close vs fileevent vs multiple interpreters} {
catch {interp delete x}
catch {interp delete y}
interp create x
interp create y
set s [socket -server accept 2828]
proc accept {s a p} {
puts $s hello
close $s
}
set c [socket [info hostname] 2828]
interp share {} $c x
interp share {} $c y
close $c
x eval {
proc readit {s} {
gets $s
if {[eof $s]} {
close $s
}
}
}
y eval {
proc readit {s} {
gets $s
if {[eof $s]} {
close $s
}
}
}
x eval "fileevent $c readable \{readit $c\}"
y eval "fileevent $c readable \{readit $c\}"
y eval [list close $c]
update
close $s
interp delete x
interp delete y
} ""
# Test end of line translations. Procedures tested are Tcl_Write, Tcl_Read.
@ -2112,13 +2220,13 @@ test io-10.2 {Tcl_Read, zero byte count} {
read stdin 0
} ""
test io-10.3 {Tcl_Read, negative byte count} {
set f [open io.test r]
set f [open longfile r]
set l [list [catch {read $f -1} msg] $msg]
close $f
set l
} {1 {bad argument "-1": should be "nonewline"}}
test io-10.4 {Tcl_Read, positive byte count} {
set f [open io.test r]
set f [open longfile r]
set x [read $f 1024]
set s [string length $x]
unset x
@ -2126,7 +2234,7 @@ test io-10.4 {Tcl_Read, positive byte count} {
set s
} 1024
test io-10.5 {Tcl_Read, multiple buffers} {
set f [open io.test r]
set f [open longfile r]
fconfigure $f -buffersize 100
set x [read $f 1024]
set s [string length $x]
@ -2135,19 +2243,19 @@ test io-10.5 {Tcl_Read, multiple buffers} {
set s
} 1024
test io-10.6 {Tcl_Read, very large read} {
set f1 [open io.test r]
set f1 [open longfile r]
set z [read $f1 1000000]
close $f1
set l [string length $z]
set x ok
set z [file size io.test]
set z [file size longfile]
if {$z != $l} {
set x broken
}
set x
} ok
test io-10.7 {Tcl_Read, nonblocking, file} {nonBlockFiles} {
set f1 [open io.test r]
set f1 [open longfile r]
fconfigure $f1 -blocking off
set z [read $f1 20]
close $f1
@ -2159,25 +2267,25 @@ test io-10.7 {Tcl_Read, nonblocking, file} {nonBlockFiles} {
set x
} ok
test io-10.8 {Tcl_Read, nonblocking, file} {nonBlockFiles} {
set f1 [open io.test r]
set f1 [open longfile r]
fconfigure $f1 -blocking off
set z [read $f1 1000000]
close $f1
set x ok
set l [string length $z]]
set z [file size io.test]]
set z [file size longfile]]
if {$z != $l} {
set x broken
}
set x
} ok
test io-10.9 {Tcl_Read, read to end of file} {
set f1 [open io.test r]
set f1 [open longfile r]
set z [read $f1]
close $f1
set l [string length $z]
set x ok
set z [file size io.test]
set z [file size longfile]
if {$z != $l} {
set x broken
}
@ -2295,7 +2403,7 @@ test io-11.1 {Tcl_Gets, reading what was written} {
set z
} ok
test io-11.2 {Tcl_Gets into variable} {
set f1 [open io.test r]
set f1 [open longfile r]
set c [gets $f1 x]
set l [string length x]
set z ok
@ -2412,7 +2520,7 @@ test io-11.10 {Tcl_Gets, exercising double buffering} {
# Test Tcl_Seek and Tcl_Tell.
test io-12.1 {Tcl_Seek to current position at start of file} {
set f1 [open io.test r]
set f1 [open longfile r]
seek $f1 0 current
set c [tell $f1]
close $f1
@ -3040,7 +3148,7 @@ test io-14.6 {Tcl_InputBlocked vs files, event driven read} {nonBlockFiles} {
# Test Tcl_InputBuffered
test io-15.1 {Tcl_InputBuffered} {
set f [open io.test r]
set f [open longfile r]
fconfigure $f -buffersize 4096
read $f 3
set l ""
@ -3050,7 +3158,7 @@ test io-15.1 {Tcl_InputBuffered} {
set l
} {4093 3}
test io-15.2 {Tcl_InputBuffered, test input flushing on seek} {
set f [open io.test r]
set f [open longfile r]
fconfigure $f -buffersize 4096
read $f 3
set l ""
@ -3066,13 +3174,13 @@ test io-15.2 {Tcl_InputBuffered, test input flushing on seek} {
# Test Tcl_SetChannelBufferSize, Tcl_GetChannelBufferSize
test io-16.1 {Tcl_GetChannelBufferSize, default buffer size} {
set f [open io.test r]
set f [open longfile r]
set s [fconfigure $f -buffersize]
close $f
set s
} 4096
test io-16.2 {Tcl_SetChannelBufferSize, Tcl_GetChannelBufferSize} {
set f [open io.test r]
set f [open longfile r]
set l ""
lappend l [fconfigure $f -buffersize]
fconfigure $f -buffersize 10000
@ -3360,7 +3468,7 @@ test io-18.8 {POSIX open access modes: TRUNC} {
close $f
set x
} abc
test io-18.9 {POSIX open access modes: NONBLOCK} {nonPortable} {
test io-18.9 {POSIX open access modes: NONBLOCK} {nonPortable macOrUnix} {
removeFile test3
set f [open test3 {WRONLY NONBLOCK CREAT}]
puts $f "NONBLOCK test"
@ -3511,9 +3619,8 @@ test io-22.1 {FileEventProc procedure: normal read event} {
set x [gets $f2]; fileevent $f2 readable {}
}
puts $f2 text; flush $f2
after 200
set x initial
update
vwait x
set x
} {text}
test io-22.2 {FileEventProc procedure: error in read event} {
@ -3523,9 +3630,8 @@ test io-22.2 {FileEventProc procedure: error in read event} {
}
fileevent $f2 readable {error bogus}
puts $f2 text; flush $f2
after 200
set x initial
update
vwait x
rename bgerror {}
list $x [fileevent $f2 readable]
} {bogus {}}
@ -3539,7 +3645,9 @@ test io-22.3 {FileEventProc procedure: normal write event} {
}
set x initial
set count 3
update
vwait x
vwait x
vwait x
set x
} {initial triggered triggered triggered}
test io-22.4 {FileEventProc procedure: eror in write event} {
@ -3549,7 +3657,7 @@ test io-22.4 {FileEventProc procedure: eror in write event} {
}
fileevent $f2 writable {error bad-write}
set x initial
update
vwait x
rename bgerror {}
list $x [fileevent $f2 writable]
} {bad-write {}}
@ -3563,9 +3671,9 @@ test io-22.5 {FileEventProc procedure: end of file} {unixOrPc unixExecs} {
lappend x $line
}
}
after 200
set x initial
update
vwait x
vwait x
close $f4
set x
} {initial foo eof}
@ -3573,7 +3681,8 @@ test io-22.5 {FileEventProc procedure: end of file} {unixOrPc unixExecs} {
catch {close $f2}
catch {close $f3}
} # Closes if {($platform(platform) != "macintosh") && \
}
# Closes if {($platform(platform) != "macintosh") && \
# ($testConfig(unixExecs) == 1)} clause
close $f
@ -3602,11 +3711,10 @@ test io-23.2 {DeleteFileEvent, cleanup on close} {
}
close $f
set x initial
update
vwait x
close $f2
set x
} {initial {f2 triggered: "foo bar"}}
test io-23.3 {DeleteFileEvent, cleanup on close} {
set f [open foo r]
set f2 [open foo r]
@ -3629,9 +3737,9 @@ test io-23.3 {DeleteFileEvent, cleanup on close} {
[catch {fileevent $f3 readable}]
} {0 {f script} 1 0 {f3 script} 0 {f script} 1 1 1 1 1}
if {[info commands testfevent] == ""} {
break
}
# Execute these tests only if the "testfevent" command is present.
if {[info commands testfevent] == "testfevent"} {
test io-24.1 {Tcl event loop vs multiple interpreters} {
testfevent create
@ -3774,6 +3882,10 @@ test io-25.6 {file events on shared files, deleting file events} {
set x
} {{script 1} {}}
}
# The above curly closes the test for presence of the "testfevent" command.
test io-26.1 {testing readability conditions} {
set f [open bar w]
puts $f abcdefg
@ -4329,6 +4441,7 @@ test io-27.6 {testing handler deletion vs reentrant calls} {
{first after update}]
} 0
removeFile longfile
removeFile script
removeFile output
removeFile test1

15
contrib/tcl/tests/license.terms
View File

@ -26,7 +26,14 @@ IS PROVIDED ON AN "AS IS" BASIS, AND THE AUTHORS AND DISTRIBUTORS HAVE
NO OBLIGATION TO PROVIDE MAINTENANCE, SUPPORT, UPDATES, ENHANCEMENTS, OR
MODIFICATIONS.
RESTRICTED RIGHTS: Use, duplication or disclosure by the government
is subject to the restrictions as set forth in subparagraph (c) (1) (ii)
of the Rights in Technical Data and Computer Software Clause as DFARS
252.227-7013 and FAR 52.227-19.
GOVERNMENT USE: If you are acquiring this software on behalf of the
U.S. government, the Government shall have only "Restricted Rights"
in the software and related documentation as defined in the Federal
Acquisition Regulations (FARs) in Clause 52.227.19 (c) (2). If you
are acquiring the software on behalf of the Department of Defense, the
software shall be classified as "Commercial Computer Software" and the
Government shall have only "Restricted Rights" as defined in Clause
252.227-7013 (c) (1) of DFARs. Notwithstanding the foregoing, the
authors grant the U.S. Government and others acting in its behalf
permission to use and distribute the software in accordance with the
terms specified in this license.

5
contrib/tcl/tests/lrange.test
View File

@ -10,7 +10,7 @@
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# SCCS: @(#) lrange.test 1.5 96/02/16 08:56:13
# SCCS: @(#) lrange.test 1.6 96/07/10 17:16:47
if {[string compare test [info procs test]] == 1} then {source defs}
@ -56,6 +56,9 @@ test lrange-1.13 {range of list elements} {
test lrange-1.14 {range of list elements} {
lrange "a b c d" end 2
} {}
test lrange-1.14 {range of list elements} {
concat \"[lrange {a b \{\ } 0 2]"
} {"a b \{\ "}
test lrange-2.1 {error conditions} {
list [catch {lrange a b} msg] $msg

5
contrib/tcl/tests/lreplace.test
View File

@ -10,7 +10,7 @@
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# SCCS: @(#) lreplace.test 1.12 96/02/16 08:56:14
# SCCS: @(#) lreplace.test 1.13 96/07/10 17:16:47
if {[string compare test [info procs test]] == 1} then {source defs}
@ -86,6 +86,9 @@ test lreplace-1.23 {lreplace command} {
test lreplace-1.24 {lreplace command} {
lreplace {1 2 3 4} end -1 z
} {1 2 3 z 4}
test lreplace-1.25 {lreplace command} {
concat \"[lreplace {\}\ hello} end end]\"
} {"\}\ "}
test lreplace-2.1 {lreplace errors} {

168
contrib/tcl/tests/socket.test
View File

@ -59,7 +59,7 @@
# listening at port 2048. If all fails, a message is printed and the tests
# using the remote server are not performed.
#
# "@(#) socket.test 1.56 96/04/20 13:29:26"
# SCCS: @(#) socket.test 1.62 96/08/01 15:57:49
if {[string compare test [info procs test]] == 1} then {source defs}
@ -108,6 +108,7 @@ if {$doTestsWithRemoteServer == 1} {
if {[catch {set commandSocket [socket $remoteServerIP \
$remoteServerPort]}] != 0} {
if {[info commands exec] == ""} {
set noRemoteTestReason "can't exec"
set doTestsWithRemoteServer 0
} else {
set remoteServerIP localhost
@ -118,23 +119,28 @@ if {$doTestsWithRemoteServer == 1} {
msg] == 0} {
after 1000
if {[catch {set commandSocket [socket $remoteServerIP \
$remoteServerPort]}] == 0} {
$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."
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"
}
}
#
@ -481,6 +487,27 @@ test socket-2.9 {socket conflict} {unixOrPc} {
invoked from within
"set f [socket -server accept 2828]..."
(file "script" line 1)}}
test socket-2.10 {close on accept, accepted socket lives} {
set done 0
set ss [socket -server accept 2828]
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] 2828]
puts $cs hello
close $cs
vwait done
set done
} 1
test socket-3.1 {socket conflict} {unixOrPc} {
removeFile script
@ -727,6 +754,20 @@ test socket-7.3 {testing socket specific options} {
llength $l
} 10
test socket-7.4 {testing socket specific options} {
set s [socket -server accept 2828]
proc accept {s a p} {
global x
set x [fconfigure $s -sockname]
close $s
}
set s1 [socket [info hostname] 2828]
vwait x
close $s
close $s1
set l ""
lappend l [lindex $x 2] [llength $x]
} {2828 3}
test socket-7.5 {testing socket specific options} {unixOrPc} {
set s [socket -server accept 2828]
proc accept {s a p} {
global x
@ -763,7 +804,7 @@ test socket-8.1 {testing -async flag on sockets} {
close $s
set x done
}
set s1 [socket -async localhost 2828]
set s1 [socket -async [info hostname] 2828]
vwait x
set z [gets $s1]
close $s
@ -771,6 +812,83 @@ test socket-8.1 {testing -async flag on sockets} {
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 2828]
set c [socket [info hostname] 2828]
puts -nonewline $c 01234567890123456789012345678901234567890123456789
close $c
vwait done
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 8080]
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] 8080]
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"
vwait done
close $l
set count
} 65566
removeFile script
#
@ -782,7 +900,7 @@ if {$doTestsWithRemoteServer == 0} {
return
}
test socket-9.1 {tcp connection} {
test socket-10.1 {tcp connection} {
sendCommand {
set socket9_1_test_server [socket -server accept 2828]
proc accept {s a p} {
@ -796,7 +914,7 @@ test socket-9.1 {tcp connection} {
sendCommand {close $socket9_1_test_server}
set r
} done
test socket-9.2 {client specifies its port} {
test socket-10.2 {client specifies its port} {
if {[info exists port]} {
incr port
} else {
@ -821,9 +939,9 @@ test socket-9.2 {client specifies its port} {
set result
} ok
#
# Tests io-9.3, io-9.4 have been removed.
# Tests io-10.3, io-10.4 have been removed.
#
test socket-9.5 {trying to connect, no server} {
test socket-10.5 {trying to connect, no server} {
set status ok
if {![catch {set s [socket $remoteServerIp 2828]}]} {
if {![catch {gets $s}]} {
@ -833,9 +951,9 @@ test socket-9.5 {trying to connect, no server} {
}
set status
} ok
test socket-9.6 {remote echo, one line} {
test socket-10.6 {remote echo, one line} {
sendCommand {
set socket9_6_test_server [socket -server accept 2828]
set socket10_6_test_server [socket -server accept 2828]
proc accept {s a p} {
fileevent $s readable [list echo $s]
fconfigure $s -buffering line -translation crlf
@ -854,12 +972,12 @@ test socket-9.6 {remote echo, one line} {
puts $f hello
set r [gets $f]
close $f
sendCommand {close $socket9_6_test_server}
sendCommand {close $socket10_6_test_server}
set r
} hello
test socket-9.7 {remote echo, 50 lines} {
test socket-10.7 {remote echo, 50 lines} {
sendCommand {
set socket9_7_test_server [socket -server accept 2828]
set socket10_7_test_server [socket -server accept 2828]
proc accept {s a p} {
fileevent $s readable [list echo $s]
fconfigure $s -buffering line -translation crlf
@ -882,7 +1000,7 @@ test socket-9.7 {remote echo, 50 lines} {
}
}
close $f
sendCommand {close $socket9_7_test_server}
sendCommand {close $socket10_7_test_server}
set cnt
} 50
# Macintosh sockets can have more than one server per port
@ -891,7 +1009,7 @@ if {$tcl_platform(platform) == "macintosh"} {
} else {
set conflictResult {1 {couldn't open socket: address already in use}}
}
test socket-9.8 {socket conflict} {
test socket-10.8 {socket conflict} {
set s1 [socket -server accept 2828]
if {[catch {set s2 [socket -server accept 2828]} msg]} {
set result [list 1 $msg]
@ -902,9 +1020,9 @@ test socket-9.8 {socket conflict} {
close $s1
set result
} $conflictResult
test socket-9.9 {server with several clients} {
test socket-10.9 {server with several clients} {
sendCommand {
set socket9_9_test_server [socket -server accept 2828]
set socket10_9_test_server [socket -server accept 2828]
proc accept {s a p} {
fconfigure $s -buffering line
fileevent $s readable [list echo $s]
@ -935,10 +1053,10 @@ test socket-9.9 {server with several clients} {
close $s1
close $s2
close $s3
sendCommand {close $socket9_9_test_server}
sendCommand {close $socket10_9_test_server}
set i
} 100
test socket-9.10 {client with several servers} {
test socket-10.10 {client with several servers} {
sendCommand {
set s1 [socket -server "accept 3000" 3000]
set s2 [socket -server "accept 3001" 3001]
@ -964,7 +1082,7 @@ test socket-9.10 {client with several servers} {
}
set l
} {3000 {} 1 3001 {} 1 3002 {} 1}
test socket-9.11 {accept callback error} {
test socket-10.11 {accept callback error} {
set s [socket -server accept 2828]
proc accept {s a p} {expr 10 / 0}
proc bgerror args {
@ -984,9 +1102,9 @@ test socket-9.11 {accept callback error} {
rename bgerror {}
set x
} {{divide by zero}}
test socket-9.12 {testing socket specific options} {
test socket-10.12 {testing socket specific options} {
sendCommand {
set socket9_12_test_server [socket -server accept 2828]
set socket10_12_test_server [socket -server accept 2828]
proc accept {s a p} {close $s}
}
set s [socket $remoteServerIP 2828]
@ -995,7 +1113,7 @@ test socket-9.12 {testing socket specific options} {
set l ""
lappend l [lindex $p 2] [llength $p] [llength $p]
close $s
sendCommand {close $socket9_12_test_server}
sendCommand {close $socket10_12_test_server}
set l
} {2828 3 3}

21
contrib/tcl/unix/Makefile.in
View File

@ -5,7 +5,7 @@
# "autoconf" program (constructs like "@foo@" will get replaced in the
# actual Makefile.
#
# SCCS: @(#) Makefile.in 1.130 96/04/18 16:55:37
# SCCS: @(#) Makefile.in 1.140 96/08/01 20:06:06
# Current Tcl version; used in various names.
@ -45,6 +45,9 @@ 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
@ -348,6 +351,10 @@ dltest/Makefile: $(DLTEST_DIR)/configure $(DLTEST_DIR)/Makefile.in tclConfig.sh
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 \
@ -360,10 +367,12 @@ install-binaries: $(TCL_LIB_FILE) tclsh
done;
@echo "Installing $(TCL_LIB_FILE)"
@$(INSTALL_DATA) $(TCL_LIB_FILE) $(LIB_INSTALL_DIR)/$(TCL_LIB_FILE)
@$(RANLIB) $(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) \
@ -378,8 +387,6 @@ install-libraries:
done;
@echo "Installing tcl.h"
@$(INSTALL_DATA) $(GENERIC_DIR)/tcl.h $(INCLUDE_INSTALL_DIR)/tcl.h
@echo "Installing tclConfig.sh"
@$(INSTALL_DATA) tclConfig.sh $(LIB_INSTALL_DIR)/tclConfig.sh
@for i in $(TOP_DIR)/library/*.tcl $(TOP_DIR)/library/tclIndex $(UNIX_DIR)/tclAppInit.c; \
do \
echo "Installing $$i"; \
@ -433,7 +440,7 @@ clean:
if test -f dltest/Makefile; then cd dltest; make clean; fi
distclean: clean
rm -f Makefile config.* tclConfig.sh
rm -f Makefile config.status config.cache config.log tclConfig.sh
if test -f dltest/Makefile; then cd dltest; make distclean; fi
depend:
@ -676,7 +683,7 @@ checkexports: $(TCL_LIB_FILE)
# to put the distribution.
#
DISTDIR = /proj/tcl/dist/tcl7.5
DISTDIR = /proj/tcl/dist/tcl7.5p1
configure: configure.in
autoconf
dist: configure
@ -684,6 +691,7 @@ dist: configure
mkdir $(DISTDIR)
mkdir $(DISTDIR)/unix
cp -p $(UNIX_DIR)/*.c $(UNIX_DIR)/*.h $(DISTDIR)/unix
rm -f $(DISTDIR)/unix/bp.c
cp Makefile.in $(DISTDIR)/unix
chmod 664 $(DISTDIR)/unix/Makefile.in
cp configure configure.in tclConfig.sh.in install-sh porting.notes \
@ -722,6 +730,7 @@ dist: configure
rm -f tclMacProjects.sit.hqx
cp -p ../mac/*.c ../mac/*.h ../mac/*.r $(DISTDIR)/mac
cp -p ../mac/porting.notes ../mac/README $(DISTDIR)/mac
cp -p ../mac/*.doc ../mac/*.pch $(DISTDIR)/mac
cp -p ../license.terms $(DISTDIR)/mac
mkdir $(DISTDIR)/unix/dltest
cp -p dltest/*.c dltest/Makefile.in $(DISTDIR)/unix/dltest

19
contrib/tcl/unix/README
View File

@ -12,14 +12,19 @@ SGI, as well as PCs running Linux, BSDI, and SCO UNIX. To compile for
a PC running Windows, see the README file in the directory ../win. To
compile for a Macintosh, see the README file in the directory ../mac.
SCCS: @(#) README 1.10 96/04/17 11:40:24
SCCS: @(#) README 1.13 96/07/31 16:28:38
How To Compile And Install Tcl:
-------------------------------
(a) Check for patches as described in ../README.
(b) Type "./configure". This runs a configuration script created by GNU
(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,
@ -29,7 +34,7 @@ How To Compile And Install Tcl:
--enable-gcc If this switch is set, Tcl will configure
itself to use gcc if it is available on your
system. Note: it is not safe to modify the
Makefile to use gcc after autoconf is run;
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
@ -44,11 +49,11 @@ How To Compile And Install Tcl:
Note: be sure to use only absolute path names (those starting with "/")
in the --prefix and --exec_prefix options.
(c) Type "make". This will create a library archive called "libtcl.a"
(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.
(d) If the make fails then you'll have to personalize the Makefile
(e) If the make fails then you'll have to personalize the Makefile
for your site or possibly modify the distribution in other ways.
First check the file "porting.notes" to see if there are hints
for compiling on your system. Then look at the porting Web page
@ -56,7 +61,7 @@ How To Compile And Install Tcl:
are comments at the beginning of it that describe the things you
might want to change and how to change them.
(e) Type "make install" to install Tcl binaries and script files in
(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
@ -65,7 +70,7 @@ How To Compile And Install Tcl:
can override these choices by modifying the "prefix" and
"exec_prefix" variables in the Makefile.
(f) At this point you can play with Tcl by invoking the "tclsh"
(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

52
contrib/tcl/unix/configure vendored
View File

@ -404,7 +404,7 @@ else
fi
# SCCS: @(#) configure.in 1.102 96/04/17 10:46:25
# SCCS: @(#) configure.in 1.107 96/07/30 08:38:37
TCL_VERSION=7.5
TCL_MAJOR_VERSION=7
@ -2996,7 +2996,7 @@ fi
# LD_SEARCH_FLAGS-Flags to pass to ld, such as "-R /usr/local/tcl/lib",
# that tell the run-time dynamic linker where to look
# for shared libraries such as libtcl.so. Depends on
# the variable LIB_INSTALL_DIR in the Makefile.
# 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.
@ -3127,7 +3127,7 @@ case $system in
DL_OBJS="tclLoadDl.o tclLoadAix.o"
DL_LIBS="-lld"
LD_FLAGS=""
LD_SEARCH_FLAGS='-L${LIB_INSTALL_DIR}'
LD_SEARCH_FLAGS='-L${LIB_RUNTIME_DIR}'
cat >> confdefs.h <<\EOF
#define NO_DLFCN_H 1
EOF
@ -3135,6 +3135,16 @@ EOF
AIX=yes
TCL_SHARED_LIB_SUFFIX='${VERSION}.a'
;;
BSD/OS-2.1*)
SHLIB_CFLAGS=""
SHLIB_LD="ld -r"
SHLIB_LD_FLAGS=""
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_CFLAGS="+z"
SHLIB_LD="ld -b"
@ -3143,7 +3153,7 @@ EOF
DL_OBJS="tclLoadShl.o"
DL_LIBS="-ldld"
LD_FLAGS="-Wl,-E"
LD_SEARCH_FLAGS='-Wl,+b,${LIB_INSTALL_DIR}:.'
LD_SEARCH_FLAGS='-Wl,+b,${LIB_RUNTIME_DIR}:.'
;;
IRIX-4.*)
SHLIB_CFLAGS="-G 0"
@ -3155,7 +3165,7 @@ EOF
LD_FLAGS="-Wl,-D,08000000"
LD_SEARCH_FLAGS=""
;;
IRIX-5.*)
IRIX-5.*|IRIX-6.*)
SHLIB_CFLAGS=""
SHLIB_LD="ld -shared -rdata_shared"
SHLIB_LD_LIBS=""
@ -3163,7 +3173,17 @@ EOF
DL_OBJS="tclLoadDl.o"
DL_LIBS=""
LD_FLAGS=""
LD_SEARCH_FLAGS='-Wl,-rpath,${LIB_INSTALL_DIR}'
LD_SEARCH_FLAGS='-Wl,-rpath,${LIB_RUNTIME_DIR}'
;;
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"
@ -3182,7 +3202,7 @@ if eval "test \"`echo '$''{'ac_cv_header_$ac_safe'+set}'`\" = set"; then
echo $ac_n "(cached) $ac_c" 1>&6
else
cat > conftest.$ac_ext <<EOF
#line 3186 "configure"
#line 3206 "configure"
#include "confdefs.h"
#include <dld.h>
EOF
@ -3240,7 +3260,7 @@ if eval "test \"`echo '$''{'ac_cv_header_$ac_safe'+set}'`\" = set"; then
echo $ac_n "(cached) $ac_c" 1>&6
else
cat > conftest.$ac_ext <<EOF
#line 3244 "configure"
#line 3264 "configure"
#include "confdefs.h"
#include <dlfcn.h>
EOF
@ -3332,7 +3352,7 @@ fi
DL_OBJS="tclLoadDl.o"
DL_LIBS=""
LD_FLAGS=""
LD_SEARCH_FLAGS='-Wl,-rpath,${LIB_INSTALL_DIR}'
LD_SEARCH_FLAGS='-Wl,-rpath,${LIB_RUNTIME_DIR}'
;;
RISCos-*)
SHLIB_CFLAGS="-G 0"
@ -3375,7 +3395,7 @@ fi
DL_OBJS="tclLoadDl.o"
DL_LIBS="-ldl"
LD_FLAGS=""
LD_SEARCH_FLAGS='-L${LIB_INSTALL_DIR}'
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
@ -3387,14 +3407,14 @@ fi
TCL_LIB_VERSIONS_OK=nodots
;;
SunOS-5*)
SHLIB_CFLAGS="-K PIC"
SHLIB_CFLAGS="-KPIC"
SHLIB_LD="/usr/ccs/bin/ld -G -z text"
SHLIB_LD_LIBS='${LIBS}'
SHLIB_SUFFIX=".so"
DL_OBJS="tclLoadDl.o"
DL_LIBS="-ldl"
LD_FLAGS=""
LD_SEARCH_FLAGS='-R ${LIB_INSTALL_DIR}'
LD_SEARCH_FLAGS='-R ${LIB_RUNTIME_DIR}'
;;
ULTRIX-4.*)
SHLIB_CFLAGS="-G 0"
@ -3407,7 +3427,7 @@ fi
LD_SEARCH_FLAGS=""
;;
UNIX_SV*)
SHLIB_CFLAGS="-K PIC"
SHLIB_CFLAGS="-KPIC"
SHLIB_LD="cc -G"
SHLIB_LD_LIBS=""
SHLIB_SUFFIX=".so"
@ -3439,7 +3459,7 @@ esac
if test "x$DL_OBJS" = "xtclLoadAout.o" ; then
echo $ac_n "checking sys/exec.h""... $ac_c" 1>&6
cat > conftest.$ac_ext <<EOF
#line 3443 "configure"
#line 3463 "configure"
#include "confdefs.h"
#include <sys/exec.h>
int main() { return 0; }
@ -3476,7 +3496,7 @@ EOF
else
echo $ac_n "checking a.out.h""... $ac_c" 1>&6
cat > conftest.$ac_ext <<EOF
#line 3480 "configure"
#line 3500 "configure"
#include "confdefs.h"
#include <a.out.h>
int main() { return 0; }
@ -3513,7 +3533,7 @@ EOF
else
echo $ac_n "checking sys/exec_aout.h""... $ac_c" 1>&6
cat > conftest.$ac_ext <<EOF
#line 3517 "configure"
#line 3537 "configure"
#include "confdefs.h"
#include <sys/exec_aout.h>
int main() { return 0; }

42
contrib/tcl/unix/configure.in
View File

@ -2,7 +2,7 @@ dnl This file is an input file used by the GNU "autoconf" program to
dnl generate the file "configure", which is run during Tcl installation
dnl to configure the system for the local environment.
AC_INIT(../generic/tcl.h)
# SCCS: @(#) configure.in 1.102 96/04/17 10:46:25
# SCCS: @(#) configure.in 1.107 96/07/30 08:38:37
TCL_VERSION=7.5
TCL_MAJOR_VERSION=7
@ -449,7 +449,7 @@ AC_CHECK_FUNC(gethostbyname, , AC_CHECK_LIB(nsl, main, [LIBS="$LIBS -lnsl"]))
# LD_SEARCH_FLAGS-Flags to pass to ld, such as "-R /usr/local/tcl/lib",
# that tell the run-time dynamic linker where to look
# for shared libraries such as libtcl.so. Depends on
# the variable LIB_INSTALL_DIR in the Makefile.
# 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.
@ -541,11 +541,21 @@ case $system in
DL_OBJS="tclLoadDl.o tclLoadAix.o"
DL_LIBS="-lld"
LD_FLAGS=""
LD_SEARCH_FLAGS='-L${LIB_INSTALL_DIR}'
LD_SEARCH_FLAGS='-L${LIB_RUNTIME_DIR}'
AC_DEFINE(NO_DLFCN_H)
AIX=yes
TCL_SHARED_LIB_SUFFIX='${VERSION}.a'
;;
BSD/OS-2.1*)
SHLIB_CFLAGS=""
SHLIB_LD="ld -r"
SHLIB_LD_FLAGS=""
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_CFLAGS="+z"
SHLIB_LD="ld -b"
@ -554,7 +564,7 @@ case $system in
DL_OBJS="tclLoadShl.o"
DL_LIBS="-ldld"
LD_FLAGS="-Wl,-E"
LD_SEARCH_FLAGS='-Wl,+b,${LIB_INSTALL_DIR}:.'
LD_SEARCH_FLAGS='-Wl,+b,${LIB_RUNTIME_DIR}:.'
;;
IRIX-4.*)
SHLIB_CFLAGS="-G 0"
@ -566,7 +576,7 @@ case $system in
LD_FLAGS="-Wl,-D,08000000"
LD_SEARCH_FLAGS=""
;;
IRIX-5.*)
IRIX-5.*|IRIX-6.*)
SHLIB_CFLAGS=""
SHLIB_LD="ld -shared -rdata_shared"
SHLIB_LD_LIBS=""
@ -574,7 +584,17 @@ case $system in
DL_OBJS="tclLoadDl.o"
DL_LIBS=""
LD_FLAGS=""
LD_SEARCH_FLAGS='-Wl,-rpath,${LIB_INSTALL_DIR}'
LD_SEARCH_FLAGS='-Wl,-rpath,${LIB_RUNTIME_DIR}'
;;
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"
@ -686,7 +706,7 @@ case $system in
DL_OBJS="tclLoadDl.o"
DL_LIBS=""
LD_FLAGS=""
LD_SEARCH_FLAGS='-Wl,-rpath,${LIB_INSTALL_DIR}'
LD_SEARCH_FLAGS='-Wl,-rpath,${LIB_RUNTIME_DIR}'
;;
RISCos-*)
SHLIB_CFLAGS="-G 0"
@ -729,7 +749,7 @@ case $system in
DL_OBJS="tclLoadDl.o"
DL_LIBS="-ldl"
LD_FLAGS=""
LD_SEARCH_FLAGS='-L${LIB_INSTALL_DIR}'
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
@ -741,14 +761,14 @@ case $system in
TCL_LIB_VERSIONS_OK=nodots
;;
SunOS-5*)
SHLIB_CFLAGS="-K PIC"
SHLIB_CFLAGS="-KPIC"
SHLIB_LD="/usr/ccs/bin/ld -G -z text"
SHLIB_LD_LIBS='${LIBS}'
SHLIB_SUFFIX=".so"
DL_OBJS="tclLoadDl.o"
DL_LIBS="-ldl"
LD_FLAGS=""
LD_SEARCH_FLAGS='-R ${LIB_INSTALL_DIR}'
LD_SEARCH_FLAGS='-R ${LIB_RUNTIME_DIR}'
;;
ULTRIX-4.*)
SHLIB_CFLAGS="-G 0"
@ -761,7 +781,7 @@ case $system in
LD_SEARCH_FLAGS=""
;;
UNIX_SV*)
SHLIB_CFLAGS="-K PIC"
SHLIB_CFLAGS="-KPIC"
SHLIB_LD="cc -G"
SHLIB_LD_LIBS=""
SHLIB_SUFFIX=".so"

1047
contrib/tcl/unix/mkLinks
View File

File diff suppressed because it is too large Load Diff

37
contrib/tcl/unix/porting.notes
View File

@ -26,7 +26,7 @@ and Tk to compile. You can also add new entries to that database
when you install Tcl and Tk on a new platform. The Web database is
likely to be more up-to-date than this file.
sccsid = SCCS: @(#) porting.notes 1.16 96/04/17 10:32:35
sccsid = SCCS: @(#) porting.notes 1.17 96/05/18 16:49:24
--------------------------------------------
Solaris, various versions
@ -355,3 +355,38 @@ Expect failures from socket tests 2.9 and 3.1.
Contact me directly if you have problems on SCO systems.
Mark Diekhans <markd@sco.com>
--------------------------------------------
Linux 1.2.13 (gcc 2.7.0, libc.so.5.0.9)
--------------------------------------------
Symptoms:
* Some extensions could not be loaded dynamically, most
prominently Blt 2.0
The given error message essentially said:
Could not resolve symbol '__eprintf'.
(This procedure is used by the macro 'assert')
Cause
* '__eprintf' is defined in 'libgcc.a', not 'libc.so.x.y'.
It is therefore impossible to load it dynamically.
* Neither tcl nor tk make use of 'assert', thereby
preventing a static linkage.
Workaround
* I included <assert.h> in 'tclAppInit.c' / 'tkAppInit.c'
and then executed 'assert (argc)' just before the call
to Tcl_Main / Tk_Main.
This forced the static linkage of '__eprintf' and
everything went fine from then on.
(Something like 'assert (1)', 'assert (a==a)' is not
sufficient, it will be optimized away).

212
contrib/tcl/unix/tclUnixChan.c
View File

@ -9,7 +9,7 @@
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
* SCCS: @(#) tclUnixChan.c 1.161 96/04/18 08:28:54
* SCCS: @(#) tclUnixChan.c 1.172 96/06/11 10:14:51
*/
#include "tclInt.h" /* Internal definitions for Tcl. */
@ -26,6 +26,9 @@ typedef struct PipeState {
int numPids; /* How many processes are attached to this pipe? */
int *pidPtr; /* The process IDs themselves. Allocated by
* the creator of the pipe. */
int isNonBlocking; /* Nonzero when the pipe is in nonblocking mode.
* Used to decide whether to wait for the children
* at close time. */
} PipeState;
/*
@ -48,6 +51,15 @@ typedef struct TcpState {
#define TCP_ASYNC_SOCKET (1<<0) /* Asynchronous socket. */
#define TCP_ASYNC_CONNECT (1<<1) /* Async connect in progress. */
/*
* The following defines the maximum length of the listen queue. This is
* the number of outstanding yet-to-be-serviced requests for a connection
* on a server socket, more than this number of outstanding requests and
* the connection request will fail.
*/
#define TCL_LISTEN_LIMIT 100
/*
* The following defines how much buffer space the kernel should maintain
* for a socket.
@ -59,15 +71,15 @@ typedef struct TcpState {
* Static routines for this file:
*/
static int CommonBlockModeProc _ANSI_ARGS_((
ClientData instanceData, Tcl_File inFile,
Tcl_File outFile, int mode));
static TcpState * CreateSocket _ANSI_ARGS_((Tcl_Interp *interp,
int port, char *host, int server,
char *myaddr, int myport, int async));
static int CreateSocketAddress _ANSI_ARGS_(
(struct sockaddr_in *sockaddrPtr,
char *host, int port));
static int FileBlockModeProc _ANSI_ARGS_((
ClientData instanceData, Tcl_File inFile,
Tcl_File outFile, int mode));
static int FileCloseProc _ANSI_ARGS_((ClientData instanceData,
Tcl_Interp *interp, Tcl_File inFile,
Tcl_File outFile));
@ -80,6 +92,9 @@ static int FilePipeOutputProc _ANSI_ARGS_((
static int FileSeekProc _ANSI_ARGS_((ClientData instanceData,
Tcl_File inFile, Tcl_File outFile, long offset,
int mode, int *errorCode));
static int PipeBlockModeProc _ANSI_ARGS_((
ClientData instanceData, Tcl_File inFile,
Tcl_File outFile, int mode));
static int PipeCloseProc _ANSI_ARGS_((ClientData instanceData,
Tcl_Interp *interp, Tcl_File inFile,
Tcl_File outFile));
@ -106,7 +121,7 @@ static int WaitForConnect _ANSI_ARGS_((TcpState *statePtr,
static Tcl_ChannelType fileChannelType = {
"file", /* Type name. */
CommonBlockModeProc, /* Set blocking/nonblocking mode.*/
FileBlockModeProc, /* Set blocking/nonblocking mode.*/
FileCloseProc, /* Close proc. */
FilePipeInputProc, /* Input proc. */
FilePipeOutputProc, /* Output proc. */
@ -122,7 +137,7 @@ static Tcl_ChannelType fileChannelType = {
static Tcl_ChannelType pipeChannelType = {
"pipe", /* Type name. */
CommonBlockModeProc, /* Set blocking/nonblocking mode.*/
PipeBlockModeProc, /* Set blocking/nonblocking mode.*/
PipeCloseProc, /* Close proc. */
FilePipeInputProc, /* Input proc. */
FilePipeOutputProc, /* Output proc. */
@ -150,7 +165,7 @@ static Tcl_ChannelType tcpChannelType = {
/*
*----------------------------------------------------------------------
*
* CommonBlockModeProc --
* FileBlockModeProc --
*
* Helper procedure to set blocking and nonblocking modes on a
* channel. Invoked either by generic IO level code or by other
@ -167,7 +182,7 @@ static Tcl_ChannelType tcpChannelType = {
/* ARGSUSED */
static int
CommonBlockModeProc(instanceData, inFile, outFile, mode)
FileBlockModeProc(instanceData, inFile, outFile, mode)
ClientData instanceData; /* Unused. */
Tcl_File inFile, outFile; /* Input, output files for channel. */
int mode; /* The mode to set. Can be one of
@ -206,6 +221,69 @@ CommonBlockModeProc(instanceData, inFile, outFile, mode)
return 0;
}
/*
*----------------------------------------------------------------------
*
* PipeBlockModeProc --
*
* Helper procedure to set blocking and nonblocking modes on a
* channel. Invoked either by generic IO level code or by other
* channel drivers after doing channel-type-specific inialization.
*
* Results:
* 0 if successful, errno when failed.
*
* Side effects:
* Sets the device into blocking or non-blocking mode.
*
*----------------------------------------------------------------------
*/
/* ARGSUSED */
static int
PipeBlockModeProc(instanceData, inFile, outFile, mode)
ClientData instanceData; /* The pipe state. */
Tcl_File inFile, outFile; /* Input, output files for channel. */
int mode; /* The mode to set. Can be one of
* TCL_MODE_BLOCKING or
* TCL_MODE_NONBLOCKING. */
{
PipeState *pipePtr;
int curStatus;
int fd;
if (inFile != NULL) {
fd = (int) Tcl_GetFileInfo(inFile, NULL);
curStatus = fcntl(fd, F_GETFL);
if (mode == TCL_MODE_BLOCKING) {
curStatus &= (~(O_NONBLOCK));
} else {
curStatus |= O_NONBLOCK;
}
if (fcntl(fd, F_SETFL, curStatus) < 0) {
return errno;
}
curStatus = fcntl(fd, F_GETFL);
}
if (outFile != NULL) {
fd = (int) Tcl_GetFileInfo(outFile, NULL);
curStatus = fcntl(fd, F_GETFL);
if (mode == TCL_MODE_BLOCKING) {
curStatus &= (~(O_NONBLOCK));
} else {
curStatus |= O_NONBLOCK;
}
if (fcntl(fd, F_SETFL, curStatus) < 0) {
return errno;
}
}
pipePtr = (PipeState *) instanceData;
pipePtr->isNonBlocking = (mode == TCL_MODE_NONBLOCKING) ? 1 : 0;
return 0;
}
/*
*----------------------------------------------------------------------
*
@ -336,17 +414,29 @@ FileCloseProc(instanceData, interp, inFile, outFile)
fd = (int) Tcl_GetFileInfo(inFile, NULL);
Tcl_FreeFile(inFile);
if (close(fd) < 0) {
errorCode = errno;
}
if (tclInInterpreterDeletion) {
if ((fd != 0) && (fd != 1) && (fd != 2)) {
if (close(fd) < 0) {
errorCode = errno;
}
}
} else if (close(fd) < 0) {
errorCode = errno;
}
}
if (outFile != NULL) {
fd = (int) Tcl_GetFileInfo(outFile, NULL);
Tcl_FreeFile(outFile);
if ((close(fd) < 0) && (errorCode == 0)) {
errorCode = errno;
}
if (tclInInterpreterDeletion) {
if ((fd != 0) && (fd != 1) && (fd != 2)) {
if ((close(fd) < 0) && (errorCode == 0)) {
errorCode = errno;
}
}
} else if ((close(fd) < 0) && (errorCode == 0)) {
errorCode = errno;
}
}
return errorCode;
}
@ -484,6 +574,7 @@ PipeCloseProc(instanceData, interp, inFile, outFile)
int fd, errorCode, result;
errorCode = 0;
result = 0;
pipePtr = (PipeState *) instanceData;
if (pipePtr->readFile != NULL) {
fd = (int) Tcl_GetFileInfo(pipePtr->readFile, NULL);
@ -499,20 +590,34 @@ PipeCloseProc(instanceData, interp, inFile, outFile)
errorCode = errno;
}
}
/*
* Wrap the error file into a channel and give it to the cleanup
* routine.
*/
if (pipePtr->errorFile != NULL) {
errChan = Tcl_CreateChannel(&fileChannelType, "pipeError",
pipePtr->errorFile, NULL, NULL);
if (pipePtr->isNonBlocking) {
/*
* If the channel is non-blocking, just detach the children PIDs
* and discard the errorFile.
*/
Tcl_DetachPids(pipePtr->numPids, pipePtr->pidPtr);
if (pipePtr->errorFile != NULL) {
Tcl_FreeFile(pipePtr->errorFile);
}
} else {
errChan = NULL;
/*
* Wrap the error file into a channel and give it to the cleanup
* routine.
*/
if (pipePtr->errorFile != NULL) {
errChan = Tcl_CreateChannel(&fileChannelType, "pipeError",
pipePtr->errorFile, NULL, NULL);
} else {
errChan = NULL;
}
result = TclCleanupChildren(interp, pipePtr->numPids, pipePtr->pidPtr,
errChan);
}
result = TclCleanupChildren(interp, pipePtr->numPids, pipePtr->pidPtr,
errChan);
if (pipePtr->numPids != 0) {
ckfree((char *) pipePtr->pidPtr);
}
@ -664,6 +769,8 @@ Tcl_MakeFileChannel(inFd, outFd, mode)
* TCL_WRITABLE to indicate whether inFile
* and/or outFile are valid. */
{
Tcl_Channel chan;
int fileUsed;
Tcl_File inFile, outFile;
char channelName[20];
@ -684,6 +791,25 @@ Tcl_MakeFileChannel(inFd, outFd, mode)
outFile = Tcl_GetFile(outFd, TCL_UNIX_FD);
}
/*
* Look to see if a channel with those two Tcl_Files already exists.
* If so, return it.
*/
chan = TclFindFileChannel(inFile, outFile, &fileUsed);
if (chan != (Tcl_Channel) NULL) {
return chan;
}
/*
* If one of the Tcl_Files is used in another channel, do not
* create a new channel containing it; this avoids core dumps
* later, when the Tcl_File would be freed twice.
*/
if (fileUsed) {
return (Tcl_Channel) NULL;
}
return Tcl_CreateChannel(&fileChannelType, channelName, inFile, outFile,
(ClientData) NULL);
}
@ -728,6 +854,7 @@ TclCreateCommandChannel(readFile, writeFile, errorFile, numPids, pidPtr)
statePtr->errorFile = errorFile;
statePtr->numPids = numPids;
statePtr->pidPtr = pidPtr;
statePtr->isNonBlocking = 0;
/*
* Use one of the fds associated with the channel as the
@ -857,7 +984,7 @@ TcpBlockModeProc(instanceData, inFile, outFile, mode)
} else {
statePtr->flags |= TCP_ASYNC_SOCKET;
}
return CommonBlockModeProc(instanceData, inFile, outFile, mode);
return FileBlockModeProc(instanceData, inFile, outFile, mode);
}
/*
@ -1271,7 +1398,7 @@ CreateSocket(interp, port, host, server, myaddr, myport, async)
status = bind(sock, (struct sockaddr *) &sockaddr,
sizeof(struct sockaddr));
if (status != -1) {
status = listen(sock, 5);
status = listen(sock, TCL_LISTEN_LIMIT);
}
} else {
if (myaddr != NULL || myport != 0) {
@ -1380,7 +1507,7 @@ CreateSocketAddress(sockaddrPtr, host, port)
addr.s_addr = INADDR_ANY;
} else {
addr.s_addr = inet_addr(host);
if (addr.s_addr == (unsigned long) -1) {
if (addr.s_addr == -1) {
hostent = gethostbyname(host);
if (hostent != NULL) {
memcpy((VOID *) &addr,
@ -1664,27 +1791,34 @@ TclGetDefaultStdChannel(type)
int mode = 0; /* compiler warning (used before set). */
char *bufMode = NULL;
/*
* If the channels were not created yet, create them now and
* store them in the static variables.
*/
switch (type) {
case TCL_STDIN:
case TCL_STDIN:
if ((lseek(0, (off_t) 0, SEEK_CUR) == -1) &&
(errno == EBADF)) {
return (Tcl_Channel) NULL;
}
fd = 0;
mode = TCL_READABLE;
bufMode = "line";
break;
case TCL_STDOUT:
break;
case TCL_STDOUT:
if ((lseek(1, (off_t) 0, SEEK_CUR) == -1) &&
(errno == EBADF)) {
return (Tcl_Channel) NULL;
}
fd = 1;
mode = TCL_WRITABLE;
bufMode = "line";
break;
case TCL_STDERR:
break;
case TCL_STDERR:
if ((lseek(2, (off_t) 0, SEEK_CUR) == -1) &&
(errno == EBADF)) {
return (Tcl_Channel) NULL;
}
fd = 2;
mode = TCL_WRITABLE;
bufMode = "none";
break;
break;
default:
panic("TclGetDefaultStdChannel: Unexpected channel type");
break;

26
contrib/tcl/unix/tclUnixInit.c
View File

@ -8,7 +8,7 @@
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
* SCCS: @(#) tclUnixInit.c 1.10 96/03/12 09:05:59
* SCCS: @(#) tclUnixInit.c 1.14 96/07/10 15:45:24
*/
#include "tclInt.h"
@ -17,7 +17,13 @@
# include <sys/utsname.h>
#endif
#if defined(__FreeBSD__)
#include <floatingpoint.h>
# include <floatingpoint.h>
#endif
#if defined(__bsdi__)
# include <sys/param.h>
# if _BSDI_VERSION > 199501
# include <dlfcn.h>
# endif
#endif
/*
@ -34,7 +40,7 @@ static char defaultLibraryDir[200] = TCL_LIBRARY;
* initialization.
*/
static char *initScript =
static char initScript[] =
"proc init {} {\n\
global tcl_library tcl_version tcl_patchLevel env\n\
rename init {}\n\
@ -43,14 +49,15 @@ static char *initScript =
lappend dirs $env(TCL_LIBRARY)\n\
}\n\
lappend dirs [info library]\n\
lappend dirs [file dirname [file dirname [info nameofexecutable]]]/lib/tcl$tcl_version\n\
set parentDir [file dirname [file dirname [info nameofexecutable]]]\n\
lappend dirs $parentDir/lib/tcl$tcl_version\n\
if [string match {*[ab]*} $tcl_patchLevel] {\n\
set lib tcl$tcl_patchLevel\n\
} else {\n\
set lib tcl$tcl_version\n\
}\n\
lappend dirs [file dirname [file dirname [pwd]]]/$lib/library\n\
lappend dirs [file dirname [pwd]]/library\n\
lappend dirs [file dirname $parentDir]/$lib/library\n\
lappend dirs $parentDir/library\n\
foreach i $dirs {\n\
set tcl_library $i\n\
if ![catch {uplevel #0 source $i/init.tcl}] {\n\
@ -132,6 +139,13 @@ TclPlatformInit(interp)
fpsetround(FP_RN);
fpsetmask(0L);
#endif
#if defined(__bsdi__) && (_BSDI_VERSION > 199501)
/*
* Find local symbols. Don't report an error if we fail.
*/
(void) dlopen (NULL, RTLD_NOW);
#endif
initialized = 1;
}
}

6
contrib/tcl/unix/tclUnixNotfy.c
View File

@ -10,7 +10,7 @@
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
* SCCS: @(#) tclUnixNotfy.c 1.30 96/03/22 12:45:31
* SCCS: @(#) tclUnixNotfy.c 1.31 96/07/23 16:17:29
*/
#include "tclInt.h"
@ -289,7 +289,7 @@ Tcl_Sleep(ms)
* early, go back to sleep again.
*/
TclGetTime(&before);
TclpGetTime(&before);
after = before;
after.sec += ms/1000;
after.usec += (ms%1000)*1000;
@ -316,7 +316,7 @@ Tcl_Sleep(ms)
}
(void) select(0, (SELECT_MASK *) 0, (SELECT_MASK *) 0,
(SELECT_MASK *) 0, &delay);
TclGetTime(&before);
TclpGetTime(&before);
}
}

10
contrib/tcl/unix/tclUnixPort.h
View File

@ -19,7 +19,7 @@
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
* SCCS: @(#) tclUnixPort.h 1.33 96/03/25 17:15:21
* SCCS: @(#) tclUnixPort.h 1.34 96/07/23 16:17:47
*/
#ifndef _TCLUNIXPORT
@ -410,4 +410,12 @@ extern char **environ;
extern double strtod();
/*
* The following macros define time related functions in terms of
* standard Unix routines.
*/
#define TclpGetDate(t,u) ((u) ? gmtime((t)) : localtime((t)))
#define TclStrftime(s,m,f,t) (strftime((s),(m),(f),(t)))
#endif /* _TCLUNIXPORT */

18
contrib/tcl/unix/tclUnixTime.c
View File

@ -9,7 +9,7 @@
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
* SCCS: @(#) tclUnixTime.c 1.10 96/02/15 11:58:41
* SCCS: @(#) tclUnixTime.c 1.11 96/07/23 16:17:21
*/
#include "tclInt.h"
@ -18,7 +18,7 @@
/*
*-----------------------------------------------------------------------------
*
* TclGetSeconds --
* TclpGetSeconds --
*
* This procedure returns the number of seconds from the epoch. On
* most Unix systems the epoch is Midnight Jan 1, 1970 GMT.
@ -33,7 +33,7 @@
*/
unsigned long
TclGetSeconds()
TclpGetSeconds()
{
return time((time_t *) NULL);
}
@ -41,7 +41,7 @@ TclGetSeconds()
/*
*-----------------------------------------------------------------------------
*
* TclGetClicks --
* TclpGetClicks --
*
* This procedure returns a value that represents the highest resolution
* clock available on the system. There are no garantees on what the
@ -58,7 +58,7 @@ TclGetSeconds()
*/
unsigned long
TclGetClicks()
TclpGetClicks()
{
unsigned long now;
#ifdef NO_GETTOD
@ -81,7 +81,7 @@ TclGetClicks()
/*
*----------------------------------------------------------------------
*
* TclGetTimeZone --
* TclpGetTimeZone --
*
* Determines the current timezone. The method varies wildly
* between different platform implementations, so its hidden in
@ -97,7 +97,7 @@ TclGetClicks()
*/
int
TclGetTimeZone (currentTime)
TclpGetTimeZone (currentTime)
unsigned long currentTime;
{
/*
@ -190,7 +190,7 @@ TclGetTimeZone (currentTime)
/*
*----------------------------------------------------------------------
*
* TclGetTime --
* TclpGetTime --
*
* Gets the current system time in seconds and microseconds
* since the beginning of the epoch: 00:00 UCT, January 1, 1970.
@ -205,7 +205,7 @@ TclGetTimeZone (currentTime)
*/
void
TclGetTime(timePtr)
TclpGetTime(timePtr)
Tcl_Time *timePtr; /* Location to store time information. */
{
struct timeval tv;