diff options
author | dgp <dgp@users.sourceforge.net> | 2007-11-16 07:20:49 (GMT) |
---|---|---|
committer | dgp <dgp@users.sourceforge.net> | 2007-11-16 07:20:49 (GMT) |
commit | 98f0d1a3406ed99293cd6bb505ccd29063208ce5 (patch) | |
tree | 91c4790b7f459c9347f152a95205730c4119ff6c | |
parent | 55e6c0333341b101e68407be7eebe42f829c9f33 (diff) | |
download | tcl-98f0d1a3406ed99293cd6bb505ccd29063208ce5.zip tcl-98f0d1a3406ed99293cd6bb505ccd29063208ce5.tar.gz tcl-98f0d1a3406ed99293cd6bb505ccd29063208ce5.tar.bz2 |
merge updates from HEAD
34 files changed, 9787 insertions, 1630 deletions
@@ -1,3 +1,114 @@ +2007-11-15 Don Porter <dgp@users.sourceforge.net> + + * generic/regc_nfa.c: Fixed infinite loop in the regexp compiler. + [Bug 1810038]. + + * generic/regc_nfa.c: Corrected looping logic in fixempties() to + avoid wasting time walking a list of dead states. [Bug 1832612] + +2007-11-15 Donal K. Fellows <donal.k.fellows@man.ac.uk> + + * generic/tclNamesp.c (NamespaceEnsembleCmd): Must pass a non-NULL + interp to Tcl_SetEnsemble* functions. + + * doc/re_syntax.n: Try to make this easier to read. It's still a very + difficult manual page! + + * unix/tcl.m4 (SC_CONFIG_CFLAGS): Allow people to turn off the -rpath + option to their linker if they so desire. This is a configuration only + recommended for (some) vendors. Relates to [Patch 1231022]. + +2007-11-15 Pat Thoyts <patthoyts@users.sourceforge.net> + + * win/tclWin32Dll.c: Prefer UINT_PTR to DWORD_PTR when casting + pointers to integer types for greater portability. [Bug 1831253] + +2007-11-15 Daniel Steffen <das@users.sourceforge.net> + + * macosx/Tcl.xcodeproj/project.pbxproj: add new chanio.test. + * macosx/Tcl.xcode/project.pbxproj: + +2007-11-14 Donal K. Fellows <donal.k.fellows@man.ac.uk> + + * generic/tclCompile.c (TclCompileScript): Ensure that we get our + count in our INST_START_CMD calls right, even when there's a failure + to compile a command directly. + + * generic/tclNamesp.c (Tcl_SetEnsembleSubcommandList) + (Tcl_SetEnsembleMappingDict): Special code to make sure that + * generic/tclCmdIL.c (TclInitInfoCmd): [info exists] is compiled right + while not allowing changes to the ensemble to cause havok. + + * generic/tclCompCmds.c (TclCompileInfoCmd): Simple compiler for the + [info] command that only handles [info exists]. + * generic/tclExecute.c (TclExecuteByteCode:INST_EXIST_*): New + instructions to allow the testing of whether a variable exists. + +2007-11-14 Andreas Kupries <andreask@activestate.com> + + * tests/chanio.test: New file. This is essentially a duplicate of + 'io.test', with all channel commands converted to their 'chan xxx' + notation. + * tests/io.test: Fixed typo in test description. + +2007-11-14 Donal K. Fellows <donal.k.fellows@man.ac.uk> + + * generic/regc*.c: Eliminate multi-char collating element code + completely. Simplifies the code quite a bit. If people still want the + full code, it will remain on the 8.4 branch. [Bug 1831425] + +2007-11-13 Jeff Hobbs <jeffh@ActiveState.com> + + * generic/tclCompCmds.c (TclCompileRegexpCmd): clean up comments, + only free dstring on OK from TclReToGlob. + (TclCompileSwitchCmd): simplify TclReToGlob usage. + +2007-11-14 Donal K. Fellows <dkf@users.sf.net> + + * generic/regc*.c: #ifdef/comment out the code that deals with + multi-character collating elements, which have never been supported. + Cuts the memory consumption of the RE compiler. [Bug 1831425] + +2007-11-13 Donal K. Fellows <dkf@users.sf.net> + + * generic/tclCompCmds.c (TclCompileSwitchCmd, TclCompileRegexpCmd): + Extend [switch] compiler to handle regular expressions as long as + things are not too complex. Fix [regexp] compiler so that non-trivial + literal regexps get fed to INST_REGEXP. + + * doc/mathop.n: Clarify definitions of some operations. + +2007-11-13 Miguel Sofer <msofer@users.sf.net> + + * unix/tclUnixInit.c: the TCL_NO_STACK_CHECK was being incorrectly + undefined here; this should be set (or not) in the compile options, it + is used elsewhere and needs to be consistent. + +2007-11-13 Pat Thoyts <patthoyts@users.sourceforge.net> + + * unix/tcl.m4: Added autoconf goo to detect and make use of + * unix/configure.in: getaddrinfo and friends. + * unix/configure: (regenerated) + +2007-11-13 Donal K. Fellows <donal.k.fellows@man.ac.uk> + + * unix/tclUnixCompat.c (TclpGetHostByName): The six-argument form of + getaddressbyname_r() uses the fifth argument to indicate whether the + lookup succeeded or not on at least one platform. [Bug 1618235] + +2007-11-13 Don Porter <dgp@users.sourceforge.net> + + * generic/regcomp.c: Convert optst() from expensive no-op to a + cheap no-op. + +2007-11-13 Donal K. Fellows <donal.k.fellows@man.ac.uk> + + * unix/tclUnixChan.c (CreateSocketAddress): Rewrote to use the + thread-safe version of gethostbyname() by forward-porting the code + used in 8.4, and added rudimentary support for getaddrinfo() (not + enabled by default, as no autoconf-ery written). Part of fix for [Bug + 1618235] + 2007-11-12 Jeff Hobbs <jeffh@ActiveState.com> * generic/tclGet.c (Tcl_Get, Tcl_GetInt): revert use of TclGet* @@ -8,7 +119,7 @@ 2007-11-12 Miguel Sofer <msofer@users.sf.net> - * generic/tclBasic.c: New macro TclResetResult, new iPtr flag + * generic/tclBasic.c: New macro TclResetResult, new iPtr flag * generic/tclExecute.c: bit INTERP_RESULT_UNCLEAN: shortcut for * generic/tclInt.h: Tcl_ResetResult for the "normal" case: * generic/tclProc.c: TCL_OK, no return options, no errorCode @@ -18,8 +129,8 @@ THIS PATCH WAS REVERTED: initial (mis)measurements overstated the perfomance wins, which turn out to be tiny. Not worth the - complication. - + complication. + 2007-11-11 Jeff Hobbs <jeffh@ActiveState.com> * generic/tclCompCmds.c, generic/tclCompile.c, generic/tclCompile.h: @@ -33,11 +144,11 @@ 2007-11-11 Miguel Sofer <msofer@users.sf.net> * generic/tclResult.c (ResetObjResult): clarify the logic. - + * generic/tclBasic.c: Increased usage of macros to detect - * generic/tclBinary.c: and take advantage of objTypes. Added + * generic/tclBinary.c: and take advantage of objTypes. Added * generic/tclClock.c: macros TclGet(Int|Long)FromObj, - * generic/tclCmdAH.c: TclGetIntForIndexM and TclListObjLength, + * generic/tclCmdAH.c: TclGetIntForIndexM and TclListObjLength, * generic/tclCmdIL.c: modified TclListObjGetElements. * generic/tclCmdMZ.c: * generic/tclCompCmds.c: The TclGetInt* macros are only a shortcut @@ -46,8 +157,8 @@ * generic/tclDictObj.c: also to other cases. * generic/tclExecute.c: * generic/tclGet.c: As this patch touches many files it has - * generic/tclIO.c: been recorded as [Patch 1830038] in order to - * generic/tclIOCmd.c: facilitate reviewing. + * generic/tclIO.c: been recorded as [Patch 1830038] in order + * generic/tclIOCmd.c: to facilitate reviewing. * generic/tclIOGT.c: * generic/tclIndexObj.c: * generic/tclInt.h: diff --git a/doc/Ensemble.3 b/doc/Ensemble.3 index 5525226..fcfe282 100644 --- a/doc/Ensemble.3 +++ b/doc/Ensemble.3 @@ -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. '\" -'\" RCS: @(#) $Id: Ensemble.3,v 1.3 2006/10/18 18:46:59 dgp Exp $ +'\" RCS: @(#) $Id: Ensemble.3,v 1.3.4.1 2007/11/16 07:20:51 dgp Exp $ '\" '\" This documents the C API introduced in TIP#235 '\" @@ -56,7 +56,9 @@ int .AS Tcl_Namespace **namespacePtrPtr in/out .AP Tcl_Interp *interp in/out The interpreter in which the ensemble is to be created or found. Also -where error result messages are written. +where error result messages are written. The functions whose names +start with \fBTcl_GetEnsemble\fR may have a NULL for the \fIinterp\fR, +but all other functions must not. .AP "const char" *name in The name of the ensemble command to be created. .AP Tcl_Namespace *namespacePtr in diff --git a/doc/mathop.n b/doc/mathop.n index d1fd7df..169fcf5 100644 --- a/doc/mathop.n +++ b/doc/mathop.n @@ -1,10 +1,10 @@ .\" -*- nroff -*- -.\" Copyright (c) 2006 Donal K. Fellows. +.\" Copyright (c) 2006-2007 Donal K. Fellows. .\" .\" See the file "license.terms" for information on usage and redistribution .\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. .\" -.\" RCS: @(#) $Id: mathop.n,v 1.4.4.1 2007/11/02 14:49:14 dgp Exp $ +.\" RCS: @(#) $Id: mathop.n,v 1.4.4.2 2007/11/16 07:20:52 dgp Exp $ .\" .so man.macros .TH mathop n 8.5 Tcl "Tcl Mathematical Operator Commands" @@ -119,16 +119,28 @@ argument must be given. \fB%\fR \fInumber number\fR . Returns the integral modulus of the first argument with respect to the second. -Each \fInumber\fR must have an integral value. +Each \fInumber\fR must have an integral value. Note that Tcl defines this +operation exactly even for negative numbers, so that the following equality +holds true: +.RS +.CS +(\fIx \fB/ \fIy\fR) \fB* \fIy \fB== \fIx \fB-\fR (\fIx \fB% \fIy\fR) +.CE +.RE .TP \fB**\fR ?\fInumber\fR ...? . Returns the result of raising each value to the power of the result of recursively operating on the result of processing the following arguments, so -\fB** 2 3 4\fR is the same as \fB** 2 [** 3 4]\fR. Each \fInumber\fR may be +.QW "\fB** 2 3 4\fR" +is the same as +.QW "\fB** 2 [** 3 4]\fR" . +Each \fInumber\fR may be any numeric value, though the second number must not be fractional if the first is negative. If no arguments are given, the result will be one, and if -only one argument is given, the result will be that argument. +only one argument is given, the result will be that argument. The +result will have an integral value only when all arguments are +integral values. .TP \fB&\fR ?\fInumber\fR ...? . @@ -140,8 +152,7 @@ result will be minus one. . Returns the bit-wise OR of each of the arbitrarily many arguments. Each \fInumber\fR must have an integral value. If no arguments are given, the -result will be zero. -.TP +result will be zero..TP \fB^\fR ?\fInumber\fR ...? . Returns the bit-wise XOR of each of the arbitrarily many arguments. Each @@ -150,22 +161,22 @@ result will be zero. .TP \fB<<\fR \fInumber number\fR . -Returns the result of shifting the first argument left by the number of bits -specified in the second argument. Each \fInumber\fR must have an integral -value. +Returns the result of bit-wise shifting the first argument left by the +number of bits specified in the second argument. Each \fInumber\fR +must have an integral value. .TP \fB>>\fR \fInumber number\fR . -Returns the result of shifting the first argument right by the number of bits -specified in the second argument. Each \fInumber\fR must have an integral -value. +Returns the result of bit-wise shifting the first argument right by +the number of bits specified in the second argument. Each \fInumber\fR +must have an integral value. .TP \fB==\fR ?\fIarg\fR ...? . Returns whether each argument is equal to the arguments on each side of it in the sense of the \fBexpr\fR == operator (\fIi.e.\fR, numeric comparison if -possible). If fewer than two arguments are given, this operation always -returns a true value. +possible, exact string comparison otherwise). If fewer than two arguments +are given, this operation always returns a true value. .TP \fBeq\fR ?\fIarg\fR ...? . @@ -223,20 +234,23 @@ The simplest way to use the operators is often by using \fBnamespace path\fR to make the commands available. This has the advantage of not affecting the set of commands defined by the current namespace. .CS -namespace path {::tcl::mathop ::tcl::mathfunc} +namespace path {\fB::tcl::mathop\fR ::tcl::mathfunc} \fI# Compute the sum of some numbers\fR set sum [\fB+\fR 1 2 3] \fI# Compute the average of a list\fR set list {1 2 3 4 5 6} -set mean [\fB/\fR [\fB+\fR {expand}$list] [double [llength $list]]] +set mean [\fB/\fR [\fB+\fR {*}$list] [double [llength $list]]] \fI# Test for list membership\fR set gotIt [\fBin\fR 3 $list] \fI# Test to see if a value is within some defined range\fR set inRange [\fB<=\fR 1 $x 5] + +\fI# Test to see if a list is sorted\fR +set sorted [\fB<=\fR {*}$list] .CE .SH "SEE ALSO" expr(n), mathfunc(n), namespace(n) diff --git a/doc/re_syntax.n b/doc/re_syntax.n index 397c93e..32f4d81 100644 --- a/doc/re_syntax.n +++ b/doc/re_syntax.n @@ -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. '\" -'\" RCS: @(#) $Id: re_syntax.n,v 1.10.2.1 2007/11/01 16:25:54 dgp Exp $ +'\" RCS: @(#) $Id: re_syntax.n,v 1.10.2.2 2007/11/16 07:20:52 dgp Exp $ '\" .so man.macros .TH re_syntax n "8.1" Tcl "Tcl Built-In Commands" @@ -25,20 +25,20 @@ as defined by POSIX, come in two flavors: \fIextended\fR REs and \fIbasic\fR REs .PQ BRE s . EREs are roughly those of the traditional \fIegrep\fR, while BREs are -roughly those of the traditional \fIed\fR. This implementation adds +roughly those of the traditional \fIed\fR. This implementation adds a third flavor, \fIadvanced\fR REs .PQ ARE s , basically EREs with some significant extensions. .PP -This manual page primarily describes AREs. BREs mostly exist for +This manual page primarily describes AREs. BREs mostly exist for backward compatibility in some old programs; they will be discussed at -the end. POSIX EREs are almost an exact subset of AREs. Features of +the end. POSIX EREs are almost an exact subset of AREs. Features of AREs that are not present in EREs will be indicated. .SH "REGULAR EXPRESSION SYNTAX" .PP Tcl regular expressions are implemented using the package written by Henry Spencer, based on the 1003.2 spec and some (not quite all) of -the Perl5 extensions (thanks, Henry!). Much of the description of +the Perl5 extensions (thanks, Henry!). Much of the description of regular expressions below is copied verbatim from his manual entry. .PP An ARE is one or more \fIbranches\fR, @@ -50,7 +50,7 @@ A branch is zero or more \fIconstraints\fR or \fIquantified atoms\fR, concatenated. It matches a match for the first, followed by a match for the second, etc; an empty branch matches the empty string. -.PP +.SS QUANTIFIERS A quantified atom is an \fIatom\fR possibly followed by a single \fIquantifier\fR. Without a quantifier, it matches a single match for the atom. @@ -90,10 +90,10 @@ but prefer the smallest number rather than the largest number of matches (see \fBMATCHING\fR) .RE .PP -The forms using \fB{\fR and \fB}\fR are known as \fIbound\fRs. The +The forms using \fB{\fR and \fB}\fR are known as \fIbound\fRs. The numbers \fIm\fR and \fIn\fR are unsigned decimal integers with permissible values from 0 to 255 inclusive. -.PP +.SS ATOMS An atom is one of: .RS 2 .IP \fB(\fIre\fB)\fR 6 @@ -128,9 +128,9 @@ when followed by a digit, it is the beginning of a \fIbound\fR (see above) where \fIx\fR is a single character with no other significance, matches that character. .RE -.PP +.SS CONSTRAINTS A \fIconstraint\fR matches an empty string when specific conditions -are met. A constraint may not be followed by a quantifier. The +are met. A constraint may not be followed by a quantifier. The simple constraints are as follows; some more constraints are described later, under \fBESCAPES\fR. .RS 2 @@ -163,7 +163,7 @@ An RE may not end with A \fIbracket expression\fR is a list of characters enclosed in .QW \fB[\|]\fR . It normally matches any single character from the list -(but see below). If the list begins with +(but see below). If the list begins with .QW \fB^\fR , it matches any single character (but see below) \fInot\fR from the rest of the list. @@ -171,22 +171,25 @@ rest of the list. If two characters in the list are separated by .QW \fB\-\fR , this is shorthand for the full \fIrange\fR of characters between those two -(inclusive) in the collating sequence, e.g. \fB[0\-9]\fR in Unicode -matches any conventional decimal digit. Two ranges may not share an -endpoint, so e.g. \fBa\-c\-e\fR is illegal. Ranges are very -collating-sequence-dependent, and portable programs should avoid -relying on them. +(inclusive) in the collating sequence, e.g. +.QW \fB[0\-9]\fR +in Unicode matches any conventional decimal digit. Two ranges may not share an +endpoint, so e.g. +.QW \fBa\-c\-e\fR +is illegal. Ranges in Tcl always use the +Unicode collating sequence, but other programs may use other collating +sequences and this can be a source of incompatability between programs. .PP To include a literal \fB]\fR or \fB\-\fR in the list, the simplest method is to enclose it in \fB[.\fR and \fB.]\fR to make it a -collating element (see below). Alternatively, make it the first +collating element (see below). Alternatively, make it the first character (following a possible .QW \fB^\fR ), or (AREs only) precede it with .QW \fB\e\fR . Alternatively, for .QW \fB\-\fR , -make it the last character, or the second endpoint of a range. To use +make it the last character, or the second endpoint of a range. To use a literal \fB\-\fR as the first endpoint of a range, make it a collating element or (AREs only) precede it with .QW \fB\e\fR . @@ -194,51 +197,10 @@ With the exception of these, some combinations using \fB[\fR (see next paragraphs), and escapes, all other special characters lose their special significance within a bracket expression. -.PP -Within a bracket expression, a collating element (a character, a -multi-character sequence that collates as if it were a single -character, or a collating-sequence name for either) enclosed in -\fB[.\fR and \fB.]\fR stands for the sequence of characters of that -collating element. The sequence is a single element of the bracket -expression's list. A bracket expression in a locale that has -multi-character collating elements can thus match more than one -character. So (insidiously), a bracket expression that starts with -\fB^\fR can match multi-character collating elements even if none of -them appear in the bracket expression! (\fINote:\fR Tcl currently has -no multi-character collating elements. This information is only for -illustration.) -.PP -For example, assume the collating sequence includes a \fBch\fR -multi-character collating element. Then the RE \fB[[.ch.]]*c\fR (zero -or more \fBch\fRs followed by \fBc\fR) matches the first five -characters of -.QW \fBchchcc\fR . -Also, the RE \fB[^c]b\fR matches all of -.QW \fBchb\fR -(because \fB[^c]\fR matches the multi-character \fBch\fR). -.PP -Within a bracket expression, a collating element enclosed in \fB[=\fR -and \fB=]\fR is an equivalence class, standing for the sequences of -characters of all collating elements equivalent to that one, including -itself. (If there are no other equivalent collating elements, the -treatment is as if the enclosing delimiters were -.QW \fB[.\fR \& -and -.QW \fB.]\fR .) -For example, if \fBo\fR and \fB\N'244'\fR are the members of an -equivalence class, then -.QW \fB[[=o=]]\fR , -.QW \fB[[=\N'244'=]]\fR , -and -.QW \fB[o\N'244']\fR \& -are all synonymous. An equivalence class may -not be an endpoint of a range. (\fINote:\fR Tcl currently implements -only the Unicode locale. It does not define any equivalence classes. -The examples above are just illustrations.) -.PP +.SS "CHARACTER CLASSES" Within a bracket expression, the name of a \fIcharacter class\fR enclosed in \fB[:\fR and \fB:]\fR stands for the list of all -characters (not all collating elements!) belonging to that class. +characters (not all collating elements!) belonging to that class. Standard character classes are: .IP \fBalpha\fR 8 A letter. @@ -265,30 +227,94 @@ A character with a visible representation (includes both alnum and punct). .IP \fBcntrl\fR 8 A control character. .PP -A locale may provide others. (Note that the current Tcl -implementation has only one locale: the Unicode locale.) A character -class may not be used as an endpoint of a range. +A locale may provide others. A character class may not be used as an endpoint +of a range. +.RS .PP +(\fINote:\fR the current Tcl implementation has only one locale, the Unicode +locale, which supports exactly the above classes.) +.RE +.SS "BRACKETED CONSTRAINTS" There are two special cases of bracket expressions: the bracket -expressions \fB[[:<:]]\fR and \fB[[:>:]]\fR are constraints, matching -empty strings at the beginning and end of a word respectively. -'\" note, discussion of escapes below references this definition of word -A word is defined as a sequence of word characters that is neither -preceded nor followed by word characters. A word character is an -\fIalnum\fR character or an underscore (\fB_\fR). These special -bracket expressions are deprecated; users of AREs should use +expressions +.QW \fB[[:<:]]\fR +and +.QW \fB[[:>:]]\fR +are constraints, matching empty strings at the beginning and end of a word +respectively. +.\" note, discussion of escapes below references this definition of word +A word is defined as a sequence of word characters that is neither preceded +nor followed by word characters. A word character is an \fIalnum\fR character +or an underscore +.PQ \fB_\fR "" . +These special bracket expressions are deprecated; users of AREs should use constraint escapes instead (see below). +.SS "COLLATING ELEMENTS" +Within a bracket expression, a collating element (a character, a +multi-character sequence that collates as if it were a single +character, or a collating-sequence name for either) enclosed in +\fB[.\fR and \fB.]\fR stands for the sequence of characters of that +collating element. The sequence is a single element of the bracket +expression's list. A bracket expression in a locale that has +multi-character collating elements can thus match more than one +character. So (insidiously), a bracket expression that starts with +\fB^\fR can match multi-character collating elements even if none of +them appear in the bracket expression! +.RS +.PP +(\fINote:\fR Tcl has no multi-character collating elements. This information +is only for illustration.) +.RE +.PP +For example, assume the collating sequence includes a \fBch\fR multi-character +collating element. Then the RE +.QW \fB[[.ch.]]*c\fR +(zero or more +.QW \fBch\fRs +followed by +.QW \fBc\fR ) +matches the first five characters of +.QW \fBchchcc\fR . +Also, the RE +.QW \fB[^c]b\fR +matches all of +.QW \fBchb\fR +(because +.QW \fB[^c]\fR +matches the multi-character +.QW \fBch\fR ). +.SS "EQUIVALENCE CLASSES" +Within a bracket expression, a collating element enclosed in \fB[=\fR +and \fB=]\fR is an equivalence class, standing for the sequences of +characters of all collating elements equivalent to that one, including +itself. (If there are no other equivalent collating elements, the +treatment is as if the enclosing delimiters were +.QW \fB[.\fR \& +and +.QW \fB.]\fR .) +For example, if \fBo\fR and \fB\N'244'\fR are the members of an +equivalence class, then +.QW \fB[[=o=]]\fR , +.QW \fB[[=\N'244'=]]\fR , +and +.QW \fB[o\N'244']\fR \& +are all synonymous. An equivalence class may not be an endpoint of a range. +.RS +.PP +(\fINote:\fR Tcl implements only the Unicode locale. It does not define any +equivalence classes. The examples above are just illustrations.) +.RE .SH ESCAPES Escapes (AREs only), which begin with a \fB\e\fR followed by an alphanumeric character, come in several varieties: character entry, -class shorthands, constraint escapes, and back references. A \fB\e\fR +class shorthands, constraint escapes, and back references. A \fB\e\fR followed by an alphanumeric character but not constituting a valid -escape is illegal in AREs. In EREs, there are no escapes: outside a +escape is illegal in AREs. In EREs, there are no escapes: outside a bracket expression, a \fB\e\fR followed by an alphanumeric character merely stands for that character as an ordinary character, and inside -a bracket expression, \fB\e\fR is an ordinary character. (The latter +a bracket expression, \fB\e\fR is an ordinary character. (The latter is the one actual incompatibility between EREs and AREs.) -.PP +.SS "CHARACTER-ENTRY ESCAPES" Character-entry escapes (AREs only) exist to make it easier to specify non-printing and otherwise inconvenient characters in REs: .RS 2 @@ -380,13 +406,13 @@ Octal digits are .PP The character-entry escapes are always taken as ordinary characters. For example, \fB\e135\fR is \fB]\fR in Unicode, but \fB\e135\fR does -not terminate a bracket expression. Beware, however, that some +not terminate a bracket expression. Beware, however, that some applications (e.g., C compilers and the Tcl interpreter if the regular expression is not quoted with braces) interpret such sequences themselves before the regular-expression package gets to see them, which may require doubling (quadrupling, etc.) the .QW \fB\e\fR . -.PP +.SS "CLASS-SHORTHAND ESCAPES" Class-shorthand escapes (AREs only) provide shorthands for certain commonly-used character classes: .RS 2 @@ -426,10 +452,16 @@ lose their outer brackets, and .QW \fB\eS\fR , and .QW \fB\eW\fR \& -are illegal. (So, for example, \fB[a-c\ed]\fR is -equivalent to \fB[a-c[:digit:]]\fR. Also, \fB[a-c\eD]\fR, which is -equivalent to \fB[a-c^[:digit:]]\fR, is illegal.) -.PP +are illegal. (So, for example, +.QW \fB[a-c\ed]\fR +is equivalent to +.QW \fB[a-c[:digit:]]\fR . +Also, +.QW \fB[a-c\eD]\fR , +which is equivalent to +.QW \fB[a-c^[:digit:]]\fR , +is illegal.) +.SS "CONSTRAINT ESCAPES" A constraint escape (AREs only) is a constraint, matching the empty string if specific conditions are met, written as an escape: .RS 2 @@ -474,13 +506,20 @@ closing capturing parentheses seen so far) a \fIback reference\fR, see below .RE .PP -A word is defined as in the specification of \fB[[:<:]]\fR and -\fB[[:>:]]\fR above. Constraint escapes are illegal within bracket -expressions. -.PP +A word is defined as in the specification of +.QW \fB[[:<:]]\fR +and +.QW \fB[[:>:]]\fR +above. Constraint escapes are illegal within bracket expressions. +.SS "BACK REFERENCES" A back reference (AREs only) matches the same string matched by the parenthesized subexpression specified by the number, so that (e.g.) -\fB([bc])\e1\fR matches \fBbb\fR or \fBcc\fR but not +.QW \fB([bc])\e1\fR +matches +.QW \fBbb\fR +or +.QW \fBcc\fR +but not .QW \fBbc\fR . The subexpression must entirely precede the back reference in the RE. Subexpressions are numbered in the order of their leading parentheses. @@ -488,9 +527,9 @@ Non-capturing parentheses do not define subexpressions. .PP There is an inherent historical ambiguity between octal character-entry escapes and back references, which is resolved by -heuristics, as hinted at above. A leading zero always indicates an -octal escape. A single non-zero digit, not followed by another digit, -is always taken as a back reference. A multi-digit sequence not +heuristics, as hinted at above. A leading zero always indicates an +octal escape. A single non-zero digit, not followed by another digit, +is always taken as a back reference. A multi-digit sequence not starting with a zero is taken as a back reference if it comes after a suitable subexpression (i.e. the number is in the legal range for a back reference), and otherwise is taken as octal. @@ -499,19 +538,19 @@ In addition to the main syntax described above, there are some special forms and miscellaneous syntactic facilities available. .PP Normally the flavor of RE being used is specified by -application-dependent means. However, this can be overridden by a -\fIdirector\fR. If an RE of any flavor begins with +application-dependent means. However, this can be overridden by a +\fIdirector\fR. If an RE of any flavor begins with .QW \fB***:\fR , -the rest of the RE is an ARE. If an RE of any flavor begins with +the rest of the RE is an ARE. If an RE of any flavor begins with .QW \fB***=\fR , the rest of the RE is taken to be a literal string, with all characters considered ordinary characters. .PP An ARE may begin with \fIembedded options\fR: a sequence \fB(?\fIxyz\fB)\fR (where \fIxyz\fR is one or more alphabetic -characters) specifies options affecting the rest of the RE. These +characters) specifies options affecting the rest of the RE. These supplement, and can override, any options specified by the -application. The available option letters are: +application. The available option letters are: .RS 2 .TP 3 \fBb\fR @@ -574,10 +613,10 @@ later within it. In addition to the usual (\fItight\fR) RE syntax, in which all characters are significant, there is an \fIexpanded\fR syntax, available in all flavors of RE with the \fB\-expanded\fR switch, or in -AREs with the embedded x option. In the expanded syntax, white-space +AREs with the embedded x option. In the expanded syntax, white-space characters are ignored and all characters between a \fB#\fR and the following newline (or the end of the RE) are ignored, permitting -paragraphing and commenting a complex RE. There are three exceptions +paragraphing and commenting a complex RE. There are three exceptions to that basic rule: .IP \(bu 3 a white-space character or @@ -603,38 +642,40 @@ Finally, in an ARE, outside bracket expressions, the sequence .QW \fB(?#\fIttt\fB)\fR (where \fIttt\fR is any text not containing a .QW \fB)\fR ) -is a comment, completely ignored. Again, this is not +is a comment, completely ignored. Again, this is not allowed between the characters of multi-character symbols like .QW \fB(?:\fR . Such comments are more a historical artifact than a useful facility, and their use is deprecated; use the expanded syntax instead. .PP \fINone\fR of these metasyntax extensions is available if the -application (or an initial \fB***=\fR director) has specified that the +application (or an initial +.QW \fB***=\fR +director) has specified that the user's input be treated as a literal string rather than as an RE. .SH MATCHING In the event that an RE could match more than one substring of a given -string, the RE matches the one starting earliest in the string. If +string, the RE matches the one starting earliest in the string. If the RE could match more than one substring starting at that point, its choice is determined by its \fIpreference\fR: either the longest substring, or the shortest. .PP -Most atoms, and all constraints, have no preference. A parenthesized -RE has the same preference (possibly none) as the RE. A quantified +Most atoms, and all constraints, have no preference. A parenthesized +RE has the same preference (possibly none) as the RE. A quantified atom with quantifier \fB{\fIm\fB}\fR or \fB{\fIm\fB}?\fR has the same -preference (possibly none) as the atom itself. A quantified atom with +preference (possibly none) as the atom itself. A quantified atom with other normal quantifiers (including \fB{\fIm\fB,\fIn\fB}\fR with -\fIm\fR equal to \fIn\fR) prefers longest match. A quantified atom +\fIm\fR equal to \fIn\fR) prefers longest match. A quantified atom with other non-greedy quantifiers (including \fB{\fIm\fB,\fIn\fB}?\fR -with \fIm\fR equal to \fIn\fR) prefers shortest match. A branch has +with \fIm\fR equal to \fIn\fR) prefers shortest match. A branch has the same preference as the first quantified atom in it which has a -preference. An RE consisting of two or more branches connected by the +preference. An RE consisting of two or more branches connected by the \fB|\fR operator prefers longest match. .PP Subject to the constraints imposed by the rules for matching the whole RE, subexpressions also match the longest or shortest possible substrings, based on their preferences, with subexpressions starting -earlier in the RE taking priority over ones starting later. Note that +earlier in the RE taking priority over ones starting later. Note that outer subexpressions thus take priority over their component subexpressions. .PP @@ -642,19 +683,26 @@ Note that the quantifiers \fB{1,1}\fR and \fB{1,1}?\fR can be used to force longest and shortest preference, respectively, on a subexpression or a whole RE. .PP -Match lengths are measured in characters, not collating elements. An -empty string is considered longer than no match at all. For example, -\fBbb*\fR matches the three middle characters of +Match lengths are measured in characters, not collating elements. An +empty string is considered longer than no match at all. For example, +.QW \fBbb*\fR +matches the three middle characters of .QW \fBabbbc\fR , -\fB(week|wee)(night|knights)\fR matches all ten characters of +.QW \fB(week|wee)(night|knights)\fR +matches all ten characters of .QW \fBweeknights\fR , -when \fB(.*).*\fR is matched against \fBabc\fR the -parenthesized subexpression matches all three characters, and when -\fB(a*)*\fR is matched against \fBbc\fR both the whole RE and the -parenthesized subexpression match an empty string. +when +.QW \fB(.*).*\fR +is matched against +.QW \fBabc\fR +the parenthesized subexpression matches all three characters, and when +.QW \fB(a*)*\fR +is matched against +.QW \fBbc\fR +both the whole RE and the parenthesized subexpression match an empty string. .PP If case-independent matching is specified, the effect is much as if -all case distinctions had vanished from the alphabet. When an +all case distinctions had vanished from the alphabet. When an alphabetic that exists in multiple cases appears as an ordinary character outside a bracket expression, it is effectively transformed into a bracket expression containing both cases, so that \fBx\fR @@ -662,7 +710,13 @@ becomes .QW \fB[xX]\fR . When it appears inside a bracket expression, all case counterparts of it are added to the bracket expression, so -that \fB[x]\fR becomes \fB[xX]\fR and \fB[^x]\fR becomes +that +.QW \fB[x]\fR +becomes +.QW \fB[xX]\fR +and +.QW \fB[^x]\fR +becomes .QW \fB[^xX]\fR . .PP If newline-sensitive matching is specified, \fB.\fR and bracket @@ -670,7 +724,7 @@ expressions using \fB^\fR will never match the newline character (so that matches will never cross newlines unless the RE explicitly arranges it) and \fB^\fR and \fB$\fR will match the empty string after and before a newline respectively, in addition to matching at -beginning and end of string respectively. ARE \fB\eA\fR and \fB\eZ\fR +beginning and end of string respectively. ARE \fB\eA\fR and \fB\eZ\fR continue to match beginning or end of string \fIonly\fR. .PP If partial newline-sensitive matching is specified, this affects @@ -679,17 +733,17 @@ but not \fB^\fR and \fB$\fR. .PP If inverse partial newline-sensitive matching is specified, this affects \fB^\fR and \fB$\fR as with newline-sensitive matching, but -not \fB.\fR and bracket expressions. This is not very useful but is +not \fB.\fR and bracket expressions. This is not very useful but is provided for symmetry. .SH "LIMITS AND COMPATIBILITY" -No particular limit is imposed on the length of REs. Programs +No particular limit is imposed on the length of REs. Programs intended to be highly portable should not employ REs longer than 256 bytes, as a POSIX-compliant implementation can refuse to accept such REs. .PP The only feature of AREs that is actually incompatible with POSIX EREs is that \fB\e\fR does not lose its special significance inside bracket -expressions. All other ARE features use syntax which is illegal or +expressions. All other ARE features use syntax which is illegal or has undefined or unspecified effects in POSIX EREs; the \fB***\fR syntax of directors likewise is outside the POSIX syntax for both BREs and EREs. @@ -707,23 +761,23 @@ references in lookahead constraints, and the longest/shortest-match .PP The matching rules for REs containing both normal and non-greedy quantifiers have changed since early beta-test versions of this -package. (The new rules are much simpler and cleaner, but do not work +package. (The new rules are much simpler and cleaner, but do not work as hard at guessing the user's real intentions.) .PP Henry Spencer's original 1986 \fIregexp\fR package, still in widespread use (e.g., in pre-8.1 releases of Tcl), implemented an -early version of today's EREs. There are four incompatibilities +early version of today's EREs. There are four incompatibilities between \fIregexp\fR's near-EREs .PQ RREs " for short" -and AREs. In roughly increasing order of significance: +and AREs. In roughly increasing order of significance: .IP \(bu 3 In AREs, \fB\e\fR followed by an alphanumeric character is either an escape or an error, while in RREs, it was just another way of writing -the alphanumeric. This should not be a problem because there was no +the alphanumeric. This should not be a problem because there was no reason to write such a sequence in RREs. .IP \(bu 3 \fB{\fR followed by a digit in an ARE is the beginning of a bound, -while in RREs, \fB{\fR was always an ordinary character. Such +while in RREs, \fB{\fR was always an ordinary character. Such sequences should be rare, and will often result in an error because following characters will not look like a valid bound. .IP \(bu 3 @@ -735,9 +789,9 @@ so a literal \fB\e\fR within \fB[\|]\fR must be written but only truly paranoid programmers routinely doubled the backslash. .IP \(bu 3 AREs report the longest/shortest match for the RE, rather than the -first found in a specified search order. This may affect some RREs +first found in a specified search order. This may affect some RREs which were written in the expectation that the first match would be -reported. (The careful crafting of RREs to optimize the search order +reported. (The careful crafting of RREs to optimize the search order for fast matching is obsolete (AREs examine all possible matches in parallel, and their performance is largely insensitive to their complexity) but cases where the search order was exploited to @@ -748,13 +802,13 @@ BREs differ from EREs in several respects. .QW \fB|\fR , .QW \fB+\fR , and \fB?\fR are ordinary characters and there is no equivalent for their -functionality. The delimiters for bounds are \fB\e{\fR and +functionality. The delimiters for bounds are \fB\e{\fR and .QW \fB\e}\fR , -with \fB{\fR and \fB}\fR by themselves ordinary characters. The +with \fB{\fR and \fB}\fR by themselves ordinary characters. The parentheses for nested subexpressions are \fB\e(\fR and .QW \fB\e)\fR , with \fB(\fR and \fB)\fR by themselves ordinary -characters. \fB^\fR is an ordinary character except at the beginning +characters. \fB^\fR is an ordinary character except at the beginning of the RE or the beginning of a parenthesized subexpression, \fB$\fR is an ordinary character except at the end of the RE or the end of a parenthesized subexpression, and \fB*\fR is an ordinary character if @@ -762,7 +816,10 @@ it appears at the beginning of the RE or the beginning of a parenthesized subexpression (after a possible leading .QW \fB^\fR ). Finally, single-digit back references are available, and \fB\e<\fR and -\fB\e>\fR are synonyms for \fB[[:<:]]\fR and \fB[[:>:]]\fR +\fB\e>\fR are synonyms for +.QW \fB[[:<:]]\fR +and +.QW \fB[[:>:]]\fR respectively; no other escapes are available. .SH "SEE ALSO" RegExp(3), regexp(n), regsub(n), lsearch(n), switch(n), text(n) diff --git a/generic/regc_color.c b/generic/regc_color.c index 02634d9..003f5fc 100644 --- a/generic/regc_color.c +++ b/generic/regc_color.c @@ -678,22 +678,6 @@ uncolorchain( a->colorchain = NULL; /* paranoia */ } -#ifdef REGEXP_MCCE_ENABLED -/* - - singleton - is this character in its own color? - ^ static int singleton(struct colormap *, pchr c); - */ -static int /* predicate */ -singleton( - struct colormap *cm, - pchr c) -{ - color co = GETCOLOR(cm, c); /* color of c */ - - return (cm->cd[co].nchrs == 1) && (cm->cd[co].sub == NOSUB); -} -#endif - /* - rainbow - add arcs of all full colors (but one) between specified states ^ static VOID rainbow(struct nfa *, struct colormap *, int, pcolor, diff --git a/generic/regc_cvec.c b/generic/regc_cvec.c index a0a14c2..64f34cd 100644 --- a/generic/regc_cvec.c +++ b/generic/regc_cvec.c @@ -36,28 +36,23 @@ /* - newcvec - allocate a new cvec - ^ static struct cvec *newcvec(int, int, int); + ^ static struct cvec *newcvec(int, int); */ static struct cvec * newcvec( int nchrs, /* to hold this many chrs... */ - int nranges, /* ... and this many ranges... */ - int nmcces) /* ... and this many MCCEs */ + int nranges) /* ... and this many ranges... */ { - size_t n, nc; - struct cvec *cv; + size_t nc = (size_t)nchrs + (size_t)nranges*2; + size_t n = sizeof(struct cvec) + nc*sizeof(chr); + struct cvec *cv = (struct cvec *) MALLOC(n); - nc = (size_t)nchrs + (size_t)nmcces*(MAXMCCE+1) + (size_t)nranges*2; - n = sizeof(struct cvec) + (size_t)(nmcces-1)*sizeof(chr *) - + nc*sizeof(chr); - cv = (struct cvec *) MALLOC(n); if (cv == NULL) { return NULL; } cv->chrspace = nchrs; - cv->chrs = (chr *)&cv->mcces[nmcces]; /* chrs just after MCCE ptrs */ - cv->mccespace = nmcces; - cv->ranges = cv->chrs + nchrs + nmcces*(MAXMCCE+1); + cv->chrs = (chr *)(((char *)cv)+sizeof(struct cvec)); + cv->ranges = cv->chrs + nchrs; cv->rangespace = nranges; return clearcvec(cv); } @@ -71,18 +66,9 @@ static struct cvec * clearcvec( struct cvec *cv) /* character vector */ { - int i; - assert(cv != NULL); cv->nchrs = 0; - assert(cv->chrs == (chr *)&cv->mcces[cv->mccespace]); - cv->nmcces = 0; - cv->nmccechrs = 0; cv->nranges = 0; - for (i = 0; i < cv->mccespace; i++) { - cv->mcces[i] = NULL; - } - return cv; } @@ -95,7 +81,6 @@ addchr( struct cvec *cv, /* character vector */ pchr c) /* character to add */ { - assert(cv->nchrs < cv->chrspace - cv->nmccechrs); cv->chrs[cv->nchrs++] = (chr)c; } @@ -115,90 +100,25 @@ addrange( cv->nranges++; } -#ifdef REGEXP_MCCE_ENABLED -/* - * This static function is currently called from a single spot in regcomp.c, - * with two NULL pointers; in that case it does nothing, so that we define out - * both the call and the code. - */ - -/* - - addmcce - add an MCCE to a cvec - ^ static VOID addmcce(struct cvec *, const chr *, const chr *); - */ - -static void -addmcce( - struct cvec *cv, /* character vector */ - const chr *startp, /* beginning of text */ - const chr *endp) /* just past end of text */ -{ - int len, i; - const chr *s, *d; - - if (startp == NULL && endp == NULL) { - return; - } - len = endp - startp; - assert(len > 0); - assert(cv->nchrs + len < cv->chrspace - cv->nmccechrs); - assert(cv->nmcces < cv->mccespace); - d = &cv->chrs[cv->chrspace - cv->nmccechrs - len - 1]; - cv->mcces[cv->nmcces++] = d; - for (s = startp, i = len; i > 0; s++, i--) { - *d++ = *s; - } - *d++ = 0; /* endmarker */ - assert(d == &cv->chrs[cv->chrspace - cv->nmccechrs]); - cv->nmccechrs += len + 1; -} -#endif - -/* - - haschr - does a cvec contain this chr? - ^ static int haschr(struct cvec *, pchr); - */ -static int /* predicate */ -haschr( - struct cvec *cv, /* character vector */ - pchr c) /* character to test for */ -{ - int i; - const chr *p; - - for (p = cv->chrs, i = cv->nchrs; i > 0; p++, i--) { - if (*p == c) { - return 1; - } - } - for (p = cv->ranges, i = cv->nranges; i > 0; p += 2, i--) { - if ((*p <= c) && (c <= *(p+1))) { - return 1; - } - } - return 0; -} - /* - getcvec - get a cvec, remembering it as v->cv - ^ static struct cvec *getcvec(struct vars *, int, int, int); + ^ static struct cvec *getcvec(struct vars *, int, int); */ static struct cvec * getcvec( struct vars *v, /* context */ int nchrs, /* to hold this many chrs... */ - int nranges, /* ... and this many ranges... */ - int nmcces) /* ... and this many MCCEs */ + int nranges) /* ... and this many ranges... */ { if ((v->cv != NULL) && (nchrs <= v->cv->chrspace) && - (nranges <= v->cv->rangespace) && (nmcces <= v->cv->mccespace)) { + (nranges <= v->cv->rangespace)) { return clearcvec(v->cv); } if (v->cv != NULL) { freecvec(v->cv); } - v->cv = newcvec(nchrs, nranges, nmcces); + v->cv = newcvec(nchrs, nranges); if (v->cv == NULL) { ERR(REG_ESPACE); } diff --git a/generic/regc_locale.c b/generic/regc_locale.c index b08c300..13c3cda 100644 --- a/generic/regc_locale.c +++ b/generic/regc_locale.c @@ -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. * - * RCS: @(#) $Id: regc_locale.c,v 1.17 2007/04/19 09:00:55 dkf Exp $ + * RCS: @(#) $Id: regc_locale.c,v 1.17.2.1 2007/11/16 07:20:53 dgp Exp $ */ /* ASCII character-name table */ @@ -611,43 +611,6 @@ static const chr printCharTable[] = { #define CH NOCELT /* - - nmcces - how many distinct MCCEs are there? - ^ static int nmcces(struct vars *); - */ -static int -nmcces( - struct vars *v) /* context */ -{ - /* - * No multi-character collating elements defined at the moment. - */ - return 0; -} - -/* - - nleaders - how many chrs can be first chrs of MCCEs? - ^ static int nleaders(struct vars *); - */ -static int -nleaders( - struct vars *v) /* context */ -{ - return 0; -} - -/* - - allmcces - return a cvec with all the MCCEs of the locale - ^ static struct cvec *allmcces(struct vars *, struct cvec *); - */ -static struct cvec * -allmcces( - struct vars *v, /* context */ - struct cvec *cv) /* this is supposed to have enough room */ -{ - return clearcvec(cv); -} - -/* - element - map collating-element name to celt ^ static celt element(struct vars *, const chr *, const chr *); */ @@ -718,8 +681,8 @@ range( return NULL; } - if (!cases) { /* easy version */ - cv = getcvec(v, 0, 1, 0); + if (!cases) { /* easy version */ + cv = getcvec(v, 0, 1); NOERRN(); addrange(cv, a, b); return cv; @@ -733,7 +696,7 @@ range( nchrs = (b - a + 1)*2 + 4; - cv = getcvec(v, nchrs, 0, 0); + cv = getcvec(v, nchrs, 0); NOERRN(); for (c=a; c<=b; c++) { @@ -759,14 +722,10 @@ range( - before - is celt x before celt y, for purposes of range legality? ^ static int before(celt, celt); */ -static int /* predicate */ +static int /* predicate */ before( - celt x, celt y) /* collating elements */ + celt x, celt y) /* collating elements */ { - /* - * trivial because no MCCEs. - */ - if (x < y) { return 1; } @@ -792,7 +751,7 @@ eclass( */ if ((v->cflags®_FAKE) && c == 'x') { - cv = getcvec(v, 4, 0, 0); + cv = getcvec(v, 4, 0); addchr(cv, (chr)'x'); addchr(cv, (chr)'y'); if (cases) { @@ -809,7 +768,7 @@ eclass( if (cases) { return allcases(v, c); } - cv = getcvec(v, 1, 0, 0); + cv = getcvec(v, 1, 0); assert(cv != NULL); addchr(cv, (chr)c); return cv; @@ -889,7 +848,7 @@ cclass( switch((enum classes) index) { case CC_PRINT: - cv = getcvec(v, NUM_PRINT_CHAR, NUM_PRINT_RANGE, 0); + cv = getcvec(v, NUM_PRINT_CHAR, NUM_PRINT_RANGE); if (cv) { for (i=0 ; (size_t)i<NUM_PRINT_CHAR ; i++) { addchr(cv, printCharTable[i]); @@ -901,7 +860,7 @@ cclass( } break; case CC_ALNUM: - cv = getcvec(v, NUM_ALPHA_CHAR, NUM_DIGIT_RANGE + NUM_ALPHA_RANGE, 0); + cv = getcvec(v, NUM_ALPHA_CHAR, NUM_DIGIT_RANGE + NUM_ALPHA_RANGE); if (cv) { for (i=0 ; (size_t)i<NUM_ALPHA_CHAR ; i++) { addchr(cv, alphaCharTable[i]); @@ -917,7 +876,7 @@ cclass( } break; case CC_ALPHA: - cv = getcvec(v, NUM_ALPHA_CHAR, NUM_ALPHA_RANGE, 0); + cv = getcvec(v, NUM_ALPHA_CHAR, NUM_ALPHA_RANGE); if (cv) { for (i=0 ; (size_t)i<NUM_ALPHA_RANGE ; i++) { addrange(cv, alphaRangeTable[i].start, @@ -929,23 +888,23 @@ cclass( } break; case CC_ASCII: - cv = getcvec(v, 0, 1, 0); + cv = getcvec(v, 0, 1); if (cv) { addrange(cv, 0, 0x7f); } break; case CC_BLANK: - cv = getcvec(v, 2, 0, 0); + cv = getcvec(v, 2, 0); addchr(cv, '\t'); addchr(cv, ' '); break; case CC_CNTRL: - cv = getcvec(v, 0, 2, 0); + cv = getcvec(v, 0, 2); addrange(cv, 0x0, 0x1f); addrange(cv, 0x7f, 0x9f); break; case CC_DIGIT: - cv = getcvec(v, 0, NUM_DIGIT_RANGE, 0); + cv = getcvec(v, 0, NUM_DIGIT_RANGE); if (cv) { for (i=0 ; (size_t)i<NUM_DIGIT_RANGE ; i++) { addrange(cv, digitRangeTable[i].start, @@ -954,7 +913,7 @@ cclass( } break; case CC_PUNCT: - cv = getcvec(v, NUM_PUNCT_CHAR, NUM_PUNCT_RANGE, 0); + cv = getcvec(v, NUM_PUNCT_CHAR, NUM_PUNCT_RANGE); if (cv) { for (i=0 ; (size_t)i<NUM_PUNCT_RANGE ; i++) { addrange(cv, punctRangeTable[i].start, @@ -975,7 +934,7 @@ cclass( * someone comes up with a better arrangement!) */ - cv = getcvec(v, 0, 3, 0); + cv = getcvec(v, 0, 3); if (cv) { addrange(cv, '0', '9'); addrange(cv, 'a', 'f'); @@ -983,7 +942,7 @@ cclass( } break; case CC_SPACE: - cv = getcvec(v, NUM_SPACE_CHAR, NUM_SPACE_RANGE, 0); + cv = getcvec(v, NUM_SPACE_CHAR, NUM_SPACE_RANGE); if (cv) { for (i=0 ; (size_t)i<NUM_SPACE_RANGE ; i++) { addrange(cv, spaceRangeTable[i].start, @@ -995,7 +954,7 @@ cclass( } break; case CC_LOWER: - cv = getcvec(v, NUM_LOWER_CHAR, NUM_LOWER_RANGE, 0); + cv = getcvec(v, NUM_LOWER_CHAR, NUM_LOWER_RANGE); if (cv) { for (i=0 ; (size_t)i<NUM_LOWER_RANGE ; i++) { addrange(cv, lowerRangeTable[i].start, @@ -1007,7 +966,7 @@ cclass( } break; case CC_UPPER: - cv = getcvec(v, NUM_UPPER_CHAR, NUM_UPPER_RANGE, 0); + cv = getcvec(v, NUM_UPPER_CHAR, NUM_UPPER_RANGE); if (cv) { for (i=0 ; (size_t)i<NUM_UPPER_RANGE ; i++) { addrange(cv, upperRangeTable[i].start, @@ -1019,7 +978,7 @@ cclass( } break; case CC_GRAPH: - cv = getcvec(v, NUM_GRAPH_CHAR, NUM_GRAPH_RANGE, 0); + cv = getcvec(v, NUM_GRAPH_CHAR, NUM_GRAPH_RANGE); if (cv) { for (i=0 ; (size_t)i<NUM_GRAPH_RANGE ; i++) { addrange(cv, graphRangeTable[i].start, @@ -1057,10 +1016,10 @@ allcases( tc = Tcl_UniCharToTitle((chr)c); if (tc != uc) { - cv = getcvec(v, 3, 0, 0); + cv = getcvec(v, 3, 0); addchr(cv, tc); } else { - cv = getcvec(v, 2, 0, 0); + cv = getcvec(v, 2, 0); } addchr(cv, lc); if (lc != uc) { diff --git a/generic/regc_nfa.c b/generic/regc_nfa.c index 9f63f73..741887f 100644 --- a/generic/regc_nfa.c +++ b/generic/regc_nfa.c @@ -88,7 +88,7 @@ newnfa( - freenfa - free an entire NFA ^ static VOID freenfa(struct nfa *); */ -static VOID +static void freenfa( struct nfa *nfa) { @@ -859,6 +859,25 @@ pull( } /* + * DGP 2007-11-15: Cloning a state with a circular constraint on its list + * of outs can lead to trouble [Bug 1810038], so get rid of them first. + */ + + for (a = from->outs; a != NULL; a = nexta) { + nexta = a->outchain; + switch (a->type) { + case '^': + case '$': + case BEHIND: + case AHEAD: + if (from == a->to) { + freearc(nfa, a); + } + break; + } + } + + /* * First, clone from state if necessary to avoid other outarcs. */ @@ -997,6 +1016,28 @@ push( } /* + * DGP 2007-11-15: Here we duplicate the same protections as appear + * in pull() above to avoid troubles with cloning a state with a + * circular constraint on its list of ins. It is not clear whether + * this is necessary, or is protecting against a "can't happen". + * Any test case that actually leads to a freearc() call here would + * be a welcome addition to the test suite. + */ + + for (a = to->ins; a != NULL; a = nexta) { + nexta = a->inchain; + switch (a->type) { + case '^': + case '$': + case BEHIND: + case AHEAD: + if (a->from == to) { + freearc(nfa, a); + } + break; + } + } + /* * First, clone to state if necessary to avoid other inarcs. */ @@ -1133,7 +1174,8 @@ fixempties( do { progress = 0; - for (s = nfa->states; s != NULL && !NISERR(); s = nexts) { + for (s = nfa->states; s != NULL && !NISERR() + && s->no != FREESTATE; s = nexts) { nexts = s->next; for (a = s->outs; a != NULL && !NISERR(); a = nexta) { nexta = a->outchain; diff --git a/generic/regcomp.c b/generic/regcomp.c index b9169f9..afe1b1b 100644 --- a/generic/regcomp.c +++ b/generic/regcomp.c @@ -53,12 +53,8 @@ static void bracket(struct vars *, struct state *, struct state *); static void cbracket(struct vars *, struct state *, struct state *); static void brackpart(struct vars *, struct state *, struct state *); static const chr *scanplain(struct vars *); -static void leaders(struct vars *, struct cvec *); static void onechr(struct vars *, pchr, struct state *, struct state *); static void dovec(struct vars *, struct cvec *, struct state *, struct state *); -#ifdef REGEXP_MCCE_ENABLED -static celt nextleader(struct vars *, pchr, pchr); -#endif static void wordchrs(struct vars *); static struct subre *subre(struct vars *, int, int, struct state *, struct state *); static void freesubre(struct vars *, struct subre *); @@ -107,9 +103,6 @@ static void subblock(struct vars *, pchr, struct state *, struct state *); static void okcolors(struct nfa *, struct colormap *); static void colorchain(struct colormap *, struct arc *); static void uncolorchain(struct colormap *, struct arc *); -#ifdef REGEXP_MCCE_ENABLED -static int singleton(struct colormap *, pchr c); -#endif static void rainbow(struct nfa *, struct colormap *, int, pcolor, struct state *, struct state *); static void colorcomplement(struct nfa *, struct colormap *, int, struct state *, struct state *, struct state *); #ifdef REG_DEBUG @@ -171,20 +164,13 @@ static void dumpcnfa(struct cnfa *, FILE *); static void dumpcstate(int, struct carc *, struct cnfa *, FILE *); #endif /* === regc_cvec.c === */ -static struct cvec *newcvec(int, int, int); static struct cvec *clearcvec(struct cvec *); static void addchr(struct cvec *, pchr); static void addrange(struct cvec *, pchr, pchr); -#ifdef REGEXP_MCCE_ENABLED -static void addmcce(struct cvec *, const chr *, const chr *); -#endif -static int haschr(struct cvec *, pchr); -static struct cvec *getcvec(struct vars *, int, int, int); +static struct cvec *newcvec(int, int); +static struct cvec *getcvec(struct vars *, int, int); static void freecvec(struct cvec *); /* === regc_locale.c === */ -static int nmcces(struct vars *); -static int nleaders(struct vars *); -static struct cvec *allmcces(struct vars *, struct cvec *); static celt element(struct vars *, const chr *, const chr *); static struct cvec *range(struct vars *, celt, celt, int); static int before(celt, celt); @@ -223,10 +209,6 @@ struct vars { int ntree; /* number of tree nodes */ struct cvec *cv; /* interface cvec */ struct cvec *cv2; /* utility cvec */ - struct cvec *mcces; /* collating-element information */ -#define ISCELEADER(v,c) (v->mcces != NULL && haschr(v->mcces, (c))) - struct state *mccepbegin; /* in nfa, start of MCCE prototypes */ - struct state *mccepend; /* in nfa, end of MCCE prototypes */ struct subre *lacons; /* lookahead-constraint vector */ int nlacons; /* size of lacons */ }; @@ -336,7 +318,6 @@ compile( v->treefree = NULL; v->cv = NULL; v->cv2 = NULL; - v->mcces = NULL; v->lacons = NULL; v->nlacons = 0; re->re_magic = REMAGIC; @@ -362,22 +343,10 @@ compile( ZAPCNFA(g->search); v->nfa = newnfa(v, v->cm, NULL); CNOERR(); - v->cv = newcvec(100, 20, 10); + v->cv = newcvec(100, 20); if (v->cv == NULL) { return freev(v, REG_ESPACE); } - i = nmcces(v); - if (i > 0) { - v->mcces = newcvec(nleaders(v), 0, i); - CNOERR(); - v->mcces = allmcces(v, v->mcces); - leaders(v, v->mcces); -#ifdef REGEXP_MCCE_ENABLED - /* Function does nothing with NULL pointers */ - addmcce(v->mcces, NULL, NULL); /* dummy */ -#endif - } - CNOERR(); /* * Parsing. @@ -550,9 +519,6 @@ freev( if (v->cv2 != NULL) { freecvec(v->cv2); } - if (v->mcces != NULL) { - freecvec(v->mcces); - } if (v->lacons != NULL) { freelacons(v->lacons, v->nlacons); } @@ -839,7 +805,6 @@ parseqatom( } NEXT(); return; - break; case '$': ARCV('$', 1); if (v->cflags®_NLANCH) { @@ -847,19 +812,16 @@ parseqatom( } NEXT(); return; - break; case SBEGIN: ARCV('^', 1); /* BOL */ ARCV('^', 0); /* or BOS */ NEXT(); return; - break; case SEND: ARCV('$', 1); /* EOL */ ARCV('$', 0); /* or EOS */ NEXT(); return; - break; case '<': wordchrs(v); /* does NEXT() */ s = newstate(v->nfa); @@ -867,7 +829,6 @@ parseqatom( nonword(v, BEHIND, lp, s); word(v, AHEAD, s, rp); return; - break; case '>': wordchrs(v); /* does NEXT() */ s = newstate(v->nfa); @@ -875,7 +836,6 @@ parseqatom( word(v, BEHIND, lp, s); nonword(v, AHEAD, s, rp); return; - break; case WBDRY: wordchrs(v); /* does NEXT() */ s = newstate(v->nfa); @@ -887,7 +847,6 @@ parseqatom( word(v, BEHIND, lp, s); nonword(v, AHEAD, s, rp); return; - break; case NWBDRY: wordchrs(v); /* does NEXT() */ s = newstate(v->nfa); @@ -899,7 +858,6 @@ parseqatom( nonword(v, BEHIND, lp, s); nonword(v, AHEAD, s, rp); return; - break; case LACON: /* lookahead constraint */ pos = v->nextvalue; NEXT(); @@ -914,7 +872,6 @@ parseqatom( NOERR(); ARCV(LACON, n); return; - break; /* * Then errors, to get them out of the way. @@ -926,11 +883,9 @@ parseqatom( case '{': ERR(REG_BADRPT); return; - break; default: ERR(REG_ASSERT); return; - break; /* * Then plain characters, and minor variants on that theme. @@ -1467,13 +1422,6 @@ cbracket( { struct state *left = newstate(v->nfa); struct state *right = newstate(v->nfa); - struct state *s; - struct arc *a; /* arc from lp */ - struct arc *ba; /* arc from left, from bracket() */ - struct arc *pa; /* MCCE-prototype arc */ - color co; - const chr *p; - int i; NOERR(); bracket(v, left, right); @@ -1485,67 +1433,16 @@ cbracket( assert(lp->nouts == 0); /* all outarcs will be ours */ /* - * Easy part of complementing + * Easy part of complementing, and all there is to do since the MCCE code + * was removed. */ colorcomplement(v->nfa, v->cm, PLAIN, left, lp, rp); NOERR(); - if (v->mcces == NULL) { /* no MCCEs -- we're done */ - dropstate(v->nfa, left); - assert(right->nins == 0); - freestate(v->nfa, right); - return; - } - - /* - * But complementing gets messy in the presence of MCCEs... - */ - - NOTE(REG_ULOCALE); - for (p = v->mcces->chrs, i = v->mcces->nchrs; i > 0; p++, i--) { - co = GETCOLOR(v->cm, *p); - a = findarc(lp, PLAIN, co); - ba = findarc(left, PLAIN, co); - if (ba == NULL) { - assert(a != NULL); - freearc(v->nfa, a); - } else { - assert(a == NULL); - } - s = newstate(v->nfa); - NOERR(); - newarc(v->nfa, PLAIN, co, lp, s); - NOERR(); - pa = findarc(v->mccepbegin, PLAIN, co); - assert(pa != NULL); - if (ba == NULL) { /* easy case, need all of them */ - cloneouts(v->nfa, pa->to, s, rp, PLAIN); - newarc(v->nfa, '$', 1, s, rp); - newarc(v->nfa, '$', 0, s, rp); - colorcomplement(v->nfa, v->cm, AHEAD, pa->to, s, rp); - } else { /* must be selective */ - if (findarc(ba->to, '$', 1) == NULL) { - newarc(v->nfa, '$', 1, s, rp); - newarc(v->nfa, '$', 0, s, rp); - colorcomplement(v->nfa, v->cm, AHEAD, pa->to, s, rp); - } - for (pa = pa->to->outs; pa != NULL; pa = pa->outchain) { - if (findarc(ba->to, PLAIN, pa->co) == NULL) { - newarc(v->nfa, PLAIN, pa->co, s, rp); - } - } - if (s->nouts == 0) { /* limit of selectivity: none */ - dropstate(v->nfa, s); /* frees arc too */ - } - } - NOERR(); - } - - delsub(v->nfa, left, right); - assert(left->nouts == 0); - freestate(v->nfa, left); + dropstate(v->nfa, left); assert(right->nins == 0); freestate(v->nfa, right); + return; } /* @@ -1577,10 +1474,10 @@ brackpart( NEXT(); /* - * Shortcut for ordinary chr (not range, not MCCE leader). + * Shortcut for ordinary chr (not range). */ - if (!SEE(RANGE) && !ISCELEADER(v, c[0])) { + if (!SEE(RANGE)) { onechr(v, c[0], lp, rp); return; } @@ -1691,48 +1588,6 @@ scanplain( } /* - - leaders - process a cvec of collating elements to also include leaders - * Also gives all characters involved their own colors, which is almost - * certainly necessary, and sets up little disconnected subNFA. - ^ static void leaders(struct vars *, struct cvec *); - */ -static void -leaders( - struct vars *v, - struct cvec *cv) -{ - int mcce; - const chr *p; - chr leader; - struct state *s; - struct arc *a; - - v->mccepbegin = newstate(v->nfa); - v->mccepend = newstate(v->nfa); - NOERR(); - - for (mcce = 0; mcce < cv->nmcces; mcce++) { - p = cv->mcces[mcce]; - leader = *p; - if (!haschr(cv, leader)) { - addchr(cv, leader); - s = newstate(v->nfa); - newarc(v->nfa, PLAIN, subcolor(v->cm, leader), v->mccepbegin, s); - okcolors(v->nfa, v->cm); - } else { - a = findarc(v->mccepbegin, PLAIN, GETCOLOR(v->cm, leader)); - assert(a != NULL); - s = a->to; - assert(s != v->mccepend); - } - p++; - assert(*p != 0 && *(p+1) == 0); /* only 2-char MCCEs for now */ - newarc(v->nfa, PLAIN, subcolor(v->cm, *p), s, v->mccepend); - okcolors(v->nfa, v->cm); - } -} - -/* - onechr - fill in arcs for a plain character, and possible case complements * This is mostly a shortcut for efficient handling of the common case. ^ static void onechr(struct vars *, pchr, struct state *, struct state *); @@ -1749,17 +1604,18 @@ onechr( return; } - /* rats, need general case anyway... */ + /* + * Rats, need general case anyway... + */ + dovec(v, allcases(v, c), lp, rp); } /* - dovec - fill in arcs for each element of a cvec - * This one has to handle the messy cases, like MCCEs and MCCE leaders. ^ static void dovec(struct vars *, struct cvec *, struct state *, ^ struct state *); */ -#ifndef REGEXP_MCCE_ENABLED static void dovec( struct vars *v, @@ -1785,184 +1641,6 @@ dovec( } } -#else /* REGEXP_MCCE_ENABLED */ -static void -dovec( - struct vars *v, - struct cvec *cv, - struct state *lp, - struct state *rp) -{ - chr ch, from, to; - celt ce; - const chr *p; - int i; - struct cvec *leads; - color co; - struct arc *a; - struct arc *pa; /* arc in prototype */ - struct state *s; - struct state *ps; /* state in prototype */ - - /* - * Need a place to store leaders, if any. - */ - - if (nmcces(v) > 0) { - assert(v->mcces != NULL); - if (v->cv2 == NULL || v->cv2->nchrs < v->mcces->nchrs) { - if (v->cv2 != NULL) { - free(v->cv2); - } - v->cv2 = newcvec(v->mcces->nchrs, 0, v->mcces->nmcces); - NOERR(); - leads = v->cv2; - } else { - leads = clearcvec(v->cv2); - } - } else { - leads = NULL; - } - - /* - * First, get the ordinary characters out of the way. - */ - - for (p = cv->chrs, i = cv->nchrs; i > 0; p++, i--) { - ch = *p; - if (!ISCELEADER(v, ch)) { - newarc(v->nfa, PLAIN, subcolor(v->cm, ch), lp, rp); - } else { - assert(singleton(v->cm, ch)); - assert(leads != NULL); - if (!haschr(leads, ch)) { - addchr(leads, ch); - } - } - } - - /* - * And the ranges. - */ - - for (p = cv->ranges, i = cv->nranges; i > 0; p += 2, i--) { - from = *p; - to = *(p+1); - while (from <= to && (ce = nextleader(v, from, to)) != NOCELT) { - if (from < ce) { - subrange(v, from, ce - 1, lp, rp); - } - assert(singleton(v->cm, ce)); - assert(leads != NULL); - if (!haschr(leads, ce)) { - addchr(leads, ce); - } - from = ce + 1; - } - if (from <= to) { - subrange(v, from, to, lp, rp); - } - } - - /* *** WARNING *** - * - * This was buggy, check before enabling: the original version would cause - * a segfault at the loopinit below if (leads==NULL && cv->nmcces!=0) - * Possibly just a problem with parens? The original condition was - * ((leads == NULL || leads->nchrs == 0) && cv->nmcces == 0) - */ - - if (leads == NULL || (leads->nchrs == 0 && cv->nmcces == 0)) { - return; - } - - /* - * Deal with the MCCE leaders. - */ - - NOTE(REG_ULOCALE); - for (p = leads->chrs, i = leads->nchrs; i > 0; p++, i--) { - co = GETCOLOR(v->cm, *p); - a = findarc(lp, PLAIN, co); - if (a != NULL) { - s = a->to; - } else { - s = newstate(v->nfa); - NOERR(); - newarc(v->nfa, PLAIN, co, lp, s); - NOERR(); - } - pa = findarc(v->mccepbegin, PLAIN, co); - assert(pa != NULL); - ps = pa->to; - newarc(v->nfa, '$', 1, s, rp); - newarc(v->nfa, '$', 0, s, rp); - colorcomplement(v->nfa, v->cm, AHEAD, ps, s, rp); - NOERR(); - } - - /* - * And the MCCEs. - */ - - for (i = 0; i < cv->nmcces; i++) { - p = cv->mcces[i]; - assert(singleton(v->cm, *p)); - if (!singleton(v->cm, *p)) { - ERR(REG_ASSERT); - return; - } - ch = *p++; - co = GETCOLOR(v->cm, ch); - a = findarc(lp, PLAIN, co); - if (a != NULL) { - s = a->to; - } else { - s = newstate(v->nfa); - NOERR(); - newarc(v->nfa, PLAIN, co, lp, s); - NOERR(); - } - assert(*p != 0); /* at least two chars */ - assert(singleton(v->cm, *p)); - ch = *p++; - co = GETCOLOR(v->cm, ch); - assert(*p == 0); /* and only two, for now */ - newarc(v->nfa, PLAIN, co, s, rp); - NOERR(); - } -} - -/* - - nextleader - find next MCCE leader within range - ^ static celt nextleader(struct vars *, pchr, pchr); - */ -static celt /* NOCELT means none */ -nextleader( - struct vars *v, - pchr from, - pchr to) -{ - int i; - const chr *p; - chr ch; - celt it = NOCELT; - - if (v->mcces == NULL) { - return it; - } - - for (i = v->mcces->nchrs, p = v->mcces->chrs; i > 0; i--, p++) { - ch = *p; - if (from <= ch && ch <= to) { - if (it == NOCELT || ch < it) { - it = ch; - } - } - } - return it; -} -#endif /* - wordchrs - set up word-chr list for word-boundary stuff, if needed @@ -2103,20 +1781,14 @@ optst( struct vars *v, struct subre *t) { - if (t == NULL) { - return; - } - /* - * Recurse through children. + * DGP (2007-11-13): I assume it was the programmer's intent to eventually + * come back and add code to optimize subRE trees, but the routine coded + * just spends effort traversing the tree and doing nothing. We can do + * nothing with less effort. */ - if (t->left != NULL) { - optst(v, t->left); - } - if (t->right != NULL) { - optst(v, t->right); - } + return; } /* @@ -2447,8 +2119,8 @@ stdump( if (!NULLCNFA(t->cnfa)) { fprintf(f, "\n"); dumpcnfa(&t->cnfa, f); - fprintf(f, "\n"); } + fprintf(f, "\n"); if (t->left != NULL) { stdump(t->left, f, nfapresent); } diff --git a/generic/regcustom.h b/generic/regcustom.h index 6b6b38c..ac33087 100644 --- a/generic/regcustom.h +++ b/generic/regcustom.h @@ -3,13 +3,13 @@ * * Development of this software was funded, in part, by Cray Research Inc., * UUNET Communications Services Inc., Sun Microsystems Inc., and Scriptics - * Corporation, none of whom are responsible for the results. The author + * Corporation, none of whom are responsible for the results. The author * thanks all of them. * - * Redistribution and use in source and binary forms -- with or without - * modification -- are permitted for any purpose, provided that - * redistributions in source form retain this entire copyright notice and - * indicate the origin and nature of any modifications. + * Redistribution and use in source and binary forms - with or without + * modification - are permitted for any purpose, provided that redistributions + * in source form retain this entire copyright notice and indicate the origin + * and nature of any modifications. * * I'd appreciate being given credit for this package in the documentation of * software which uses it, but that is not a requirement. @@ -26,23 +26,28 @@ * ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. */ -/* headers if any */ +/* + * Headers if any. + */ + #include "tclInt.h" -/* overrides for regguts.h definitions, if any */ -#define FUNCPTR(name, args) (*name) _ANSI_ARGS_(args) +/* + * Overrides for regguts.h definitions, if any. + */ + +#define FUNCPTR(name, args) (*name)args #define MALLOC(n) ckalloc(n) #define FREE(p) ckfree(VS(p)) #define REALLOC(p,n) ckrealloc(VS(p),n) - - /* - * Do not insert extras between the "begin" and "end" lines -- this - * chunk is automatically extracted to be fitted into regex.h. + * Do not insert extras between the "begin" and "end" lines - this chunk is + * automatically extracted to be fitted into regex.h. */ + /* --- begin --- */ -/* ensure certain things don't sneak in from system headers */ +/* Ensure certain things don't sneak in from system headers. */ #ifdef __REG_WIDE_T #undef __REG_WIDE_T #endif @@ -67,70 +72,90 @@ #ifdef __REG_NOCHAR #undef __REG_NOCHAR #endif -/* interface types */ +/* Interface types */ #define __REG_WIDE_T Tcl_UniChar -#define __REG_REGOFF_T long /* not really right, but good enough... */ -#define __REG_VOID_T VOID -#define __REG_CONST CONST -/* names and declarations */ +#define __REG_REGOFF_T long /* Not really right, but good enough... */ +#define __REG_VOID_T void +#define __REG_CONST const +/* Names and declarations */ #define __REG_WIDE_COMPILE TclReComp #define __REG_WIDE_EXEC TclReExec -#define __REG_NOFRONT /* don't want regcomp() and regexec() */ -#define __REG_NOCHAR /* or the char versions */ +#define __REG_NOFRONT /* Don't want regcomp() and regexec() */ +#define __REG_NOCHAR /* Or the char versions */ #define regfree TclReFree #define regerror TclReError /* --- end --- */ +/* + * Internal character type and related. + */ - -/* internal character type and related */ -typedef Tcl_UniChar chr; /* the type itself */ -typedef int pchr; /* what it promotes to */ -typedef unsigned uchr; /* unsigned type that will hold a chr */ -typedef int celt; /* type to hold chr, MCCE number, or NOCELT */ -#define NOCELT (-1) /* celt value which is not valid chr or MCCE */ -#define CHR(c) (UCHAR(c)) /* turn char literal into chr literal */ -#define DIGITVAL(c) ((c)-'0') /* turn chr digit into its value */ +typedef Tcl_UniChar chr; /* The type itself. */ +typedef int pchr; /* What it promotes to. */ +typedef unsigned uchr; /* Unsigned type that will hold a chr. */ +typedef int celt; /* Type to hold chr, or NOCELT */ +#define NOCELT (-1) /* Celt value which is not valid chr */ +#define CHR(c) (UCHAR(c)) /* Turn char literal into chr literal */ +#define DIGITVAL(c) ((c)-'0') /* Turn chr digit into its value */ #if TCL_UTF_MAX > 3 -#define CHRBITS 32 /* bits in a chr; must not use sizeof */ -#define CHR_MIN 0x00000000 /* smallest and largest chr; the value */ -#define CHR_MAX 0xffffffff /* CHR_MAX-CHR_MIN+1 should fit in uchr */ +#define CHRBITS 32 /* Bits in a chr; must not use sizeof */ +#define CHR_MIN 0x00000000 /* Smallest and largest chr; the value */ +#define CHR_MAX 0xffffffff /* CHR_MAX-CHR_MIN+1 should fit in uchr */ #else -#define CHRBITS 16 /* bits in a chr; must not use sizeof */ -#define CHR_MIN 0x0000 /* smallest and largest chr; the value */ -#define CHR_MAX 0xffff /* CHR_MAX-CHR_MIN+1 should fit in uchr */ +#define CHRBITS 16 /* Bits in a chr; must not use sizeof */ +#define CHR_MIN 0x0000 /* Smallest and largest chr; the value */ +#define CHR_MAX 0xffff /* CHR_MAX-CHR_MIN+1 should fit in uchr */ #endif -/* functions operating on chr */ +/* + * Functions operating on chr. + */ + #define iscalnum(x) Tcl_UniCharIsAlnum(x) #define iscalpha(x) Tcl_UniCharIsAlpha(x) #define iscdigit(x) Tcl_UniCharIsDigit(x) #define iscspace(x) Tcl_UniCharIsSpace(x) -/* name the external functions */ +/* + * Name the external functions. + */ + #define compile TclReComp #define exec TclReExec -/* enable/disable debugging code (by whether REG_DEBUG is defined or not) */ -#if 0 /* no debug unless requested by makefile */ +/* +& Enable/disable debugging code (by whether REG_DEBUG is defined or not). +*/ + +#if 0 /* No debug unless requested by makefile. */ #define REG_DEBUG /* */ #endif -/* method of allocating a local workspace */ +/* + * Method of allocating a local workspace. We used a thread-specific data + * space to store this because the regular expression engine is never + * reentered from the same thread; it doesn't make any callbacks. + */ + #if 1 #define AllocVars(vPtr) \ static Tcl_ThreadDataKey varsKey; \ register struct vars *vPtr = (struct vars *) \ - Tcl_GetThreadData(&varsKey, sizeof(struct vars)) + Tcl_GetThreadData(&varsKey, sizeof(struct vars)) #else -/* This strategy for allocating workspace is "more proper" in some sense, but +/* + * This strategy for allocating workspace is "more proper" in some sense, but * quite a bit slower. Using TSD (as above) leads to code that is quite a bit - * faster in practice. */ + * faster in practice (measured!) + */ #define AllocVars(vPtr) \ register struct vars *vPtr = (struct vars *) MALLOC(sizeof(struct vars)) #define FreeVars(vPtr) \ FREE(vPtr) #endif -/* and pick up the standard header */ +/* + * And pick up the standard header. + */ + #include "regex.h" diff --git a/generic/regguts.h b/generic/regguts.h index 991979e..cbf6615 100644 --- a/generic/regguts.h +++ b/generic/regguts.h @@ -60,24 +60,24 @@ /* voids */ #ifndef VOID -#define VOID void /* for function return values */ +#define VOID void /* for function return values */ #endif #ifndef DISCARD -#define DISCARD void /* for throwing values away */ +#define DISCARD void /* for throwing values away */ #endif #ifndef PVOID -#define PVOID void * /* generic pointer */ +#define PVOID void * /* generic pointer */ #endif #ifndef VS -#define VS(x) ((void*)(x)) /* cast something to generic ptr */ +#define VS(x) ((void*)(x)) /* cast something to generic ptr */ #endif #ifndef NOPARMS -#define NOPARMS void /* for empty parm lists */ +#define NOPARMS void /* for empty parm lists */ #endif /* const */ #ifndef CONST -#define CONST const /* for old compilers, might be empty */ +#define CONST const /* for old compilers, might be empty */ #endif /* function-pointer declarator */ @@ -105,7 +105,7 @@ #include <limits.h> #endif #ifndef _POSIX2_RE_DUP_MAX -#define _POSIX2_RE_DUP_MAX 255 /* normally from <limits.h> */ +#define _POSIX2_RE_DUP_MAX 255 /* normally from <limits.h> */ #endif /* @@ -189,7 +189,7 @@ union tree { #define tcolor colors.ccolor #define tptr ptrs.pptr -/* internal per-color structure for the color machinery */ +/* Internal per-color descriptor structure for the color machinery */ struct colordesc { uchr nchrs; /* number of chars of this color */ color sub; /* open subcolor (if any); free chain ptr */ @@ -235,9 +235,9 @@ struct colormap { /* * Interface definitions for locale-interface functions in locale.c. - * Multi-character collating elements (MCCEs) cause most of the trouble. */ +/* Representation of a set of characters. */ struct cvec { int nchrs; /* number of chrs */ int chrspace; /* number of chrs possible */ @@ -245,18 +245,11 @@ struct cvec { int nranges; /* number of ranges (chr pairs) */ int rangespace; /* number of chrs possible */ chr *ranges; /* pointer to vector of chr pairs */ - int nmcces; /* number of MCCEs */ - int mccespace; /* number of MCCEs possible */ - int nmccechrs; /* number of chrs used for MCCEs */ - chr *mcces[1]; /* pointers to 0-terminated MCCEs */ - /* and both batches of chrs are on the end */ }; -/* caution: this value cannot be changed easily */ -#define MAXMCCE 2 /* length of longest MCCE */ - /* - * definitions for NFA internal representation + * definitions for non-deterministic finite autmaton (NFA) internal + * representation * * Having a "from" pointer within each arc may seem redundant, but it saves a * lot of hassle. @@ -284,7 +277,7 @@ struct arcbatch { /* for bulk allocation of arcs */ struct state { int no; -# define FREESTATE (-1) +#define FREESTATE (-1) char flag; /* marks special states */ int nins; /* number of inarcs */ struct arc *ins; /* chain of inarcs */ @@ -401,7 +394,8 @@ struct guts { }; /* - * Magic for allocating a variable workspace. + * Magic for allocating a variable workspace. This default version is + * stack-hungry. */ #ifndef AllocVars diff --git a/generic/tclCmdIL.c b/generic/tclCmdIL.c index d558cd1..a7c53f4 100644 --- a/generic/tclCmdIL.c +++ b/generic/tclCmdIL.c @@ -16,7 +16,7 @@ * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclCmdIL.c,v 1.115.2.8 2007/11/12 19:18:14 dgp Exp $ + * RCS: @(#) $Id: tclCmdIL.c,v 1.115.2.9 2007/11/16 07:20:53 dgp Exp $ */ #include "tclInt.h" @@ -110,8 +110,6 @@ static int InfoCompleteCmd(ClientData dummy, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]); static int InfoDefaultCmd(ClientData dummy, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]); -static int InfoExistsCmd(ClientData dummy, Tcl_Interp *interp, - int objc, Tcl_Obj *CONST objv[]); /* TIP #280 - New 'info' subcommand 'frame' */ static int InfoFrameCmd(ClientData dummy, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]); @@ -161,7 +159,7 @@ static const struct { {"commands", InfoCommandsCmd}, {"complete", InfoCompleteCmd}, {"default", InfoDefaultCmd}, - {"exists", InfoExistsCmd}, + {"exists", TclInfoExistsCmd}, {"frame", InfoFrameCmd}, {"functions", InfoFunctionsCmd}, {"globals", TclInfoGlobalsCmd}, @@ -416,6 +414,13 @@ TclInitInfoCmd( } Tcl_SetEnsembleMappingDict(interp, ensemble, mapDict); } + + /* + * Enable compilation of the [info exists] subcommand. + */ + + ((Command *)ensemble)->compileProc = &TclCompileInfoCmd; + return ensemble; } @@ -990,7 +995,7 @@ InfoDefaultCmd( /* *---------------------------------------------------------------------- * - * InfoExistsCmd -- + * TclInfoExistsCmd -- * * Called to implement the "info exists" command that determines whether * a variable exists. Handles the following syntax: @@ -1007,8 +1012,8 @@ InfoDefaultCmd( *---------------------------------------------------------------------- */ -static int -InfoExistsCmd( +int +TclInfoExistsCmd( ClientData dummy, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ diff --git a/generic/tclCompCmds.c b/generic/tclCompCmds.c index 5d64717..9bc0f30 100644 --- a/generic/tclCompCmds.c +++ b/generic/tclCompCmds.c @@ -12,7 +12,7 @@ * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclCompCmds.c,v 1.109.2.10 2007/11/12 19:18:15 dgp Exp $ + * RCS: @(#) $Id: tclCompCmds.c,v 1.109.2.11 2007/11/16 07:20:53 dgp Exp $ */ #include "tclInt.h" @@ -61,7 +61,6 @@ TclCompileCmdWord((interp), (tokenPtr)+1, (tokenPtr)->numComponents, \ (envPtr)) - /* * Convenience macro for use when compiling tokens to be pushed. The ANSI C * "prototype" for this macro is: @@ -916,8 +915,7 @@ TclCompileDictCmd( Tcl_Token **keyTokenPtrs, *dictVarTokenPtr, *bodyTokenPtr; DictUpdateInfo *duiPtr; JumpFixup jumpFixup; - - + /* * Parse the command. Expect the following: * dict update <lit(eral)> <any> <lit> ?<any> <lit> ...? <lit> @@ -995,9 +993,9 @@ TclCompileDictCmd( /* * Normal termination code: the stack has the key list below the * result of the body evaluation: swap them and finish the update - * code. + * code. */ - + TclEmitOpcode( INST_END_CATCH, envPtr); TclEmitInstInt4( INST_REVERSE, 2, envPtr); TclEmitInstInt4( INST_DICT_UPDATE_END, dictIndex, envPtr); @@ -1006,7 +1004,7 @@ TclCompileDictCmd( /* * Jump around the exceptional termination code */ - + TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP, &jumpFixup); /* @@ -1014,7 +1012,7 @@ TclCompileDictCmd( * options in the stack, bring up the key list, finish the update * code, and finally return with the catched return data */ - + ExceptionRangeTarget(envPtr, range, catchOffset); TclEmitOpcode( INST_PUSH_RESULT, envPtr); TclEmitOpcode( INST_PUSH_RETURN_OPTIONS, envPtr); @@ -1025,7 +1023,6 @@ TclCompileDictCmd( TclEmitInt4( infoIndex, envPtr); TclEmitOpcode( INST_RETURN_STK, envPtr); - if (TclFixupForwardJumpToHere(envPtr, &jumpFixup, 127)) { Tcl_Panic("TclCompileDictCmd(update): bad jump distance %d", CurrentOffset(envPtr) - jumpFixup.codeOffset); @@ -1303,7 +1300,6 @@ TclCompileForCmd( envPtr->currStackDepth = savedStackDepth + 1; TclEmitOpcode(INST_POP, envPtr); - /* * Compile the "next" subcommand. */ @@ -1890,7 +1886,6 @@ TclCompileIfCmd( tokenPtr = TokenAfter(tokenPtr); } - TclInitJumpFixupArray(&jumpFalseFixupArray); TclInitJumpFixupArray(&jumpEndFixupArray); code = TCL_OK; @@ -1929,7 +1924,6 @@ TclCompileIfCmd( envPtr->currStackDepth = savedStackDepth; testTokenPtr = tokenPtr; - if (realCond) { /* * Find out if the condition is a constant. @@ -1964,7 +1958,6 @@ TclCompileIfCmd( code = TCL_OK; } - /* * Skip over the optional "then" before the then clause. */ @@ -2944,8 +2937,8 @@ TclCompileRegexpCmd( } /* - * Get the regexp string. If it is not a simple string, punt to runtime. - * If it has a '-', it could be an incorrectly formed regexp command. + * Get the regexp string. If it is not a simple string or can't be + * converted to a glob pattern, push the word for the INST_REGEXP. */ varTokenPtr = TokenAfter(varTokenPtr); @@ -2953,9 +2946,12 @@ TclCompileRegexpCmd( if (varTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) { Tcl_DString ds; - simple = 1; str = (char *) varTokenPtr[1].start; len = varTokenPtr[1].size; + /* + * If it has a '-', it could be an incorrectly formed regexp command. + */ + if ((*str == '-') && !sawLast) { return TCL_ERROR; } @@ -2971,17 +2967,18 @@ TclCompileRegexpCmd( /* * Attempt to convert pattern to glob. If successful, push the - * converted pattern. + * converted pattern as a literal. */ if (TclReToGlob(NULL, varTokenPtr[1].start, len, &ds, &exact) - != TCL_OK) { - return TCL_ERROR; + == TCL_OK) { + simple = 1; + PushLiteral(envPtr, Tcl_DStringValue(&ds),Tcl_DStringLength(&ds)); + Tcl_DStringFree(&ds); } + } - PushLiteral(envPtr, Tcl_DStringValue(&ds), Tcl_DStringLength(&ds)); - Tcl_DStringFree(&ds); - } else { + if (!simple) { CompileWord(envPtr, varTokenPtr, interp, parsePtr->numWords-2); } @@ -3175,7 +3172,7 @@ CompileReturnInternal( unsigned char op, int code, int level, - Tcl_Obj *returnOpts) + Tcl_Obj *returnOpts) { TclEmitPush(TclAddLiteralObj(envPtr, returnOpts, NULL), envPtr); TclEmitInstInt4(op, code, envPtr); @@ -3543,7 +3540,7 @@ TclCompileSwitchCmd( int numWords; /* Number of words in command. */ Tcl_Token *valueTokenPtr; /* Token for the value to switch on. */ - enum {Switch_Exact, Switch_Glob} mode; + enum {Switch_Exact, Switch_Glob, Switch_Regexp} mode; /* What kind of switch are we doing? */ Tcl_Token *bodyTokenArray; /* Array of real pattern list items. */ @@ -3571,12 +3568,14 @@ TclCompileSwitchCmd( /* * Only handle the following versions: - * switch -- word {pattern body ...} - * switch -exact -- word {pattern body ...} - * switch -glob -- word {pattern body ...} - * switch -- word simpleWordPattern simpleWordBody ... - * switch -exact -- word simpleWordPattern simpleWordBody ... - * switch -glob -- word simpleWordPattern simpleWordBody ... + * switch -- word {pattern body ...} + * switch -exact -- word {pattern body ...} + * switch -glob -- word {pattern body ...} + * switch -regexp -- word {pattern body ...} + * switch -- word simpleWordPattern simpleWordBody ... + * switch -exact -- word simpleWordPattern simpleWordBody ... + * switch -glob -- word simpleWordPattern simpleWordBody ... + * switch -regexp -- word simpleWordPattern simpleWordBody ... * When the mode is -glob, can also handle a -nocase flag. * * First off, we don't care how the command's word was generated; we're @@ -3628,6 +3627,14 @@ TclCompileSwitchCmd( foundMode = 1; valueIndex++; continue; + } else if ((size <= 7) && !memcmp(chrs, "-regexp", size)) { + if (foundMode) { + return TCL_ERROR; + } + mode = Switch_Regexp; + foundMode = 1; + valueIndex++; + continue; } else if ((size <= 7) && !memcmp(chrs, "-nocase", size)) { noCase = 1; valueIndex++; @@ -3651,7 +3658,7 @@ TclCompileSwitchCmd( } tokenPtr = TokenAfter(tokenPtr); numWords--; - if (noCase && (mode == Switch_Exact)) { + if (noCase && (mode != Switch_Exact)) { /* * Can't compile this case; no opcode for case-insensitive equality! */ @@ -4063,19 +4070,65 @@ TclCompileSwitchCmd( if (i!=numWords-2 || bodyToken[numWords-2]->size != 7 || memcmp(bodyToken[numWords-2]->start, "default", 7)) { /* - * Generate the test for the arm. This code is slightly - * inefficient, but much simpler than the first version. + * Generate the test for the arm. */ - TclCompileTokens(interp, bodyToken[i], 1, envPtr); - TclEmitInstInt4(INST_OVER, 1, envPtr); switch (mode) { case Switch_Exact: + TclEmitOpcode(INST_DUP, envPtr); + TclCompileTokens(interp, bodyToken[i], 1, envPtr); TclEmitOpcode(INST_STR_EQ, envPtr); break; case Switch_Glob: + TclCompileTokens(interp, bodyToken[i], 1, envPtr); + TclEmitInstInt4(INST_OVER, 1, envPtr); TclEmitInstInt1(INST_STR_MATCH, noCase, envPtr); break; + case Switch_Regexp: { + int simple = 0, exact = 0; + + if (bodyToken[i]->type == TCL_TOKEN_TEXT) { + Tcl_DString ds; + + if (bodyToken[i]->size == 0) { + /* + * The semantics of regexps are that they always match + * when the RE == "". + */ + + PushLiteral(envPtr, "1", 1); + break; + } + + /* + * Attempt to convert pattern to glob. If successful, push + * the converted pattern. + */ + + if (TclReToGlob(NULL, bodyToken[i]->start, + bodyToken[i]->size, &ds, &exact) == TCL_OK) { + simple = 1; + PushLiteral(envPtr, Tcl_DStringValue(&ds), + Tcl_DStringLength(&ds)); + Tcl_DStringFree(&ds); + } + } + if (!simple) { + TclCompileTokens(interp, bodyToken[i], 1, envPtr); + } + + TclEmitInstInt4(INST_OVER, 1, envPtr); + if (simple) { + if (exact && !noCase) { + TclEmitOpcode(INST_STR_EQ, envPtr); + } else { + TclEmitInstInt1(INST_STR_MATCH, noCase, envPtr); + } + } else { + TclEmitInstInt1(INST_REGEXP, noCase, envPtr); + } + break; + } default: Tcl_Panic("unknown switch mode: %d", mode); } @@ -4449,7 +4502,6 @@ TclCompileWhileCmd( } } - /* * Set the loop's body, continue and break offsets. */ @@ -5233,7 +5285,6 @@ TclCompileDivOpCmd( } return TCL_OK; } - /* *---------------------------------------------------------------------- @@ -5246,7 +5297,7 @@ TclCompileDivOpCmd( * * Results: * Returns the variable's index in the table of compiled locals if the - * tail is known at compile time, or -1 otherwise. + * tail is known at compile time, or -1 otherwise. * * Side effects: * None. @@ -5258,14 +5309,14 @@ static int IndexTailVarIfKnown( Tcl_Interp *interp, Tcl_Token *varTokenPtr, /* Token representing the variable name */ - CompileEnv *envPtr) /* Holds resulting instructions. */ + CompileEnv *envPtr) /* Holds resulting instructions. */ { Tcl_Obj *tailPtr; const char *tailName, *p; int len, n = varTokenPtr->numComponents; Tcl_Token *lastTokenPtr; int full, localIndex; - + /* * Determine if the tail is (a) known at compile time, and (b) not an * array element. Should any of these fail, return an error so that @@ -5285,13 +5336,13 @@ IndexTailVarIfKnown( lastTokenPtr = varTokenPtr; } else { full = 0; - lastTokenPtr = varTokenPtr + n; + lastTokenPtr = varTokenPtr + n; if (!TclWordKnownAtCompileTime(lastTokenPtr, tailPtr)) { Tcl_DecrRefCount(tailPtr); return -1; } } - + tailName = TclGetStringFromObj(tailPtr, &len); if (len) { @@ -5299,7 +5350,7 @@ IndexTailVarIfKnown( /* * Possible array: bail out */ - + Tcl_DecrRefCount(tailPtr); return -1; } @@ -5307,7 +5358,7 @@ IndexTailVarIfKnown( /* * Get the tail: immediately after the last '::' */ - + for(p = tailName + len -1; p > tailName; p--) { if ((*p == ':') && (*(p-1) == ':')) { p++; @@ -5331,7 +5382,6 @@ IndexTailVarIfKnown( Tcl_DecrRefCount(tailPtr); return localIndex; } - /* *---------------------------------------------------------------------- @@ -5359,22 +5409,21 @@ TclCompileUpvarCmd( CompileEnv *envPtr) /* Holds resulting instructions. */ { Tcl_Token *tokenPtr, *otherTokenPtr, *localTokenPtr; - int simpleVarName, isScalar, localIndex, numWords, i; + int simpleVarName, isScalar, localIndex, numWords, i; DefineLineInformation; /* TIP #280 */ Tcl_Obj *objPtr = Tcl_NewObj(); - + if (envPtr->procPtr == NULL) { Tcl_DecrRefCount(objPtr); return TCL_ERROR; } - + numWords = parsePtr->numWords; if (numWords < 3) { Tcl_DecrRefCount(objPtr); return TCL_ERROR; } - /* * Push the frame index if it is known at compile time */ @@ -5388,11 +5437,11 @@ TclCompileUpvarCmd( * Attempt to convert to a level reference. Note that TclObjGetFrame * only changes the obj type when a conversion was successful. */ - + TclObjGetFrame(interp, objPtr, &framePtr); newTypePtr = objPtr->typePtr; Tcl_DecrRefCount(objPtr); - + if (newTypePtr != typePtr) { if(numWords%2) { return TCL_ERROR; @@ -5412,7 +5461,7 @@ TclCompileUpvarCmd( Tcl_DecrRefCount(objPtr); return TCL_ERROR; } - + /* * Loop over the (otherVar, thisVar) pairs. If any of the thisVar is not a * local variable, return an error so that the non-compiled command will @@ -5432,7 +5481,7 @@ TclCompileUpvarCmd( } TclEmitInstInt4(INST_UPVAR, localIndex, envPtr); } - + /* * Pop the frame index, and set the result to empty */ @@ -5441,7 +5490,6 @@ TclCompileUpvarCmd( PushLiteral(envPtr, "", 0); return TCL_OK; } - /* *---------------------------------------------------------------------- @@ -5470,13 +5518,13 @@ TclCompileNamespaceCmd( CompileEnv *envPtr) /* Holds resulting instructions. */ { Tcl_Token *tokenPtr, *otherTokenPtr, *localTokenPtr; - int simpleVarName, isScalar, localIndex, numWords, i; + int simpleVarName, isScalar, localIndex, numWords, i; DefineLineInformation; /* TIP #280 */ - + if (envPtr->procPtr == NULL) { return TCL_ERROR; } - + /* * Only compile [namespace upvar ...]: needs an odd number of args, >=5 */ @@ -5486,7 +5534,6 @@ TclCompileNamespaceCmd( return TCL_ERROR; } - /* * Check if the second argument is "upvar" */ @@ -5525,7 +5572,7 @@ TclCompileNamespaceCmd( } TclEmitInstInt4(INST_NSUPVAR, localIndex, envPtr); } - + /* * Pop the namespace, and set the result to empty */ @@ -5534,7 +5581,6 @@ TclCompileNamespaceCmd( PushLiteral(envPtr, "", 0); return TCL_OK; } - /* *---------------------------------------------------------------------- @@ -5548,7 +5594,7 @@ TclCompileNamespaceCmd( * evaluation to runtime. * * Side effects: - * Instructions are added to envPtr to execute the "global" command at + * Instructions are added to envPtr to execute the "global" command at * runtime. * *---------------------------------------------------------------------- @@ -5562,9 +5608,9 @@ TclCompileGlobalCmd( CompileEnv *envPtr) /* Holds resulting instructions. */ { Tcl_Token *varTokenPtr; - int localIndex, numWords, i; + int localIndex, numWords, i; DefineLineInformation; /* TIP #280 */ - + numWords = parsePtr->numWords; if (numWords < 2) { return TCL_ERROR; @@ -5577,7 +5623,7 @@ TclCompileGlobalCmd( if (envPtr->procPtr == NULL) { return TCL_ERROR; } - + /* * Push the namespace */ @@ -5599,7 +5645,7 @@ TclCompileGlobalCmd( CompileWord(envPtr, varTokenPtr, interp, 1); TclEmitInstInt4(INST_NSUPVAR, localIndex, envPtr); } - + /* * Pop the namespace, and set the result to empty */ @@ -5608,7 +5654,6 @@ TclCompileGlobalCmd( PushLiteral(envPtr, "", 0); return TCL_OK; } - /* *---------------------------------------------------------------------- @@ -5622,7 +5667,7 @@ TclCompileGlobalCmd( * evaluation to runtime. * * Side effects: - * Instructions are added to envPtr to execute the "variable" command at + * Instructions are added to envPtr to execute the "variable" command at * runtime. * *---------------------------------------------------------------------- @@ -5636,9 +5681,9 @@ TclCompileVariableCmd( CompileEnv *envPtr) /* Holds resulting instructions. */ { Tcl_Token *varTokenPtr, *valueTokenPtr; - int localIndex, numWords, i; + int localIndex, numWords, i; DefineLineInformation; /* TIP #280 */ - + numWords = parsePtr->numWords; if (numWords < 2) { return TCL_ERROR; @@ -5647,13 +5692,13 @@ TclCompileVariableCmd( /* * Bail out if not compiling a proc body */ - + if (envPtr->procPtr == NULL) { return TCL_ERROR; } - + /* - * Loop over the (var, value) pairs. + * Loop over the (var, value) pairs. */ valueTokenPtr = parsePtr->tokenPtr; @@ -5666,10 +5711,10 @@ TclCompileVariableCmd( if(localIndex < 0) { return TCL_ERROR; } - + CompileWord(envPtr, varTokenPtr, interp, 1); TclEmitInstInt4(INST_VARIABLE, localIndex, envPtr); - + if (i != numWords) { /* * A value has been given: set the variable, pop the value @@ -5680,7 +5725,7 @@ TclCompileVariableCmd( TclEmitOpcode(INST_POP, envPtr); } } - + /* * Set the result to empty */ @@ -5688,7 +5733,152 @@ TclCompileVariableCmd( PushLiteral(envPtr, "", 0); return TCL_OK; } + +/* + *---------------------------------------------------------------------- + * + * TclCompileInfoCmd -- + * + * Procedure called to compile the "info" command. Only handles the + * "exists" subcommand. + * + * Results: + * Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer + * evaluation to runtime. + * + * Side effects: + * Instructions are added to envPtr to execute the "info exists" + * subcommand at runtime. + * + *---------------------------------------------------------------------- + */ + +int +TclCompileInfoCmd( + Tcl_Interp *interp, /* Used for error reporting. */ + Tcl_Parse *parsePtr, /* Points to a parse structure for the command + * created by Tcl_ParseCommand. */ + CompileEnv *envPtr) /* Holds resulting instructions. */ +{ + Tcl_Token *tokenPtr; + int isScalar, simpleVarName, localIndex, numWords; + DefineLineInformation; /* TIP #280 */ + + numWords = parsePtr->numWords; + if (numWords != 3) { + return TCL_ERROR; + } + + /* + * Ensure that the next word is "exists"; that's the only case we will + * deal with. + */ + + tokenPtr = TokenAfter(parsePtr->tokenPtr); + if (parsePtr->tokenPtr->type == TCL_TOKEN_SIMPLE_WORD && + tokenPtr->type == TCL_TOKEN_SIMPLE_WORD) { + const char *word = tokenPtr[1].start; + int numBytes = tokenPtr[1].size; + Command *cmdPtr; + Tcl_Obj *mapObj, *existsObj, *targetCmdObj; + Tcl_DString ds; + + /* + * There's a sporting chance we'll be able to compile this. But now we + * must check properly. To do that, look up what we expect to be + * called (inefficient, should be in context?) and check that that's + * an ensemble that has [info exists] as its appropriate subcommand. + */ + + Tcl_DStringInit(&ds); + Tcl_DStringAppend(&ds, parsePtr->tokenPtr[1].start, + parsePtr->tokenPtr[1].size); + cmdPtr = (Command *) Tcl_FindCommand(interp, Tcl_DStringValue(&ds), + (Tcl_Namespace *) envPtr->iPtr->globalNsPtr, 0); + Tcl_DStringFree(&ds); + if (cmdPtr == NULL || cmdPtr->compileProc != &TclCompileInfoCmd) { + /* + * Not [info], and can't be bothered to follow rabbit hole of + * renaming. This is an optimization, darnit! + */ + + return TCL_ERROR; + } + + if (Tcl_GetEnsembleMappingDict(interp, (Tcl_Command) cmdPtr, + &mapObj) != TCL_OK || mapObj == NULL) { + /* + * Either not an ensemble or a mapping isn't installed. Crud. Too + * hard to proceed. + */ + + return TCL_ERROR; + } + + TclNewStringObj(existsObj, word, numBytes); + if (Tcl_DictObjGet(NULL, mapObj, existsObj, &targetCmdObj) != TCL_OK + || targetCmdObj == NULL) { + /* + * We've not got a valid subcommand. + */ + + TclDecrRefCount(existsObj); + return TCL_ERROR; + } + TclDecrRefCount(existsObj); + + cmdPtr = (Command *) Tcl_GetCommandFromObj(interp, targetCmdObj); + if (cmdPtr == NULL || cmdPtr->objProc != &TclInfoExistsCmd) { + /* + * Maps to something unexpected. Help! + */ + + return TCL_ERROR; + } + + /* + * OK, it really is [info exists]! + */ + } else { + return TCL_ERROR; + } + + /* + * Decide if we can use a frame slot for the var/array name or if we need + * to emit code to compute and push the name at runtime. We use a frame + * slot (entry in the array of local vars) if we are compiling a procedure + * body and if the name is simple text that does not include namespace + * qualifiers. + */ + + tokenPtr = TokenAfter(tokenPtr); + PushVarName(interp, tokenPtr, envPtr, TCL_CREATE_VAR, &localIndex, + &simpleVarName, &isScalar, mapPtr->loc[eclIndex].line[2]); + + /* + * Emit instruction to check the variable for existence. + */ + if (simpleVarName) { + if (isScalar) { + if (localIndex < 0) { + TclEmitOpcode(INST_EXIST_STK, envPtr); + } else { + TclEmitInstInt4(INST_EXIST_SCALAR, localIndex, envPtr); + } + } else { + if (localIndex < 0) { + TclEmitOpcode(INST_EXIST_ARRAY_STK, envPtr); + } else { + TclEmitInstInt4(INST_EXIST_ARRAY, localIndex, envPtr); + } + } + } else { + TclEmitOpcode(INST_EXIST_STK, envPtr); + } + + return TCL_OK; +} /* * Local Variables: diff --git a/generic/tclCompile.c b/generic/tclCompile.c index 25b9d1e..cffb8a4 100644 --- a/generic/tclCompile.c +++ b/generic/tclCompile.c @@ -11,7 +11,7 @@ * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclCompile.c,v 1.117.2.13 2007/11/12 19:18:16 dgp Exp $ + * RCS: @(#) $Id: tclCompile.c,v 1.117.2.14 2007/11/16 07:20:53 dgp Exp $ */ #include "tclInt.h" @@ -388,6 +388,17 @@ InstructionDesc tclInstructionTable[] = { {"regexp", 2, -1, 1, {OPERAND_INT1}}, /* Regexp: push (regexp stknext stktop) opnd == nocase */ + + {"existScalar", 5, 1, 1, {OPERAND_LVT4}}, + /* Test if scalar variable at index op1 in call frame exists */ + {"existArray", 5, 0, 1, {OPERAND_LVT4}}, + /* Test if array element exists; array at slot op1, element is + * stktop */ + {"existArrayStk", 1, -1, 0, {OPERAND_NONE}}, + /* Test if array element exists; element is stktop, array name is + * stknext */ + {"existStk", 1, 0, 0, {OPERAND_NONE}}, + /* Test if general variable exists; unparsed variable name is stktop*/ {0} }; @@ -1138,9 +1149,9 @@ TclCompileScript( Tcl_DString ds; /* TIP #280 */ ExtCmdLoc *eclPtr = envPtr->extCmdMapPtr; - int *wlines; - int wlineat, cmdLine; - Tcl_Parse *parsePtr = (Tcl_Parse *) TclStackAlloc(interp, sizeof(Tcl_Parse)); + int *wlines, wlineat, cmdLine; + Tcl_Parse *parsePtr = (Tcl_Parse *) + TclStackAlloc(interp, sizeof(Tcl_Parse)); Tcl_DStringInit(&ds); @@ -1167,8 +1178,10 @@ TclCompileScript( cmdLine = envPtr->line; do { if (Tcl_ParseCommand(interp, p, bytesLeft, 0, parsePtr) != TCL_OK) { + /* + * Compile bytecodes to report the parse error at runtime. + */ - /* Compile bytecodes to report the parse error at runtime. */ Tcl_LogCommandInfo(interp, script, parsePtr->commandStart, /* Drop the command terminator (";","]") if appropriate */ (parsePtr->term == @@ -1179,8 +1192,8 @@ TclCompileScript( } gotParse = 1; if (parsePtr->numWords > 0) { - int expand = 0; /* Set if there are dynamic expansions - * to handle */ + int expand = 0; /* Set if there are dynamic expansions to + * handle */ /* * If not the first command, pop the previous command's result @@ -1264,8 +1277,9 @@ TclCompileScript( TclAdvanceLines(&cmdLine, p, parsePtr->commandStart); EnterCmdWordData(eclPtr, parsePtr->commandStart - envPtr->source, - parsePtr->tokenPtr, parsePtr->commandStart, parsePtr->commandSize, - parsePtr->numWords, cmdLine, &wlines); + parsePtr->tokenPtr, parsePtr->commandStart, + parsePtr->commandSize, parsePtr->numWords, cmdLine, + &wlines); wlineat = eclPtr->nuloc - 1; /* @@ -1335,6 +1349,7 @@ TclCompileScript( * produce such a beast (currently 'while 1' only) set * envPtr->atCmdStart to 0 in order to signal this * case. [Bug 1752146] + * * Note that the environment is initialised with * atCmdStart=1 to avoid emitting ISC for the first * command. @@ -1377,6 +1392,20 @@ TclCompileScript( } goto finishCommand; } else { + if (envPtr->atCmdStart && savedCodeNext != 0) { + /* + * Decrease the number of commands being + * started at the current point. Note that + * this depends on the exact layout of the + * INST_START_CMD's operands, so be careful! + */ + + unsigned char *fixPtr = envPtr->codeNext - 4; + + TclStoreInt4AtPtr(TclGetUInt4AtPtr(fixPtr)-1, + fixPtr); + } + /* * Restore numCommands and codeNext to their * correct values, removing any commands compiled @@ -1563,11 +1592,10 @@ TclCompileTokens( */ if (Tcl_DStringLength(&textBuffer) > 0) { - int literal; - - literal = TclRegisterNewLiteral(envPtr, + int literal = TclRegisterNewLiteral(envPtr, Tcl_DStringValue(&textBuffer), Tcl_DStringLength(&textBuffer)); + TclEmitPush(literal, envPtr); numObjsToConcat++; Tcl_DStringFree(&textBuffer); @@ -1909,8 +1937,7 @@ TclInitByteCodeObj( #endif int numLitObjects = envPtr->literalArrayNext; Namespace *namespacePtr; - int i; - int new; + int i, isNew; Interp *iPtr; iPtr = envPtr->iPtr; @@ -2027,7 +2054,7 @@ TclInitByteCodeObj( */ Tcl_SetHashValue(Tcl_CreateHashEntry(iPtr->lineBCPtr, (char *) codePtr, - &new), envPtr->extCmdMapPtr); + &isNew), envPtr->extCmdMapPtr); envPtr->extCmdMapPtr = NULL; codePtr->localCachePtr = NULL; @@ -2127,8 +2154,8 @@ TclFindCompiledLocal( procPtr->numCompiledLocals++; } return localVar; - } + /* *---------------------------------------------------------------------- * @@ -3621,7 +3648,7 @@ FormatInstruction( int opnd = 0, i, j, numBytes = 1; int localCt = procPtr ? procPtr->numCompiledLocals : 0; CompiledLocal *localPtr = procPtr ? procPtr->firstLocalPtr : NULL; - char suffixBuffer[64]; /* Additional info to print after main opcode + char suffixBuffer[128]; /* Additional info to print after main opcode * and immediates. */ char *suffixSrc = NULL; Tcl_Obj *suffixObj = NULL; @@ -3662,7 +3689,8 @@ FormatInstruction( if (opCode == INST_PUSH4) { suffixObj = codePtr->objArrayPtr[opnd]; } else if (opCode == INST_START_CMD && opnd != 1) { - sprintf(suffixBuffer, ", %u cmds start here", opnd); + sprintf(suffixBuffer+strlen(suffixBuffer), + ", %u cmds start here", opnd); } Tcl_AppendPrintfToObj(bufferObj, "%u ", (unsigned int) opnd); if (instDesc->opTypes[i] == OPERAND_AUX4) { diff --git a/generic/tclCompile.h b/generic/tclCompile.h index e8d5cbc..8d94530 100644 --- a/generic/tclCompile.h +++ b/generic/tclCompile.h @@ -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. * - * RCS: @(#) $Id: tclCompile.h,v 1.70.2.11 2007/11/12 19:18:16 dgp Exp $ + * RCS: @(#) $Id: tclCompile.h,v 1.70.2.12 2007/11/16 07:20:53 dgp Exp $ */ #ifndef _TCLCOMPILATION @@ -640,8 +640,14 @@ typedef struct ByteCode { #define INST_REGEXP 127 +/* For [info exists] compilation */ +#define INST_EXIST_SCALAR 128 +#define INST_EXIST_ARRAY 129 +#define INST_EXIST_ARRAY_STK 130 +#define INST_EXIST_STK 131 + /* The last opcode */ -#define LAST_INST_OPCODE 127 +#define LAST_INST_OPCODE 131 /* * Table describing the Tcl bytecode instructions: their name (for displaying diff --git a/generic/tclExecute.c b/generic/tclExecute.c index bb83839..35d2f41 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -13,7 +13,7 @@ * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclExecute.c,v 1.285.2.23 2007/11/13 13:07:41 dgp Exp $ + * RCS: @(#) $Id: tclExecute.c,v 1.285.2.24 2007/11/16 07:20:54 dgp Exp $ */ #include "tclInt.h" @@ -1721,8 +1721,6 @@ TclExecuteByteCode( iPtr->stats.instructionCount[*pc]++; #endif - TCL_DTRACE_INST_NEXT(); - /* * Check for asynchronous handlers [Bug 746722]; we do the check every * ASYNC_CHECK_COUNT_MASK instruction, of the form (2**n-1). @@ -1758,6 +1756,8 @@ TclExecuteByteCode( } } + TCL_DTRACE_INST_NEXT(); + /* * These two instructions account for 26% of all instructions (according * to measurements on tclbench by Ben Vitale @@ -3107,6 +3107,121 @@ TclExecuteByteCode( * --------------------------------------------------------- */ + /* + * --------------------------------------------------------- + * Start of INST_EXIST instructions. + */ + { + int opnd, pcAdjustment; + Tcl_Obj *part1Ptr, *part2Ptr; + Var *varPtr, *arrayPtr; + +#define ReadTraced(varPtr) ((varPtr)->flags & VAR_TRACED_READ) + + case INST_EXIST_SCALAR: + opnd = TclGetUInt4AtPtr(pc+1); + varPtr = &(compiledLocals[opnd]); + while (TclIsVarLink(varPtr)) { + varPtr = varPtr->value.linkPtr; + } + TRACE(("%u => ", opnd)); + if (ReadTraced(varPtr)) { + DECACHE_STACK_INFO(); + if (TclObjCallVarTraces(iPtr, NULL, varPtr, NULL, NULL, + TCL_TRACE_READS, 0, opnd) != TCL_OK) { + varPtr = NULL; + } + CACHE_STACK_INFO(); + } + /* + * Tricky! Arrays always exist. + */ + if (varPtr == NULL || varPtr->value.objPtr == NULL) { + objResultPtr = constants[0]; + } else { + objResultPtr = constants[1]; + } + TRACE_APPEND(("%.30s\n", O2S(objResultPtr))); + NEXT_INST_F(5, 0, 1); + + case INST_EXIST_ARRAY: + opnd = TclGetUInt4AtPtr(pc+1); + part2Ptr = OBJ_AT_TOS; + arrayPtr = &(compiledLocals[opnd]); + while (TclIsVarLink(arrayPtr)) { + arrayPtr = arrayPtr->value.linkPtr; + } + TRACE(("%u \"%.30s\" => ", opnd, O2S(part2Ptr))); + if (TclIsVarArray(arrayPtr) && !ReadTraced(arrayPtr)) { + varPtr = VarHashFindVar(arrayPtr->value.tablePtr, part2Ptr); + if (!varPtr) { + objResultPtr = constants[0]; + TRACE_APPEND(("%.30s\n", O2S(objResultPtr))); + NEXT_INST_F(5, 1, 1); + } else if (!ReadTraced(varPtr)) { + objResultPtr = constants[varPtr->value.objPtr != NULL ? 1:0]; + TRACE_APPEND(("%.30s\n", O2S(objResultPtr))); + NEXT_INST_F(5, 1, 1); + } + } + varPtr = TclLookupArrayElement(interp, NULL, part2Ptr, 0, "access", + 0, 0, arrayPtr, opnd); + if (varPtr&&(ReadTraced(varPtr)||(arrayPtr&&ReadTraced(arrayPtr)))) { + DECACHE_STACK_INFO(); + if (TclObjCallVarTraces(iPtr, arrayPtr, varPtr, NULL, + part2Ptr, TCL_TRACE_READS, 0, opnd) != TCL_OK) { + varPtr = NULL; + } + CACHE_STACK_INFO(); + } + if (varPtr == NULL) { + objResultPtr = constants[0]; + } else { + objResultPtr = constants[varPtr->value.objPtr != NULL ? 1 : 0]; + } + TRACE_APPEND(("%.30s\n", O2S(objResultPtr))); + NEXT_INST_F(5, 1, 1); + + case INST_EXIST_ARRAY_STK: + cleanup = 2; + pcAdjustment = 1; + part2Ptr = OBJ_AT_TOS; /* element name */ + part1Ptr = OBJ_UNDER_TOS; /* array name */ + TRACE(("\"%.30s(%.30s)\" => ", O2S(part1Ptr), O2S(part2Ptr))); + goto doExistStk; + + case INST_EXIST_STK: + cleanup = 1; + pcAdjustment = 1; + part2Ptr = NULL; + part1Ptr = OBJ_AT_TOS; /* variable name */ + TRACE(("\"%.30s\" => ", O2S(part1Ptr))); + + doExistStk: + varPtr = TclObjLookupVarEx(interp, part1Ptr, part2Ptr, 0, "access", + /*createPart1*/0, /*createPart2*/0, &arrayPtr); + if (varPtr&&(ReadTraced(varPtr)||(arrayPtr&&ReadTraced(arrayPtr)))) { + DECACHE_STACK_INFO(); + if (TclObjCallVarTraces(iPtr, arrayPtr, varPtr, part1Ptr, + part2Ptr, TCL_TRACE_READS, 0, -1) != TCL_OK) { + varPtr = NULL; + } + CACHE_STACK_INFO(); + } + if (!varPtr) { + objResultPtr = constants[0]; + } else { + objResultPtr = constants[varPtr->value.objPtr != NULL ? 1:0]; + } + TRACE_APPEND(("%.30s\n", O2S(objResultPtr))); + NEXT_INST_V(pcAdjustment, cleanup, 1); + } + + /* + * End of INST_EXIST instructions. + * --------------------------------------------------------- + */ + case INST_UPVAR: { int opnd; Var *varPtr, *otherPtr; diff --git a/generic/tclInt.h b/generic/tclInt.h index 639a8c4..9fb2502 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -13,7 +13,7 @@ * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclInt.h,v 1.310.2.14 2007/11/13 13:07:42 dgp Exp $ + * RCS: @(#) $Id: tclInt.h,v 1.310.2.15 2007/11/16 07:20:54 dgp Exp $ */ #ifndef _TCLINT @@ -2471,6 +2471,8 @@ MODULE_SCOPE int TclIncrObj(Tcl_Interp *interp, Tcl_Obj *valuePtr, Tcl_Obj *incrPtr); MODULE_SCOPE Tcl_Obj * TclIncrObjVar2(Tcl_Interp *interp, Tcl_Obj *part1Ptr, Tcl_Obj *part2Ptr, Tcl_Obj *incrPtr, int flags); +MODULE_SCOPE int TclInfoExistsCmd(ClientData dummy, Tcl_Interp *interp, + int objc, Tcl_Obj *CONST objv[]); MODULE_SCOPE Tcl_Obj * TclInfoFrame(Tcl_Interp *interp, CmdFrame *framePtr); MODULE_SCOPE int TclInfoGlobalsCmd(ClientData dummy, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]); @@ -2551,7 +2553,7 @@ MODULE_SCOPE int TclpDeleteFile(CONST char *path); MODULE_SCOPE void TclpFinalizeCondition(Tcl_Condition *condPtr); MODULE_SCOPE void TclpFinalizeMutex(Tcl_Mutex *mutexPtr); MODULE_SCOPE void TclpFinalizePipes(void); -MODULE_SCOPE void TclpFinalizeSockets _ANSI_ARGS_((void)); +MODULE_SCOPE void TclpFinalizeSockets(void); MODULE_SCOPE int TclpThreadCreate(Tcl_ThreadId *idPtr, Tcl_ThreadCreateProc proc, ClientData clientData, int stackSize, int flags); @@ -2941,6 +2943,8 @@ MODULE_SCOPE int TclCompileGlobalCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, struct CompileEnv *envPtr); MODULE_SCOPE int TclCompileIfCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, struct CompileEnv *envPtr); +MODULE_SCOPE int TclCompileInfoCmd(Tcl_Interp *interp, + Tcl_Parse *parsePtr, struct CompileEnv *envPtr); MODULE_SCOPE int TclCompileIncrCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, struct CompileEnv *envPtr); MODULE_SCOPE int TclCompileLappendCmd(Tcl_Interp *interp, diff --git a/generic/tclNamesp.c b/generic/tclNamesp.c index 1863faf..fe14f14 100644 --- a/generic/tclNamesp.c +++ b/generic/tclNamesp.c @@ -23,7 +23,7 @@ * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclNamesp.c,v 1.134.2.10 2007/11/12 19:18:20 dgp Exp $ + * RCS: @(#) $Id: tclNamesp.c,v 1.134.2.11 2007/11/16 07:20:54 dgp Exp $ */ #include "tclInt.h" @@ -5200,10 +5200,10 @@ NamespaceEnsembleCmd( flags = (permitPrefix ? flags|TCL_ENSEMBLE_PREFIX : flags&~TCL_ENSEMBLE_PREFIX); - Tcl_SetEnsembleSubcommandList(NULL, token, subcmdObj); - Tcl_SetEnsembleMappingDict(NULL, token, mapObj); - Tcl_SetEnsembleUnknownHandler(NULL, token, unknownObj); - Tcl_SetEnsembleFlags(NULL, token, flags); + Tcl_SetEnsembleSubcommandList(interp, token, subcmdObj); + Tcl_SetEnsembleMappingDict(interp, token, mapObj); + Tcl_SetEnsembleUnknownHandler(interp, token, unknownObj); + Tcl_SetEnsembleFlags(interp, token, flags); return TCL_OK; } @@ -5318,13 +5318,12 @@ Tcl_SetEnsembleSubcommandList( Tcl_Obj *oldList; if (cmdPtr->objProc != NsEnsembleImplementationCmd) { - if (interp != NULL) { - Tcl_AppendResult(interp, "command is not an ensemble", NULL); - } + Tcl_AppendResult(interp, "command is not an ensemble", NULL); return TCL_ERROR; } if (subcmdList != NULL) { int length; + if (TclListObjLength(interp, subcmdList, &length) != TCL_OK) { return TCL_ERROR; } @@ -5352,6 +5351,18 @@ Tcl_SetEnsembleSubcommandList( ensemblePtr->nsPtr->exportLookupEpoch++; + /* + * Special hack to make compiling of [info exists] work when the + * dictionary is modified. + */ + + if (cmdPtr->compileProc != NULL) { + ((Interp *)interp)->compileEpoch++; + if (subcmdList != NULL) { + cmdPtr->compileProc = NULL; + } + } + return TCL_OK; } @@ -5383,13 +5394,12 @@ Tcl_SetEnsembleMappingDict( Tcl_Obj *oldDict; if (cmdPtr->objProc != NsEnsembleImplementationCmd) { - if (interp != NULL) { - Tcl_AppendResult(interp, "command is not an ensemble", NULL); - } + Tcl_AppendResult(interp, "command is not an ensemble", NULL); return TCL_ERROR; } if (mapDict != NULL) { int size; + if (Tcl_DictObjSize(interp, mapDict, &size) != TCL_OK) { return TCL_ERROR; } @@ -5417,6 +5427,18 @@ Tcl_SetEnsembleMappingDict( ensemblePtr->nsPtr->exportLookupEpoch++; + /* + * Special hack to make compiling of [info exists] work when the + * dictionary is modified. + */ + + if (cmdPtr->compileProc != NULL) { + ((Interp *)interp)->compileEpoch++; + if (mapDict == NULL) { + cmdPtr->compileProc = NULL; + } + } + return TCL_OK; } @@ -5448,9 +5470,7 @@ Tcl_SetEnsembleUnknownHandler( Tcl_Obj *oldList; if (cmdPtr->objProc != NsEnsembleImplementationCmd) { - if (interp != NULL) { - Tcl_AppendResult(interp, "command is not an ensemble", NULL); - } + Tcl_AppendResult(interp, "command is not an ensemble", NULL); return TCL_ERROR; } if (unknownList != NULL) { @@ -5513,9 +5533,7 @@ Tcl_SetEnsembleFlags( EnsembleConfig *ensemblePtr; if (cmdPtr->objProc != NsEnsembleImplementationCmd) { - if (interp != NULL) { - Tcl_AppendResult(interp, "command is not an ensemble", NULL); - } + Tcl_AppendResult(interp, "command is not an ensemble", NULL); return TCL_ERROR; } diff --git a/generic/tclTrace.c b/generic/tclTrace.c index 1dffdf2..8fd1377 100644 --- a/generic/tclTrace.c +++ b/generic/tclTrace.c @@ -11,7 +11,7 @@ * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclTrace.c,v 1.37.2.6 2007/09/17 15:03:45 dgp Exp $ + * RCS: @(#) $Id: tclTrace.c,v 1.37.2.7 2007/11/16 07:20:54 dgp Exp $ */ #include "tclInt.h" @@ -96,7 +96,7 @@ typedef struct { */ typedef int (Tcl_TraceTypeObjCmd)(Tcl_Interp *interp, int optionIndex, - int objc, Tcl_Obj *CONST objv[]); + int objc, Tcl_Obj *const objv[]); static Tcl_TraceTypeObjCmd TraceVariableObjCmd; static Tcl_TraceTypeObjCmd TraceCommandObjCmd; @@ -109,7 +109,7 @@ static Tcl_TraceTypeObjCmd TraceExecutionObjCmd; * add to the list of supported trace types. */ -static CONST char *traceTypeOptions[] = { +static const char *traceTypeOptions[] = { "execution", "command", "variable", NULL }; static Tcl_TraceTypeObjCmd *traceSubCmds[] = { @@ -123,22 +123,22 @@ static Tcl_TraceTypeObjCmd *traceSubCmds[] = { */ static int CallTraceFunction(Tcl_Interp *interp, Trace *tracePtr, - Command *cmdPtr, CONST char *command, int numChars, - int objc, Tcl_Obj *CONST objv[]); + Command *cmdPtr, const char *command, int numChars, + int objc, Tcl_Obj *const objv[]); static char * TraceVarProc(ClientData clientData, Tcl_Interp *interp, - CONST char *name1, CONST char *name2, int flags); + const char *name1, const char *name2, int flags); static void TraceCommandProc(ClientData clientData, - Tcl_Interp *interp, CONST char *oldName, - CONST char *newName, int flags); + Tcl_Interp *interp, const char *oldName, + const char *newName, int flags); static Tcl_CmdObjTraceProc TraceExecutionProc; static int StringTraceProc(ClientData clientData, - Tcl_Interp* interp, int level, - CONST char* command, Tcl_Command commandInfo, - int objc, Tcl_Obj *CONST objv[]); + Tcl_Interp *interp, int level, + const char *command, Tcl_Command commandInfo, + int objc, Tcl_Obj *const objv[]); static void StringTraceDeleteProc(ClientData clientData); static void DisposeTraceResult(int flags, char *result); -static int TraceVarEx(Tcl_Interp *interp, CONST char *part1, - CONST char *part2, register VarTrace *tracePtr); +static int TraceVarEx(Tcl_Interp *interp, const char *part1, + const char *part2, register VarTrace *tracePtr); /* * The following structure holds the client data for string-based @@ -147,7 +147,7 @@ static int TraceVarEx(Tcl_Interp *interp, CONST char *part1, typedef struct StringTraceData { ClientData clientData; /* Client data from Tcl_CreateTrace */ - Tcl_CmdTraceProc* proc; /* Trace function from Tcl_CreateTrace */ + Tcl_CmdTraceProc *proc; /* Trace function from Tcl_CreateTrace */ } StringTraceData; /* @@ -175,12 +175,12 @@ Tcl_TraceObjCmd( ClientData dummy, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ - Tcl_Obj *CONST objv[]) /* Argument objects. */ + Tcl_Obj *const objv[]) /* Argument objects. */ { int optionIndex; char *name, *flagOps, *p; /* Main sub commands to 'trace' */ - static CONST char *traceOptions[] = { + static const char *traceOptions[] = { "add", "info", "remove", #ifndef TCL_REMOVE_OBSOLETE_TRACES "variable", "vdelete", "vinfo", @@ -384,7 +384,7 @@ TraceExecutionObjCmd( Tcl_Interp *interp, /* Current interpreter. */ int optionIndex, /* Add, info or remove */ int objc, /* Number of arguments. */ - Tcl_Obj *CONST objv[]) /* Argument objects. */ + Tcl_Obj *const objv[]) /* Argument objects. */ { int commandLength, index; char *name, *command; @@ -392,7 +392,7 @@ TraceExecutionObjCmd( enum traceOptions { TRACE_ADD, TRACE_INFO, TRACE_REMOVE }; - static CONST char *opStrings[] = { + static const char *opStrings[] = { "enter", "leave", "enterstep", "leavestep", NULL }; enum operations { @@ -523,7 +523,7 @@ TraceExecutionObjCmd( Tcl_DeleteTrace(interp, tcmdPtr->stepTrace); tcmdPtr->stepTrace = NULL; if (tcmdPtr->startCmd != NULL) { - ckfree((char *)tcmdPtr->startCmd); + ckfree((char *) tcmdPtr->startCmd); } } if (tcmdPtr->flags & TCL_TRACE_EXEC_IN_PROGRESS) { @@ -534,7 +534,7 @@ TraceExecutionObjCmd( tcmdPtr->flags = 0; } if ((--tcmdPtr->refCount) <= 0) { - ckfree((char*)tcmdPtr); + ckfree((char *) tcmdPtr); } break; } @@ -638,13 +638,13 @@ TraceCommandObjCmd( Tcl_Interp *interp, /* Current interpreter. */ int optionIndex, /* Add, info or remove */ int objc, /* Number of arguments. */ - Tcl_Obj *CONST objv[]) /* Argument objects. */ + Tcl_Obj *const objv[]) /* Argument objects. */ { int commandLength, index; char *name, *command; size_t length; enum traceOptions { TRACE_ADD, TRACE_INFO, TRACE_REMOVE }; - static CONST char *opStrings[] = { "delete", "rename", NULL }; + static const char *opStrings[] = { "delete", "rename", NULL }; enum operations { TRACE_CMD_DELETE, TRACE_CMD_RENAME }; switch ((enum traceOptions) optionIndex) { @@ -836,13 +836,13 @@ TraceVariableObjCmd( Tcl_Interp *interp, /* Current interpreter. */ int optionIndex, /* Add, info or remove */ int objc, /* Number of arguments. */ - Tcl_Obj *CONST objv[]) /* Argument objects. */ + Tcl_Obj *const objv[]) /* Argument objects. */ { int commandLength, index; char *name, *command; size_t length; enum traceOptions { TRACE_ADD, TRACE_INFO, TRACE_REMOVE }; - static CONST char *opStrings[] = { + static const char *opStrings[] = { "array", "read", "unset", "write", NULL }; enum operations { @@ -1028,7 +1028,7 @@ TraceVariableObjCmd( ClientData Tcl_CommandTraceInfo( Tcl_Interp *interp, /* Interpreter containing command. */ - CONST char *cmdName, /* Name of command. */ + const char *cmdName, /* Name of command. */ int flags, /* OR-ed combo or TCL_GLOBAL_ONLY, * TCL_NAMESPACE_ONLY (can be 0). */ Tcl_CommandTraceProc *proc, /* Function assocated with trace. */ @@ -1094,7 +1094,7 @@ int Tcl_TraceCommand( Tcl_Interp *interp, /* Interpreter in which command is to be * traced. */ - CONST char *cmdName, /* Name of command. */ + const char *cmdName, /* Name of command. */ int flags, /* OR-ed collection of bits, including any of * TCL_TRACE_RENAME, TCL_TRACE_DELETE, and any * of the TRACE_*_EXEC flags */ @@ -1149,7 +1149,7 @@ Tcl_TraceCommand( void Tcl_UntraceCommand( Tcl_Interp *interp, /* Interpreter containing command. */ - CONST char *cmdName, /* Name of command. */ + const char *cmdName, /* Name of command. */ int flags, /* OR-ed collection of bits, including any of * TCL_TRACE_RENAME, TCL_TRACE_DELETE, and any * of the TRACE_*_EXEC flags */ @@ -1163,7 +1163,7 @@ Tcl_UntraceCommand( ActiveCommandTrace *activePtr; int hasExecTraces = 0; - cmdPtr = (Command*)Tcl_FindCommand(interp, cmdName, NULL, + cmdPtr = (Command *) Tcl_FindCommand(interp, cmdName, NULL, TCL_LEAVE_ERR_MSG); if (cmdPtr == NULL) { return; @@ -1211,7 +1211,7 @@ Tcl_UntraceCommand( tracePtr->flags = 0; if ((--tracePtr->refCount) <= 0) { - ckfree((char*)tracePtr); + ckfree((char *) tracePtr); } if (hasExecTraces) { @@ -1254,8 +1254,8 @@ static void TraceCommandProc( ClientData clientData, /* Information about the command trace. */ Tcl_Interp *interp, /* Interpreter containing command. */ - CONST char *oldName, /* Name of command being changed. */ - CONST char *newName, /* New name of command. Empty string or NULL + const char *oldName, /* Name of command being changed. */ + const char *newName, /* New name of command. Empty string or NULL * means command is being deleted (renamed to * ""). */ int flags) /* OR-ed bits giving operation and other @@ -1318,7 +1318,7 @@ TraceCommandProc( Tcl_DeleteTrace(interp, tcmdPtr->stepTrace); tcmdPtr->stepTrace = NULL; if (tcmdPtr->startCmd != NULL) { - ckfree((char *)tcmdPtr->startCmd); + ckfree((char *) tcmdPtr->startCmd); } } if (tcmdPtr->flags & TCL_TRACE_EXEC_IN_PROGRESS) { @@ -1361,7 +1361,7 @@ TraceCommandProc( tcmdPtr->refCount--; } if ((--tcmdPtr->refCount) <= 0) { - ckfree((char*)tcmdPtr); + ckfree((char *) tcmdPtr); } } @@ -1393,7 +1393,7 @@ TraceCommandProc( int TclCheckExecutionTraces( Tcl_Interp *interp, /* The current interpreter. */ - CONST char *command, /* Pointer to beginning of the current command + const char *command, /* Pointer to beginning of the current command * string. */ int numChars, /* The number of characters in 'command' which * are part of the command string. */ @@ -1401,14 +1401,13 @@ TclCheckExecutionTraces( int code, /* The current result code. */ int traceFlags, /* Current tracing situation. */ int objc, /* Number of arguments for the command. */ - Tcl_Obj *CONST objv[]) /* Pointers to Tcl_Obj of each argument. */ + Tcl_Obj *const objv[]) /* Pointers to Tcl_Obj of each argument. */ { Interp *iPtr = (Interp *) interp; CommandTrace *tracePtr, *lastTracePtr; ActiveCommandTrace active; int curLevel; int traceCode = TCL_OK; - TraceCommandInfo* tcmdPtr; Tcl_InterpState state = NULL; if (cmdPtr->tracePtr == NULL) { @@ -1442,7 +1441,9 @@ TclCheckExecutionTraces( active.nextTracePtr = tracePtr->nextPtr; } if (tracePtr->traceProc == TraceCommandProc) { - tcmdPtr = (TraceCommandInfo*)tracePtr->clientData; + TraceCommandInfo *tcmdPtr = (TraceCommandInfo *) + tracePtr->clientData; + if (tcmdPtr->flags != 0) { tcmdPtr->curFlags = traceFlags | TCL_TRACE_EXEC_DIRECT; tcmdPtr->curCode = code; @@ -1450,10 +1451,10 @@ TclCheckExecutionTraces( if (state == NULL) { state = Tcl_SaveInterpState(interp, code); } - traceCode = TraceExecutionProc((ClientData)tcmdPtr, interp, - curLevel, command, (Tcl_Command)cmdPtr, objc, objv); + traceCode = TraceExecutionProc((ClientData) tcmdPtr, interp, + curLevel, command, (Tcl_Command) cmdPtr, objc, objv); if ((--tcmdPtr->refCount) <= 0) { - ckfree((char*)tcmdPtr); + ckfree((char *) tcmdPtr); } } } @@ -1495,7 +1496,7 @@ TclCheckExecutionTraces( int TclCheckInterpTraces( Tcl_Interp *interp, /* The current interpreter. */ - CONST char *command, /* Pointer to beginning of the current command + const char *command, /* Pointer to beginning of the current command * string. */ int numChars, /* The number of characters in 'command' which * are part of the command string. */ @@ -1503,7 +1504,7 @@ TclCheckInterpTraces( int code, /* The current result code. */ int traceFlags, /* Current tracing situation. */ int objc, /* Number of arguments for the command. */ - Tcl_Obj *CONST objv[]) /* Pointers to Tcl_Obj of each argument. */ + Tcl_Obj *const objv[]) /* Pointers to Tcl_Obj of each argument. */ { Interp *iPtr = (Interp *) interp; Trace *tracePtr, *lastTracePtr; @@ -1578,10 +1579,11 @@ TclCheckInterpTraces( if (tracePtr->flags & traceFlags) { if (tracePtr->proc == TraceExecutionProc) { - TraceCommandInfo* tcmdPtr = - (TraceCommandInfo *) tracePtr->clientData; + TraceCommandInfo *tcmdPtr = (TraceCommandInfo *) + tracePtr->clientData; + tcmdPtr->curFlags = traceFlags; - tcmdPtr->curCode = code; + tcmdPtr->curCode = code; } traceCode = (tracePtr->proc)(tracePtr->clientData, interp, curLevel, command, (Tcl_Command) cmdPtr, @@ -1642,12 +1644,12 @@ CallTraceFunction( Tcl_Interp *interp, /* The current interpreter. */ register Trace *tracePtr, /* Describes the trace function to call. */ Command *cmdPtr, /* Points to command's Command struct. */ - CONST char *command, /* Points to the first character of the + const char *command, /* Points to the first character of the * command's source before substitutions. */ int numChars, /* The number of characters in the command's * source. */ register int objc, /* Number of arguments for the command. */ - Tcl_Obj *CONST objv[]) /* Pointers to Tcl_Obj of each argument. */ + Tcl_Obj *const objv[]) /* Pointers to Tcl_Obj of each argument. */ { Interp *iPtr = (Interp *) interp; char *commandCopy; @@ -1658,14 +1660,14 @@ CallTraceFunction( */ commandCopy = TclStackAlloc(interp, (unsigned) (numChars + 1)); - memcpy((void *) commandCopy, (void *) command, (size_t) numChars); + memcpy(commandCopy, command, (size_t) numChars); commandCopy[numChars] = '\0'; /* * Call the trace function then free allocated storage. */ - traceCode = (tracePtr->proc)(tracePtr->clientData, (Tcl_Interp*) iPtr, + traceCode = (tracePtr->proc)(tracePtr->clientData, (Tcl_Interp *) iPtr, iPtr->numLevels, commandCopy, (Tcl_Command) cmdPtr, objc, objv); TclStackFree(interp, commandCopy); @@ -1693,9 +1695,10 @@ static void CommandObjTraceDeleted( ClientData clientData) { - TraceCommandInfo* tcmdPtr = (TraceCommandInfo*)clientData; + TraceCommandInfo *tcmdPtr = (TraceCommandInfo *) clientData; + if ((--tcmdPtr->refCount) <= 0) { - ckfree((char*)tcmdPtr); + ckfree((char *) tcmdPtr); } } @@ -1729,17 +1732,17 @@ TraceExecutionProc( ClientData clientData, Tcl_Interp *interp, int level, - CONST char *command, + const char *command, Tcl_Command cmdInfo, int objc, - struct Tcl_Obj *CONST objv[]) + struct Tcl_Obj *const objv[]) { int call = 0; Interp *iPtr = (Interp *) interp; - TraceCommandInfo* tcmdPtr = (TraceCommandInfo*)clientData; + TraceCommandInfo *tcmdPtr = (TraceCommandInfo *) clientData; int flags = tcmdPtr->curFlags; - int code = tcmdPtr->curCode; - int traceCode = TCL_OK; + int code = tcmdPtr->curCode; + int traceCode = TCL_OK; if (tcmdPtr->flags & TCL_TRACE_EXEC_IN_PROGRESS) { /* @@ -1778,7 +1781,7 @@ TraceExecutionProc( Tcl_DeleteTrace(interp, tcmdPtr->stepTrace); tcmdPtr->stepTrace = NULL; if (tcmdPtr->startCmd != NULL) { - ckfree((char *)tcmdPtr->startCmd); + ckfree((char *) tcmdPtr->startCmd); } } @@ -1816,8 +1819,8 @@ TraceExecutionProc( Tcl_DStringAppendElement(&cmd, "enterstep"); } } else if (flags & TCL_TRACE_LEAVE_EXEC) { - Tcl_Obj* resultCode; - char* resultCodeStr; + Tcl_Obj *resultCode; + char *resultCodeStr; /* * Append result code. @@ -1866,10 +1869,11 @@ TraceExecutionProc( traceCode = Tcl_Eval(interp, Tcl_DStringValue(&cmd)); tcmdPtr->flags &= ~TCL_TRACE_EXEC_IN_PROGRESS; - /* - * Restore the interp tracing flag to prevent cmd traces - * from affecting interp traces. + /* + * Restore the interp tracing flag to prevent cmd traces from + * affecting interp traces. */ + iPtr->flags = saveInterpFlags; if (tcmdPtr->flags == 0) { flags |= TCL_TRACE_DESTROYED; @@ -1888,10 +1892,11 @@ TraceExecutionProc( if ((flags & TCL_TRACE_ENTER_EXEC) && (tcmdPtr->stepTrace == NULL) && (tcmdPtr->flags & (TCL_TRACE_ENTER_DURING_EXEC | TCL_TRACE_LEAVE_DURING_EXEC))) { + register unsigned len = strlen(command) + 1; + tcmdPtr->startLevel = level; - tcmdPtr->startCmd = - (char *) ckalloc((unsigned) (strlen(command) + 1)); - strcpy(tcmdPtr->startCmd, command); + tcmdPtr->startCmd = ckalloc(len); + memcpy(tcmdPtr->startCmd, command, len); tcmdPtr->refCount++; tcmdPtr->stepTrace = Tcl_CreateObjTrace(interp, 0, (tcmdPtr->flags & TCL_TRACE_ANY_EXEC) >> 2, @@ -1904,13 +1909,13 @@ TraceExecutionProc( Tcl_DeleteTrace(interp, tcmdPtr->stepTrace); tcmdPtr->stepTrace = NULL; if (tcmdPtr->startCmd != NULL) { - ckfree((char *)tcmdPtr->startCmd); + ckfree(tcmdPtr->startCmd); } } } if (call) { if ((--tcmdPtr->refCount) <= 0) { - ckfree((char*)tcmdPtr); + ckfree((char *) tcmdPtr); } } return traceCode; @@ -1939,8 +1944,8 @@ static char * TraceVarProc( ClientData clientData, /* Information about the variable trace. */ Tcl_Interp *interp, /* Interpreter containing variable. */ - CONST char *name1, /* Name of variable or array. */ - CONST char *name2, /* Name of element within array; NULL means + const char *name1, /* Name of variable or array. */ + const char *name2, /* Name of element within array; NULL means * scalar variable is being referenced. */ int flags) /* OR-ed bits giving operation and other * information. */ @@ -2046,12 +2051,12 @@ TraceVarProc( * form: * * void proc(ClientData clientData, - * Tcl_Interp* interp, + * Tcl_Interp * interp, * int level, - * CONST char* command, + * const char * command, * Tcl_Command commandInfo, * int objc, - * Tcl_Obj *CONST objv[]); + * Tcl_Obj *const objv[]); * * The 'clientData' and 'interp' arguments to 'proc' will be the same as * the arguments to Tcl_CreateObjTrace. The 'level' argument gives the @@ -2090,12 +2095,12 @@ TraceVarProc( Tcl_Trace Tcl_CreateObjTrace( - Tcl_Interp* interp, /* Tcl interpreter */ + Tcl_Interp *interp, /* Tcl interpreter */ int level, /* Maximum nesting level */ int flags, /* Flags, see above */ - Tcl_CmdObjTraceProc* proc, /* Trace callback */ + Tcl_CmdObjTraceProc *proc, /* Trace callback */ ClientData clientData, /* Client data for the callback */ - Tcl_CmdObjTraceDeleteProc* delProc) + Tcl_CmdObjTraceDeleteProc *delProc) /* Function to call when trace is deleted */ { register Trace *tracePtr; @@ -2186,8 +2191,9 @@ Tcl_CreateTrace( * command. */ ClientData clientData) /* Arbitrary value word to pass to proc. */ { - StringTraceData* data; - data = (StringTraceData *) ckalloc(sizeof(*data)); + StringTraceData *data = (StringTraceData *) + ckalloc(sizeof(StringTraceData)); + data->clientData = clientData; data->proc = proc; return Tcl_CreateObjTrace(interp, level, 0, StringTraceProc, @@ -2213,16 +2219,16 @@ Tcl_CreateTrace( static int StringTraceProc( ClientData clientData, - Tcl_Interp* interp, + Tcl_Interp *interp, int level, - CONST char* command, + const char *command, Tcl_Command commandInfo, int objc, - Tcl_Obj *CONST *objv) + Tcl_Obj *const *objv) { - StringTraceData* data = (StringTraceData*) clientData; - Command* cmdPtr = (Command*) commandInfo; - CONST char** argv; /* Args to pass to string trace proc */ + StringTraceData *data = (StringTraceData *) clientData; + Command *cmdPtr = (Command *) commandInfo; + const char **argv; /* Args to pass to string trace proc */ int i; /* @@ -2230,8 +2236,8 @@ StringTraceProc( * which uses strings for everything. */ - argv = (CONST char **) TclStackAlloc(interp, - (unsigned) ((objc + 1) * sizeof(CONST char *))); + argv = (const char **) TclStackAlloc(interp, + (unsigned) ((objc + 1) * sizeof(const char *))); for (i = 0; i < objc; i++) { argv[i] = Tcl_GetString(objv[i]); } @@ -2245,7 +2251,7 @@ StringTraceProc( (data->proc)(data->clientData, interp, level, (char *) command, cmdPtr->proc, cmdPtr->clientData, objc, argv); - TclStackFree(interp, (void *)argv); + TclStackFree(interp, (void *) argv); return TCL_OK; } @@ -2360,7 +2366,7 @@ Tcl_DeleteTrace( * Delete the trace object. */ - Tcl_EventuallyFree((char*)tracePtr, TCL_DYNAMIC); + Tcl_EventuallyFree((char *) tracePtr, TCL_DYNAMIC); } /* @@ -2384,7 +2390,7 @@ Tcl_DeleteTrace( Var * TclVarTraceExists( Tcl_Interp *interp, /* The interpreter */ - CONST char *varName) /* The variable name */ + const char *varName) /* The variable name */ { Var *varPtr; Var *arrayPtr; @@ -2462,7 +2468,9 @@ TclObjCallVarTraces( int leaveErrMsg, /* If true, and one of the traces indicates an * error, then leave an error message and * stack trace information in *iPTr. */ - int index) + int index) /* Index into the local variable table of the + * variable, or -1. Only used when part1Ptr is + * NULL. */ { char *part1, *part2; @@ -2471,8 +2479,9 @@ TclObjCallVarTraces( } part1 = TclGetString(part1Ptr); part2 = part2Ptr? TclGetString(part2Ptr) : NULL; - - return TclCallVarTraces(iPtr, arrayPtr, varPtr, part1, part2, flags, leaveErrMsg); + + return TclCallVarTraces(iPtr, arrayPtr, varPtr, part1, part2, flags, + leaveErrMsg); } int @@ -2482,8 +2491,8 @@ TclCallVarTraces( * variable, or NULL if the variable isn't an * element of an array. */ Var *varPtr, /* Variable whose traces are to be invoked. */ - CONST char *part1, - CONST char *part2, /* Variable's two-part name. */ + const char *part1, + const char *part2, /* Variable's two-part name. */ int flags, /* Flags passed to trace functions: indicates * what's happening to variable, plus maybe * TCL_GLOBAL_ONLY or TCL_NAMESPACE_ONLY */ @@ -2494,7 +2503,7 @@ TclCallVarTraces( register VarTrace *tracePtr; ActiveVarTrace active; char *result; - CONST char *openParen, *p; + const char *openParen, *p; Tcl_DString nameCopy; int copiedName; int code = TCL_OK; @@ -2502,7 +2511,7 @@ TclCallVarTraces( Tcl_InterpState state = NULL; Tcl_HashEntry *hPtr; int traceflags = flags & VAR_ALL_TRACES; - + /* * If there are already similar trace functions active for the variable, * don't call them again. @@ -2568,9 +2577,9 @@ TclCallVarTraces( active.nextPtr = iPtr->activeVarTracePtr; iPtr->activeVarTracePtr = &active; Tcl_Preserve((ClientData) iPtr); - if (arrayPtr && !TclIsVarTraceActive(arrayPtr) && (arrayPtr->flags & traceflags)) { - hPtr = Tcl_FindHashEntry(&iPtr->varTraces, - (char *) arrayPtr); + if (arrayPtr && !TclIsVarTraceActive(arrayPtr) + && (arrayPtr->flags & traceflags)) { + hPtr = Tcl_FindHashEntry(&iPtr->varTraces, (char *) arrayPtr); active.varPtr = arrayPtr; for (tracePtr = (VarTrace *) Tcl_GetHashValue(hPtr); tracePtr != NULL; tracePtr = active.nextTracePtr) { @@ -2615,8 +2624,7 @@ TclCallVarTraces( } active.varPtr = varPtr; if (varPtr->flags & traceflags) { - hPtr = Tcl_FindHashEntry(&iPtr->varTraces, - (char *) varPtr); + hPtr = Tcl_FindHashEntry(&iPtr->varTraces, (char *) varPtr); for (tracePtr = (VarTrace *) Tcl_GetHashValue(hPtr); tracePtr != NULL; tracePtr = active.nextTracePtr) { active.nextTracePtr = tracePtr->nextPtr; @@ -2637,7 +2645,7 @@ TclCallVarTraces( /* * Ignore errors in unset traces. */ - + DisposeTraceResult(tracePtr->flags, result); } else { disposeFlags = tracePtr->flags; @@ -2659,7 +2667,7 @@ TclCallVarTraces( done: if (code == TCL_ERROR) { if (leaveErrMsg) { - CONST char *type = ""; + const char *type = ""; Tcl_Obj *options = Tcl_GetReturnOptions((Tcl_Interp *)iPtr, code); Tcl_Obj *errorInfoKey, *errorInfo; @@ -2787,7 +2795,7 @@ DisposeTraceResult( void Tcl_UntraceVar( Tcl_Interp *interp, /* Interpreter containing variable. */ - CONST char *varName, /* Name of variable; may end with "(index)" to + const char *varName, /* Name of variable; may end with "(index)" to * signify an array reference. */ int flags, /* OR-ed collection of bits describing current * trace, including any of TCL_TRACE_READS, @@ -2819,8 +2827,8 @@ Tcl_UntraceVar( void Tcl_UntraceVar2( Tcl_Interp *interp, /* Interpreter containing variable. */ - CONST char *part1, /* Name of variable or array. */ - CONST char *part2, /* Name of element within array; NULL means + const char *part1, /* Name of variable or array. */ + const char *part2, /* Name of element within array; NULL means * trace applies to scalar variable or array * as-a-whole. */ int flags, /* OR-ed collection of bits describing current @@ -2904,8 +2912,8 @@ Tcl_UntraceVar2( tracePtr = tracePtr->nextPtr) { allFlags |= tracePtr->flags; } - - updateFlags: + + updateFlags: varPtr->flags &= ~VAR_ALL_TRACES; if (allFlags & VAR_ALL_TRACES) { varPtr->flags |= (allFlags & VAR_ALL_TRACES); @@ -2914,6 +2922,7 @@ Tcl_UntraceVar2( * If this is the last trace on the variable, and the variable is * unset and unused, then free up the variable. */ + TclCleanupVar(varPtr, NULL); } } @@ -2944,7 +2953,7 @@ Tcl_UntraceVar2( ClientData Tcl_VarTraceInfo( Tcl_Interp *interp, /* Interpreter containing variable. */ - CONST char *varName, /* Name of variable; may end with "(index)" to + const char *varName, /* Name of variable; may end with "(index)" to * signify an array reference. */ int flags, /* OR-ed combo or TCL_GLOBAL_ONLY, * TCL_NAMESPACE_ONLY (can be 0). */ @@ -2978,8 +2987,8 @@ Tcl_VarTraceInfo( ClientData Tcl_VarTraceInfo2( Tcl_Interp *interp, /* Interpreter containing variable. */ - CONST char *part1, /* Name of variable or array. */ - CONST char *part2, /* Name of element within array; NULL means + const char *part1, /* Name of variable or array. */ + const char *part2, /* Name of element within array; NULL means * trace applies to scalar variable or array * as-a-whole. */ int flags, /* OR-ed combination of TCL_GLOBAL_ONLY, @@ -3055,7 +3064,7 @@ int Tcl_TraceVar( Tcl_Interp *interp, /* Interpreter in which variable is to be * traced. */ - CONST char *varName, /* Name of variable; may end with "(index)" to + const char *varName, /* Name of variable; may end with "(index)" to * signify an array reference. */ int flags, /* OR-ed collection of bits, including any of * TCL_TRACE_READS, TCL_TRACE_WRITES, @@ -3093,8 +3102,8 @@ int Tcl_TraceVar2( Tcl_Interp *interp, /* Interpreter in which variable is to be * traced. */ - CONST char *part1, /* Name of scalar variable or array. */ - CONST char *part2, /* Name of element within array; NULL means + const char *part1, /* Name of scalar variable or array. */ + const char *part2, /* Name of element within array; NULL means * trace applies to scalar variable or array * as-a-whole. */ int flags, /* OR-ed collection of bits, including any of @@ -3146,8 +3155,8 @@ static int TraceVarEx( Tcl_Interp *interp, /* Interpreter in which variable is to be * traced. */ - CONST char *part1, /* Name of scalar variable or array. */ - CONST char *part2, /* Name of element within array; NULL means + const char *part1, /* Name of scalar variable or array. */ + const char *part2, /* Name of element within array; NULL means * trace applies to scalar variable or array * as-a-whole. */ register VarTrace *tracePtr)/* Structure containing flags, traceProc and @@ -3159,9 +3168,8 @@ TraceVarEx( { Interp *iPtr = (Interp *) interp; Var *varPtr, *arrayPtr; - int flagMask; + int flagMask, isNew; Tcl_HashEntry *hPtr; - int new; /* * We strip 'flags' down to just the parts which are relevant to @@ -3199,15 +3207,18 @@ TraceVarEx( #endif tracePtr->flags = tracePtr->flags & flagMask; - hPtr = Tcl_CreateHashEntry(&iPtr->varTraces, - (char *) varPtr, &new); - if (new) { + hPtr = Tcl_CreateHashEntry(&iPtr->varTraces, (char *) varPtr, &isNew); + if (isNew) { tracePtr->nextPtr = NULL; } else { tracePtr->nextPtr = (VarTrace *) Tcl_GetHashValue(hPtr); } Tcl_SetHashValue(hPtr, (char *) tracePtr); + /* + * Mark the variable as traced so we know to call them. + */ + varPtr->flags |= (tracePtr->flags & VAR_ALL_TRACES); return TCL_OK; diff --git a/generic/tclVar.c b/generic/tclVar.c index 63b393d..565d04a 100644 --- a/generic/tclVar.c +++ b/generic/tclVar.c @@ -16,7 +16,7 @@ * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclVar.c,v 1.135.2.10 2007/11/12 19:18:21 dgp Exp $ + * RCS: @(#) $Id: tclVar.c,v 1.135.2.11 2007/11/16 07:20:54 dgp Exp $ */ #include "tclInt.h" @@ -148,8 +148,9 @@ static void AppendLocals(Tcl_Interp *interp, Tcl_Obj *listPtr, static void DeleteSearches(Interp *iPtr, Var *arrayVarPtr); static void DeleteArray(Interp *iPtr, Tcl_Obj *arrayNamePtr, Var *varPtr, int flags); -static Tcl_Var ObjFindNamespaceVar(Tcl_Interp *interp, Tcl_Obj *namePtr, - Tcl_Namespace *contextNsPtr, int flags); +static Tcl_Var ObjFindNamespaceVar(Tcl_Interp *interp, + Tcl_Obj *namePtr, Tcl_Namespace *contextNsPtr, + int flags); static int ObjMakeUpvar(Tcl_Interp *interp, CallFrame *framePtr, Tcl_Obj *otherP1Ptr, const char *otherP2, const int otherFlags, @@ -245,11 +246,11 @@ Tcl_ObjType tclArraySearchType = { "array search", NULL, NULL, NULL, SetArraySearchObj }; - + Var * TclVarHashCreateVar( TclVarHashTable *tablePtr, - const char *key, + const char *key, int *newPtr) { Tcl_Obj *keyPtr; @@ -400,7 +401,7 @@ TclLookupVar( /* *---------------------------------------------------------------------- * - * TclObjLookupVar -- + * TclObjLookupVar, TclObjLookupVarEx -- * * This function is used by virtually all of the variable code to locate * a variable given its name(s). The parsing into array/element @@ -483,14 +484,27 @@ TclObjLookupVar( Var * TclObjLookupVarEx( - Tcl_Interp *interp, - Tcl_Obj *part1Ptr, - Tcl_Obj *part2Ptr, - int flags, - const char *msg, - const int createPart1, - const int createPart2, - Var **arrayPtrPtr) + Tcl_Interp *interp, /* Interpreter to use for lookup. */ + Tcl_Obj *part1Ptr, /* If part2Ptr isn't NULL, this is the name of + * an array. Otherwise, this is a full + * variable name that could include a + * parenthesized array element. */ + Tcl_Obj *part2Ptr, /* Name of element within array, or NULL. */ + int flags, /* Only TCL_GLOBAL_ONLY, TCL_NAMESPACE_ONLY, + * and TCL_LEAVE_ERR_MSG bits matter. */ + const char *msg, /* Verb to use in error messages, e.g. "read" + * or "set". Only needed if TCL_LEAVE_ERR_MSG + * is set in flags. */ + const int createPart1, /* If 1, create hash table entry for part 1 of + * name, if it doesn't already exist. If 0, + * return error if it doesn't exist. */ + const int createPart2, /* If 1, create hash table entry for part 2 of + * name, if it doesn't already exist. If 0, + * return error if it doesn't exist. */ + Var **arrayPtrPtr) /* If the name refers to an element of an + * array, *arrayPtrPtr gets filled in with + * address of array variable. Otherwise this + * is set to NULL. */ { Interp *iPtr = (Interp *) interp; register Var *varPtr; /* Points to the variable's in-frame Var @@ -522,8 +536,7 @@ TclObjLookupVarEx( if (typePtr == &localVarNameType) { int localIndex; - localVarNameTypeHandling: - + localVarNameTypeHandling: localIndex = (int) part1Ptr->internalRep.ptrAndLongRep.value; if (HasLocalVars(varFramePtr) && !(flags & (TCL_GLOBAL_ONLY | TCL_NAMESPACE_ONLY)) @@ -532,7 +545,8 @@ TclObjLookupVarEx( * Use the cached index if the names coincide. */ - Tcl_Obj *namePtr = (Tcl_Obj *) part1Ptr->internalRep.ptrAndLongRep.ptr; + Tcl_Obj *namePtr = (Tcl_Obj *) + part1Ptr->internalRep.ptrAndLongRep.ptr; Tcl_Obj *checkNamePtr = localName(iPtr->varFramePtr, localIndex); if ((!namePtr && (checkNamePtr == part1Ptr)) || @@ -711,8 +725,10 @@ TclObjLookupVarEx( part1Ptr->typePtr = &localVarNameType; if (part1Ptr != localName(iPtr->varFramePtr, index)) { - part1Ptr->internalRep.ptrAndLongRep.ptr = localName(iPtr->varFramePtr, index); - Tcl_IncrRefCount((Tcl_Obj *)part1Ptr->internalRep.ptrAndLongRep.ptr); + part1Ptr->internalRep.ptrAndLongRep.ptr = + localName(iPtr->varFramePtr, index); + Tcl_IncrRefCount((Tcl_Obj *) + part1Ptr->internalRep.ptrAndLongRep.ptr); } else { part1Ptr->internalRep.ptrAndLongRep.ptr = NULL; } @@ -919,11 +935,10 @@ TclLookupSimpleVar( || !HasLocalVars(varFramePtr) || (strstr(varName, "::") != NULL)) { const char *tail; - int lookGlobal; - - lookGlobal = (flags & TCL_GLOBAL_ONLY) + int lookGlobal = (flags & TCL_GLOBAL_ONLY) || (cxtNsPtr == iPtr->globalNsPtr) || ((*varName == ':') && (*(varName+1) == ':')); + if (lookGlobal) { *indexPtr = -1; flags = (flags | TCL_GLOBAL_ONLY) & ~TCL_NAMESPACE_ONLY; @@ -942,7 +957,8 @@ TclLookupSimpleVar( */ varPtr = (Var *) ObjFindNamespaceVar(interp, varNamePtr, - (Tcl_Namespace *) cxtNsPtr, (flags | AVOID_RESOLVERS) & ~TCL_LEAVE_ERR_MSG); + (Tcl_Namespace *) cxtNsPtr, + (flags | AVOID_RESOLVERS) & ~TCL_LEAVE_ERR_MSG); if (varPtr == NULL) { Tcl_Obj *tailPtr; @@ -952,11 +968,11 @@ TclLookupSimpleVar( if (varNsPtr == NULL) { *errMsgPtr = badNamespace; return NULL; - } - if (tail == NULL) { + } else if (tail == NULL) { *errMsgPtr = missingName; return NULL; - } else if (tail != varName) { + } + if (tail != varName) { tailPtr = Tcl_NewStringObj(tail, -1); } else { tailPtr = varNamePtr; @@ -984,9 +1000,11 @@ TclLookupSimpleVar( Tcl_Obj **objPtrPtr = &varFramePtr->localCachePtr->varName0; for (i=0 ; i<localCt ; i++, objPtrPtr++) { - Tcl_Obj *objPtr = *objPtrPtr; + register Tcl_Obj *objPtr = *objPtrPtr; + if (objPtr) { char *localName = TclGetString(objPtr); + if ((varName[0] == localName[0]) && (strcmp(varName, localName) == 0)) { *indexPtr = i; @@ -1366,7 +1384,9 @@ TclPtrGetVar( * in the array part1. */ const int flags, /* OR-ed combination of TCL_GLOBAL_ONLY, and * TCL_LEAVE_ERR_MSG bits. */ - int index) + int index) /* Index into the local variable table of the + * variable, or -1. Only used when part1Ptr is + * NULL. */ { Interp *iPtr = (Interp *) interp; const char *msg; @@ -2011,7 +2031,9 @@ TclPtrIncrObjVar( * any of TCL_GLOBAL_ONLY, TCL_NAMESPACE_ONLY, * TCL_APPEND_VALUE, TCL_LIST_ELEMENT, * TCL_LEAVE_ERR_MSG. */ - int index) + int index) /* Index into the local variable table of the + * variable, or -1. Only used when part1Ptr is + * NULL. */ { register Tcl_Obj *varValuePtr, *newValuePtr = NULL; int duplicated, code; @@ -2322,7 +2344,8 @@ UnsetVarStruct( dummyVar.flags &= ~VAR_TRACE_ACTIVE; TclObjCallVarTraces(iPtr, arrayPtr, (Var *) &dummyVar, part1Ptr, part2Ptr, - (flags & (TCL_GLOBAL_ONLY|TCL_NAMESPACE_ONLY))| TCL_TRACE_UNSETS, + (flags & (TCL_GLOBAL_ONLY|TCL_NAMESPACE_ONLY)) + | TCL_TRACE_UNSETS, /* leaveErrMsg */ 0, -1); if (tPtr) { Tcl_DeleteHashEntry(tPtr); @@ -4205,11 +4228,11 @@ ParseSearchId( * optimize this address arithmetic! */ - id = (int)(((char*)handleObj->internalRep.twoPtrValue.ptr1) - - ((char*)NULL)); + id = (int)(((char *) handleObj->internalRep.twoPtrValue.ptr1) - + ((char *) NULL)); string = TclGetString(handleObj); - offset = (((char*)handleObj->internalRep.twoPtrValue.ptr2) - - ((char*)NULL)); + offset = (((char *) handleObj->internalRep.twoPtrValue.ptr2) - + ((char *) NULL)); /* * This test cannot be placed inside the Tcl_Obj machinery, since it is @@ -4219,9 +4242,7 @@ ParseSearchId( if (strcmp(string+offset, varName) != 0) { Tcl_AppendResult(interp, "search identifier \"", string, "\" isn't for variable \"", varName, "\"", NULL); - Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "ARRAYSEARCH", string, - NULL); - return NULL; + goto badLookup; } /* @@ -4235,7 +4256,7 @@ ParseSearchId( if (varPtr->flags & VAR_SEARCH_ACTIVE) { Tcl_HashEntry *hPtr = - Tcl_FindHashEntry(&iPtr->varSearches,(char *) varPtr); + Tcl_FindHashEntry(&iPtr->varSearches, (char *) varPtr); for (searchPtr = (ArraySearch *) Tcl_GetHashValue(hPtr); searchPtr != NULL; searchPtr = searchPtr->nextPtr) { @@ -4245,6 +4266,7 @@ ParseSearchId( } } Tcl_AppendResult(interp, "couldn't find search \"", string, "\"", NULL); + badLookup: Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "ARRAYSEARCH", string, NULL); return NULL; } @@ -4610,11 +4632,13 @@ TclObjVarErrMsg( const char *operation, /* String describing operation that failed, * e.g. "read", "set", or "unset". */ const char *reason, /* String describing why operation failed. */ - int index) + int index) /* Index into the local variable table of the + * variable, or -1. Only used when part1Ptr is + * NULL. */ { Tcl_ResetResult(interp); if (!part1Ptr) { - part1Ptr = localName(((Interp*)interp)->varFramePtr, index); + part1Ptr = localName(((Interp *)interp)->varFramePtr, index); } Tcl_AppendResult(interp, "can't ", operation, " \"", TclGetString(part1Ptr), NULL); @@ -4685,8 +4709,9 @@ DupLocalVarName( } dupPtr->internalRep.ptrAndLongRep.ptr = namePtr; Tcl_IncrRefCount(namePtr); - - dupPtr->internalRep.ptrAndLongRep.value = srcPtr->internalRep.ptrAndLongRep.value; + + dupPtr->internalRep.ptrAndLongRep.value = + srcPtr->internalRep.ptrAndLongRep.value; dupPtr->typePtr = &localVarNameType; } @@ -4894,7 +4919,7 @@ ObjFindNamespaceVar( Tcl_Var var; Tcl_Obj *simpleNamePtr; char *name = TclGetString(namePtr); - + /* * If this namespace has a variable resolver, then give it first crack at * the variable resolution. It may return a Tcl_Var value, it may signal @@ -4955,7 +4980,7 @@ ObjFindNamespaceVar( } else { simpleNamePtr = namePtr; } - + for (search = 0; (search < 2) && (varPtr == NULL); search++) { if ((nsPtr[search] != NULL) && (simpleName != NULL)) { varPtr = VarHashFindVar(&nsPtr[search]->varTable, simpleNamePtr); @@ -4964,13 +4989,12 @@ ObjFindNamespaceVar( if (simpleName != name) { Tcl_DecrRefCount(simpleNamePtr); } - if (varPtr != NULL) { - return (Tcl_Var) varPtr; - } else if (flags & TCL_LEAVE_ERR_MSG) { + if ((varPtr == NULL) && (flags & TCL_LEAVE_ERR_MSG)) { Tcl_ResetResult(interp); Tcl_AppendResult(interp, "unknown variable \"", name, "\"", NULL); + Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "VARIABLE", name, NULL); } - return (Tcl_Var) NULL; + return (Tcl_Var) varPtr; } /* @@ -5489,8 +5513,8 @@ CompareVarKeys( } /* - * Don't use Tcl_GetStringFromObj as it would prevent l1 and l2 being - * in a register. + * Don't use Tcl_GetStringFromObj as it would prevent l1 and l2 being in a + * register. */ p1 = TclGetString(objPtr1); @@ -5540,7 +5564,7 @@ HashVarKey( * character's bits hang around in the low-order bits of the hash value * for ever, plus they spread fairly rapidly up to the high-order bits * to fill out the hash value. This seems works well both for decimal - * and *non-decimal strings. + * and non-decimal strings. */ for (i=0 ; i<length ; i++) { diff --git a/macosx/Tcl.xcode/project.pbxproj b/macosx/Tcl.xcode/project.pbxproj index ee0b0fb..a9e7056 100644 --- a/macosx/Tcl.xcode/project.pbxproj +++ b/macosx/Tcl.xcode/project.pbxproj @@ -176,7 +176,7 @@ /* Begin PBXFileReference section */ 8DD76FB20486AB0100D96B5E /* tcltest */ = {isa = PBXFileReference; explicitFileType = "compiled.mach-o.executable"; includeInIndex = 0; path = tcltest; sourceTree = BUILT_PRODUCTS_DIR; }; F91E62260C1AE686006C9D96 /* Tclsh-Info.plist.in */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = text.xml; path = "Tclsh-Info.plist.in"; sourceTree = "<group>"; }; - F95FAFF90B34F1130072E431 /* macOSXLoad.test */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = text; path = macOSXLoad.test; sourceTree = "<group>"; }; + F95FAFF90B34F1130072E431 /* macOSXLoad.test */ = {isa = PBXFileReference; explicitFileType = text.script; fileEncoding = 4; path = macOSXLoad.test; sourceTree = "<group>"; }; F966C07408F2820D005CB29B /* CoreFoundation.framework */ = {isa = PBXFileReference; lastKnownFileType = wrapper.framework; name = CoreFoundation.framework; path = /System/Library/Frameworks/CoreFoundation.framework; sourceTree = "<absolute>"; }; F96D3DFA08F272A4004A47F5 /* ChangeLog */ = {isa = PBXFileReference; explicitFileType = text; fileEncoding = 4; path = ChangeLog; sourceTree = "<group>"; }; F96D3DFB08F272A4004A47F5 /* changes */ = {isa = PBXFileReference; explicitFileType = text; fileEncoding = 4; path = changes; sourceTree = "<group>"; }; @@ -901,6 +901,7 @@ F9903CB0094FAADA004613E9 /* tclTomMathDecls.h */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.h; path = tclTomMathDecls.h; sourceTree = "<group>"; }; F9A3084B08F2D4CE00BAE1AB /* tclsh */ = {isa = PBXFileReference; explicitFileType = "compiled.mach-o.executable"; includeInIndex = 0; path = tclsh; sourceTree = BUILT_PRODUCTS_DIR; }; F9A3084E08F2D4F400BAE1AB /* Tcl.framework */ = {isa = PBXFileReference; includeInIndex = 0; lastKnownFileType = wrapper.framework; path = Tcl.framework; sourceTree = BUILT_PRODUCTS_DIR; }; + F9A493240CEBF38300B78AE2 /* chanio.test */ = {isa = PBXFileReference; explicitFileType = text.script; fileEncoding = 4; path = chanio.test; sourceTree = "<group>"; }; F9ECB1120B26521500A28025 /* pkgIndex.tcl */ = {isa = PBXFileReference; explicitFileType = text.script; fileEncoding = 4; path = pkgIndex.tcl; sourceTree = "<group>"; }; F9ECB1130B26521500A28025 /* platform.tcl */ = {isa = PBXFileReference; explicitFileType = text.script; fileEncoding = 4; path = platform.tcl; sourceTree = "<group>"; }; F9ECB1140B26521500A28025 /* shell.tcl */ = {isa = PBXFileReference; explicitFileType = text.script; fileEncoding = 4; path = shell.tcl; sourceTree = "<group>"; }; @@ -930,7 +931,7 @@ F966C06F08F281DC005CB29B /* Frameworks */, 1AB674ADFE9D54B511CA2CBB /* Products */, ); - comments = "Copyright (c) 2004-2007 Daniel A. Steffen <das@users.sourceforge.net>\n\nSee the file \"license.terms\" for information on usage and redistribution of\nthis file, and for a DISCLAIMER OF ALL WARRANTIES.\n\nRCS: @(#) $Id: project.pbxproj,v 1.6.2.1 2007/09/06 18:20:32 dgp Exp $\n"; + comments = "Copyright (c) 2004-2007 Daniel A. Steffen <das@users.sourceforge.net>\n\nSee the file \"license.terms\" for information on usage and redistribution of\nthis file, and for a DISCLAIMER OF ALL WARRANTIES.\n\nRCS: @(#) $Id: project.pbxproj,v 1.6.2.2 2007/11/16 07:20:55 dgp Exp $\n"; name = Tcl; path = .; sourceTree = SOURCE_ROOT; @@ -1553,6 +1554,7 @@ F96D434C08F272B5004A47F5 /* binary.test */, F96D434D08F272B5004A47F5 /* case.test */, F96D434E08F272B5004A47F5 /* chan.test */, + F9A493240CEBF38300B78AE2 /* chanio.test */, F96D434F08F272B5004A47F5 /* clock.test */, F96D435008F272B5004A47F5 /* cmdAH.test */, F96D435108F272B5004A47F5 /* cmdIL.test */, diff --git a/macosx/Tcl.xcodeproj/project.pbxproj b/macosx/Tcl.xcodeproj/project.pbxproj index af23ace..6490464 100644 --- a/macosx/Tcl.xcodeproj/project.pbxproj +++ b/macosx/Tcl.xcodeproj/project.pbxproj @@ -177,7 +177,7 @@ /* Begin PBXFileReference section */ 8DD76FB20486AB0100D96B5E /* tcltest */ = {isa = PBXFileReference; explicitFileType = "compiled.mach-o.executable"; includeInIndex = 0; path = tcltest; sourceTree = BUILT_PRODUCTS_DIR; }; F91E62260C1AE686006C9D96 /* Tclsh-Info.plist.in */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = text.xml; path = "Tclsh-Info.plist.in"; sourceTree = "<group>"; }; - F95FAFF90B34F1130072E431 /* macOSXLoad.test */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = text; path = macOSXLoad.test; sourceTree = "<group>"; }; + F95FAFF90B34F1130072E431 /* macOSXLoad.test */ = {isa = PBXFileReference; explicitFileType = text.script; fileEncoding = 4; path = macOSXLoad.test; sourceTree = "<group>"; }; F966C07408F2820D005CB29B /* CoreFoundation.framework */ = {isa = PBXFileReference; lastKnownFileType = wrapper.framework; name = CoreFoundation.framework; path = /System/Library/Frameworks/CoreFoundation.framework; sourceTree = "<absolute>"; }; F96D3DFA08F272A4004A47F5 /* ChangeLog */ = {isa = PBXFileReference; explicitFileType = text; fileEncoding = 4; path = ChangeLog; sourceTree = "<group>"; }; F96D3DFB08F272A4004A47F5 /* changes */ = {isa = PBXFileReference; explicitFileType = text; fileEncoding = 4; path = changes; sourceTree = "<group>"; }; @@ -902,6 +902,7 @@ F9903CB0094FAADA004613E9 /* tclTomMathDecls.h */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.h; path = tclTomMathDecls.h; sourceTree = "<group>"; }; F9A3084B08F2D4CE00BAE1AB /* tclsh */ = {isa = PBXFileReference; explicitFileType = "compiled.mach-o.executable"; includeInIndex = 0; path = tclsh; sourceTree = BUILT_PRODUCTS_DIR; }; F9A3084E08F2D4F400BAE1AB /* Tcl.framework */ = {isa = PBXFileReference; includeInIndex = 0; lastKnownFileType = wrapper.framework; path = Tcl.framework; sourceTree = BUILT_PRODUCTS_DIR; }; + F9A493240CEBF38300B78AE2 /* chanio.test */ = {isa = PBXFileReference; explicitFileType = text.script; fileEncoding = 4; path = chanio.test; sourceTree = "<group>"; }; F9ECB1120B26521500A28025 /* pkgIndex.tcl */ = {isa = PBXFileReference; explicitFileType = text.script; fileEncoding = 4; path = pkgIndex.tcl; sourceTree = "<group>"; }; F9ECB1130B26521500A28025 /* platform.tcl */ = {isa = PBXFileReference; explicitFileType = text.script; fileEncoding = 4; path = platform.tcl; sourceTree = "<group>"; }; F9ECB1140B26521500A28025 /* shell.tcl */ = {isa = PBXFileReference; explicitFileType = text.script; fileEncoding = 4; path = shell.tcl; sourceTree = "<group>"; }; @@ -932,7 +933,7 @@ F966C06F08F281DC005CB29B /* Frameworks */, 1AB674ADFE9D54B511CA2CBB /* Products */, ); - comments = "Copyright (c) 2004-2007 Daniel A. Steffen <das@users.sourceforge.net>\n\nSee the file \"license.terms\" for information on usage and redistribution of\nthis file, and for a DISCLAIMER OF ALL WARRANTIES.\n\nRCS: @(#) $Id: project.pbxproj,v 1.21.2.5 2007/09/14 16:28:37 dgp Exp $\n"; + comments = "Copyright (c) 2004-2007 Daniel A. Steffen <das@users.sourceforge.net>\n\nSee the file \"license.terms\" for information on usage and redistribution of\nthis file, and for a DISCLAIMER OF ALL WARRANTIES.\n\nRCS: @(#) $Id: project.pbxproj,v 1.21.2.6 2007/11/16 07:20:55 dgp Exp $\n"; name = Tcl; path = .; sourceTree = SOURCE_ROOT; @@ -1556,6 +1557,7 @@ F96D434C08F272B5004A47F5 /* binary.test */, F96D434D08F272B5004A47F5 /* case.test */, F96D434E08F272B5004A47F5 /* chan.test */, + F9A493240CEBF38300B78AE2 /* chanio.test */, F96D434F08F272B5004A47F5 /* clock.test */, F96D435008F272B5004A47F5 /* cmdAH.test */, F96D435108F272B5004A47F5 /* cmdIL.test */, diff --git a/tests/chanio.test b/tests/chanio.test new file mode 100644 index 0000000..b7a9676 --- /dev/null +++ b/tests/chanio.test @@ -0,0 +1,7463 @@ +# -*- tcl -*- +# Functionality covered: operation of all IO commands, and all procedures +# defined in generic/tclIO.c. +# +# This file contains a collection of tests for one or more of the Tcl +# built-in commands. Sourcing this file into Tcl runs the tests and +# generates output for errors. No output means no errors were found. +# +# Copyright (c) 1991-1994 The Regents of the University of California. +# Copyright (c) 1994-1997 Sun Microsystems, Inc. +# Copyright (c) 1998-1999 by Scriptics Corporation. +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# +# RCS: @(#) $Id: chanio.test,v 1.1.2.2 2007/11/16 07:20:56 dgp Exp $ + +if {[catch {package require tcltest 2}]} { + chan puts stderr "Skipping tests in [info script]. tcltest 2 required." + return +} +namespace eval ::tcl::test::io { + namespace import ::tcltest::* + + variable umaskValue + variable path + variable f + variable i + variable n + variable v + variable msg + variable expected + + testConstraint testchannel [llength [info commands testchannel]] + testConstraint exec [llength [info commands exec]] + testConstraint openpipe 1 + testConstraint fileevent [llength [info commands fileevent]] + testConstraint fcopy [llength [info commands fcopy]] + testConstraint testfevent [llength [info commands testfevent]] + testConstraint testchannelevent [llength [info commands testchannelevent]] + testConstraint testmainthread [llength [info commands testmainthread]] + testConstraint testthread [llength [info commands testthread]] + + # You need a *very* special environment to do some tests. In + # particular, many file systems do not support large-files... + testConstraint largefileSupport 0 + + # some tests can only be run is umask is 2 + # if "umask" cannot be run, the tests will be skipped. + set umaskValue 0 + testConstraint umask [expr {![catch {set umaskValue [scan [exec /bin/sh -c umask] %o]}]}] + + testConstraint makeFileInHome [expr {![file exists ~/_test_] && [file writable ~]}] + + # set up a long data file for some of the following tests + + set path(longfile) [makeFile {} longfile] + set f [open $path(longfile) w] + chan configure $f -eofchar {} -translation lf + for { set i 0 } { $i < 100 } { incr i} { + chan puts $f "#123456789abcdef0123456789abcdef0123456789abcdef0123456789abcdef0123456789abcdef +\#123456789abcdef01 +\#" + } + chan close $f + + set path(cat) [makeFile { + set f stdin + if {$argv != ""} { + set f [open [lindex $argv 0]] + } + chan configure $f -encoding binary -translation lf -blocking 0 -eofchar \x1a + chan configure stdout -encoding binary -translation lf -buffering none + chan event $f readable "foo $f" + proc foo {f} { + set x [chan read $f] + catch {chan puts -nonewline $x} + if {[chan eof $f]} { + chan close $f + exit 0 + } + } + vwait forever + } cat] + + set thisScript [file join [pwd] [info script]] + + proc contents {file} { + set f [open $file] + chan configure $f -translation binary + set a [chan read $f] + chan close $f + return $a + } + +test chan-io-1.5 {Tcl_WriteChars: CheckChannelErrors} {emptyTest} { + # no test, need to cause an async error. +} {} +set path(test1) [makeFile {} test1] +test chan-io-1.6 {Tcl_WriteChars: WriteBytes} { + set f [open $path(test1) w] + chan configure $f -encoding binary + chan puts -nonewline $f "a\u4e4d\0" + chan close $f + contents $path(test1) +} "a\x4d\x00" +test chan-io-1.7 {Tcl_WriteChars: WriteChars} { + set f [open $path(test1) w] + chan configure $f -encoding shiftjis + chan puts -nonewline $f "a\u4e4d\0" + chan close $f + contents $path(test1) +} "a\x93\xe1\x00" +set path(test2) [makeFile {} test2] +test chan-io-1.8 {Tcl_WriteChars: WriteChars} { + # This test written for SF bug #506297. + # + # Executing this test without the fix for the referenced bug + # applied to tcl will cause tcl, more specifically WriteChars, to + # go into an infinite loop. + + set f [open $path(test2) w] + chan configure $f -encoding iso2022-jp + chan puts -nonewline $f [format %s%c [string repeat " " 4] 12399] + chan close $f + contents $path(test2) +} " \x1b\$B\$O\x1b(B" + +test chan-io-1.9 {Tcl_WriteChars: WriteChars} { + # When closing a channel with an encoding that appends + # escape bytes, check for the case where the escape + # bytes overflow the current IO buffer. The bytes + # should be moved into a new buffer. + + set data "1234567890 [format %c 12399]" + + set sizes [list] + + # With default buffer size + set f [open $path(test2) w] + chan configure $f -encoding iso2022-jp + chan puts -nonewline $f $data + chan close $f + lappend sizes [file size $path(test2)] + + # With buffer size equal to the length + # of the data, the escape bytes would + # go into the next buffer. + + set f [open $path(test2) w] + chan configure $f -encoding iso2022-jp -buffersize 16 + chan puts -nonewline $f $data + chan close $f + lappend sizes [file size $path(test2)] + + # With buffer size that is large enough + # to hold 1 byte of escaped data, but + # not all 3. This should not write + # the escape bytes to the first buffer + # and then again to the second buffer. + + set f [open $path(test2) w] + chan configure $f -encoding iso2022-jp -buffersize 17 + chan puts -nonewline $f $data + chan close $f + lappend sizes [file size $path(test2)] + + # With buffer size that can hold 2 out of + # 3 bytes of escaped data. + + set f [open $path(test2) w] + chan configure $f -encoding iso2022-jp -buffersize 18 + chan puts -nonewline $f $data + chan close $f + lappend sizes [file size $path(test2)] + + # With buffer size that can hold all the + # data and escape bytes. + + set f [open $path(test2) w] + chan configure $f -encoding iso2022-jp -buffersize 19 + chan puts -nonewline $f $data + chan close $f + lappend sizes [file size $path(test2)] + + set sizes +} {19 19 19 19 19} + +test chan-io-2.1 {WriteBytes} { + # loop until all bytes are written + + set f [open $path(test1) w] + chan configure $f -encoding binary -buffersize 16 -translation crlf + chan puts $f "abcdefghijklmnopqrstuvwxyz" + chan close $f + contents $path(test1) +} "abcdefghijklmnopqrstuvwxyz\r\n" +test chan-io-2.2 {WriteBytes: savedLF > 0} { + # After flushing buffer, there was a \n left over from the last + # \n -> \r\n expansion. It gets stuck at beginning of this buffer. + + set f [open $path(test1) w] + chan configure $f -encoding binary -buffersize 16 -translation crlf + chan puts -nonewline $f "123456789012345\n12" + set x [list [contents $path(test1)]] + chan close $f + lappend x [contents $path(test1)] +} [list "123456789012345\r" "123456789012345\r\n12"] +test chan-io-2.3 {WriteBytes: flush on line} { + # Tcl "line" buffering has weird behavior: if current buffer contains + # a \n, entire buffer gets flushed. Logical behavior would be to flush + # only up to the \n. + + set f [open $path(test1) w] + chan configure $f -encoding binary -buffering line -translation crlf + chan puts -nonewline $f "\n12" + set x [contents $path(test1)] + chan close $f + set x +} "\r\n12" +test chan-io-2.4 {WriteBytes: reset sawLF after each buffer} { + set f [open $path(test1) w] + chan configure $f -encoding binary -buffering line -translation lf \ + -buffersize 16 + chan puts -nonewline $f "abcdefg\nhijklmnopqrstuvwxyz" + set x [list [contents $path(test1)]] + chan close $f + lappend x [contents $path(test1)] +} [list "abcdefg\nhijklmno" "abcdefg\nhijklmnopqrstuvwxyz"] + +test chan-io-3.1 {WriteChars: compatibility with WriteBytes} { + # loop until all bytes are written + + set f [open $path(test1) w] + chan configure $f -encoding ascii -buffersize 16 -translation crlf + chan puts $f "abcdefghijklmnopqrstuvwxyz" + chan close $f + contents $path(test1) +} "abcdefghijklmnopqrstuvwxyz\r\n" +test chan-io-3.2 {WriteChars: compatibility with WriteBytes: savedLF > 0} { + # After flushing buffer, there was a \n left over from the last + # \n -> \r\n expansion. It gets stuck at beginning of this buffer. + + set f [open $path(test1) w] + chan configure $f -encoding ascii -buffersize 16 -translation crlf + chan puts -nonewline $f "123456789012345\n12" + set x [list [contents $path(test1)]] + chan close $f + lappend x [contents $path(test1)] +} [list "123456789012345\r" "123456789012345\r\n12"] +test chan-io-3.3 {WriteChars: compatibility with WriteBytes: flush on line} { + # Tcl "line" buffering has weird behavior: if current buffer contains + # a \n, entire buffer gets flushed. Logical behavior would be to flush + # only up to the \n. + + set f [open $path(test1) w] + chan configure $f -encoding ascii -buffering line -translation crlf + chan puts -nonewline $f "\n12" + set x [contents $path(test1)] + chan close $f + set x +} "\r\n12" +test chan-io-3.4 {WriteChars: loop over stage buffer} { + # stage buffer maps to more than can be queued at once. + + set f [open $path(test1) w] + chan configure $f -encoding jis0208 -buffersize 16 + chan puts -nonewline $f "\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\" + set x [list [contents $path(test1)]] + chan close $f + lappend x [contents $path(test1)] +} [list "!)!)!)!)!)!)!)!)" "!)!)!)!)!)!)!)!)!)!)!)!)!)!)!)"] +test chan-io-3.5 {WriteChars: saved != 0} { + # Bytes produced by UtfToExternal from end of last channel buffer + # had to be moved to beginning of next channel buffer to preserve + # requested buffersize. + + set f [open $path(test1) w] + chan configure $f -encoding jis0208 -buffersize 17 + chan puts -nonewline $f "\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\" + set x [list [contents $path(test1)]] + chan close $f + lappend x [contents $path(test1)] +} [list "!)!)!)!)!)!)!)!)!" "!)!)!)!)!)!)!)!)!)!)!)!)!)!)!)"] +test chan-io-3.6 {WriteChars: (stageRead + dstWrote == 0)} { + # One incomplete UTF-8 character at end of staging buffer. Backup + # in src to the beginning of that UTF-8 character and try again. + # + # Translate the first 16 bytes, produce 14 bytes of output, 2 left over + # (first two bytes of \uff21 in UTF-8). Given those two bytes try + # translating them again, find that no bytes are read produced, and break + # to outer loop where those two bytes will have the remaining 4 bytes + # (the last byte of \uff21 plus the all of \uff22) appended. + + set f [open $path(test1) w] + chan configure $f -encoding shiftjis -buffersize 16 + chan puts -nonewline $f "12345678901234\uff21\uff22" + set x [list [contents $path(test1)]] + chan close $f + lappend x [contents $path(test1)] +} [list "12345678901234\x82\x60" "12345678901234\x82\x60\x82\x61"] +test chan-io-3.7 {WriteChars: (bufPtr->nextAdded > bufPtr->length)} { + # When translating UTF-8 to external, the produced bytes went past end + # of the channel buffer. This is done purpose -- we then truncate the + # bytes at the end of the partial character to preserve the requested + # blocksize on flush. The truncated bytes are moved to the beginning + # of the next channel buffer. + + set f [open $path(test1) w] + chan configure $f -encoding jis0208 -buffersize 17 + chan puts -nonewline $f "\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\" + set x [list [contents $path(test1)]] + chan close $f + lappend x [contents $path(test1)] +} [list "!)!)!)!)!)!)!)!)!" "!)!)!)!)!)!)!)!)!)!)!)!)!)!)!)"] +test chan-io-3.8 {WriteChars: reset sawLF after each buffer} { + set f [open $path(test1) w] + chan configure $f -encoding ascii -buffering line -translation lf \ + -buffersize 16 + chan puts -nonewline $f "abcdefg\nhijklmnopqrstuvwxyz" + set x [list [contents $path(test1)]] + chan close $f + lappend x [contents $path(test1)] +} [list "abcdefg\nhijklmno" "abcdefg\nhijklmnopqrstuvwxyz"] + +test chan-io-4.1 {TranslateOutputEOL: lf} { + # search for \n + + set f [open $path(test1) w] + chan configure $f -buffering line -translation lf + chan puts $f "abcde" + set x [list [contents $path(test1)]] + chan close $f + lappend x [contents $path(test1)] +} [list "abcde\n" "abcde\n"] +test chan-io-4.2 {TranslateOutputEOL: cr} { + # search for \n, replace with \r + + set f [open $path(test1) w] + chan configure $f -buffering line -translation cr + chan puts $f "abcde" + set x [list [contents $path(test1)]] + chan close $f + lappend x [contents $path(test1)] +} [list "abcde\r" "abcde\r"] +test chan-io-4.3 {TranslateOutputEOL: crlf} { + # simple case: search for \n, replace with \r + + set f [open $path(test1) w] + chan configure $f -buffering line -translation crlf + chan puts $f "abcde" + set x [list [contents $path(test1)]] + chan close $f + lappend x [contents $path(test1)] +} [list "abcde\r\n" "abcde\r\n"] +test chan-io-4.4 {TranslateOutputEOL: crlf} { + # keep storing more bytes in output buffer until output buffer is full. + # We have 13 bytes initially that would turn into 18 bytes. Fill + # dest buffer while (dstEnd < dstMax). + + set f [open $path(test1) w] + chan configure $f -translation crlf -buffersize 16 + chan puts -nonewline $f "1234567\n\n\n\n\nA" + set x [list [contents $path(test1)]] + chan close $f + lappend x [contents $path(test1)] +} [list "1234567\r\n\r\n\r\n\r\n\r" "1234567\r\n\r\n\r\n\r\n\r\nA"] +test chan-io-4.5 {TranslateOutputEOL: crlf} { + # Check for overflow of the destination buffer + + set f [open $path(test1) w] + chan configure $f -translation crlf -buffersize 12 + chan puts -nonewline $f "12345678901\n456789012345678901234" + chan close $f + set x [contents $path(test1)] +} "12345678901\r\n456789012345678901234" + +test chan-io-5.1 {CheckFlush: not full} { + set f [open $path(test1) w] + chan configure $f + chan puts -nonewline $f "12345678901234567890" + set x [list [contents $path(test1)]] + chan close $f + lappend x [contents $path(test1)] +} [list "" "12345678901234567890"] +test chan-io-5.2 {CheckFlush: full} { + set f [open $path(test1) w] + chan configure $f -buffersize 16 + chan puts -nonewline $f "12345678901234567890" + set x [list [contents $path(test1)]] + chan close $f + lappend x [contents $path(test1)] +} [list "1234567890123456" "12345678901234567890"] +test chan-io-5.3 {CheckFlush: not line} { + set f [open $path(test1) w] + chan configure $f -buffering line + chan puts -nonewline $f "12345678901234567890" + set x [list [contents $path(test1)]] + chan close $f + lappend x [contents $path(test1)] +} [list "" "12345678901234567890"] +test chan-io-5.4 {CheckFlush: line} { + set f [open $path(test1) w] + chan configure $f -buffering line -translation lf -encoding ascii + chan puts -nonewline $f "1234567890\n1234567890" + set x [list [contents $path(test1)]] + chan close $f + lappend x [contents $path(test1)] +} [list "1234567890\n1234567890" "1234567890\n1234567890"] +test chan-io-5.5 {CheckFlush: none} { + set f [open $path(test1) w] + chan configure $f -buffering none + chan puts -nonewline $f "1234567890" + set x [list [contents $path(test1)]] + chan close $f + lappend x [contents $path(test1)] +} [list "1234567890" "1234567890"] + +test chan-io-6.1 {Tcl_GetsObj: working} { + set f [open $path(test1) w] + chan puts $f "foo\nboo" + chan close $f + set f [open $path(test1)] + set x [chan gets $f] + chan close $f + set x +} {foo} +test chan-io-6.2 {Tcl_GetsObj: CheckChannelErrors() != 0} emptyTest { + # no test, need to cause an async error. +} {} +test chan-io-6.3 {Tcl_GetsObj: how many have we used?} { + # if (bufPtr != NULL) {oldRemoved = bufPtr->nextRemoved} + + set f [open $path(test1) w] + chan configure $f -translation crlf + chan puts $f "abc\ndefg" + chan close $f + set f [open $path(test1)] + set x [list [chan tell $f] [chan gets $f line] [chan tell $f] [chan gets $f line] $line] + chan close $f + set x +} {0 3 5 4 defg} +test chan-io-6.4 {Tcl_GetsObj: encoding == NULL} { + set f [open $path(test1) w] + chan configure $f -translation binary + chan puts $f "\x81\u1234\0" + chan close $f + set f [open $path(test1)] + chan configure $f -translation binary + set x [list [chan gets $f line] $line] + chan close $f + set x +} [list 3 "\x81\x34\x00"] +test chan-io-6.5 {Tcl_GetsObj: encoding != NULL} { + set f [open $path(test1) w] + chan configure $f -translation binary + chan puts $f "\x88\xea\x92\x9a" + chan close $f + set f [open $path(test1)] + chan configure $f -encoding shiftjis + set x [list [chan gets $f line] $line] + chan close $f + set x +} [list 2 "\u4e00\u4e01"] +set a "bbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbb" +append a $a +append a $a +test chan-io-6.6 {Tcl_GetsObj: loop test} { + # if (dst >= dstEnd) + + set f [open $path(test1) w] + chan puts $f $a + chan puts $f hi + chan close $f + set f [open $path(test1)] + set x [list [chan gets $f line] $line] + chan close $f + set x +} [list 256 $a] +test chan-io-6.7 {Tcl_GetsObj: error in input} {stdio openpipe} { + # if (FilterInputBytes(chanPtr, &gs) != 0) + + set f [open "|[list [interpreter] $path(cat)]" w+] + chan puts -nonewline $f "hi\nwould" + chan flush $f + chan gets $f + chan configure $f -blocking 0 + set x [chan gets $f line] + chan close $f + set x +} {-1} +test chan-io-6.8 {Tcl_GetsObj: remember if EOF is seen} { + set f [open $path(test1) w] + chan puts $f "abcdef\x1aghijk\nwombat" + chan close $f + set f [open $path(test1)] + chan configure $f -eofchar \x1a + set x [list [chan gets $f line] $line [chan gets $f line] $line] + chan close $f + set x +} {6 abcdef -1 {}} +test chan-io-6.9 {Tcl_GetsObj: remember if EOF is seen} { + set f [open $path(test1) w] + chan puts $f "abcdefghijk\nwom\u001abat" + chan close $f + set f [open $path(test1)] + chan configure $f -eofchar \x1a + set x [list [chan gets $f line] $line [chan gets $f line] $line] + chan close $f + set x +} {11 abcdefghijk 3 wom} +# Comprehensive tests +test chan-io-6.10 {Tcl_GetsObj: lf mode: no chars} { + set f [open $path(test1) w] + chan close $f + set f [open $path(test1)] + chan configure $f -translation lf + set x [list [chan gets $f line] $line] + chan close $f + set x +} {-1 {}} +test chan-io-6.11 {Tcl_GetsObj: lf mode: lone \n} { + set f [open $path(test1) w] + chan configure $f -translation lf + chan puts -nonewline $f "\n" + chan close $f + set f [open $path(test1)] + chan configure $f -translation lf + set x [list [chan gets $f line] $line [chan gets $f line] $line] + chan close $f + set x +} {0 {} -1 {}} +test chan-io-6.12 {Tcl_GetsObj: lf mode: lone \r} { + set f [open $path(test1) w] + chan configure $f -translation lf + chan puts -nonewline $f "\r" + chan close $f + set f [open $path(test1)] + chan configure $f -translation lf + set x [list [chan gets $f line] $line [chan gets $f line] $line] + chan close $f + set x +} [list 1 "\r" -1 ""] +test chan-io-6.13 {Tcl_GetsObj: lf mode: 1 char} { + set f [open $path(test1) w] + chan configure $f -translation lf + chan puts -nonewline $f a + chan close $f + set f [open $path(test1)] + chan configure $f -translation lf + set x [list [chan gets $f line] $line [chan gets $f line] $line] + chan close $f + set x +} {1 a -1 {}} +test chan-io-6.14 {Tcl_GetsObj: lf mode: 1 char followed by EOL} { + set f [open $path(test1) w] + chan configure $f -translation lf + chan puts -nonewline $f "a\n" + chan close $f + set f [open $path(test1)] + chan configure $f -translation lf + set x [list [chan gets $f line] $line [chan gets $f line] $line] + chan close $f + set x +} {1 a -1 {}} +test chan-io-6.15 {Tcl_GetsObj: lf mode: several chars} { + set f [open $path(test1) w] + chan configure $f -translation lf + chan puts -nonewline $f "abcd\nefgh\rijkl\r\nmnop" + chan close $f + set f [open $path(test1)] + chan configure $f -translation lf + set x [list [chan gets $f line] $line [chan gets $f line] $line [chan gets $f line] $line [chan gets $f line] $line] + chan close $f + set x +} [list 4 "abcd" 10 "efgh\rijkl\r" 4 "mnop" -1 ""] +test chan-io-6.16 {Tcl_GetsObj: cr mode: no chars} { + set f [open $path(test1) w] + chan close $f + set f [open $path(test1)] + chan configure $f -translation cr + set x [list [chan gets $f line] $line] + chan close $f + set x +} {-1 {}} +test chan-io-6.17 {Tcl_GetsObj: cr mode: lone \n} { + set f [open $path(test1) w] + chan configure $f -translation lf + chan puts -nonewline $f "\n" + chan close $f + set f [open $path(test1)] + chan configure $f -translation cr + set x [list [chan gets $f line] $line [chan gets $f line] $line] + chan close $f + set x +} [list 1 "\n" -1 ""] +test chan-io-6.18 {Tcl_GetsObj: cr mode: lone \r} { + set f [open $path(test1) w] + chan configure $f -translation lf + chan puts -nonewline $f "\r" + chan close $f + set f [open $path(test1)] + chan configure $f -translation cr + set x [list [chan gets $f line] $line [chan gets $f line] $line] + chan close $f + set x +} {0 {} -1 {}} +test chan-io-6.19 {Tcl_GetsObj: cr mode: 1 char} { + set f [open $path(test1) w] + chan configure $f -translation lf + chan puts -nonewline $f a + chan close $f + set f [open $path(test1)] + chan configure $f -translation cr + set x [list [chan gets $f line] $line [chan gets $f line] $line] + chan close $f + set x +} {1 a -1 {}} +test chan-io-6.20 {Tcl_GetsObj: cr mode: 1 char followed by EOL} { + set f [open $path(test1) w] + chan configure $f -translation lf + chan puts -nonewline $f "a\r" + chan close $f + set f [open $path(test1)] + chan configure $f -translation cr + set x [list [chan gets $f line] $line [chan gets $f line] $line] + chan close $f + set x +} {1 a -1 {}} +test chan-io-6.21 {Tcl_GetsObj: cr mode: several chars} { + set f [open $path(test1) w] + chan configure $f -translation lf + chan puts -nonewline $f "abcd\nefgh\rijkl\r\nmnop" + chan close $f + set f [open $path(test1)] + chan configure $f -translation cr + set x [list [chan gets $f line] $line [chan gets $f line] $line [chan gets $f line] $line [chan gets $f line] $line] + chan close $f + set x +} [list 9 "abcd\nefgh" 4 "ijkl" 5 "\nmnop" -1 ""] +test chan-io-6.22 {Tcl_GetsObj: crlf mode: no chars} { + set f [open $path(test1) w] + chan close $f + set f [open $path(test1)] + chan configure $f -translation crlf + set x [list [chan gets $f line] $line] + chan close $f + set x +} {-1 {}} +test chan-io-6.23 {Tcl_GetsObj: crlf mode: lone \n} { + set f [open $path(test1) w] + chan configure $f -translation lf + chan puts -nonewline $f "\n" + chan close $f + set f [open $path(test1)] + chan configure $f -translation crlf + set x [list [chan gets $f line] $line [chan gets $f line] $line] + chan close $f + set x +} [list 1 "\n" -1 ""] +test chan-io-6.24 {Tcl_GetsObj: crlf mode: lone \r} { + set f [open $path(test1) w] + chan configure $f -translation lf + chan puts -nonewline $f "\r" + chan close $f + set f [open $path(test1)] + chan configure $f -translation crlf + set x [list [chan gets $f line] $line [chan gets $f line] $line] + chan close $f + set x +} [list 1 "\r" -1 ""] +test chan-io-6.25 {Tcl_GetsObj: crlf mode: \r\r} { + set f [open $path(test1) w] + chan configure $f -translation lf + chan puts -nonewline $f "\r\r" + chan close $f + set f [open $path(test1)] + chan configure $f -translation crlf + set x [list [chan gets $f line] $line [chan gets $f line] $line] + chan close $f + set x +} [list 2 "\r\r" -1 ""] +test chan-io-6.26 {Tcl_GetsObj: crlf mode: \r\n} { + set f [open $path(test1) w] + chan configure $f -translation lf + chan puts -nonewline $f "\r\n" + chan close $f + set f [open $path(test1)] + chan configure $f -translation crlf + set x [list [chan gets $f line] $line [chan gets $f line] $line] + chan close $f + set x +} [list 0 "" -1 ""] +test chan-io-6.27 {Tcl_GetsObj: crlf mode: 1 char} { + set f [open $path(test1) w] + chan configure $f -translation lf + chan puts -nonewline $f a + chan close $f + set f [open $path(test1)] + chan configure $f -translation crlf + set x [list [chan gets $f line] $line [chan gets $f line] $line] + chan close $f + set x +} {1 a -1 {}} +test chan-io-6.28 {Tcl_GetsObj: crlf mode: 1 char followed by EOL} { + set f [open $path(test1) w] + chan configure $f -translation lf + chan puts -nonewline $f "a\r\n" + chan close $f + set f [open $path(test1)] + chan configure $f -translation crlf + set x [list [chan gets $f line] $line [chan gets $f line] $line] + chan close $f + set x +} {1 a -1 {}} +test chan-io-6.29 {Tcl_GetsObj: crlf mode: several chars} { + set f [open $path(test1) w] + chan configure $f -translation lf + chan puts -nonewline $f "abcd\nefgh\rijkl\r\nmnop" + chan close $f + set f [open $path(test1)] + chan configure $f -translation crlf + set x [list [chan gets $f line] $line [chan gets $f line] $line [chan gets $f line] $line] + chan close $f + set x +} [list 14 "abcd\nefgh\rijkl" 4 "mnop" -1 ""] +test chan-io-6.30 {Tcl_GetsObj: crlf mode: buffer exhausted} {testchannel} { + # if (eol >= dstEnd) + + set f [open $path(test1) w] + chan configure $f -translation lf + chan puts -nonewline $f "123456789012345\r\nabcdefghijklmnoprstuvwxyz" + chan close $f + set f [open $path(test1)] + chan configure $f -translation crlf -buffersize 16 + set x [list [chan gets $f line] $line [testchannel inputbuffered $f]] + chan close $f + set x +} [list 15 "123456789012345" 15] +test chan-io-6.31 {Tcl_GetsObj: crlf mode: buffer exhausted, blocked} {stdio testchannel openpipe fileevent} { + # (FilterInputBytes() != 0) + + set f [open "|[list [interpreter] $path(cat)]" w+] + chan configure $f -translation {crlf lf} -buffering none + chan puts -nonewline $f "bbbbbbbbbbbbbb\r\n123456789012345\r" + chan configure $f -buffersize 16 + set x [chan gets $f] + chan configure $f -blocking 0 + lappend x [chan gets $f line] $line [chan blocked $f] [testchannel inputbuffered $f] + chan close $f + set x +} [list "bbbbbbbbbbbbbb" -1 "" 1 16] +test chan-io-6.32 {Tcl_GetsObj: crlf mode: buffer exhausted, more data} {testchannel} { + # not (FilterInputBytes() != 0) + + set f [open $path(test1) w] + chan configure $f -translation lf + chan puts -nonewline $f "123456789012345\r\n123" + chan close $f + set f [open $path(test1)] + chan configure $f -translation crlf -buffersize 16 + set x [list [chan gets $f line] $line [chan tell $f] [testchannel inputbuffered $f]] + chan close $f + set x +} [list 15 "123456789012345" 17 3] +test chan-io-6.33 {Tcl_GetsObj: crlf mode: buffer exhausted, at eof} { + # eol still equals dstEnd + + set f [open $path(test1) w] + chan configure $f -translation lf + chan puts -nonewline $f "123456789012345\r" + chan close $f + set f [open $path(test1)] + chan configure $f -translation crlf -buffersize 16 + set x [list [chan gets $f line] $line [chan eof $f]] + chan close $f + set x +} [list 16 "123456789012345\r" 1] +test chan-io-6.34 {Tcl_GetsObj: crlf mode: buffer exhausted, not followed by \n} { + # not (*eol == '\n') + + set f [open $path(test1) w] + chan configure $f -translation lf + chan puts -nonewline $f "123456789012345\rabcd\r\nefg" + chan close $f + set f [open $path(test1)] + chan configure $f -translation crlf -buffersize 16 + set x [list [chan gets $f line] $line [chan tell $f]] + chan close $f + set x +} [list 20 "123456789012345\rabcd" 22] +test chan-io-6.35 {Tcl_GetsObj: auto mode: no chars} { + set f [open $path(test1) w] + chan close $f + set f [open $path(test1)] + chan configure $f -translation auto + set x [list [chan gets $f line] $line] + chan close $f + set x +} {-1 {}} +test chan-io-6.36 {Tcl_GetsObj: auto mode: lone \n} { + set f [open $path(test1) w] + chan configure $f -translation lf + chan puts -nonewline $f "\n" + chan close $f + set f [open $path(test1)] + chan configure $f -translation auto + set x [list [chan gets $f line] $line [chan gets $f line] $line] + chan close $f + set x +} [list 0 "" -1 ""] +test chan-io-6.37 {Tcl_GetsObj: auto mode: lone \r} { + set f [open $path(test1) w] + chan configure $f -translation lf + chan puts -nonewline $f "\r" + chan close $f + set f [open $path(test1)] + chan configure $f -translation auto + set x [list [chan gets $f line] $line [chan gets $f line] $line] + chan close $f + set x +} [list 0 "" -1 ""] +test chan-io-6.38 {Tcl_GetsObj: auto mode: \r\r} { + set f [open $path(test1) w] + chan configure $f -translation lf + chan puts -nonewline $f "\r\r" + chan close $f + set f [open $path(test1)] + chan configure $f -translation auto + set x [list [chan gets $f line] $line [chan gets $f line] $line [chan gets $f line] $line] + chan close $f + set x +} [list 0 "" 0 "" -1 ""] +test chan-io-6.39 {Tcl_GetsObj: auto mode: \r\n} { + set f [open $path(test1) w] + chan configure $f -translation lf + chan puts -nonewline $f "\r\n" + chan close $f + set f [open $path(test1)] + chan configure $f -translation auto + set x [list [chan gets $f line] $line [chan gets $f line] $line] + chan close $f + set x +} [list 0 "" -1 ""] +test chan-io-6.40 {Tcl_GetsObj: auto mode: 1 char} { + set f [open $path(test1) w] + chan configure $f -translation lf + chan puts -nonewline $f a + chan close $f + set f [open $path(test1)] + chan configure $f -translation auto + set x [list [chan gets $f line] $line [chan gets $f line] $line] + chan close $f + set x +} {1 a -1 {}} +test chan-io-6.41 {Tcl_GetsObj: auto mode: 1 char followed by EOL} { + set f [open $path(test1) w] + chan configure $f -translation lf + chan puts -nonewline $f "a\r\n" + chan close $f + set f [open $path(test1)] + chan configure $f -translation auto + set x [list [chan gets $f line] $line [chan gets $f line] $line] + chan close $f + set x +} {1 a -1 {}} +test chan-io-6.42 {Tcl_GetsObj: auto mode: several chars} { + set f [open $path(test1) w] + chan configure $f -translation lf + chan puts -nonewline $f "abcd\nefgh\rijkl\r\nmnop" + chan close $f + set f [open $path(test1)] + chan configure $f -translation auto + set x [list [chan gets $f line] $line [chan gets $f line] $line] + lappend x [chan gets $f line] $line [chan gets $f line] $line [chan gets $f line] $line + chan close $f + set x +} [list 4 "abcd" 4 "efgh" 4 "ijkl" 4 "mnop" -1 ""] +test chan-io-6.43 {Tcl_GetsObj: input saw cr} {stdio testchannel openpipe fileevent} { + # if (chanPtr->flags & INPUT_SAW_CR) + + set f [open "|[list [interpreter] $path(cat)]" w+] + chan configure $f -translation {auto lf} -buffering none + chan puts -nonewline $f "bbbbbbbbbbbbbbb\n123456789abcdef\r" + chan configure $f -buffersize 16 + set x [list [chan gets $f]] + chan configure $f -blocking 0 + lappend x [chan gets $f line] $line [testchannel queuedcr $f] + chan configure $f -blocking 1 + chan puts -nonewline $f "\nabcd\refg\x1a" + lappend x [chan gets $f line] $line [testchannel queuedcr $f] + lappend x [chan gets $f line] $line + chan close $f + set x +} [list "bbbbbbbbbbbbbbb" 15 "123456789abcdef" 1 4 "abcd" 0 3 "efg"] +test chan-io-6.44 {Tcl_GetsObj: input saw cr, not followed by cr} {stdio testchannel openpipe fileevent} { + # not (*eol == '\n') + + set f [open "|[list [interpreter] $path(cat)]" w+] + chan configure $f -translation {auto lf} -buffering none + chan puts -nonewline $f "bbbbbbbbbbbbbbb\n123456789abcdef\r" + chan configure $f -buffersize 16 + set x [list [chan gets $f]] + chan configure $f -blocking 0 + lappend x [chan gets $f line] $line [testchannel queuedcr $f] + chan configure $f -blocking 1 + chan puts -nonewline $f "abcd\refg\x1a" + lappend x [chan gets $f line] $line [testchannel queuedcr $f] + lappend x [chan gets $f line] $line + chan close $f + set x +} [list "bbbbbbbbbbbbbbb" 15 "123456789abcdef" 1 4 "abcd" 0 3 "efg"] +test chan-io-6.45 {Tcl_GetsObj: input saw cr, skip right number of bytes} {stdio testchannel openpipe fileevent} { + # Tcl_ExternalToUtf() + + set f [open "|[list [interpreter] $path(cat)]" w+] + chan configure $f -translation {auto lf} -buffering none + chan configure $f -encoding unicode + chan puts -nonewline $f "bbbbbbbbbbbbbbb\n123456789abcdef\r" + chan configure $f -buffersize 16 + chan gets $f + chan configure $f -blocking 0 + set x [list [chan gets $f line] $line [testchannel queuedcr $f]] + chan configure $f -blocking 1 + chan puts -nonewline $f "\nabcd\refg" + lappend x [chan gets $f line] $line [testchannel queuedcr $f] + chan close $f + set x +} [list 15 "123456789abcdef" 1 4 "abcd" 0] +test chan-io-6.46 {Tcl_GetsObj: input saw cr, followed by just \n should give eof} {stdio testchannel openpipe fileevent} { + # memmove() + + set f [open "|[list [interpreter] $path(cat)]" w+] + chan configure $f -translation {auto lf} -buffering none + chan puts -nonewline $f "bbbbbbbbbbbbbbb\n123456789abcdef\r" + chan configure $f -buffersize 16 + chan gets $f + chan configure $f -blocking 0 + set x [list [chan gets $f line] $line [testchannel queuedcr $f]] + chan configure $f -blocking 1 + chan puts -nonewline $f "\n\x1a" + lappend x [chan gets $f line] $line [testchannel queuedcr $f] + chan close $f + set x +} [list 15 "123456789abcdef" 1 -1 "" 0] +test chan-io-6.47 {Tcl_GetsObj: auto mode: \r at end of buffer, peek for \n} {testchannel} { + # (eol == dstEnd) + + set f [open $path(test1) w] + chan configure $f -translation lf + chan puts -nonewline $f "123456789012345\r\nabcdefghijklmnopq" + chan close $f + set f [open $path(test1)] + chan configure $f -translation auto -buffersize 16 + set x [list [chan gets $f] [testchannel inputbuffered $f]] + chan close $f + set x +} [list "123456789012345" 15] +test chan-io-6.48 {Tcl_GetsObj: auto mode: \r at end of buffer, no more avail} {testchannel} { + # PeekAhead() did not get any, so (eol >= dstEnd) + + set f [open $path(test1) w] + chan configure $f -translation lf + chan puts -nonewline $f "123456789012345\r" + chan close $f + set f [open $path(test1)] + chan configure $f -translation auto -buffersize 16 + set x [list [chan gets $f] [testchannel queuedcr $f]] + chan close $f + set x +} [list "123456789012345" 1] +test chan-io-6.49 {Tcl_GetsObj: auto mode: \r followed by \n} {testchannel} { + # if (*eol == '\n') {skip++} + + set f [open $path(test1) w] + chan configure $f -translation lf + chan puts -nonewline $f "123456\r\n78901" + chan close $f + set f [open $path(test1)] + set x [list [chan gets $f] [testchannel queuedcr $f] [chan tell $f] [chan gets $f]] + chan close $f + set x +} [list "123456" 0 8 "78901"] +test chan-io-6.50 {Tcl_GetsObj: auto mode: \r not followed by \n} {testchannel} { + # not (*eol == '\n') + + set f [open $path(test1) w] + chan configure $f -translation lf + chan puts -nonewline $f "123456\r78901" + chan close $f + set f [open $path(test1)] + set x [list [chan gets $f] [testchannel queuedcr $f] [chan tell $f] [chan gets $f]] + chan close $f + set x +} [list "123456" 0 7 "78901"] +test chan-io-6.51 {Tcl_GetsObj: auto mode: \n} { + # else if (*eol == '\n') {goto gotoeol;} + + set f [open $path(test1) w] + chan configure $f -translation lf + chan puts -nonewline $f "123456\n78901" + chan close $f + set f [open $path(test1)] + set x [list [chan gets $f] [chan tell $f] [chan gets $f]] + chan close $f + set x +} [list "123456" 7 "78901"] +test chan-io-6.52 {Tcl_GetsObj: saw EOF character} {testchannel} { + # if (eof != NULL) + + set f [open $path(test1) w] + chan configure $f -translation lf + chan puts -nonewline $f "123456\x1ak9012345\r" + chan close $f + set f [open $path(test1)] + chan configure $f -eofchar \x1a + set x [list [chan gets $f] [testchannel queuedcr $f] [chan tell $f] [chan gets $f]] + chan close $f + set x +} [list "123456" 0 6 ""] +test chan-io-6.53 {Tcl_GetsObj: device EOF} { + # didn't produce any bytes + + set f [open $path(test1) w] + chan close $f + set f [open $path(test1)] + set x [list [chan gets $f line] $line [chan eof $f]] + chan close $f + set x +} {-1 {} 1} +test chan-io-6.54 {Tcl_GetsObj: device EOF} { + # got some bytes before EOF. + + set f [open $path(test1) w] + chan puts -nonewline $f abc + chan close $f + set f [open $path(test1)] + set x [list [chan gets $f line] $line [chan eof $f]] + chan close $f + set x +} {3 abc 1} +test chan-io-6.55 {Tcl_GetsObj: overconverted} { + # Tcl_ExternalToUtf(), make sure state updated + + set f [open $path(test1) w] + chan configure $f -encoding iso2022-jp + chan puts $f "there\u4e00ok\n\u4e01more bytes\nhere" + chan close $f + set f [open $path(test1)] + chan configure $f -encoding iso2022-jp + set x [list [chan gets $f line] $line [chan gets $f line] $line [chan gets $f line] $line] + chan close $f + set x +} [list 8 "there\u4e00ok" 11 "\u4e01more bytes" 4 "here"] +test chan-io-6.56 {Tcl_GetsObj: incomplete lines should disable file events} {stdio openpipe fileevent} { + update + set f [open "|[list [interpreter] $path(cat)]" w+] + chan configure $f -buffering none + chan puts -nonewline $f "foobar" + chan configure $f -blocking 0 + variable x {} + after 500 [namespace code { lappend x timeout }] + chan event $f readable [namespace code { lappend x [chan gets $f] }] + vwait [namespace which -variable x] + vwait [namespace which -variable x] + chan configure $f -blocking 1 + chan puts -nonewline $f "baz\n" + after 500 [namespace code { lappend x timeout }] + chan configure $f -blocking 0 + vwait [namespace which -variable x] + vwait [namespace which -variable x] + chan close $f + set x +} {{} timeout foobarbaz timeout} + +test chan-io-7.1 {FilterInputBytes: split up character at end of buffer} { + # (result == TCL_CONVERT_MULTIBYTE) + + set f [open $path(test1) w] + chan configure $f -encoding shiftjis + chan puts $f "1234567890123\uff10\uff11\uff12\uff13\uff14\nend" + chan close $f + set f [open $path(test1)] + chan configure $f -encoding shiftjis -buffersize 16 + set x [chan gets $f] + chan close $f + set x +} "1234567890123\uff10\uff11\uff12\uff13\uff14" +test chan-io-7.2 {FilterInputBytes: split up character in middle of buffer} { + # (bufPtr->nextAdded < bufPtr->bufLength) + + set f [open $path(test1) w] + chan configure $f -encoding binary + chan puts -nonewline $f "1234567890\n123\x82\x4f\x82\x50\x82" + chan close $f + set f [open $path(test1)] + chan configure $f -encoding shiftjis + set x [list [chan gets $f line] $line [chan eof $f]] + chan close $f + set x +} [list 10 "1234567890" 0] +test chan-io-7.3 {FilterInputBytes: split up character at EOF} {testchannel} { + set f [open $path(test1) w] + chan configure $f -encoding binary + chan puts -nonewline $f "1234567890123\x82\x4f\x82\x50\x82" + chan close $f + set f [open $path(test1)] + chan configure $f -encoding shiftjis + set x [list [chan gets $f line] $line] + lappend x [chan tell $f] [testchannel inputbuffered $f] [chan eof $f] + lappend x [chan gets $f line] $line + chan close $f + set x +} [list 15 "1234567890123\uff10\uff11" 18 0 1 -1 ""] +test chan-io-7.4 {FilterInputBytes: recover from split up character} {stdio openpipe fileevent} { + set f [open "|[list [interpreter] $path(cat)]" w+] + chan configure $f -encoding binary -buffering none + chan puts -nonewline $f "1234567890123\x82\x4f\x82\x50\x82" + chan configure $f -encoding shiftjis -blocking 0 + chan event $f read [namespace code "ready $f"] + variable x {} + proc ready {f} { + variable x + lappend x [chan gets $f line] $line [chan blocked $f] + } + vwait [namespace which -variable x] + chan configure $f -encoding binary -blocking 1 + chan puts $f "\x51\x82\x52" + chan configure $f -encoding shiftjis + vwait [namespace which -variable x] + chan close $f + set x +} [list -1 "" 1 17 "1234567890123\uff10\uff11\uff12\uff13" 0] + +test chan-io-8.1 {PeekAhead: only go to device if no more cached data} {testchannel} { + # (bufPtr->nextPtr == NULL) + + set f [open $path(test1) w] + chan configure $f -encoding ascii -translation lf + chan puts -nonewline $f "123456789012345\r\n2345678" + chan close $f + set f [open $path(test1)] + chan configure $f -encoding ascii -translation auto -buffersize 16 + # here + chan gets $f + set x [testchannel inputbuffered $f] + chan close $f + set x +} "7" +test chan-io-8.2 {PeekAhead: only go to device if no more cached data} {stdio testchannel openpipe fileevent} { + # not (bufPtr->nextPtr == NULL) + + set f [open "|[list [interpreter] $path(cat)]" w+] + chan configure $f -translation lf -encoding ascii -buffering none + chan puts -nonewline $f "123456789012345\r\nbcdefghijklmnopqrstuvwxyz" + variable x {} + chan event $f read [namespace code "ready $f"] + proc ready {f} { + variable x + lappend x [chan gets $f line] $line [testchannel inputbuffered $f] + } + chan configure $f -encoding unicode -buffersize 16 -blocking 0 + vwait [namespace which -variable x] + chan configure $f -translation auto -encoding ascii -blocking 1 + # here + vwait [namespace which -variable x] + chan close $f + set x +} [list -1 "" 42 15 "123456789012345" 25] +test chan-io-8.3 {PeekAhead: no cached data available} {stdio testchannel openpipe fileevent} { + # (bytesLeft == 0) + + set f [open "|[list [interpreter] $path(cat)]" w+] + chan configure $f -translation {auto binary} + chan puts -nonewline $f "abcdefghijklmno\r" + chan flush $f + set x [list [chan gets $f line] $line [testchannel queuedcr $f]] + chan close $f + set x +} [list 15 "abcdefghijklmno" 1] +set a "123456789012345678901234567890" +append a "123456789012345678901234567890" +append a "1234567890123456789012345678901" +test chan-io-8.4 {PeekAhead: cached data available in this buffer} { + # not (bytesLeft == 0) + + set f [open $path(test1) w+] + chan configure $f -translation binary + chan puts $f "${a}\r\nabcdef" + chan close $f + set f [open $path(test1)] + chan configure $f -encoding binary -translation auto + + # "${a}\r" was converted in one operation (because ENCODING_LINESIZE + # is 30). To check if "\n" follows, calls PeekAhead and determines + # that cached data is available in buffer w/o having to call driver. + + set x [chan gets $f] + chan close $f + set x +} $a +unset a +test chan-io-8.5 {PeekAhead: don't peek if last read was short} {stdio testchannel openpipe fileevent} { + # (bufPtr->nextAdded < bufPtr->length) + + set f [open "|[list [interpreter] $path(cat)]" w+] + chan configure $f -translation {auto binary} + chan puts -nonewline $f "abcdefghijklmno\r" + chan flush $f + # here + set x [list [chan gets $f line] $line [testchannel queuedcr $f]] + chan close $f + set x +} {15 abcdefghijklmno 1} +test chan-io-8.6 {PeekAhead: change to non-blocking mode} {stdio testchannel openpipe fileevent} { + # ((chanPtr->flags & CHANNEL_NONBLOCKING) == 0) + + set f [open "|[list [interpreter] $path(cat)]" w+] + chan configure $f -translation {auto binary} -buffersize 16 + chan puts -nonewline $f "abcdefghijklmno\r" + chan flush $f + # here + set x [list [chan gets $f line] $line [testchannel queuedcr $f]] + chan close $f + set x +} {15 abcdefghijklmno 1} +test chan-io-8.7 {PeekAhead: cleanup} {stdio testchannel openpipe fileevent} { + # Make sure bytes are removed from buffer. + + set f [open "|[list [interpreter] $path(cat)]" w+] + chan configure $f -translation {auto binary} -buffering none + chan puts -nonewline $f "abcdefghijklmno\r" + # here + set x [list [chan gets $f line] $line [testchannel queuedcr $f]] + chan puts -nonewline $f "\x1a" + lappend x [chan gets $f line] $line + chan close $f + set x +} {15 abcdefghijklmno 1 -1 {}} + +test chan-io-9.1 {CommonGetsCleanup} emptyTest { +} {} + +test chan-io-10.1 {Tcl_ReadChars: CheckChannelErrors} emptyTest { + # no test, need to cause an async error. +} {} +test chan-io-10.2 {Tcl_ReadChars: loop until enough copied} { + # one time + # for (copied = 0; (unsigned) toRead > 0; ) + + set f [open $path(test1) w] + chan puts $f abcdefghijklmnop + chan close $f + + set f [open $path(test1)] + set x [chan read $f 5] + chan close $f + set x +} {abcde} +test chan-io-10.3 {Tcl_ReadChars: loop until enough copied} { + # multiple times + # for (copied = 0; (unsigned) toRead > 0; ) + + set f [open $path(test1) w] + chan puts $f abcdefghijklmnopqrstuvwxyz + chan close $f + + set f [open $path(test1)] + chan configure $f -buffersize 16 + # here + set x [chan read $f 19] + chan close $f + set x +} {abcdefghijklmnopqrs} +test chan-io-10.4 {Tcl_ReadChars: no more in channel buffer} { + # (copiedNow < 0) + + set f [open $path(test1) w] + chan puts -nonewline $f abcdefghijkl + chan close $f + + set f [open $path(test1)] + # here + set x [chan read $f 1000] + chan close $f + set x +} {abcdefghijkl} +test chan-io-10.5 {Tcl_ReadChars: stop on EOF} { + # (chanPtr->flags & CHANNEL_EOF) + + set f [open $path(test1) w] + chan puts -nonewline $f abcdefghijkl + chan close $f + + set f [open $path(test1)] + # here + set x [chan read $f 1000] + chan close $f + set x +} {abcdefghijkl} + +test chan-io-11.1 {ReadBytes: want to read a lot} { + # ((unsigned) toRead > (unsigned) srcLen) + + set f [open $path(test1) w] + chan puts -nonewline $f abcdefghijkl + chan close $f + set f [open $path(test1)] + chan configure $f -encoding binary + # here + set x [chan read $f 1000] + chan close $f + set x +} {abcdefghijkl} +test chan-io-11.2 {ReadBytes: want to read all} { + # ((unsigned) toRead > (unsigned) srcLen) + + set f [open $path(test1) w] + chan puts -nonewline $f abcdefghijkl + chan close $f + set f [open $path(test1)] + chan configure $f -encoding binary + # here + set x [chan read $f] + chan close $f + set x +} {abcdefghijkl} +test chan-io-11.3 {ReadBytes: allocate more space} { + # (toRead > length - offset - 1) + + set f [open $path(test1) w] + chan puts -nonewline $f abcdefghijklmnopqrstuvwxyz + chan close $f + set f [open $path(test1)] + chan configure $f -buffersize 16 -encoding binary + # here + set x [chan read $f] + chan close $f + set x +} {abcdefghijklmnopqrstuvwxyz} +test chan-io-11.4 {ReadBytes: EOF char found} { + # (TranslateInputEOL() != 0) + + set f [open $path(test1) w] + chan puts $f abcdefghijklmnopqrstuvwxyz + chan close $f + set f [open $path(test1)] + chan configure $f -eofchar m -encoding binary + # here + set x [list [chan read $f] [chan eof $f] [chan read $f] [chan eof $f]] + chan close $f + set x +} [list "abcdefghijkl" 1 "" 1] + +test chan-io-12.1 {ReadChars: want to read a lot} { + # ((unsigned) toRead > (unsigned) srcLen) + + set f [open $path(test1) w] + chan puts -nonewline $f abcdefghijkl + chan close $f + set f [open $path(test1)] + # here + set x [chan read $f 1000] + chan close $f + set x +} {abcdefghijkl} +test chan-io-12.2 {ReadChars: want to read all} { + # ((unsigned) toRead > (unsigned) srcLen) + + set f [open $path(test1) w] + chan puts -nonewline $f abcdefghijkl + chan close $f + set f [open $path(test1)] + # here + set x [chan read $f] + chan close $f + set x +} {abcdefghijkl} +test chan-io-12.3 {ReadChars: allocate more space} { + # (toRead > length - offset - 1) + + set f [open $path(test1) w] + chan puts -nonewline $f abcdefghijklmnopqrstuvwxyz + chan close $f + set f [open $path(test1)] + chan configure $f -buffersize 16 + # here + set x [chan read $f] + chan close $f + set x +} {abcdefghijklmnopqrstuvwxyz} +test chan-io-12.4 {ReadChars: split-up char} {stdio testchannel openpipe fileevent} { + # (srcRead == 0) + + set f [open "|[list [interpreter] $path(cat)]" w+] + chan configure $f -encoding binary -buffering none -buffersize 16 + chan puts -nonewline $f "123456789012345\x96" + chan configure $f -encoding shiftjis -blocking 0 + + chan event $f read [namespace code "ready $f"] + proc ready {f} { + variable x + lappend x [chan read $f] [testchannel inputbuffered $f] + } + variable x {} + + chan configure $f -encoding shiftjis + vwait [namespace which -variable x] + chan configure $f -encoding binary -blocking 1 + chan puts -nonewline $f "\x7b" + after 500 ;# Give the cat process time to catch up + chan configure $f -encoding shiftjis -blocking 0 + vwait [namespace which -variable x] + chan close $f + set x +} [list "123456789012345" 1 "\u672c" 0] +test chan-io-12.5 {ReadChars: chan events on partial characters} {stdio openpipe fileevent} { + set path(test1) [makeFile { + chan configure stdout -encoding binary -buffering none + chan gets stdin; chan puts -nonewline "\xe7" + chan gets stdin; chan puts -nonewline "\x89" + chan gets stdin; chan puts -nonewline "\xa6" + } test1] + set f [open "|[list [interpreter] $path(test1)]" r+] + chan event $f readable [namespace code { + lappend x [chan read $f] + if {[chan eof $f]} { + lappend x eof + } + }] + chan puts $f "go1" + chan flush $f + chan configure $f -blocking 0 -encoding utf-8 + variable x {} + vwait [namespace which -variable x] + after 500 [namespace code { lappend x timeout }] + vwait [namespace which -variable x] + chan puts $f "go2" + chan flush $f + vwait [namespace which -variable x] + after 500 [namespace code { lappend x timeout }] + vwait [namespace which -variable x] + chan puts $f "go3" + chan flush $f + vwait [namespace which -variable x] + vwait [namespace which -variable x] + lappend x [catch {chan close $f} msg] $msg + set x +} "{} timeout {} timeout \u7266 {} eof 0 {}" + +test chan-io-13.1 {TranslateInputEOL: cr mode} {} { + set f [open $path(test1) w] + chan configure $f -translation lf + chan puts -nonewline $f "abcd\rdef\r" + chan close $f + set f [open $path(test1)] + chan configure $f -translation cr + set x [chan read $f] + chan close $f + set x +} "abcd\ndef\n" +test chan-io-13.2 {TranslateInputEOL: crlf mode} { + set f [open $path(test1) w] + chan configure $f -translation lf + chan puts -nonewline $f "abcd\r\ndef\r\n" + chan close $f + set f [open $path(test1)] + chan configure $f -translation crlf + set x [chan read $f] + chan close $f + set x +} "abcd\ndef\n" +test chan-io-13.3 {TranslateInputEOL: crlf mode: naked cr} { + # (src >= srcMax) + + set f [open $path(test1) w] + chan configure $f -translation lf + chan puts -nonewline $f "abcd\r\ndef\r" + chan close $f + set f [open $path(test1)] + chan configure $f -translation crlf + set x [chan read $f] + chan close $f + set x +} "abcd\ndef\r" +test chan-io-13.4 {TranslateInputEOL: crlf mode: cr followed by not \n} { + # (src >= srcMax) + + set f [open $path(test1) w] + chan configure $f -translation lf + chan puts -nonewline $f "abcd\r\ndef\rfgh" + chan close $f + set f [open $path(test1)] + chan configure $f -translation crlf + set x [chan read $f] + chan close $f + set x +} "abcd\ndef\rfgh" +test chan-io-13.5 {TranslateInputEOL: crlf mode: naked lf} { + # (src >= srcMax) + + set f [open $path(test1) w] + chan configure $f -translation lf + chan puts -nonewline $f "abcd\r\ndef\nfgh" + chan close $f + set f [open $path(test1)] + chan configure $f -translation crlf + set x [chan read $f] + chan close $f + set x +} "abcd\ndef\nfgh" +test chan-io-13.6 {TranslateInputEOL: auto mode: saw cr in last segment} {stdio testchannel openpipe fileevent} { + # (chanPtr->flags & INPUT_SAW_CR) + # This test may fail on slower machines. + + set f [open "|[list [interpreter] $path(cat)]" w+] + chan configure $f -blocking 0 -buffering none -translation {auto lf} + + chan event $f read [namespace code "ready $f"] + proc ready {f} { + variable x + lappend x [chan read $f] [testchannel queuedcr $f] + } + variable x {} + variable y {} + + chan puts -nonewline $f "abcdefghj\r" + after 500 [namespace code {set y ok}] + vwait [namespace which -variable y] + + chan puts -nonewline $f "\n01234" + after 500 [namespace code {set y ok}] + vwait [namespace which -variable y] + + chan close $f + set x +} [list "abcdefghj\n" 1 "01234" 0] +test chan-io-13.7 {TranslateInputEOL: auto mode: naked \r} {testchannel openpipe} { + # (src >= srcMax) + + set f [open $path(test1) w] + chan configure $f -translation lf + chan puts -nonewline $f "abcd\r" + chan close $f + set f [open $path(test1)] + chan configure $f -translation auto + set x [list [chan read $f] [testchannel queuedcr $f]] + chan close $f + set x +} [list "abcd\n" 1] +test chan-io-13.8 {TranslateInputEOL: auto mode: \r\n} { + # (*src == '\n') + + set f [open $path(test1) w] + chan configure $f -translation lf + chan puts -nonewline $f "abcd\r\ndef" + chan close $f + set f [open $path(test1)] + chan configure $f -translation auto + set x [chan read $f] + chan close $f + set x +} "abcd\ndef" +test chan-io-13.9 {TranslateInputEOL: auto mode: \r followed by not \n} { + set f [open $path(test1) w] + chan configure $f -translation lf + chan puts -nonewline $f "abcd\rdef" + chan close $f + set f [open $path(test1)] + chan configure $f -translation auto + set x [chan read $f] + chan close $f + set x +} "abcd\ndef" +test chan-io-13.10 {TranslateInputEOL: auto mode: \n} { + # not (*src == '\r') + + set f [open $path(test1) w] + chan configure $f -translation lf + chan puts -nonewline $f "abcd\ndef" + chan close $f + set f [open $path(test1)] + chan configure $f -translation auto + set x [chan read $f] + chan close $f + set x +} "abcd\ndef" +test chan-io-13.11 {TranslateInputEOL: EOF char} { + # (*chanPtr->inEofChar != '\0') + + set f [open $path(test1) w] + chan configure $f -translation lf + chan puts -nonewline $f "abcd\ndefgh" + chan close $f + set f [open $path(test1)] + chan configure $f -translation auto -eofchar e + set x [chan read $f] + chan close $f + set x +} "abcd\nd" +test chan-io-13.12 {TranslateInputEOL: find EOF char in src} { + # (*chanPtr->inEofChar != '\0') + + set f [open $path(test1) w] + chan configure $f -translation lf + chan puts -nonewline $f "\r\n\r\n\r\nab\r\n\r\ndef\r\n\r\n\r\n" + chan close $f + set f [open $path(test1)] + chan configure $f -translation auto -eofchar e + set x [chan read $f] + chan close $f + set x +} "\n\n\nab\n\nd" + +# Test standard handle management. The functions tested are +# Tcl_SetStdChannel and Tcl_GetStdChannel. Incidentally we are +# also testing channel table management. + +if {[info commands testchannel] != ""} { + set consoleFileNames [lsort [testchannel open]] +} else { + # just to avoid an error + set consoleFileNames [list] +} + +test chan-io-14.1 {Tcl_SetStdChannel and Tcl_GetStdChannel} {testchannel} { + set l "" + lappend l [chan configure stdin -buffering] + lappend l [chan configure stdout -buffering] + lappend l [chan configure stderr -buffering] + lappend l [lsort [testchannel open]] + set l +} [list line line none $consoleFileNames] +test chan-io-14.2 {Tcl_SetStdChannel and Tcl_GetStdChannel} { + interp create x + set l "" + lappend l [x eval {chan configure stdin -buffering}] + lappend l [x eval {chan configure stdout -buffering}] + lappend l [x eval {chan configure stderr -buffering}] + interp delete x + set l +} {line line none} +set path(test3) [makeFile {} test3] +test chan-io-14.3 {Tcl_SetStdChannel & Tcl_GetStdChannel} {exec openpipe} { + set f [open $path(test1) w] + chan puts -nonewline $f { + chan close stdin + chan close stdout + chan close stderr + set f [} + chan puts $f [list open $path(test1) r]] + chan puts $f "set f2 \[[list open $path(test2) w]]" + chan puts $f "set f3 \[[list open $path(test3) w]]" + chan puts $f { chan puts stdout [chan gets stdin] + chan puts stdout out + chan puts stderr err + chan close $f + chan close $f2 + chan close $f3 + } + chan close $f + set result [exec [interpreter] $path(test1)] + set f [open $path(test2) r] + set f2 [open $path(test3) r] + lappend result [chan read $f] [chan read $f2] + chan close $f + chan close $f2 + set result +} {{ +out +} {err +}} +# This test relies on the fact that the smallest available fd is used first. +test chan-io-14.4 {Tcl_SetStdChannel & Tcl_GetStdChannel} {exec unix} { + set f [open $path(test1) w] + chan puts -nonewline $f { chan close stdin + chan close stdout + chan close stderr + set f [} + chan puts $f [list open $path(test1) r]] + chan puts $f "set f2 \[[list open $path(test2) w]]" + chan puts $f "set f3 \[[list open $path(test3) w]]" + chan puts $f { chan puts stdout [chan gets stdin] + chan puts stdout $f2 + chan puts stderr $f3 + chan close $f + chan close $f2 + chan close $f3 + } + chan close $f + set result [exec [interpreter] $path(test1)] + set f [open $path(test2) r] + set f2 [open $path(test3) r] + lappend result [chan read $f] [chan read $f2] + chan close $f + chan close $f2 + set result +} {{ chan close stdin +file1 +} {file2 +}} +catch {interp delete z} +test chan-io-14.5 {Tcl_GetChannel: stdio name translation} { + interp create z + chan eof stdin + catch {z eval chan flush stdin} msg1 + catch {z eval chan close stdin} msg2 + catch {z eval chan flush stdin} msg3 + set result [list $msg1 $msg2 $msg3] + interp delete z + set result +} {{channel "stdin" wasn't opened for writing} {} {can not find channel named "stdin"}} +test chan-io-14.6 {Tcl_GetChannel: stdio name translation} { + interp create z + chan eof stdout + catch {z eval chan flush stdout} msg1 + catch {z eval chan close stdout} msg2 + catch {z eval chan flush stdout} msg3 + set result [list $msg1 $msg2 $msg3] + interp delete z + set result +} {{} {} {can not find channel named "stdout"}} +test chan-io-14.7 {Tcl_GetChannel: stdio name translation} { + interp create z + chan eof stderr + catch {z eval chan flush stderr} msg1 + catch {z eval chan close stderr} msg2 + catch {z eval chan flush stderr} msg3 + set result [list $msg1 $msg2 $msg3] + interp delete z + set result +} {{} {} {can not find channel named "stderr"}} +set path(script) [makeFile {} script] +test chan-io-14.8 {reuse of stdio special channels} {stdio openpipe} { + file delete $path(script) + file delete $path(test1) + set f [open $path(script) w] + chan puts -nonewline $f { + chan close stderr + set f [} + chan puts $f [list open $path(test1) w]] + chan puts -nonewline $f { + chan puts stderr hello + chan close $f + set f [} + chan puts $f [list open $path(test1) r]] + chan puts $f { + chan puts [chan gets $f] + } + chan close $f + set f [open "|[list [interpreter] $path(script)]" r] + set c [chan gets $f] + chan close $f + set c +} hello +test chan-io-14.9 {reuse of stdio special channels} {stdio openpipe fileevent} { + file delete $path(script) + file delete $path(test1) + set f [open $path(script) w] + chan puts $f { + array set path [lindex $argv 0] + set f [open $path(test1) w] + chan puts $f hello + chan close $f + chan close stderr + set f [open "|[list [info nameofexecutable] $path(cat) $path(test1)]" r] + chan puts [chan gets $f] + } + chan close $f + set f [open "|[list [interpreter] $path(script) [array get path]]" r] + set c [chan gets $f] + chan close $f + # Added delay to give Windows time to stop the spawned process and clean + # up its grip on the file test1. Added delete as proper test cleanup. + # The failing tests were 18.1 and 18.2 as first re-users of file "test1". + after 10000 + file delete $path(script) + file delete $path(test1) + set c +} hello + +test chan-io-15.1 {Tcl_CreateChan CloseHandler} emptyTest { +} {} + +test chan-io-16.1 {Tcl_DeleteChan CloseHandler} emptyTest { +} {} + +# Test channel table management. The functions tested are +# GetChannelTable, DeleteChannelTable, Tcl_RegisterChannel, +# Tcl_UnregisterChannel, Tcl_GetChannel and Tcl_CreateChannel. +# +# These functions use "eof stdin" to ensure that the standard +# channels are added to the channel table of the interpreter. + +test chan-io-17.1 {GetChannelTable, DeleteChannelTable on std handles} {testchannel} { + set l1 [testchannel refcount stdin] + chan eof stdin + interp create x + set l "" + lappend l [expr [testchannel refcount stdin] - $l1] + x eval {chan eof stdin} + lappend l [expr [testchannel refcount stdin] - $l1] + interp delete x + lappend l [expr [testchannel refcount stdin] - $l1] + set l +} {0 1 0} +test chan-io-17.2 {GetChannelTable, DeleteChannelTable on std handles} {testchannel} { + set l1 [testchannel refcount stdout] + chan eof stdin + interp create x + set l "" + lappend l [expr [testchannel refcount stdout] - $l1] + x eval {chan eof stdout} + lappend l [expr [testchannel refcount stdout] - $l1] + interp delete x + lappend l [expr [testchannel refcount stdout] - $l1] + set l +} {0 1 0} +test chan-io-17.3 {GetChannelTable, DeleteChannelTable on std handles} {testchannel} { + set l1 [testchannel refcount stderr] + chan eof stdin + interp create x + set l "" + lappend l [expr [testchannel refcount stderr] - $l1] + x eval {chan eof stderr} + lappend l [expr [testchannel refcount stderr] - $l1] + interp delete x + lappend l [expr [testchannel refcount stderr] - $l1] + set l +} {0 1 0} + +test chan-io-18.1 {Tcl_RegisterChannel, Tcl_UnregisterChannel} {testchannel} { + file delete -force $path(test1) + set l "" + set f [open $path(test1) w] + lappend l [lindex [testchannel info $f] 15] + chan close $f + if {[catch {lindex [testchannel info $f] 15} msg]} { + lappend l $msg + } else { + lappend l "very broken: $f found after being chan closed" + } + string compare [string tolower $l] \ + [list 1 [format "can not find channel named \"%s\"" $f]] +} 0 +test chan-io-18.2 {Tcl_RegisterChannel, Tcl_UnregisterChannel} {testchannel} { + file delete -force $path(test1) + set l "" + set f [open $path(test1) w] + lappend l [lindex [testchannel info $f] 15] + interp create x + interp share "" $f x + lappend l [lindex [testchannel info $f] 15] + x eval chan close $f + lappend l [lindex [testchannel info $f] 15] + interp delete x + lappend l [lindex [testchannel info $f] 15] + chan close $f + if {[catch {lindex [testchannel info $f] 15} msg]} { + lappend l $msg + } else { + lappend l "very broken: $f found after being chan closed" + } + string compare [string tolower $l] \ + [list 1 2 1 1 [format "can not find channel named \"%s\"" $f]] +} 0 +test chan-io-18.3 {Tcl_RegisterChannel, Tcl_UnregisterChannel} {testchannel} { + file delete $path(test1) + set l "" + set f [open $path(test1) w] + lappend l [lindex [testchannel info $f] 15] + interp create x + interp share "" $f x + lappend l [lindex [testchannel info $f] 15] + interp delete x + lappend l [lindex [testchannel info $f] 15] + chan close $f + if {[catch {lindex [testchannel info $f] 15} msg]} { + lappend l $msg + } else { + lappend l "very broken: $f found after being chan closed" + } + string compare [string tolower $l] \ + [list 1 2 1 [format "can not find channel named \"%s\"" $f]] +} 0 + +test chan-io-19.1 {Tcl_GetChannel->Tcl_GetStdChannel, standard handles} { + chan eof stdin +} 0 +test chan-io-19.2 {testing Tcl_GetChannel, user opened handle} { + file delete $path(test1) + set f [open $path(test1) w] + set x [chan eof $f] + chan close $f + set x +} 0 +test chan-io-19.3 {Tcl_GetChannel, channel not found} { + list [catch {chan eof file34} msg] $msg +} {1 {can not find channel named "file34"}} +test chan-io-19.4 {Tcl_CreateChannel, insertion into channel table} {testchannel} { + file delete $path(test1) + set f [open $path(test1) w] + set l "" + lappend l [chan eof $f] + chan close $f + if {[catch {lindex [testchannel info $f] 15} msg]} { + lappend l $msg + } else { + lappend l "very broken: $f found after being chan closed" + } + string compare [string tolower $l] \ + [list 0 [format "can not find channel named \"%s\"" $f]] +} 0 + +test chan-io-20.1 {Tcl_CreateChannel: initial settings} { + set a [open $path(test2) w] + set old [encoding system] + encoding system ascii + set f [open $path(test1) w] + set x [chan configure $f -encoding] + chan close $f + encoding system $old + chan close $a + set x +} {ascii} +test chan-io-20.2 {Tcl_CreateChannel: initial settings} {win} { + set f [open $path(test1) w+] + set x [list [chan configure $f -eofchar] [chan configure $f -translation]] + chan close $f + set x +} [list [list \x1a ""] {auto crlf}] +test chan-io-20.3 {Tcl_CreateChannel: initial settings} {unix} { + set f [open $path(test1) w+] + set x [list [chan configure $f -eofchar] [chan configure $f -translation]] + chan close $f + set x +} {{{} {}} {auto lf}} +set path(stdout) [makeFile {} stdout] +test chan-io-20.5 {Tcl_CreateChannel: install channel in empty slot} {stdio openpipe} { + set f [open $path(script) w] + chan puts -nonewline $f { + chan close stdout + set f1 [} + chan puts $f [list open $path(stdout) w]] + chan puts $f { + chan configure $f1 -buffersize 777 + chan puts stderr [chan configure stdout -buffersize] + } + chan close $f + set f [open "|[list [interpreter] $path(script)]"] + catch {chan close $f} msg + set msg +} {777} + +test chan-io-21.1 {Chan CloseChannelsOnExit} emptyTest { +} {} + +# Test management of attributes associated with a channel, such as +# its default translation, its name and type, etc. The functions +# tested in this group are Tcl_GetChannelName, +# Tcl_GetChannelType and Tcl_GetChannelFile. Tcl_GetChannelInstanceData +# not tested because files do not use the instance data. + +test chan-io-22.1 {Tcl_GetChannelMode} emptyTest { + # Not used anywhere in Tcl. +} {} + +test chan-io-23.1 {Tcl_GetChannelName} {testchannel} { + file delete $path(test1) + set f [open $path(test1) w] + set n [testchannel name $f] + chan close $f + string compare $n $f +} 0 + +test chan-io-24.1 {Tcl_GetChannelType} {testchannel} { + file delete $path(test1) + set f [open $path(test1) w] + set t [testchannel type $f] + chan close $f + string compare $t file +} 0 + +test chan-io-25.1 {Tcl_GetChannelHandle, input} {testchannel} { + set f [open $path(test1) w] + chan configure $f -translation lf -eofchar {} + chan puts $f "1234567890\n098765432" + chan close $f + set f [open $path(test1) r] + chan gets $f + set l "" + lappend l [testchannel inputbuffered $f] + lappend l [chan tell $f] + chan close $f + set l +} {10 11} +test chan-io-25.2 {Tcl_GetChannelHandle, output} {testchannel} { + file delete $path(test1) + set f [open $path(test1) w] + chan configure $f -translation lf + chan puts $f hello + set l "" + lappend l [testchannel outputbuffered $f] + lappend l [chan tell $f] + chan flush $f + lappend l [testchannel outputbuffered $f] + lappend l [chan tell $f] + chan close $f + file delete $path(test1) + set l +} {6 6 0 6} + +test chan-io-26.1 {Tcl_GetChannelInstanceData} {stdio openpipe} { + # "pid" command uses Tcl_GetChannelInstanceData + # Don't care what pid is (but must be a number), just want to exercise it. + + set f [open "|[list [interpreter] << exit]"] + expr [pid $f] + chan close $f +} {} + +# Test flushing. The functions tested here are FlushChannel. + +test chan-io-27.1 {FlushChannel, no output buffered} { + file delete $path(test1) + set f [open $path(test1) w] + chan flush $f + set s [file size $path(test1)] + chan close $f + set s +} 0 +test chan-io-27.2 {FlushChannel, some output buffered} { + file delete $path(test1) + set f [open $path(test1) w] + chan configure $f -translation lf -eofchar {} + set l "" + chan puts $f hello + lappend l [file size $path(test1)] + chan flush $f + lappend l [file size $path(test1)] + chan close $f + lappend l [file size $path(test1)] + set l +} {0 6 6} +test chan-io-27.3 {FlushChannel, implicit flush on chan close} { + file delete $path(test1) + set f [open $path(test1) w] + chan configure $f -translation lf -eofchar {} + set l "" + chan puts $f hello + lappend l [file size $path(test1)] + chan close $f + lappend l [file size $path(test1)] + set l +} {0 6} +test chan-io-27.4 {FlushChannel, implicit flush when buffer fills} { + file delete $path(test1) + set f [open $path(test1) w] + chan configure $f -translation lf -eofchar {} + chan configure $f -buffersize 60 + set l "" + lappend l [file size $path(test1)] + for {set i 0} {$i < 12} {incr i} { + chan puts $f hello + } + lappend l [file size $path(test1)] + chan flush $f + lappend l [file size $path(test1)] + chan close $f + set l +} {0 60 72} +test chan-io-27.5 {FlushChannel, implicit flush when buffer fills and on chan close} \ + {unixOrPc} { + file delete $path(test1) + set f [open $path(test1) w] + chan configure $f -translation lf -buffersize 60 -eofchar {} + set l "" + lappend l [file size $path(test1)] + for {set i 0} {$i < 12} {incr i} { + chan puts $f hello + } + lappend l [file size $path(test1)] + chan close $f + lappend l [file size $path(test1)] + set l +} {0 60 72} +set path(pipe) [makeFile {} pipe] +set path(output) [makeFile {} output] +test chan-io-27.6 {FlushChannel, async flushing, async chan close} \ + {stdio asyncPipeChan Close openpipe} { + file delete $path(pipe) + file delete $path(output) + set f [open $path(pipe) w] + chan puts $f "set f \[[list open $path(output) w]]" + chan puts $f { + chan configure $f -translation lf -buffering none -eofchar {} + while {![chan eof stdin]} { + after 20 + chan puts -nonewline $f [chan read stdin 1024] + } + chan close $f + } + chan close $f + set x 01234567890123456789012345678901 + for {set i 0} {$i < 11} {incr i} { + set x "$x$x" + } + set f [open $path(output) w] + chan close $f + set f [open "|[list [interpreter] $path(pipe)]" w] + chan configure $f -blocking off + chan puts -nonewline $f $x + chan close $f + set counter 0 + while {([file size $path(output)] < 65536) && ($counter < 1000)} { + after 20 [list incr [namespace which -variable counter]] + vwait [namespace which -variable counter] + } + if {$counter == 1000} { + set result "file size only [file size $path(output)]" + } else { + set result ok + } +} ok + +# Tests closing a channel. The functions tested are Chan CloseChannel and Tcl_Chan Close. + +test chan-io-28.1 {Chan CloseChannel called when all references are dropped} {testchannel} { + file delete $path(test1) + set f [open $path(test1) w] + interp create x + interp share "" $f x + set l "" + lappend l [testchannel refcount $f] + x eval chan close $f + interp delete x + lappend l [testchannel refcount $f] + chan close $f + set l +} {2 1} +test chan-io-28.2 {Chan CloseChannel called when all references are dropped} { + file delete $path(test1) + set f [open $path(test1) w] + interp create x + interp share "" $f x + chan puts -nonewline $f abc + chan close $f + x eval chan puts $f def + x eval chan close $f + interp delete x + set f [open $path(test1) r] + set l [chan gets $f] + chan close $f + set l +} abcdef +test chan-io-28.3 {Chan CloseChannel, not called before output queue is empty} \ + {stdio asyncPipeChan Close nonPortable openpipe} { + file delete $path(pipe) + file delete $path(output) + set f [open $path(pipe) w] + chan puts $f { + + # Need to not have eof char appended on chan close, because the other + # side of the pipe already chan closed, so that writing would cause an + # error "invalid file". + + chan configure stdout -eofchar {} + chan configure stderr -eofchar {} + + set f [open $path(output) w] + chan configure $f -translation lf -buffering none + for {set x 0} {$x < 20} {incr x} { + after 20 + chan puts -nonewline $f [chan read stdin 1024] + } + chan close $f + } + chan close $f + set x 01234567890123456789012345678901 + for {set i 0} {$i < 11} {incr i} { + set x "$x$x" + } + set f [open $path(output) w] + chan close $f + set f [open "|[list [interpreter] pipe]" r+] + chan configure $f -blocking off -eofchar {} + + chan puts -nonewline $f $x + chan close $f + set counter 0 + while {([file size $path(output)] < 20480) && ($counter < 1000)} { + after 20 [list incr [namespace which -variable counter]] + vwait [namespace which -variable counter] + } + if {$counter == 1000} { + set result probably_broken + } else { + set result ok + } +} ok +test chan-io-28.4 {Tcl_Chan Close} {testchannel} { + file delete $path(test1) + set l "" + lappend l [lsort [testchannel open]] + set f [open $path(test1) w] + lappend l [lsort [testchannel open]] + chan close $f + lappend l [lsort [testchannel open]] + set x [list $consoleFileNames \ + [lsort [list {*}$consoleFileNames $f]] \ + $consoleFileNames] + string compare $l $x +} 0 +test chan-io-28.5 {Tcl_Chan Close vs standard handles} {stdio unix testchannel openpipe} { + file delete $path(script) + set f [open $path(script) w] + chan puts $f { + chan close stdin + chan puts [testchannel open] + } + chan close $f + set f [open "|[list [interpreter] $path(script)]" r] + set l [chan gets $f] + chan close $f + set l +} {file1 file2} + +test chan-io-29.1 {Tcl_WriteChars, channel not writable} { + list [catch {chan puts stdin hello} msg] $msg +} {1 {channel "stdin" wasn't opened for writing}} +test chan-io-29.2 {Tcl_WriteChars, empty string} { + file delete $path(test1) + set f [open $path(test1) w] + chan configure $f -eofchar {} + chan puts -nonewline $f "" + chan close $f + file size $path(test1) +} 0 +test chan-io-29.3 {Tcl_WriteChars, nonempty string} { + file delete $path(test1) + set f [open $path(test1) w] + chan configure $f -eofchar {} + chan puts -nonewline $f hello + chan close $f + file size $path(test1) +} 5 +test chan-io-29.4 {Tcl_WriteChars, buffering in full buffering mode} {testchannel} { + file delete $path(test1) + set f [open $path(test1) w] + chan configure $f -translation lf -buffering full -eofchar {} + chan puts $f hello + set l "" + lappend l [testchannel outputbuffered $f] + lappend l [file size $path(test1)] + chan flush $f + lappend l [testchannel outputbuffered $f] + lappend l [file size $path(test1)] + chan close $f + set l +} {6 0 0 6} +test chan-io-29.5 {Tcl_WriteChars, buffering in line buffering mode} {testchannel} { + file delete $path(test1) + set f [open $path(test1) w] + chan configure $f -translation lf -buffering line -eofchar {} + chan puts -nonewline $f hello + set l "" + lappend l [testchannel outputbuffered $f] + lappend l [file size $path(test1)] + chan puts $f hello + lappend l [testchannel outputbuffered $f] + lappend l [file size $path(test1)] + chan close $f + set l +} {5 0 0 11} +test chan-io-29.6 {Tcl_WriteChars, buffering in no buffering mode} {testchannel} { + file delete $path(test1) + set f [open $path(test1) w] + chan configure $f -translation lf -buffering none -eofchar {} + chan puts -nonewline $f hello + set l "" + lappend l [testchannel outputbuffered $f] + lappend l [file size $path(test1)] + chan puts $f hello + lappend l [testchannel outputbuffered $f] + lappend l [file size $path(test1)] + chan close $f + set l +} {0 5 0 11} +test chan-io-29.7 {Tcl_Flush, full buffering} {testchannel} { + file delete $path(test1) + set f [open $path(test1) w] + chan configure $f -translation lf -buffering full -eofchar {} + chan puts -nonewline $f hello + set l "" + lappend l [testchannel outputbuffered $f] + lappend l [file size $path(test1)] + chan puts $f hello + lappend l [testchannel outputbuffered $f] + lappend l [file size $path(test1)] + chan flush $f + lappend l [testchannel outputbuffered $f] + lappend l [file size $path(test1)] + chan close $f + set l +} {5 0 11 0 0 11} +test chan-io-29.8 {Tcl_Flush, full buffering} {testchannel} { + file delete $path(test1) + set f [open $path(test1) w] + chan configure $f -translation lf -buffering line + chan puts -nonewline $f hello + set l "" + lappend l [testchannel outputbuffered $f] + lappend l [file size $path(test1)] + chan flush $f + lappend l [testchannel outputbuffered $f] + lappend l [file size $path(test1)] + chan puts $f hello + lappend l [testchannel outputbuffered $f] + lappend l [file size $path(test1)] + chan flush $f + lappend l [testchannel outputbuffered $f] + lappend l [file size $path(test1)] + chan close $f + set l +} {5 0 0 5 0 11 0 11} +test chan-io-29.9 {Tcl_Flush, channel not writable} { + list [catch {chan flush stdin} msg] $msg +} {1 {channel "stdin" wasn't opened for writing}} +test chan-io-29.10 {Tcl_WriteChars, looping and buffering} { + file delete $path(test1) + set f1 [open $path(test1) w] + chan configure $f1 -translation lf -eofchar {} + set f2 [open $path(longfile) r] + for {set x 0} {$x < 10} {incr x} { + chan puts $f1 [chan gets $f2] + } + chan close $f2 + chan close $f1 + file size $path(test1) +} 387 +test chan-io-29.11 {Tcl_WriteChars, no newline, implicit flush} { + file delete $path(test1) + set f1 [open $path(test1) w] + chan configure $f1 -eofchar {} + set f2 [open $path(longfile) r] + for {set x 0} {$x < 10} {incr x} { + chan puts -nonewline $f1 [chan gets $f2] + } + chan close $f1 + chan close $f2 + file size $path(test1) +} 377 +test chan-io-29.12 {Tcl_WriteChars on a pipe} {stdio openpipe} { + file delete $path(test1) + file delete $path(pipe) + set f1 [open $path(pipe) w] + chan puts $f1 "set f1 \[[list open $path(longfile) r]]" + chan puts $f1 { + for {set x 0} {$x < 10} {incr x} { + chan puts [chan gets $f1] + } + } + chan close $f1 + set f1 [open "|[list [interpreter] $path(pipe)]" r] + set f2 [open $path(longfile) r] + set y ok + for {set x 0} {$x < 10} {incr x} { + set l1 [chan gets $f1] + set l2 [chan gets $f2] + if {"$l1" != "$l2"} { + set y broken + } + } + chan close $f1 + chan close $f2 + set y +} ok +test chan-io-29.13 {Tcl_WriteChars to a pipe, line buffered} {stdio openpipe} { + file delete $path(test1) + file delete $path(pipe) + set f1 [open $path(pipe) w] + chan puts $f1 { + chan puts [chan gets stdin] + chan puts [chan gets stdin] + } + chan close $f1 + set y ok + set f1 [open "|[list [interpreter] $path(pipe)]" r+] + chan configure $f1 -buffering line + set f2 [open $path(longfile) r] + set line [chan gets $f2] + chan puts $f1 $line + set backline [chan gets $f1] + if {"$line" != "$backline"} { + set y broken + } + set line [chan gets $f2] + chan puts $f1 $line + set backline [chan gets $f1] + if {"$line" != "$backline"} { + set y broken + } + chan close $f1 + chan close $f2 + set y +} ok +test chan-io-29.14 {Tcl_WriteChars, buffering and implicit flush at chan close} { + file delete $path(test3) + set f [open $path(test3) w] + chan puts -nonewline $f "Text1" + chan puts -nonewline $f " Text 2" + chan puts $f " Text 3" + chan close $f + set f [open $path(test3) r] + set x [chan gets $f] + chan close $f + set x +} {Text1 Text 2 Text 3} +test chan-io-29.15 {Tcl_Flush, channel not open for writing} { + file delete $path(test1) + set fd [open $path(test1) w] + chan close $fd + set fd [open $path(test1) r] + set x [list [catch {chan flush $fd} msg] $msg] + chan close $fd + string compare $x \ + [list 1 "channel \"$fd\" wasn't opened for writing"] +} 0 +test chan-io-29.16 {Tcl_Flush on pipe opened only for reading} {stdio openpipe} { + set fd [open "|[list [interpreter] cat longfile]" r] + set x [list [catch {chan flush $fd} msg] $msg] + catch {chan close $fd} + string compare $x \ + [list 1 "channel \"$fd\" wasn't opened for writing"] +} 0 +test chan-io-29.17 {Tcl_WriteChars buffers, then Tcl_Flush flushes} { + file delete $path(test1) + set f1 [open $path(test1) w] + chan configure $f1 -translation lf + chan puts $f1 hello + chan puts $f1 hello + chan puts $f1 hello + chan flush $f1 + set x [file size $path(test1)] + chan close $f1 + set x +} 18 +test chan-io-29.18 {Tcl_WriteChars and Tcl_Flush intermixed} { + file delete $path(test1) + set x "" + set f1 [open $path(test1) w] + chan configure $f1 -translation lf + chan puts $f1 hello + chan puts $f1 hello + chan puts $f1 hello + chan flush $f1 + lappend x [file size $path(test1)] + chan puts $f1 hello + chan flush $f1 + lappend x [file size $path(test1)] + chan puts $f1 hello + chan flush $f1 + lappend x [file size $path(test1)] + chan close $f1 + set x +} {18 24 30} +test chan-io-29.19 {Explicit and implicit flushes} { + file delete $path(test1) + set f1 [open $path(test1) w] + chan configure $f1 -translation lf -eofchar {} + set x "" + chan puts $f1 hello + chan puts $f1 hello + chan puts $f1 hello + chan flush $f1 + lappend x [file size $path(test1)] + chan puts $f1 hello + chan flush $f1 + lappend x [file size $path(test1)] + chan puts $f1 hello + chan close $f1 + lappend x [file size $path(test1)] + set x +} {18 24 30} +test chan-io-29.20 {Implicit flush when buffer is full} { + file delete $path(test1) + set f1 [open $path(test1) w] + chan configure $f1 -translation lf -eofchar {} + set line "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789" + for {set x 0} {$x < 100} {incr x} { + chan puts $f1 $line + } + set z "" + lappend z [file size $path(test1)] + for {set x 0} {$x < 100} {incr x} { + chan puts $f1 $line + } + lappend z [file size $path(test1)] + chan close $f1 + lappend z [file size $path(test1)] + set z +} {4096 12288 12600} +test chan-io-29.21 {Tcl_Flush to pipe} {stdio openpipe} { + file delete $path(pipe) + set f1 [open $path(pipe) w] + chan puts $f1 {set x [chan read stdin 6]} + chan puts $f1 {set cnt [string length $x]} + chan puts $f1 {chan puts "read $cnt characters"} + chan close $f1 + set f1 [open "|[list [interpreter] $path(pipe)]" r+] + chan puts $f1 hello + chan flush $f1 + set x [chan gets $f1] + catch {chan close $f1} + set x +} "read 6 characters" +test chan-io-29.22 {Tcl_Flush called at other end of pipe} {stdio openpipe} { + file delete $path(pipe) + set f1 [open $path(pipe) w] + chan puts $f1 { + chan configure stdout -buffering full + chan puts hello + chan puts hello + chan flush stdout + chan gets stdin + chan puts bye + chan flush stdout + } + chan close $f1 + set f1 [open "|[list [interpreter] $path(pipe)]" r+] + set x "" + lappend x [chan gets $f1] + lappend x [chan gets $f1] + chan puts $f1 hello + chan flush $f1 + lappend x [chan gets $f1] + chan close $f1 + set x +} {hello hello bye} +test chan-io-29.23 {Tcl_Flush and line buffering at end of pipe} {stdio openpipe} { + file delete $path(pipe) + set f1 [open $path(pipe) w] + chan puts $f1 { + chan puts hello + chan puts hello + chan gets stdin + chan puts bye + } + chan close $f1 + set f1 [open "|[list [interpreter] $path(pipe)]" r+] + set x "" + lappend x [chan gets $f1] + lappend x [chan gets $f1] + chan puts $f1 hello + chan flush $f1 + lappend x [chan gets $f1] + chan close $f1 + set x +} {hello hello bye} +test chan-io-29.24 {Tcl_WriteChars and Tcl_Flush move end of file} { + set f [open $path(test3) w] + chan puts $f "Line 1" + chan puts $f "Line 2" + set f2 [open $path(test3)] + set x {} + lappend x [chan read -nonewline $f2] + chan close $f2 + chan flush $f + set f2 [open $path(test3)] + lappend x [chan read -nonewline $f2] + chan close $f2 + chan close $f + set x +} "{} {Line 1\nLine 2}" +test chan-io-29.25 {Implicit flush with Tcl_Flush to command pipelines} {stdio openpipe fileevent} { + file delete $path(test3) + set f [open "|[list [interpreter] $path(cat) | [interpreter] $path(cat) > $path(test3)]" w] + chan puts $f "Line 1" + chan puts $f "Line 2" + chan close $f + after 100 + set f [open $path(test3) r] + set x [chan read $f] + chan close $f + set x +} "Line 1\nLine 2\n" +test chan-io-29.26 {Tcl_Flush, Tcl_Write on bidirectional pipelines} {stdio unixExecs openpipe} { + set f [open "|[list cat -u]" r+] + chan puts $f "Line1" + chan flush $f + set x [chan gets $f] + chan close $f + set x +} {Line1} +test chan-io-29.27 {Tcl_Flush on chan closed pipeline} {stdio openpipe} { + file delete $path(pipe) + set f [open $path(pipe) w] + chan puts $f {exit} + chan close $f + set f [open "|[list [interpreter] $path(pipe)]" r+] + chan gets $f + chan puts $f output + after 50 + # + # The flush below will get a SIGPIPE. This is an expected part of + # test and indicates that the test operates correctly. If you run + # this test under a debugger, the signal will by intercepted unless + # you disable the debugger's signal interception. + # + if {[catch {chan flush $f} msg]} { + set x [list 1 $msg $::errorCode] + catch {chan close $f} + } else { + if {[catch {chan close $f} msg]} { + set x [list 1 $msg $::errorCode] + } else { + set x {this was supposed to fail and did not} + } + } + regsub {".*":} $x {"":} x + string tolower $x +} {1 {error flushing "": broken pipe} {posix epipe {broken pipe}}} +test chan-io-29.28 {Tcl_WriteChars, lf mode} { + file delete $path(test1) + set f [open $path(test1) w] + chan configure $f -translation lf -eofchar {} + chan puts $f hello\nthere\nand\nhere + chan flush $f + set s [file size $path(test1)] + chan close $f + set s +} 21 +test chan-io-29.29 {Tcl_WriteChars, cr mode} { + file delete $path(test1) + set f [open $path(test1) w] + chan configure $f -translation cr -eofchar {} + chan puts $f hello\nthere\nand\nhere + chan close $f + file size $path(test1) +} 21 +test chan-io-29.30 {Tcl_WriteChars, crlf mode} { + file delete $path(test1) + set f [open $path(test1) w] + chan configure $f -translation crlf -eofchar {} + chan puts $f hello\nthere\nand\nhere + chan close $f + file size $path(test1) +} 25 +test chan-io-29.31 {Tcl_WriteChars, background flush} {stdio openpipe} { + file delete $path(pipe) + file delete $path(output) + set f [open $path(pipe) w] + chan puts $f "set f \[[list open $path(output) w]]" + chan puts $f {chan configure $f -translation lf} + set x [list while {![chan eof stdin]}] + set x "$x {" + chan puts $f $x + chan puts $f { chan puts -nonewline $f [chan read stdin 4096]} + chan puts $f { chan flush $f} + chan puts $f "}" + chan puts $f {chan close $f} + chan close $f + set x 01234567890123456789012345678901 + for {set i 0} {$i < 11} {incr i} { + set x "$x$x" + } + set f [open $path(output) w] + chan close $f + set f [open "|[list [interpreter] $path(pipe)]" r+] + chan configure $f -blocking off + chan puts -nonewline $f $x + chan close $f + set counter 0 + while {([file size $path(output)] < 65536) && ($counter < 1000)} { + after 10 [list incr [namespace which -variable counter]] + vwait [namespace which -variable counter] + } + if {$counter == 1000} { + set result "file size only [file size $path(output)]" + } else { + set result ok + } + # allow a little time for the background process to chan close. + # otherwise, the following test fails on the [file delete $path(output) + # on Windows because a process still has the file open. + after 100 set v 1; vwait v + set result +} ok +test chan-io-29.32 {Tcl_WriteChars, background flush to slow reader} \ + {stdio asyncPipeChan Close openpipe} { + file delete $path(pipe) + file delete $path(output) + set f [open $path(pipe) w] + chan puts $f "set f \[[list open $path(output) w]]" + chan puts $f {chan configure $f -translation lf} + set x [list while {![chan eof stdin]}] + set x "$x \{" + chan puts $f $x + chan puts $f { after 20} + chan puts $f { chan puts -nonewline $f [chan read stdin 1024]} + chan puts $f { chan flush $f} + chan puts $f "\}" + chan puts $f {chan close $f} + chan close $f + set x 01234567890123456789012345678901 + for {set i 0} {$i < 11} {incr i} { + set x "$x$x" + } + set f [open $path(output) w] + chan close $f + set f [open "|[list [interpreter] $path(pipe)]" r+] + chan configure $f -blocking off + chan puts -nonewline $f $x + chan close $f + set counter 0 + while {([file size $path(output)] < 65536) && ($counter < 1000)} { + after 20 [list incr [namespace which -variable counter]] + vwait [namespace which -variable counter] + } + if {$counter == 1000} { + set result "file size only [file size $path(output)]" + } else { + set result ok + } +} ok +test chan-io-29.33 {Tcl_Flush, implicit flush on exit} {exec} { + set f [open $path(script) w] + chan puts $f "set f \[[list open $path(test1) w]]" + chan puts $f {chan configure $f -translation lf + chan puts $f hello + chan puts $f bye + chan puts $f strange + } + chan close $f + exec [interpreter] $path(script) + set f [open $path(test1) r] + set r [chan read $f] + chan close $f + set r +} "hello\nbye\nstrange\n" +test chan-io-29.34 {Tcl_Chan Close, async flush on chan close, using sockets} {socket tempNotMac fileevent} { + variable c 0 + variable x running + set l abcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyz + proc writelots {s l} { + for {set i 0} {$i < 2000} {incr i} { + chan puts $s $l + } + } + proc accept {s a p} { + variable x + chan event $s readable [namespace code [list readit $s]] + chan configure $s -blocking off + set x accepted + } + proc readit {s} { + variable c + variable x + set l [chan gets $s] + + if {[chan eof $s]} { + chan close $s + set x done + } elseif {([string length $l] > 0) || ![chan blocked $s]} { + incr c + } + } + set ss [socket -server [namespace code accept] -myaddr 127.0.0.1 0] + set cs [socket 127.0.0.1 [lindex [chan configure $ss -sockname] 2]] + vwait [namespace which -variable x] + chan configure $cs -blocking off + writelots $cs $l + chan close $cs + chan close $ss + vwait [namespace which -variable x] + set c +} 2000 +test chan-io-29.35 {Tcl_Chan Close vs chan event vs multiple interpreters} {socket tempNotMac fileevent} { + # On Mac, this test screws up sockets such that subsequent tests using port 2828 + # either cause errors or panic(). + + catch {interp delete x} + catch {interp delete y} + interp create x + interp create y + set s [socket -server [namespace code accept] -myaddr 127.0.0.1 0] + proc accept {s a p} { + chan puts $s hello + chan close $s + } + set c [socket 127.0.0.1 [lindex [chan configure $s -sockname] 2]] + interp share {} $c x + interp share {} $c y + chan close $c + x eval { + proc readit {s} { + chan gets $s + if {[chan eof $s]} { + chan close $s + } + } + } + y eval { + proc readit {s} { + chan gets $s + if {[chan eof $s]} { + chan close $s + } + } + } + x eval "chan event $c readable \{readit $c\}" + y eval "chan event $c readable \{readit $c\}" + y eval [list chan close $c] + update + chan close $s + interp delete x + interp delete y +} "" + +# Test end of line translations. Procedures tested are Tcl_Write, Tcl_Read. + +test chan-io-30.1 {Tcl_Write lf, Tcl_Read lf} { + file delete $path(test1) + set f [open $path(test1) w] + chan configure $f -translation lf + chan puts $f hello\nthere\nand\nhere + chan close $f + set f [open $path(test1) r] + chan configure $f -translation lf + set x [chan read $f] + chan close $f + set x +} "hello\nthere\nand\nhere\n" +test chan-io-30.2 {Tcl_Write lf, Tcl_Read cr} { + file delete $path(test1) + set f [open $path(test1) w] + chan configure $f -translation lf + chan puts $f hello\nthere\nand\nhere + chan close $f + set f [open $path(test1) r] + chan configure $f -translation cr + set x [chan read $f] + chan close $f + set x +} "hello\nthere\nand\nhere\n" +test chan-io-30.3 {Tcl_Write lf, Tcl_Read crlf} { + file delete $path(test1) + set f [open $path(test1) w] + chan configure $f -translation lf + chan puts $f hello\nthere\nand\nhere + chan close $f + set f [open $path(test1) r] + chan configure $f -translation crlf + set x [chan read $f] + chan close $f + set x +} "hello\nthere\nand\nhere\n" +test chan-io-30.4 {Tcl_Write cr, Tcl_Read cr} { + file delete $path(test1) + set f [open $path(test1) w] + chan configure $f -translation cr + chan puts $f hello\nthere\nand\nhere + chan close $f + set f [open $path(test1) r] + chan configure $f -translation cr + set x [chan read $f] + chan close $f + set x +} "hello\nthere\nand\nhere\n" +test chan-io-30.5 {Tcl_Write cr, Tcl_Read lf} { + file delete $path(test1) + set f [open $path(test1) w] + chan configure $f -translation cr + chan puts $f hello\nthere\nand\nhere + chan close $f + set f [open $path(test1) r] + chan configure $f -translation lf + set x [chan read $f] + chan close $f + set x +} "hello\rthere\rand\rhere\r" +test chan-io-30.6 {Tcl_Write cr, Tcl_Read crlf} { + file delete $path(test1) + set f [open $path(test1) w] + chan configure $f -translation cr + chan puts $f hello\nthere\nand\nhere + chan close $f + set f [open $path(test1) r] + chan configure $f -translation crlf + set x [chan read $f] + chan close $f + set x +} "hello\rthere\rand\rhere\r" +test chan-io-30.7 {Tcl_Write crlf, Tcl_Read crlf} { + file delete $path(test1) + set f [open $path(test1) w] + chan configure $f -translation crlf + chan puts $f hello\nthere\nand\nhere + chan close $f + set f [open $path(test1) r] + chan configure $f -translation crlf + set x [chan read $f] + chan close $f + set x +} "hello\nthere\nand\nhere\n" +test chan-io-30.8 {Tcl_Write crlf, Tcl_Read lf} { + file delete $path(test1) + set f [open $path(test1) w] + chan configure $f -translation crlf + chan puts $f hello\nthere\nand\nhere + chan close $f + set f [open $path(test1) r] + chan configure $f -translation lf + set x [chan read $f] + chan close $f + set x +} "hello\r\nthere\r\nand\r\nhere\r\n" +test chan-io-30.9 {Tcl_Write crlf, Tcl_Read cr} { + file delete $path(test1) + set f [open $path(test1) w] + chan configure $f -translation crlf + chan puts $f hello\nthere\nand\nhere + chan close $f + set f [open $path(test1) r] + chan configure $f -translation cr + set x [chan read $f] + chan close $f + set x +} "hello\n\nthere\n\nand\n\nhere\n\n" +test chan-io-30.10 {Tcl_Write lf, Tcl_Read auto} { + file delete $path(test1) + set f [open $path(test1) w] + chan configure $f -translation lf + chan puts $f hello\nthere\nand\nhere + chan close $f + set f [open $path(test1) r] + set c [chan read $f] + set x [chan configure $f -translation] + chan close $f + list $c $x +} {{hello +there +and +here +} auto} +test chan-io-30.11 {Tcl_Write cr, Tcl_Read auto} { + file delete $path(test1) + set f [open $path(test1) w] + chan configure $f -translation cr + chan puts $f hello\nthere\nand\nhere + chan close $f + set f [open $path(test1) r] + set c [chan read $f] + set x [chan configure $f -translation] + chan close $f + list $c $x +} {{hello +there +and +here +} auto} +test chan-io-30.12 {Tcl_Write crlf, Tcl_Read auto} { + file delete $path(test1) + set f [open $path(test1) w] + chan configure $f -translation crlf + chan puts $f hello\nthere\nand\nhere + chan close $f + set f [open $path(test1) r] + set c [chan read $f] + set x [chan configure $f -translation] + chan close $f + list $c $x +} {{hello +there +and +here +} auto} +test chan-io-30.13 {Tcl_Write crlf on block boundary, Tcl_Read auto} { + file delete $path(test1) + set f [open $path(test1) w] + chan configure $f -translation crlf + set line "123456789ABCDE" ;# 14 char plus crlf + chan puts -nonewline $f x ;# shift crlf across block boundary + for {set i 0} {$i < 700} {incr i} { + chan puts $f $line + } + chan close $f + set f [open $path(test1) r] + chan configure $f -translation auto + set c [chan read $f] + chan close $f + string length $c +} [expr 700*15+1] +test chan-io-30.14 {Tcl_Write crlf on block boundary, Tcl_Read crlf} { + file delete $path(test1) + set f [open $path(test1) w] + chan configure $f -translation crlf + set line "123456789ABCDE" ;# 14 char plus crlf + chan puts -nonewline $f x ;# shift crlf across block boundary + for {set i 0} {$i < 700} {incr i} { + chan puts $f $line + } + chan close $f + set f [open $path(test1) r] + chan configure $f -translation crlf + set c [chan read $f] + chan close $f + string length $c +} [expr 700*15+1] +test chan-io-30.15 {Tcl_Write mixed, Tcl_Read auto} { + file delete $path(test1) + set f [open $path(test1) w] + chan configure $f -translation lf + chan puts $f hello\nthere\nand\rhere + chan close $f + set f [open $path(test1) r] + chan configure $f -translation auto + set c [chan read $f] + chan close $f + set c +} {hello +there +and +here +} +test chan-io-30.16 {Tcl_Write ^Z at end, Tcl_Read auto} { + file delete $path(test1) + set f [open $path(test1) w] + chan configure $f -translation lf + chan puts -nonewline $f hello\nthere\nand\rhere\n\x1a + chan close $f + set f [open $path(test1) r] + chan configure $f -eofchar \x1a -translation auto + set c [chan read $f] + chan close $f + set c +} {hello +there +and +here +} +test chan-io-30.17 {Tcl_Write, implicit ^Z at end, Tcl_Read auto} {win} { + file delete $path(test1) + set f [open $path(test1) w] + chan configure $f -eofchar \x1a -translation lf + chan puts $f hello\nthere\nand\rhere + chan close $f + set f [open $path(test1) r] + chan configure $f -eofchar \x1a -translation auto + set c [chan read $f] + chan close $f + set c +} {hello +there +and +here +} +test chan-io-30.18 {Tcl_Write, ^Z in middle, Tcl_Read auto} { + file delete $path(test1) + set f [open $path(test1) w] + chan configure $f -translation lf + set s [format "abc\ndef\n%cghi\nqrs" 26] + chan puts $f $s + chan close $f + set f [open $path(test1) r] + chan configure $f -eofchar \x1a -translation auto + set l "" + lappend l [chan gets $f] + lappend l [chan gets $f] + lappend l [chan eof $f] + lappend l [chan gets $f] + lappend l [chan eof $f] + lappend l [chan gets $f] + lappend l [chan eof $f] + chan close $f + set l +} {abc def 0 {} 1 {} 1} +test chan-io-30.19 {Tcl_Write, ^Z no newline in middle, Tcl_Read auto} { + file delete $path(test1) + set f [open $path(test1) w] + chan configure $f -translation lf + set s [format "abc\ndef\n%cghi\nqrs" 26] + chan puts $f $s + chan close $f + set f [open $path(test1) r] + chan configure $f -eofchar \x1a -translation auto + set l "" + lappend l [chan gets $f] + lappend l [chan gets $f] + lappend l [chan eof $f] + lappend l [chan gets $f] + lappend l [chan eof $f] + lappend l [chan gets $f] + lappend l [chan eof $f] + chan close $f + set l +} {abc def 0 {} 1 {} 1} +test chan-io-30.20 {Tcl_Write, ^Z in middle ignored, Tcl_Read lf} { + file delete $path(test1) + set f [open $path(test1) w] + chan configure $f -translation lf -eofchar {} + set s [format "abc\ndef\n%cghi\nqrs" 26] + chan puts $f $s + chan close $f + set f [open $path(test1) r] + chan configure $f -translation lf -eofchar {} + set l "" + lappend l [chan gets $f] + lappend l [chan gets $f] + lappend l [chan eof $f] + lappend l [chan gets $f] + lappend l [chan eof $f] + lappend l [chan gets $f] + lappend l [chan eof $f] + lappend l [chan gets $f] + lappend l [chan eof $f] + chan close $f + set l +} "abc def 0 \x1aghi 0 qrs 0 {} 1" +test chan-io-30.21 {Tcl_Write, ^Z in middle ignored, Tcl_Read cr} { + file delete $path(test1) + set f [open $path(test1) w] + chan configure $f -translation lf -eofchar {} + set s [format "abc\ndef\n%cghi\nqrs" 26] + chan puts $f $s + chan close $f + set f [open $path(test1) r] + chan configure $f -translation cr -eofchar {} + set l "" + set x [chan gets $f] + lappend l [string compare $x "abc\ndef\n\x1aghi\nqrs\n"] + lappend l [chan eof $f] + lappend l [chan gets $f] + lappend l [chan eof $f] + chan close $f + set l +} {0 1 {} 1} +test chan-io-30.22 {Tcl_Write, ^Z in middle ignored, Tcl_Read crlf} { + file delete $path(test1) + set f [open $path(test1) w] + chan configure $f -translation lf -eofchar {} + set s [format "abc\ndef\n%cghi\nqrs" 26] + chan puts $f $s + chan close $f + set f [open $path(test1) r] + chan configure $f -translation crlf -eofchar {} + set l "" + set x [chan gets $f] + lappend l [string compare $x "abc\ndef\n\x1aghi\nqrs\n"] + lappend l [chan eof $f] + lappend l [chan gets $f] + lappend l [chan eof $f] + chan close $f + set l +} {0 1 {} 1} +test chan-io-30.23 {Tcl_Write lf, ^Z in middle, Tcl_Read auto} { + file delete $path(test1) + set f [open $path(test1) w] + chan configure $f -translation lf + set c [format abc\ndef\n%cqrs\ntuv 26] + chan puts $f $c + chan close $f + set f [open $path(test1) r] + chan configure $f -translation auto -eofchar \x1a + set c [string length [chan read $f]] + set e [chan eof $f] + chan close $f + list $c $e +} {8 1} +test chan-io-30.24 {Tcl_Write lf, ^Z in middle, Tcl_Read lf} { + file delete $path(test1) + set f [open $path(test1) w] + chan configure $f -translation lf + set c [format abc\ndef\n%cqrs\ntuv 26] + chan puts $f $c + chan close $f + set f [open $path(test1) r] + chan configure $f -translation lf -eofchar \x1a + set c [string length [chan read $f]] + set e [chan eof $f] + chan close $f + list $c $e +} {8 1} +test chan-io-30.25 {Tcl_Write cr, ^Z in middle, Tcl_Read auto} { + file delete $path(test1) + set f [open $path(test1) w] + chan configure $f -translation cr + set c [format abc\ndef\n%cqrs\ntuv 26] + chan puts $f $c + chan close $f + set f [open $path(test1) r] + chan configure $f -translation auto -eofchar \x1a + set c [string length [chan read $f]] + set e [chan eof $f] + chan close $f + list $c $e +} {8 1} +test chan-io-30.26 {Tcl_Write cr, ^Z in middle, Tcl_Read cr} { + file delete $path(test1) + set f [open $path(test1) w] + chan configure $f -translation cr + set c [format abc\ndef\n%cqrs\ntuv 26] + chan puts $f $c + chan close $f + set f [open $path(test1) r] + chan configure $f -translation cr -eofchar \x1a + set c [string length [chan read $f]] + set e [chan eof $f] + chan close $f + list $c $e +} {8 1} +test chan-io-30.27 {Tcl_Write crlf, ^Z in middle, Tcl_Read auto} { + file delete $path(test1) + set f [open $path(test1) w] + chan configure $f -translation crlf + set c [format abc\ndef\n%cqrs\ntuv 26] + chan puts $f $c + chan close $f + set f [open $path(test1) r] + chan configure $f -translation auto -eofchar \x1a + set c [string length [chan read $f]] + set e [chan eof $f] + chan close $f + list $c $e +} {8 1} +test chan-io-30.28 {Tcl_Write crlf, ^Z in middle, Tcl_Read crlf} { + file delete $path(test1) + set f [open $path(test1) w] + chan configure $f -translation crlf + set c [format abc\ndef\n%cqrs\ntuv 26] + chan puts $f $c + chan close $f + set f [open $path(test1) r] + chan configure $f -translation crlf -eofchar \x1a + set c [string length [chan read $f]] + set e [chan eof $f] + chan close $f + list $c $e +} {8 1} + +# Test end of line translations. Functions tested are Tcl_Write and Tcl_Gets. + +test chan-io-31.1 {Tcl_Write lf, Tcl_Gets auto} { + file delete $path(test1) + set f [open $path(test1) w] + chan configure $f -translation lf + chan puts $f hello\nthere\nand\nhere + chan close $f + set f [open $path(test1) r] + set l "" + lappend l [chan gets $f] + lappend l [chan tell $f] + lappend l [chan configure $f -translation] + lappend l [chan gets $f] + lappend l [chan tell $f] + lappend l [chan configure $f -translation] + chan close $f + set l +} {hello 6 auto there 12 auto} +test chan-io-31.2 {Tcl_Write cr, Tcl_Gets auto} { + file delete $path(test1) + set f [open $path(test1) w] + chan configure $f -translation cr + chan puts $f hello\nthere\nand\nhere + chan close $f + set f [open $path(test1) r] + set l "" + lappend l [chan gets $f] + lappend l [chan tell $f] + lappend l [chan configure $f -translation] + lappend l [chan gets $f] + lappend l [chan tell $f] + lappend l [chan configure $f -translation] + chan close $f + set l +} {hello 6 auto there 12 auto} +test chan-io-31.3 {Tcl_Write crlf, Tcl_Gets auto} { + file delete $path(test1) + set f [open $path(test1) w] + chan configure $f -translation crlf + chan puts $f hello\nthere\nand\nhere + chan close $f + set f [open $path(test1) r] + set l "" + lappend l [chan gets $f] + lappend l [chan tell $f] + lappend l [chan configure $f -translation] + lappend l [chan gets $f] + lappend l [chan tell $f] + lappend l [chan configure $f -translation] + chan close $f + set l +} {hello 7 auto there 14 auto} +test chan-io-31.4 {Tcl_Write lf, Tcl_Gets lf} { + file delete $path(test1) + set f [open $path(test1) w] + chan configure $f -translation lf + chan puts $f hello\nthere\nand\nhere + chan close $f + set f [open $path(test1) r] + chan configure $f -translation lf + set l "" + lappend l [chan gets $f] + lappend l [chan tell $f] + lappend l [chan configure $f -translation] + lappend l [chan gets $f] + lappend l [chan tell $f] + lappend l [chan configure $f -translation] + chan close $f + set l +} {hello 6 lf there 12 lf} +test chan-io-31.5 {Tcl_Write lf, Tcl_Gets cr} { + file delete $path(test1) + set f [open $path(test1) w] + chan configure $f -translation lf + chan puts $f hello\nthere\nand\nhere + chan close $f + set f [open $path(test1) r] + chan configure $f -translation cr + set l "" + lappend l [string length [chan gets $f]] + lappend l [chan tell $f] + lappend l [chan configure $f -translation] + lappend l [chan eof $f] + lappend l [chan gets $f] + lappend l [chan tell $f] + lappend l [chan configure $f -translation] + lappend l [chan eof $f] + chan close $f + set l +} {21 21 cr 1 {} 21 cr 1} +test chan-io-31.6 {Tcl_Write lf, Tcl_Gets crlf} { + file delete $path(test1) + set f [open $path(test1) w] + chan configure $f -translation lf + chan puts $f hello\nthere\nand\nhere + chan close $f + set f [open $path(test1) r] + chan configure $f -translation crlf + set l "" + lappend l [string length [chan gets $f]] + lappend l [chan tell $f] + lappend l [chan configure $f -translation] + lappend l [chan eof $f] + lappend l [chan gets $f] + lappend l [chan tell $f] + lappend l [chan configure $f -translation] + lappend l [chan eof $f] + chan close $f + set l +} {21 21 crlf 1 {} 21 crlf 1} +test chan-io-31.7 {Tcl_Write cr, Tcl_Gets cr} { + file delete $path(test1) + set f [open $path(test1) w] + chan configure $f -translation cr + chan puts $f hello\nthere\nand\nhere + chan close $f + set f [open $path(test1) r] + chan configure $f -translation cr + set l "" + lappend l [chan gets $f] + lappend l [chan tell $f] + lappend l [chan configure $f -translation] + lappend l [chan eof $f] + lappend l [chan gets $f] + lappend l [chan tell $f] + lappend l [chan configure $f -translation] + lappend l [chan eof $f] + chan close $f + set l +} {hello 6 cr 0 there 12 cr 0} +test chan-io-31.8 {Tcl_Write cr, Tcl_Gets lf} { + file delete $path(test1) + set f [open $path(test1) w] + chan configure $f -translation cr + chan puts $f hello\nthere\nand\nhere + chan close $f + set f [open $path(test1) r] + chan configure $f -translation lf + set l "" + lappend l [string length [chan gets $f]] + lappend l [chan tell $f] + lappend l [chan configure $f -translation] + lappend l [chan eof $f] + lappend l [chan gets $f] + lappend l [chan tell $f] + lappend l [chan configure $f -translation] + lappend l [chan eof $f] + chan close $f + set l +} {21 21 lf 1 {} 21 lf 1} +test chan-io-31.9 {Tcl_Write cr, Tcl_Gets crlf} { + file delete $path(test1) + set f [open $path(test1) w] + chan configure $f -translation cr + chan puts $f hello\nthere\nand\nhere + chan close $f + set f [open $path(test1) r] + chan configure $f -translation crlf + set l "" + lappend l [string length [chan gets $f]] + lappend l [chan tell $f] + lappend l [chan configure $f -translation] + lappend l [chan eof $f] + lappend l [chan gets $f] + lappend l [chan tell $f] + lappend l [chan configure $f -translation] + lappend l [chan eof $f] + chan close $f + set l +} {21 21 crlf 1 {} 21 crlf 1} +test chan-io-31.10 {Tcl_Write crlf, Tcl_Gets crlf} { + file delete $path(test1) + set f [open $path(test1) w] + chan configure $f -translation crlf + chan puts $f hello\nthere\nand\nhere + chan close $f + set f [open $path(test1) r] + chan configure $f -translation crlf + set l "" + lappend l [chan gets $f] + lappend l [chan tell $f] + lappend l [chan configure $f -translation] + lappend l [chan eof $f] + lappend l [chan gets $f] + lappend l [chan tell $f] + lappend l [chan configure $f -translation] + lappend l [chan eof $f] + chan close $f + set l +} {hello 7 crlf 0 there 14 crlf 0} +test chan-io-31.11 {Tcl_Write crlf, Tcl_Gets cr} { + file delete $path(test1) + set f [open $path(test1) w] + chan configure $f -translation crlf + chan puts $f hello\nthere\nand\nhere + chan close $f + set f [open $path(test1) r] + chan configure $f -translation cr + set l "" + lappend l [chan gets $f] + lappend l [chan tell $f] + lappend l [chan configure $f -translation] + lappend l [chan eof $f] + lappend l [string length [chan gets $f]] + lappend l [chan tell $f] + lappend l [chan configure $f -translation] + lappend l [chan eof $f] + chan close $f + set l +} {hello 6 cr 0 6 13 cr 0} +test chan-io-31.12 {Tcl_Write crlf, Tcl_Gets lf} { + file delete $path(test1) + set f [open $path(test1) w] + chan configure $f -translation crlf + chan puts $f hello\nthere\nand\nhere + chan close $f + set f [open $path(test1) r] + chan configure $f -translation lf + set l "" + lappend l [string length [chan gets $f]] + lappend l [chan tell $f] + lappend l [chan configure $f -translation] + lappend l [chan eof $f] + lappend l [string length [chan gets $f]] + lappend l [chan tell $f] + lappend l [chan configure $f -translation] + lappend l [chan eof $f] + chan close $f + set l +} {6 7 lf 0 6 14 lf 0} +test chan-io-31.13 {binary mode is synonym of lf mode} { + file delete $path(test1) + set f [open $path(test1) w] + chan configure $f -translation binary + set x [chan configure $f -translation] + chan close $f + set x +} lf +# +# Test chan-io-9.14 has been removed because "auto" output translation mode is +# not supoprted. +# +test chan-io-31.14 {Tcl_Write mixed, Tcl_Gets auto} { + file delete $path(test1) + set f [open $path(test1) w] + chan configure $f -translation lf + chan puts $f hello\nthere\rand\r\nhere + chan close $f + set f [open $path(test1) r] + chan configure $f -translation auto + set l "" + lappend l [chan gets $f] + lappend l [chan gets $f] + lappend l [chan gets $f] + lappend l [chan gets $f] + lappend l [chan eof $f] + lappend l [chan gets $f] + lappend l [chan eof $f] + chan close $f + set l +} {hello there and here 0 {} 1} +test chan-io-31.15 {Tcl_Write mixed, Tcl_Gets auto} { + file delete $path(test1) + set f [open $path(test1) w] + chan configure $f -translation lf + chan puts -nonewline $f hello\nthere\rand\r\nhere\r + chan close $f + set f [open $path(test1) r] + chan configure $f -translation auto + set l "" + lappend l [chan gets $f] + lappend l [chan gets $f] + lappend l [chan gets $f] + lappend l [chan gets $f] + lappend l [chan eof $f] + lappend l [chan gets $f] + lappend l [chan eof $f] + chan close $f + set l +} {hello there and here 0 {} 1} +test chan-io-31.16 {Tcl_Write mixed, Tcl_Gets auto} { + file delete $path(test1) + set f [open $path(test1) w] + chan configure $f -translation lf + chan puts -nonewline $f hello\nthere\rand\r\nhere\n + chan close $f + set f [open $path(test1) r] + set l "" + lappend l [chan gets $f] + lappend l [chan gets $f] + lappend l [chan gets $f] + lappend l [chan gets $f] + lappend l [chan eof $f] + lappend l [chan gets $f] + lappend l [chan eof $f] + chan close $f + set l +} {hello there and here 0 {} 1} +test chan-io-31.17 {Tcl_Write mixed, Tcl_Gets auto} { + file delete $path(test1) + set f [open $path(test1) w] + chan configure $f -translation lf + chan puts -nonewline $f hello\nthere\rand\r\nhere\r\n + chan close $f + set f [open $path(test1) r] + chan configure $f -translation auto + set l "" + lappend l [chan gets $f] + lappend l [chan gets $f] + lappend l [chan gets $f] + lappend l [chan gets $f] + lappend l [chan eof $f] + lappend l [chan gets $f] + lappend l [chan eof $f] + chan close $f + set l +} {hello there and here 0 {} 1} +test chan-io-31.18 {Tcl_Write ^Z at end, Tcl_Gets auto} { + file delete $path(test1) + set f [open $path(test1) w] + chan configure $f -translation lf + set s [format "hello\nthere\nand\rhere\n\%c" 26] + chan puts $f $s + chan close $f + set f [open $path(test1) r] + chan configure $f -eofchar \x1a -translation auto + set l "" + lappend l [chan gets $f] + lappend l [chan gets $f] + lappend l [chan gets $f] + lappend l [chan gets $f] + lappend l [chan eof $f] + lappend l [chan gets $f] + lappend l [chan eof $f] + chan close $f + set l +} {hello there and here 0 {} 1} +test chan-io-31.19 {Tcl_Write, implicit ^Z at end, Tcl_Gets auto} { + file delete $path(test1) + set f [open $path(test1) w] + chan configure $f -eofchar \x1a -translation lf + chan puts $f hello\nthere\nand\rhere + chan close $f + set f [open $path(test1) r] + chan configure $f -eofchar \x1a -translation auto + set l "" + lappend l [chan gets $f] + lappend l [chan gets $f] + lappend l [chan gets $f] + lappend l [chan gets $f] + lappend l [chan eof $f] + lappend l [chan gets $f] + lappend l [chan eof $f] + chan close $f + set l +} {hello there and here 0 {} 1} +test chan-io-31.20 {Tcl_Write, ^Z in middle, Tcl_Gets auto, eofChar} { + file delete $path(test1) + set f [open $path(test1) w] + chan configure $f -translation lf + set s [format "abc\ndef\n%cqrs\ntuv" 26] + chan puts $f $s + chan close $f + set f [open $path(test1) r] + chan configure $f -eofchar \x1a + chan configure $f -translation auto + set l "" + lappend l [chan gets $f] + lappend l [chan gets $f] + lappend l [chan eof $f] + lappend l [chan gets $f] + lappend l [chan eof $f] + chan close $f + set l +} {abc def 0 {} 1} +test chan-io-31.21 {Tcl_Write, no newline ^Z in middle, Tcl_Gets auto, eofChar} { + file delete $path(test1) + set f [open $path(test1) w] + chan configure $f -translation lf + set s [format "abc\ndef\n%cqrs\ntuv" 26] + chan puts $f $s + chan close $f + set f [open $path(test1) r] + chan configure $f -eofchar \x1a -translation auto + set l "" + lappend l [chan gets $f] + lappend l [chan gets $f] + lappend l [chan eof $f] + lappend l [chan gets $f] + lappend l [chan eof $f] + chan close $f + set l +} {abc def 0 {} 1} +test chan-io-31.22 {Tcl_Write, ^Z in middle ignored, Tcl_Gets lf} { + file delete $path(test1) + set f [open $path(test1) w] + chan configure $f -translation lf -eofchar {} + set s [format "abc\ndef\n%cqrs\ntuv" 26] + chan puts $f $s + chan close $f + set f [open $path(test1) r] + chan configure $f -translation lf -eofchar {} + set l "" + lappend l [chan gets $f] + lappend l [chan gets $f] + lappend l [chan eof $f] + lappend l [chan gets $f] + lappend l [chan eof $f] + lappend l [chan gets $f] + lappend l [chan eof $f] + lappend l [chan gets $f] + lappend l [chan eof $f] + chan close $f + set l +} "abc def 0 \x1aqrs 0 tuv 0 {} 1" +test chan-io-31.23 {Tcl_Write, ^Z in middle ignored, Tcl_Gets cr} { + file delete $path(test1) + set f [open $path(test1) w] + chan configure $f -translation cr -eofchar {} + set s [format "abc\ndef\n%cqrs\ntuv" 26] + chan puts $f $s + chan close $f + set f [open $path(test1) r] + chan configure $f -translation cr -eofchar {} + set l "" + lappend l [chan gets $f] + lappend l [chan gets $f] + lappend l [chan eof $f] + lappend l [chan gets $f] + lappend l [chan eof $f] + lappend l [chan gets $f] + lappend l [chan eof $f] + lappend l [chan gets $f] + lappend l [chan eof $f] + chan close $f + set l +} "abc def 0 \x1aqrs 0 tuv 0 {} 1" +test chan-io-31.24 {Tcl_Write, ^Z in middle ignored, Tcl_Gets crlf} { + file delete $path(test1) + set f [open $path(test1) w] + chan configure $f -translation crlf -eofchar {} + set s [format "abc\ndef\n%cqrs\ntuv" 26] + chan puts $f $s + chan close $f + set f [open $path(test1) r] + chan configure $f -translation crlf -eofchar {} + set l "" + lappend l [chan gets $f] + lappend l [chan gets $f] + lappend l [chan eof $f] + lappend l [chan gets $f] + lappend l [chan eof $f] + lappend l [chan gets $f] + lappend l [chan eof $f] + lappend l [chan gets $f] + lappend l [chan eof $f] + chan close $f + set l +} "abc def 0 \x1aqrs 0 tuv 0 {} 1" +test chan-io-31.25 {Tcl_Write lf, ^Z in middle, Tcl_Gets auto} { + file delete $path(test1) + set f [open $path(test1) w] + chan configure $f -translation lf + set s [format "abc\ndef\n%cqrs\ntuv" 26] + chan puts $f $s + chan close $f + set f [open $path(test1) r] + chan configure $f -translation auto -eofchar \x1a + set l "" + lappend l [chan gets $f] + lappend l [chan gets $f] + lappend l [chan eof $f] + lappend l [chan gets $f] + lappend l [chan eof $f] + chan close $f + set l +} {abc def 0 {} 1} +test chan-io-31.26 {Tcl_Write lf, ^Z in middle, Tcl_Gets lf} { + file delete $path(test1) + set f [open $path(test1) w] + chan configure $f -translation lf + set s [format "abc\ndef\n%cqrs\ntuv" 26] + chan puts $f $s + chan close $f + set f [open $path(test1) r] + chan configure $f -translation lf -eofchar \x1a + set l "" + lappend l [chan gets $f] + lappend l [chan gets $f] + lappend l [chan eof $f] + lappend l [chan gets $f] + lappend l [chan eof $f] + chan close $f + set l +} {abc def 0 {} 1} +test chan-io-31.27 {Tcl_Write cr, ^Z in middle, Tcl_Gets auto} { + file delete $path(test1) + set f [open $path(test1) w] + chan configure $f -translation cr -eofchar {} + set s [format "abc\ndef\n%cqrs\ntuv" 26] + chan puts $f $s + chan close $f + set f [open $path(test1) r] + chan configure $f -translation auto -eofchar \x1a + set l "" + lappend l [chan gets $f] + lappend l [chan gets $f] + lappend l [chan eof $f] + lappend l [chan gets $f] + lappend l [chan eof $f] + chan close $f + set l +} {abc def 0 {} 1} +test chan-io-31.28 {Tcl_Write cr, ^Z in middle, Tcl_Gets cr} { + file delete $path(test1) + set f [open $path(test1) w] + chan configure $f -translation cr -eofchar {} + set s [format "abc\ndef\n%cqrs\ntuv" 26] + chan puts $f $s + chan close $f + set f [open $path(test1) r] + chan configure $f -translation cr -eofchar \x1a + set l "" + lappend l [chan gets $f] + lappend l [chan gets $f] + lappend l [chan eof $f] + lappend l [chan gets $f] + lappend l [chan eof $f] + chan close $f + set l +} {abc def 0 {} 1} +test chan-io-31.29 {Tcl_Write crlf, ^Z in middle, Tcl_Gets auto} { + file delete $path(test1) + set f [open $path(test1) w] + chan configure $f -translation crlf -eofchar {} + set s [format "abc\ndef\n%cqrs\ntuv" 26] + chan puts $f $s + chan close $f + set f [open $path(test1) r] + chan configure $f -translation auto -eofchar \x1a + set l "" + lappend l [chan gets $f] + lappend l [chan gets $f] + lappend l [chan eof $f] + lappend l [chan gets $f] + lappend l [chan eof $f] + chan close $f + set l +} {abc def 0 {} 1} +test chan-io-31.30 {Tcl_Write crlf, ^Z in middle, Tcl_Gets crlf} { + file delete $path(test1) + set f [open $path(test1) w] + chan configure $f -translation crlf -eofchar {} + set s [format "abc\ndef\n%cqrs\ntuv" 26] + chan puts $f $s + chan close $f + set f [open $path(test1) r] + chan configure $f -translation crlf -eofchar \x1a + set l "" + lappend l [chan gets $f] + lappend l [chan gets $f] + lappend l [chan eof $f] + lappend l [chan gets $f] + lappend l [chan eof $f] + chan close $f + set l +} {abc def 0 {} 1} +test chan-io-31.31 {Tcl_Write crlf on block boundary, Tcl_Gets crlf} { + file delete $path(test1) + set f [open $path(test1) w] + chan configure $f -translation crlf + set line "123456789ABCDE" ;# 14 char plus crlf + chan puts -nonewline $f x ;# shift crlf across block boundary + for {set i 0} {$i < 700} {incr i} { + chan puts $f $line + } + chan close $f + set f [open $path(test1) r] + chan configure $f -translation crlf + set c "" + while {[chan gets $f line] >= 0} { + append c $line\n + } + chan close $f + string length $c +} [expr 700*15+1] +test chan-io-31.32 {Tcl_Write crlf on block boundary, Tcl_Gets auto} { + file delete $path(test1) + set f [open $path(test1) w] + chan configure $f -translation crlf + set line "123456789ABCDE" ;# 14 char plus crlf + chan puts -nonewline $f x ;# shift crlf across block boundary + for {set i 0} {$i < 700} {incr i} { + chan puts $f $line + } + chan close $f + set f [open $path(test1) r] + chan configure $f -translation auto + set c "" + while {[chan gets $f line] >= 0} { + append c $line\n + } + chan close $f + string length $c +} [expr 700*15+1] + +# Test Tcl_Read and buffering. + +test chan-io-32.1 {Tcl_Read, channel not readable} { + list [catch {read stdout} msg] $msg +} {1 {channel "stdout" wasn't opened for reading}} +test chan-io-32.2 {Tcl_Read, zero byte count} { + chan read stdin 0 +} "" +test chan-io-32.3 {Tcl_Read, negative byte count} { + set f [open $path(longfile) r] + set l [list [catch {chan read $f -1} msg] $msg] + chan close $f + set l +} {1 {bad argument "-1": should be "nonewline"}} +test chan-io-32.4 {Tcl_Read, positive byte count} { + set f [open $path(longfile) r] + set x [chan read $f 1024] + set s [string length $x] + unset x + chan close $f + set s +} 1024 +test chan-io-32.5 {Tcl_Read, multiple buffers} { + set f [open $path(longfile) r] + chan configure $f -buffersize 100 + set x [chan read $f 1024] + set s [string length $x] + unset x + chan close $f + set s +} 1024 +test chan-io-32.6 {Tcl_Read, very large read} { + set f1 [open $path(longfile) r] + set z [chan read $f1 1000000] + chan close $f1 + set l [string length $z] + set x ok + set z [file size $path(longfile)] + if {$z != $l} { + set x broken + } + set x +} ok +test chan-io-32.7 {Tcl_Read, nonblocking, file} {nonBlockFiles} { + set f1 [open $path(longfile) r] + chan configure $f1 -blocking off + set z [chan read $f1 20] + chan close $f1 + set l [string length $z] + set x ok + if {$l != 20} { + set x broken + } + set x +} ok +test chan-io-32.8 {Tcl_Read, nonblocking, file} {nonBlockFiles} { + set f1 [open $path(longfile) r] + chan configure $f1 -blocking off + set z [chan read $f1 1000000] + chan close $f1 + set x ok + set l [string length $z] + set z [file size $path(longfile)] + if {$z != $l} { + set x broken + } + set x +} ok +test chan-io-32.9 {Tcl_Read, read to end of file} { + set f1 [open $path(longfile) r] + set z [chan read $f1] + chan close $f1 + set l [string length $z] + set x ok + set z [file size $path(longfile)] + if {$z != $l} { + set x broken + } + set x +} ok +test chan-io-32.10 {Tcl_Read from a pipe} {stdio openpipe} { + file delete $path(pipe) + set f1 [open $path(pipe) w] + chan puts $f1 {chan puts [chan gets stdin]} + chan close $f1 + set f1 [open "|[list [interpreter] $path(pipe)]" r+] + chan puts $f1 hello + chan flush $f1 + set x [chan read $f1] + chan close $f1 + set x +} "hello\n" +test chan-io-32.11 {Tcl_Read from a pipe} {stdio openpipe} { + file delete $path(pipe) + set f1 [open $path(pipe) w] + chan puts $f1 {chan puts [chan gets stdin]} + chan puts $f1 {chan puts [chan gets stdin]} + chan close $f1 + set f1 [open "|[list [interpreter] $path(pipe)]" r+] + chan puts $f1 hello + chan flush $f1 + set x "" + lappend x [chan read $f1 6] + chan puts $f1 hello + chan flush $f1 + lappend x [chan read $f1] + chan close $f1 + set x +} {{hello +} {hello +}} +test chan-io-32.12 {Tcl_Read, -nonewline} { + file delete $path(test1) + set f1 [open $path(test1) w] + chan puts $f1 hello + chan puts $f1 bye + chan close $f1 + set f1 [open $path(test1) r] + set c [chan read -nonewline $f1] + chan close $f1 + set c +} {hello +bye} +test chan-io-32.13 {Tcl_Read, -nonewline} { + file delete $path(test1) + set f1 [open $path(test1) w] + chan puts $f1 hello + chan puts $f1 bye + chan close $f1 + set f1 [open $path(test1) r] + set c [chan read -nonewline $f1] + chan close $f1 + list [string length $c] $c +} {9 {hello +bye}} +test chan-io-32.14 {Tcl_Read, reading in small chunks} { + file delete $path(test1) + set f [open $path(test1) w] + chan puts $f "Two lines: this one" + chan puts $f "and this one" + chan close $f + set f [open $path(test1)] + set x [list [chan read $f 1] [chan read $f 2] [chan read $f]] + chan close $f + set x +} {T wo { lines: this one +and this one +}} +test chan-io-32.15 {Tcl_Read, asking for more input than available} { + file delete $path(test1) + set f [open $path(test1) w] + chan puts $f "Two lines: this one" + chan puts $f "and this one" + chan close $f + set f [open $path(test1)] + set x [chan read $f 100] + chan close $f + set x +} {Two lines: this one +and this one +} +test chan-io-32.16 {Tcl_Read, read to end of file with -nonewline} { + file delete $path(test1) + set f [open $path(test1) w] + chan puts $f "Two lines: this one" + chan puts $f "and this one" + chan close $f + set f [open $path(test1)] + set x [chan read -nonewline $f] + chan close $f + set x +} {Two lines: this one +and this one} + +# Test Tcl_Gets. + +test chan-io-33.1 {Tcl_Gets, reading what was written} { + file delete $path(test1) + set f1 [open $path(test1) w] + set y "first line" + chan puts $f1 $y + chan close $f1 + set f1 [open $path(test1) r] + set x [chan gets $f1] + set z ok + if {"$x" != "$y"} { + set z broken + } + chan close $f1 + set z +} ok +test chan-io-33.2 {Tcl_Gets into variable} { + set f1 [open $path(longfile) r] + set c [chan gets $f1 x] + set l [string length x] + set z ok + if {$l != $l} { + set z broken + } + chan close $f1 + set z +} ok +test chan-io-33.3 {Tcl_Gets from pipe} {stdio openpipe} { + file delete $path(pipe) + set f1 [open $path(pipe) w] + chan puts $f1 {chan puts [chan gets stdin]} + chan close $f1 + set f1 [open "|[list [interpreter] $path(pipe)]" r+] + chan puts $f1 hello + chan flush $f1 + set x [chan gets $f1] + chan close $f1 + set z ok + if {"$x" != "hello"} { + set z broken + } + set z +} ok +test chan-io-33.4 {Tcl_Gets with long line} { + file delete $path(test3) + set f [open $path(test3) w] + chan puts -nonewline $f "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ" + chan puts -nonewline $f "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ" + chan puts -nonewline $f "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ" + chan puts -nonewline $f "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ" + chan puts $f "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ" + chan close $f + set f [open $path(test3)] + set x [chan gets $f] + chan close $f + set x +} {abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ} +test chan-io-33.5 {Tcl_Gets with long line} { + set f [open $path(test3)] + set x [chan gets $f y] + chan close $f + list $x $y +} {260 abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ} +test chan-io-33.6 {Tcl_Gets and end of file} { + file delete $path(test3) + set f [open $path(test3) w] + chan puts -nonewline $f "Test1\nTest2" + chan close $f + set f [open $path(test3)] + set x {} + set y {} + lappend x [chan gets $f y] $y + set y {} + lappend x [chan gets $f y] $y + set y {} + lappend x [chan gets $f y] $y + chan close $f + set x +} {5 Test1 5 Test2 -1 {}} +test chan-io-33.7 {Tcl_Gets and bad variable} { + set f [open $path(test3) w] + chan puts $f "Line 1" + chan puts $f "Line 2" + chan close $f + catch {unset x} + set x 24 + set f [open $path(test3) r] + set result [list [catch {chan gets $f x(0)} msg] $msg] + chan close $f + set result +} {1 {can't set "x(0)": variable isn't array}} +test chan-io-33.8 {Tcl_Gets, exercising double buffering} { + set f [open $path(test3) w] + chan configure $f -translation lf -eofchar {} + set x "" + for {set y 0} {$y < 99} {incr y} {set x "a$x"} + for {set y 0} {$y < 100} {incr y} {chan puts $f $x} + chan close $f + set f [open $path(test3) r] + chan configure $f -translation lf + for {set y 0} {$y < 100} {incr y} {chan gets $f} + chan close $f + set y +} 100 +test chan-io-33.9 {Tcl_Gets, exercising double buffering} { + set f [open $path(test3) w] + chan configure $f -translation lf -eofchar {} + set x "" + for {set y 0} {$y < 99} {incr y} {set x "a$x"} + for {set y 0} {$y < 200} {incr y} {chan puts $f $x} + chan close $f + set f [open $path(test3) r] + chan configure $f -translation lf + for {set y 0} {$y < 200} {incr y} {chan gets $f} + chan close $f + set y +} 200 +test chan-io-33.10 {Tcl_Gets, exercising double buffering} { + set f [open $path(test3) w] + chan configure $f -translation lf -eofchar {} + set x "" + for {set y 0} {$y < 99} {incr y} {set x "a$x"} + for {set y 0} {$y < 300} {incr y} {chan puts $f $x} + chan close $f + set f [open $path(test3) r] + chan configure $f -translation lf + for {set y 0} {$y < 300} {incr y} {chan gets $f} + chan close $f + set y +} 300 + +# Test Tcl_Seek and Tcl_Tell. + +test chan-io-34.1 {Tcl_Seek to current position at start of file} { + set f1 [open $path(longfile) r] + chan seek $f1 0 current + set c [chan tell $f1] + chan close $f1 + set c +} 0 +test chan-io-34.2 {Tcl_Seek to offset from start} { + file delete $path(test1) + set f1 [open $path(test1) w] + chan configure $f1 -translation lf -eofchar {} + chan puts $f1 "abcdefghijklmnopqrstuvwxyz" + chan puts $f1 "abcdefghijklmnopqrstuvwxyz" + chan close $f1 + set f1 [open $path(test1) r] + chan seek $f1 10 start + set c [chan tell $f1] + chan close $f1 + set c +} 10 +test chan-io-34.3 {Tcl_Seek to end of file} { + file delete $path(test1) + set f1 [open $path(test1) w] + chan configure $f1 -translation lf -eofchar {} + chan puts $f1 "abcdefghijklmnopqrstuvwxyz" + chan puts $f1 "abcdefghijklmnopqrstuvwxyz" + chan close $f1 + set f1 [open $path(test1) r] + chan seek $f1 0 end + set c [chan tell $f1] + chan close $f1 + set c +} 54 +test chan-io-34.4 {Tcl_Seek to offset from end of file} { + file delete $path(test1) + set f1 [open $path(test1) w] + chan configure $f1 -translation lf -eofchar {} + chan puts $f1 "abcdefghijklmnopqrstuvwxyz" + chan puts $f1 "abcdefghijklmnopqrstuvwxyz" + chan close $f1 + set f1 [open $path(test1) r] + chan seek $f1 -10 end + set c [chan tell $f1] + chan close $f1 + set c +} 44 +test chan-io-34.5 {Tcl_Seek to offset from current position} { + file delete $path(test1) + set f1 [open $path(test1) w] + chan configure $f1 -translation lf -eofchar {} + chan puts $f1 "abcdefghijklmnopqrstuvwxyz" + chan puts $f1 "abcdefghijklmnopqrstuvwxyz" + chan close $f1 + set f1 [open $path(test1) r] + chan seek $f1 10 current + chan seek $f1 10 current + set c [chan tell $f1] + chan close $f1 + set c +} 20 +test chan-io-34.6 {Tcl_Seek to offset from end of file} { + file delete $path(test1) + set f1 [open $path(test1) w] + chan configure $f1 -translation lf -eofchar {} + chan puts $f1 "abcdefghijklmnopqrstuvwxyz" + chan puts $f1 "abcdefghijklmnopqrstuvwxyz" + chan close $f1 + set f1 [open $path(test1) r] + chan seek $f1 -10 end + set c [chan tell $f1] + set r [chan read $f1] + chan close $f1 + list $c $r +} {44 {rstuvwxyz +}} +test chan-io-34.7 {Tcl_Seek to offset from end of file, then to current position} { + file delete $path(test1) + set f1 [open $path(test1) w] + chan configure $f1 -translation lf -eofchar {} + chan puts $f1 "abcdefghijklmnopqrstuvwxyz" + chan puts $f1 "abcdefghijklmnopqrstuvwxyz" + chan close $f1 + set f1 [open $path(test1) r] + chan seek $f1 -10 end + set c1 [chan tell $f1] + set r1 [chan read $f1 5] + chan seek $f1 0 current + set c2 [chan tell $f1] + chan close $f1 + list $c1 $r1 $c2 +} {44 rstuv 49} +test chan-io-34.8 {Tcl_Seek on pipes: not supported} {stdio openpipe} { + set f1 [open "|[list [interpreter]]" r+] + set x [list [catch {chan seek $f1 0 current} msg] $msg] + chan close $f1 + regsub {".*":} $x {"":} x + string tolower $x +} {1 {error during seek on "": invalid argument}} +test chan-io-34.9 {Tcl_Seek, testing buffered input flushing} { + file delete $path(test3) + set f [open $path(test3) w] + chan configure $f -eofchar {} + chan puts -nonewline $f "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ" + chan close $f + set f [open $path(test3) RDWR] + set x [chan read $f 1] + chan seek $f 3 + lappend x [chan read $f 1] + chan seek $f 0 start + lappend x [chan read $f 1] + chan seek $f 10 current + lappend x [chan read $f 1] + chan seek $f -2 end + lappend x [chan read $f 1] + chan seek $f 50 end + lappend x [chan read $f 1] + chan seek $f 1 + lappend x [chan read $f 1] + chan close $f + set x +} {a d a l Y {} b} +set path(test3) [makeFile {} test3] +test chan-io-34.10 {Tcl_Seek testing flushing of buffered input} { + set f [open $path(test3) w] + chan configure $f -translation lf + chan puts $f xyz\n123 + chan close $f + set f [open $path(test3) r+] + chan configure $f -translation lf + set x [chan gets $f] + chan seek $f 0 current + chan puts $f 456 + chan close $f + list $x [viewFile test3] +} "xyz {xyz +456}" +test chan-io-34.11 {Tcl_Seek testing flushing of buffered output} { + set f [open $path(test3) w] + chan puts $f xyz\n123 + chan close $f + set f [open $path(test3) w+] + chan puts $f xyzzy + chan seek $f 2 + set x [chan gets $f] + chan close $f + list $x [viewFile test3] +} "zzy xyzzy" +test chan-io-34.12 {Tcl_Seek testing combination of write, seek back and read} { + set f [open $path(test3) w] + chan configure $f -translation lf -eofchar {} + chan puts $f xyz\n123 + chan close $f + set f [open $path(test3) a+] + chan configure $f -translation lf -eofchar {} + chan puts $f xyzzy + chan flush $f + set x [chan tell $f] + chan seek $f -4 cur + set y [chan gets $f] + chan close $f + list $x [viewFile test3] $y +} {14 {xyz +123 +xyzzy} zzy} +test chan-io-34.13 {Tcl_Tell at start of file} { + file delete $path(test1) + set f1 [open $path(test1) w] + set p [chan tell $f1] + chan close $f1 + set p +} 0 +test chan-io-34.14 {Tcl_Tell after seek to end of file} { + file delete $path(test1) + set f1 [open $path(test1) w] + chan configure $f1 -translation lf -eofchar {} + chan puts $f1 "abcdefghijklmnopqrstuvwxyz" + chan puts $f1 "abcdefghijklmnopqrstuvwxyz" + chan close $f1 + set f1 [open $path(test1) r] + chan seek $f1 0 end + set c1 [chan tell $f1] + chan close $f1 + set c1 +} 54 +test chan-io-34.15 {Tcl_Tell combined with seeking} { + file delete $path(test1) + set f1 [open $path(test1) w] + chan configure $f1 -translation lf -eofchar {} + chan puts $f1 "abcdefghijklmnopqrstuvwxyz" + chan puts $f1 "abcdefghijklmnopqrstuvwxyz" + chan close $f1 + set f1 [open $path(test1) r] + chan seek $f1 10 start + set c1 [chan tell $f1] + chan seek $f1 10 current + set c2 [chan tell $f1] + chan close $f1 + list $c1 $c2 +} {10 20} +test chan-io-34.16 {Tcl_Tell on pipe: always -1} {stdio openpipe} { + set f1 [open "|[list [interpreter]]" r+] + set c [chan tell $f1] + chan close $f1 + set c +} -1 +test chan-io-34.17 {Tcl_Tell on pipe: always -1} {stdio openpipe} { + set f1 [open "|[list [interpreter]]" r+] + chan puts $f1 {chan puts hello} + chan flush $f1 + set c [chan tell $f1] + chan gets $f1 + chan close $f1 + set c +} -1 +test chan-io-34.18 {Tcl_Tell combined with seeking and reading} { + file delete $path(test2) + set f [open $path(test2) w] + chan configure $f -translation lf -eofchar {} + chan puts -nonewline $f "line1\nline2\nline3\nline4\nline5\n" + chan close $f + set f [open $path(test2)] + chan configure $f -translation lf + set x [chan tell $f] + chan read $f 3 + lappend x [chan tell $f] + chan seek $f 2 + lappend x [chan tell $f] + chan seek $f 10 current + lappend x [chan tell $f] + chan seek $f 0 end + lappend x [chan tell $f] + chan close $f + set x +} {0 3 2 12 30} +test chan-io-34.19 {Tcl_Tell combined with opening in append mode} { + set f [open $path(test3) w] + chan configure $f -translation lf -eofchar {} + chan puts $f "abcdefghijklmnopqrstuvwxyz" + chan puts $f "abcdefghijklmnopqrstuvwxyz" + chan close $f + set f [open $path(test3) a] + set c [chan tell $f] + chan close $f + set c +} 54 +test chan-io-34.20 {Tcl_Tell combined with writing} { + set f [open $path(test3) w] + set l "" + chan seek $f 29 start + lappend l [chan tell $f] + chan puts -nonewline $f a + chan seek $f 39 start + lappend l [chan tell $f] + chan puts -nonewline $f a + lappend l [chan tell $f] + chan seek $f 407 end + lappend l [chan tell $f] + chan close $f + set l +} {29 39 40 447} +test chan-io-34.21 {Tcl_Seek and Tcl_Tell on large files} {largefileSupport} { + file delete $path(test3) + set f [open $path(test3) w] + chan configure $f -encoding binary + set l "" + lappend l [chan tell $f] + chan puts -nonewline $f abcdef + lappend l [chan tell $f] + chan flush $f + lappend l [chan tell $f] + # 4GB offset! + chan seek $f 0x100000000 + lappend l [chan tell $f] + chan puts -nonewline $f abcdef + lappend l [chan tell $f] + chan close $f + lappend l [file size $f] + # truncate... + chan close [open $path(test3) w] + lappend l [file size $f] + set l +} {0 6 6 4294967296 4294967302 4294967302 0} + +# Test Tcl_Eof + +test chan-io-35.1 {Tcl_Eof} { + file delete $path(test1) + set f [open $path(test1) w] + chan puts $f hello + chan puts $f hello + chan close $f + set f [open $path(test1)] + set x [chan eof $f] + lappend x [chan eof $f] + chan gets $f + lappend x [chan eof $f] + chan gets $f + lappend x [chan eof $f] + chan gets $f + lappend x [chan eof $f] + lappend x [chan eof $f] + chan close $f + set x +} {0 0 0 0 1 1} +test chan-io-35.2 {Tcl_Eof with pipe} {stdio openpipe} { + file delete $path(pipe) + set f1 [open $path(pipe) w] + chan puts $f1 {chan gets stdin} + chan puts $f1 {chan puts hello} + chan close $f1 + set f1 [open "|[list [interpreter] $path(pipe)]" r+] + chan puts $f1 hello + set x [chan eof $f1] + chan flush $f1 + lappend x [chan eof $f1] + chan gets $f1 + lappend x [chan eof $f1] + chan gets $f1 + lappend x [chan eof $f1] + chan close $f1 + set x +} {0 0 0 1} +test chan-io-35.3 {Tcl_Eof with pipe} {stdio openpipe} { + file delete $path(pipe) + set f1 [open $path(pipe) w] + chan puts $f1 {chan gets stdin} + chan puts $f1 {chan puts hello} + chan close $f1 + set f1 [open "|[list [interpreter] $path(pipe)]" r+] + chan puts $f1 hello + set x [chan eof $f1] + chan flush $f1 + lappend x [chan eof $f1] + chan gets $f1 + lappend x [chan eof $f1] + chan gets $f1 + lappend x [chan eof $f1] + chan gets $f1 + lappend x [chan eof $f1] + chan gets $f1 + lappend x [chan eof $f1] + chan close $f1 + set x +} {0 0 0 1 1 1} +test chan-io-35.4 {Tcl_Eof, eof detection on nonblocking file} {nonBlockFiles} { + file delete $path(test1) + set f [open $path(test1) w] + chan close $f + set f [open $path(test1) r] + chan configure $f -blocking off + set l "" + lappend l [chan gets $f] + lappend l [chan eof $f] + chan close $f + set l +} {{} 1} +test chan-io-35.5 {Tcl_Eof, eof detection on nonblocking pipe} {stdio openpipe} { + file delete $path(pipe) + set f [open $path(pipe) w] + chan puts $f { + exit + } + chan close $f + set f [open "|[list [interpreter] $path(pipe)]" r] + set l "" + lappend l [chan gets $f] + lappend l [chan eof $f] + chan close $f + set l +} {{} 1} +test chan-io-35.6 {Tcl_Eof, eof char, lf write, auto read} { + file delete $path(test1) + set f [open $path(test1) w] + chan configure $f -translation lf -eofchar \x1a + chan puts $f abc\ndef + chan close $f + set s [file size $path(test1)] + set f [open $path(test1) r] + chan configure $f -translation auto -eofchar \x1a + set l [string length [chan read $f]] + set e [chan eof $f] + chan close $f + list $s $l $e +} {9 8 1} +test chan-io-35.7 {Tcl_Eof, eof char, lf write, lf read} { + file delete $path(test1) + set f [open $path(test1) w] + chan configure $f -translation lf -eofchar \x1a + chan puts $f abc\ndef + chan close $f + set s [file size $path(test1)] + set f [open $path(test1) r] + chan configure $f -translation lf -eofchar \x1a + set l [string length [chan read $f]] + set e [chan eof $f] + chan close $f + list $s $l $e +} {9 8 1} +test chan-io-35.8 {Tcl_Eof, eof char, cr write, auto read} { + file delete $path(test1) + set f [open $path(test1) w] + chan configure $f -translation cr -eofchar \x1a + chan puts $f abc\ndef + chan close $f + set s [file size $path(test1)] + set f [open $path(test1) r] + chan configure $f -translation auto -eofchar \x1a + set l [string length [chan read $f]] + set e [chan eof $f] + chan close $f + list $s $l $e +} {9 8 1} +test chan-io-35.9 {Tcl_Eof, eof char, cr write, cr read} { + file delete $path(test1) + set f [open $path(test1) w] + chan configure $f -translation cr -eofchar \x1a + chan puts $f abc\ndef + chan close $f + set s [file size $path(test1)] + set f [open $path(test1) r] + chan configure $f -translation cr -eofchar \x1a + set l [string length [chan read $f]] + set e [chan eof $f] + chan close $f + list $s $l $e +} {9 8 1} +test chan-io-35.10 {Tcl_Eof, eof char, crlf write, auto read} { + file delete $path(test1) + set f [open $path(test1) w] + chan configure $f -translation crlf -eofchar \x1a + chan puts $f abc\ndef + chan close $f + set s [file size $path(test1)] + set f [open $path(test1) r] + chan configure $f -translation auto -eofchar \x1a + set l [string length [chan read $f]] + set e [chan eof $f] + chan close $f + list $s $l $e +} {11 8 1} +test chan-io-35.11 {Tcl_Eof, eof char, crlf write, crlf read} { + file delete $path(test1) + set f [open $path(test1) w] + chan configure $f -translation crlf -eofchar \x1a + chan puts $f abc\ndef + chan close $f + set s [file size $path(test1)] + set f [open $path(test1) r] + chan configure $f -translation crlf -eofchar \x1a + set l [string length [chan read $f]] + set e [chan eof $f] + chan close $f + list $s $l $e +} {11 8 1} +test chan-io-35.12 {Tcl_Eof, eof char in middle, lf write, auto read} { + file delete $path(test1) + set f [open $path(test1) w] + chan configure $f -translation lf -eofchar {} + set i [format abc\ndef\n%cqrs\nuvw 26] + chan puts $f $i + chan close $f + set c [file size $path(test1)] + set f [open $path(test1) r] + chan configure $f -translation auto -eofchar \x1a + set l [string length [chan read $f]] + set e [chan eof $f] + chan close $f + list $c $l $e +} {17 8 1} +test chan-io-35.13 {Tcl_Eof, eof char in middle, lf write, lf read} { + file delete $path(test1) + set f [open $path(test1) w] + chan configure $f -translation lf -eofchar {} + set i [format abc\ndef\n%cqrs\nuvw 26] + chan puts $f $i + chan close $f + set c [file size $path(test1)] + set f [open $path(test1) r] + chan configure $f -translation lf -eofchar \x1a + set l [string length [chan read $f]] + set e [chan eof $f] + chan close $f + list $c $l $e +} {17 8 1} +test chan-io-35.14 {Tcl_Eof, eof char in middle, cr write, auto read} { + file delete $path(test1) + set f [open $path(test1) w] + chan configure $f -translation cr -eofchar {} + set i [format abc\ndef\n%cqrs\nuvw 26] + chan puts $f $i + chan close $f + set c [file size $path(test1)] + set f [open $path(test1) r] + chan configure $f -translation auto -eofchar \x1a + set l [string length [chan read $f]] + set e [chan eof $f] + chan close $f + list $c $l $e +} {17 8 1} +test chan-io-35.15 {Tcl_Eof, eof char in middle, cr write, cr read} { + file delete $path(test1) + set f [open $path(test1) w] + chan configure $f -translation cr -eofchar {} + set i [format abc\ndef\n%cqrs\nuvw 26] + chan puts $f $i + chan close $f + set c [file size $path(test1)] + set f [open $path(test1) r] + chan configure $f -translation cr -eofchar \x1a + set l [string length [chan read $f]] + set e [chan eof $f] + chan close $f + list $c $l $e +} {17 8 1} +test chan-io-35.16 {Tcl_Eof, eof char in middle, crlf write, auto read} { + file delete $path(test1) + set f [open $path(test1) w] + chan configure $f -translation crlf -eofchar {} + set i [format abc\ndef\n%cqrs\nuvw 26] + chan puts $f $i + chan close $f + set c [file size $path(test1)] + set f [open $path(test1) r] + chan configure $f -translation auto -eofchar \x1a + set l [string length [chan read $f]] + set e [chan eof $f] + chan close $f + list $c $l $e +} {21 8 1} +test chan-io-35.17 {Tcl_Eof, eof char in middle, crlf write, crlf read} { + file delete $path(test1) + set f [open $path(test1) w] + chan configure $f -translation crlf -eofchar {} + set i [format abc\ndef\n%cqrs\nuvw 26] + chan puts $f $i + chan close $f + set c [file size $path(test1)] + set f [open $path(test1) r] + chan configure $f -translation crlf -eofchar \x1a + set l [string length [chan read $f]] + set e [chan eof $f] + chan close $f + list $c $l $e +} {21 8 1} + +# Test Tcl_InputBlocked + +test chan-io-36.1 {Tcl_InputBlocked on nonblocking pipe} {stdio openpipe} { + set f1 [open "|[list [interpreter]]" r+] + chan puts $f1 {chan puts hello_from_pipe} + chan flush $f1 + chan gets $f1 + chan configure $f1 -blocking off -buffering full + chan puts $f1 {chan puts hello} + set x "" + lappend x [chan gets $f1] + lappend x [chan blocked $f1] + chan flush $f1 + after 200 + lappend x [chan gets $f1] + lappend x [chan blocked $f1] + lappend x [chan gets $f1] + lappend x [chan blocked $f1] + chan close $f1 + set x +} {{} 1 hello 0 {} 1} +test chan-io-36.2 {Tcl_InputBlocked on blocking pipe} {stdio openpipe} { + set f1 [open "|[list [interpreter]]" r+] + chan configure $f1 -buffering line + chan puts $f1 {chan puts hello_from_pipe} + set x "" + lappend x [chan gets $f1] + lappend x [chan blocked $f1] + chan puts $f1 {exit} + lappend x [chan gets $f1] + lappend x [chan blocked $f1] + lappend x [chan eof $f1] + chan close $f1 + set x +} {hello_from_pipe 0 {} 0 1} +test chan-io-36.3 {Tcl_InputBlocked vs files, short read} { + file delete $path(test1) + set f [open $path(test1) w] + chan puts $f abcdefghijklmnop + chan close $f + set f [open $path(test1) r] + set l "" + lappend l [chan blocked $f] + lappend l [chan read $f 3] + lappend l [chan blocked $f] + lappend l [chan read -nonewline $f] + lappend l [chan blocked $f] + lappend l [chan eof $f] + chan close $f + set l +} {0 abc 0 defghijklmnop 0 1} +test chan-io-36.4 {Tcl_InputBlocked vs files, event driven read} {fileevent} { + proc in {f} { + variable l + variable x + lappend l [chan read $f 3] + if {[chan eof $f]} {lappend l eof; chan close $f; set x done} + } + file delete $path(test1) + set f [open $path(test1) w] + chan puts $f abcdefghijklmnop + chan close $f + set f [open $path(test1) r] + set l "" + chan event $f readable [namespace code [list in $f]] + variable x + vwait [namespace which -variable x] + set l +} {abc def ghi jkl mno {p +} eof} +test chan-io-36.5 {Tcl_InputBlocked vs files, short read, nonblocking} {nonBlockFiles} { + file delete $path(test1) + set f [open $path(test1) w] + chan puts $f abcdefghijklmnop + chan close $f + set f [open $path(test1) r] + chan configure $f -blocking off + set l "" + lappend l [chan blocked $f] + lappend l [chan read $f 3] + lappend l [chan blocked $f] + lappend l [chan read -nonewline $f] + lappend l [chan blocked $f] + lappend l [chan eof $f] + chan close $f + set l +} {0 abc 0 defghijklmnop 0 1} +test chan-io-36.6 {Tcl_InputBlocked vs files, event driven read} {nonBlockFiles fileevent} { + proc in {f} { + variable l + variable x + lappend l [chan read $f 3] + if {[chan eof $f]} {lappend l eof; chan close $f; set x done} + } + file delete $path(test1) + set f [open $path(test1) w] + chan puts $f abcdefghijklmnop + chan close $f + set f [open $path(test1) r] + chan configure $f -blocking off + set l "" + chan event $f readable [namespace code [list in $f]] + variable x + vwait [namespace which -variable x] + set l +} {abc def ghi jkl mno {p +} eof} + +# Test Tcl_InputBuffered + +test chan-io-37.1 {Tcl_InputBuffered} {testchannel} { + set f [open $path(longfile) r] + chan configure $f -buffersize 4096 + chan read $f 3 + set l "" + lappend l [testchannel inputbuffered $f] + lappend l [chan tell $f] + chan close $f + set l +} {4093 3} +test chan-io-37.2 {Tcl_InputBuffered, test input flushing on seek} {testchannel} { + set f [open $path(longfile) r] + chan configure $f -buffersize 4096 + chan read $f 3 + set l "" + lappend l [testchannel inputbuffered $f] + lappend l [chan tell $f] + chan seek $f 0 current + lappend l [testchannel inputbuffered $f] + lappend l [chan tell $f] + chan close $f + set l +} {4093 3 0 3} + +# Test Tcl_SetChannelBufferSize, Tcl_GetChannelBufferSize + +test chan-io-38.1 {Tcl_GetChannelBufferSize, default buffer size} { + set f [open $path(longfile) r] + set s [chan configure $f -buffersize] + chan close $f + set s +} 4096 +test chan-io-38.2 {Tcl_SetChannelBufferSize, Tcl_GetChannelBufferSize} { + set f [open $path(longfile) r] + set l "" + lappend l [chan configure $f -buffersize] + chan configure $f -buffersize 10000 + lappend l [chan configure $f -buffersize] + chan configure $f -buffersize 1 + lappend l [chan configure $f -buffersize] + chan configure $f -buffersize -1 + lappend l [chan configure $f -buffersize] + chan configure $f -buffersize 0 + lappend l [chan configure $f -buffersize] + chan configure $f -buffersize 100000 + lappend l [chan configure $f -buffersize] + chan configure $f -buffersize 10000000 + lappend l [chan configure $f -buffersize] + chan close $f + set l +} {4096 10000 1 1 1 100000 100000} +test chan-io-38.3 {Tcl_SetChannelBufferSize, changing buffersize between reads} { + # This test crashes the interp if Bug #427196 is not fixed + + set chan [open [info script] r] + chan configure $chan -buffersize 10 + set var [chan read $chan 2] + chan configure $chan -buffersize 32 + append var [chan read $chan] + chan close $chan +} {} + +# Test Tcl_SetChannelOption, Tcl_GetChannelOption + +test chan-io-39.1 {Tcl_GetChannelOption} { + file delete $path(test1) + set f1 [open $path(test1) w] + set x [chan configure $f1 -blocking] + chan close $f1 + set x +} 1 +# +# Test 17.2 was removed. +# +test chan-io-39.2 {Tcl_GetChannelOption} { + file delete $path(test1) + set f1 [open $path(test1) w] + set x [chan configure $f1 -buffering] + chan close $f1 + set x +} full +test chan-io-39.3 {Tcl_GetChannelOption} { + file delete $path(test1) + set f1 [open $path(test1) w] + chan configure $f1 -buffering line + set x [chan configure $f1 -buffering] + chan close $f1 + set x +} line +test chan-io-39.4 {Tcl_GetChannelOption, Tcl_SetChannelOption} { + file delete $path(test1) + set f1 [open $path(test1) w] + set l "" + lappend l [chan configure $f1 -buffering] + chan configure $f1 -buffering line + lappend l [chan configure $f1 -buffering] + chan configure $f1 -buffering none + lappend l [chan configure $f1 -buffering] + chan configure $f1 -buffering line + lappend l [chan configure $f1 -buffering] + chan configure $f1 -buffering full + lappend l [chan configure $f1 -buffering] + chan close $f1 + set l +} {full line none line full} +test chan-io-39.5 {Tcl_GetChannelOption, invariance} { + file delete $path(test1) + set f1 [open $path(test1) w] + set l "" + lappend l [chan configure $f1 -buffering] + lappend l [list [catch {chan configure $f1 -buffering green} msg] $msg] + lappend l [chan configure $f1 -buffering] + chan close $f1 + set l +} {full {1 {bad value for -buffering: must be one of full, line, or none}} full} +test chan-io-39.6 {Tcl_SetChannelOption, multiple options} { + file delete $path(test1) + set f1 [open $path(test1) w] + chan configure $f1 -translation lf -buffering line + chan puts $f1 hello + chan puts $f1 bye + set x [file size $path(test1)] + chan close $f1 + set x +} 10 +test chan-io-39.7 {Tcl_SetChannelOption, buffering, translation} { + file delete $path(test1) + set f1 [open $path(test1) w] + chan configure $f1 -translation lf + chan puts $f1 hello + chan puts $f1 bye + set x "" + chan configure $f1 -buffering line + lappend x [file size $path(test1)] + chan puts $f1 really_bye + lappend x [file size $path(test1)] + chan close $f1 + set x +} {0 21} +test chan-io-39.8 {Tcl_SetChannelOption, different buffering options} { + file delete $path(test1) + set f1 [open $path(test1) w] + set l "" + chan configure $f1 -translation lf -buffering none -eofchar {} + chan puts -nonewline $f1 hello + lappend l [file size $path(test1)] + chan puts -nonewline $f1 hello + lappend l [file size $path(test1)] + chan configure $f1 -buffering full + chan puts -nonewline $f1 hello + lappend l [file size $path(test1)] + chan configure $f1 -buffering none + lappend l [file size $path(test1)] + chan puts -nonewline $f1 hello + lappend l [file size $path(test1)] + chan close $f1 + lappend l [file size $path(test1)] + set l +} {5 10 10 10 20 20} +test chan-io-39.9 {Tcl_SetChannelOption, blocking mode} {nonBlockFiles} { + file delete $path(test1) + set f1 [open $path(test1) w] + chan close $f1 + set f1 [open $path(test1) r] + set x "" + lappend x [chan configure $f1 -blocking] + chan configure $f1 -blocking off + lappend x [chan configure $f1 -blocking] + lappend x [chan gets $f1] + lappend x [chan read $f1 1000] + lappend x [chan blocked $f1] + lappend x [chan eof $f1] + chan close $f1 + set x +} {1 0 {} {} 0 1} +test chan-io-39.10 {Tcl_SetChannelOption, blocking mode} {stdio openpipe} { + file delete $path(pipe) + set f1 [open $path(pipe) w] + chan puts $f1 { + chan gets stdin + after 100 + chan puts hi + chan gets stdin + } + chan close $f1 + set x "" + set f1 [open "|[list [interpreter] $path(pipe)]" r+] + chan configure $f1 -blocking off -buffering line + lappend x [chan configure $f1 -blocking] + lappend x [chan gets $f1] + lappend x [chan blocked $f1] + chan configure $f1 -blocking on + chan puts $f1 hello + chan configure $f1 -blocking off + lappend x [chan gets $f1] + lappend x [chan blocked $f1] + chan configure $f1 -blocking on + chan puts $f1 bye + chan configure $f1 -blocking off + lappend x [chan gets $f1] + lappend x [chan blocked $f1] + chan configure $f1 -blocking on + lappend x [chan configure $f1 -blocking] + lappend x [chan gets $f1] + lappend x [chan blocked $f1] + lappend x [chan eof $f1] + lappend x [chan gets $f1] + lappend x [chan eof $f1] + chan close $f1 + set x +} {0 {} 1 {} 1 {} 1 1 hi 0 0 {} 1} +test chan-io-39.11 {Tcl_SetChannelOption, Tcl_GetChannelOption, buffer size} { + file delete $path(test1) + set f [open $path(test1) w] + chan configure $f -buffersize -10 + set x [chan configure $f -buffersize] + chan close $f + set x +} 4096 +test chan-io-39.12 {Tcl_SetChannelOption, Tcl_GetChannelOption buffer size} { + file delete $path(test1) + set f [open $path(test1) w] + chan configure $f -buffersize 10000000 + set x [chan configure $f -buffersize] + chan close $f + set x +} 4096 +test chan-io-39.13 {Tcl_SetChannelOption, Tcl_GetChannelOption, buffer size} { + file delete $path(test1) + set f [open $path(test1) w] + chan configure $f -buffersize 40000 + set x [chan configure $f -buffersize] + chan close $f + set x +} 40000 +test chan-io-39.14 {Tcl_SetChannelOption: -encoding, binary & utf-8} { + file delete $path(test1) + set f [open $path(test1) w] + chan configure $f -encoding {} + chan puts -nonewline $f \xe7\x89\xa6 + chan close $f + set f [open $path(test1) r] + chan configure $f -encoding utf-8 + set x [chan read $f] + chan close $f + set x +} \u7266 +test chan-io-39.15 {Tcl_SetChannelOption: -encoding, binary & utf-8} { + file delete $path(test1) + set f [open $path(test1) w] + chan configure $f -encoding binary + chan puts -nonewline $f \xe7\x89\xa6 + chan close $f + set f [open $path(test1) r] + chan configure $f -encoding utf-8 + set x [chan read $f] + chan close $f + set x +} \u7266 +test chan-io-39.16 {Tcl_SetChannelOption: -encoding, errors} { + file delete $path(test1) + set f [open $path(test1) w] + set result [list [catch {chan configure $f -encoding foobar} msg] $msg] + chan close $f + set result +} {1 {unknown encoding "foobar"}} +test chan-io-39.17 {Tcl_SetChannelOption: -encoding, clearing CHANNEL_NEED_MORE_DATA} {stdio openpipe fileevent} { + set f [open "|[list [interpreter] $path(cat)]" r+] + chan configure $f -encoding binary + chan puts -nonewline $f "\xe7" + chan flush $f + chan configure $f -encoding utf-8 -blocking 0 + variable x {} + chan event $f readable [namespace code { lappend x [chan read $f] }] + vwait [namespace which -variable x] + after 300 [namespace code { lappend x timeout }] + vwait [namespace which -variable x] + chan configure $f -encoding utf-8 + vwait [namespace which -variable x] + after 300 [namespace code { lappend x timeout }] + vwait [namespace which -variable x] + chan configure $f -encoding binary + vwait [namespace which -variable x] + after 300 [namespace code { lappend x timeout }] + vwait [namespace which -variable x] + chan close $f + set x +} "{} timeout {} timeout \xe7 timeout" +test chan-io-39.18 {Tcl_SetChannelOption, setting read mode independently} \ + {socket} { + proc accept {s a p} {chan close $s} + set s1 [socket -server [namespace code accept] -myaddr 127.0.0.1 0] + set port [lindex [chan configure $s1 -sockname] 2] + set s2 [socket 127.0.0.1 $port] + update + chan configure $s2 -translation {auto lf} + set modes [chan configure $s2 -translation] + chan close $s1 + chan close $s2 + set modes +} {auto lf} +test chan-io-39.19 {Tcl_SetChannelOption, setting read mode independently} \ + {socket} { + proc accept {s a p} {chan close $s} + set s1 [socket -server [namespace code accept] -myaddr 127.0.0.1 0] + set port [lindex [chan configure $s1 -sockname] 2] + set s2 [socket 127.0.0.1 $port] + update + chan configure $s2 -translation {auto crlf} + set modes [chan configure $s2 -translation] + chan close $s1 + chan close $s2 + set modes +} {auto crlf} +test chan-io-39.20 {Tcl_SetChannelOption, setting read mode independently} \ + {socket} { + proc accept {s a p} {chan close $s} + set s1 [socket -server [namespace code accept] -myaddr 127.0.0.1 0] + set port [lindex [chan configure $s1 -sockname] 2] + set s2 [socket 127.0.0.1 $port] + update + chan configure $s2 -translation {auto cr} + set modes [chan configure $s2 -translation] + chan close $s1 + chan close $s2 + set modes +} {auto cr} +test chan-io-39.21 {Tcl_SetChannelOption, setting read mode independently} \ + {socket} { + proc accept {s a p} {chan close $s} + set s1 [socket -server [namespace code accept] -myaddr 127.0.0.1 0] + set port [lindex [chan configure $s1 -sockname] 2] + set s2 [socket 127.0.0.1 $port] + update + chan configure $s2 -translation {auto auto} + set modes [chan configure $s2 -translation] + chan close $s1 + chan close $s2 + set modes +} {auto crlf} +test chan-io-39.22 {Tcl_SetChannelOption, invariance} {unix} { + file delete $path(test1) + set f1 [open $path(test1) w+] + set l "" + lappend l [chan configure $f1 -eofchar] + chan configure $f1 -eofchar {ON GO} + lappend l [chan configure $f1 -eofchar] + chan configure $f1 -eofchar D + lappend l [chan configure $f1 -eofchar] + chan close $f1 + set l +} {{{} {}} {O G} {D D}} +test chan-io-39.22a {Tcl_SetChannelOption, invariance} { + file delete $path(test1) + set f1 [open $path(test1) w+] + set l [list] + chan configure $f1 -eofchar {ON GO} + lappend l [chan configure $f1 -eofchar] + chan configure $f1 -eofchar D + lappend l [chan configure $f1 -eofchar] + lappend l [list [catch {chan configure $f1 -eofchar {1 2 3}} msg] $msg] + chan close $f1 + set l +} {{O G} {D D} {1 {bad value for -eofchar: should be a list of zero, one, or two elements}}} +test chan-io-39.23 {Tcl_GetChannelOption, server socket is not readable or + writeable, it should still have valid -eofchar and -translation options } { + set l [list] + set sock [socket -server [namespace code accept] -myaddr 127.0.0.1 0] + lappend l [chan configure $sock -eofchar] [chan configure $sock -translation] + chan close $sock + set l +} {{{}} auto} +test chan-io-39.24 {Tcl_SetChannelOption, server socket is not readable or + writable so we can't change -eofchar or -translation } { + set l [list] + set sock [socket -server [namespace code accept] -myaddr 127.0.0.1 0] + chan configure $sock -eofchar D -translation lf + lappend l [chan configure $sock -eofchar] [chan configure $sock -translation] + chan close $sock + set l +} {{{}} auto} + +test chan-io-40.1 {POSIX open access modes: RDWR} { + file delete $path(test3) + set f [open $path(test3) w] + chan puts $f xyzzy + chan close $f + set f [open $path(test3) RDWR] + chan puts -nonewline $f "ab" + chan seek $f 0 current + set x [chan gets $f] + chan close $f + set f [open $path(test3) r] + lappend x [chan gets $f] + chan close $f + set x +} {zzy abzzy} +test chan-io-40.2 {POSIX open access modes: CREAT} {unix} { + file delete $path(test3) + set f [open $path(test3) {WRONLY CREAT} 0600] + file stat $path(test3) stats + set x [format "0%o" [expr $stats(mode)&0o777]] + chan puts $f "line 1" + chan close $f + set f [open $path(test3) r] + lappend x [chan gets $f] + chan close $f + set x +} {0600 {line 1}} +test chan-io-40.3 {POSIX open access modes: CREAT} {unix umask} { + # This test only works if your umask is 2, like ouster's. + file delete $path(test3) + set f [open $path(test3) {WRONLY CREAT}] + chan close $f + file stat $path(test3) stats + format "0%o" [expr $stats(mode)&0o777] +} [format %04o [expr {0o666 & ~ $umaskValue}]] +test chan-io-40.4 {POSIX open access modes: CREAT} { + file delete $path(test3) + set f [open $path(test3) w] + chan configure $f -eofchar {} + chan puts $f xyzzy + chan close $f + set f [open $path(test3) {WRONLY CREAT}] + chan configure $f -eofchar {} + chan puts -nonewline $f "ab" + chan close $f + set f [open $path(test3) r] + set x [chan gets $f] + chan close $f + set x +} abzzy +test chan-io-40.5 {POSIX open access modes: APPEND} { + file delete $path(test3) + set f [open $path(test3) w] + chan configure $f -translation lf -eofchar {} + chan puts $f xyzzy + chan close $f + set f [open $path(test3) {WRONLY APPEND}] + chan configure $f -translation lf + chan puts $f "new line" + chan seek $f 0 + chan puts $f "abc" + chan close $f + set f [open $path(test3) r] + chan configure $f -translation lf + set x "" + chan seek $f 6 current + lappend x [chan gets $f] + lappend x [chan gets $f] + chan close $f + set x +} {{new line} abc} +test chan-io-40.6 {POSIX open access modes: EXCL} -match regexp -body { + file delete $path(test3) + set f [open $path(test3) w] + chan puts $f xyzzy + chan close $f + open $path(test3) {WRONLY CREAT EXCL} +} -returnCodes error -result {(?i)couldn't open ".*test3": file (already )?exists} +test chan-io-40.7 {POSIX open access modes: EXCL} { + file delete $path(test3) + set f [open $path(test3) {WRONLY CREAT EXCL}] + chan configure $f -eofchar {} + chan puts $f "A test line" + chan close $f + viewFile test3 +} {A test line} +test chan-io-40.8 {POSIX open access modes: TRUNC} { + file delete $path(test3) + set f [open $path(test3) w] + chan puts $f xyzzy + chan close $f + set f [open $path(test3) {WRONLY TRUNC}] + chan puts $f abc + chan close $f + set f [open $path(test3) r] + set x [chan gets $f] + chan close $f + set x +} abc +test chan-io-40.9 {POSIX open access modes: NONBLOCK} {nonPortable unix} { + file delete $path(test3) + set f [open $path(test3) {WRONLY NONBLOCK CREAT}] + chan puts $f "NONBLOCK test" + chan close $f + set f [open $path(test3) r] + set x [chan gets $f] + chan close $f + set x +} {NONBLOCK test} +test chan-io-40.10 {POSIX open access modes: RDONLY} { + set f [open $path(test1) w] + chan puts $f "two lines: this one" + chan puts $f "and this" + chan close $f + set f [open $path(test1) RDONLY] + set x [list [chan gets $f] [catch {chan puts $f Test} msg] $msg] + chan close $f + string compare [string tolower $x] \ + [list {two lines: this one} 1 \ + [format "channel \"%s\" wasn't opened for writing" $f]] +} 0 +test chan-io-40.11 {POSIX open access modes: RDONLY} -match regexp -body { + file delete $path(test3) + open $path(test3) RDONLY +} -returnCodes error -result {(?i)couldn't open ".*test3": no such file or directory} +test chan-io-40.12 {POSIX open access modes: WRONLY} -match regexp -body { + file delete $path(test3) + open $path(test3) WRONLY +} -returnCodes error -result {(?i)couldn't open ".*test3": no such file or directory} +test chan-io-40.13 {POSIX open access modes: WRONLY} { + makeFile xyzzy test3 + set f [open $path(test3) WRONLY] + chan configure $f -eofchar {} + chan puts -nonewline $f "ab" + chan seek $f 0 current + set x [list [catch {chan gets $f} msg] $msg] + chan close $f + lappend x [viewFile test3] + string compare [string tolower $x] \ + [list 1 "channel \"$f\" wasn't opened for reading" abzzy] +} 0 +test chan-io-40.14 {POSIX open access modes: RDWR} -match regexp -body { + file delete $path(test3) + open $path(test3) RDWR +} -returnCodes error -result {(?i)couldn't open ".*test3": no such file or directory} +test chan-io-40.15 {POSIX open access modes: RDWR} { + makeFile xyzzy test3 + set f [open $path(test3) RDWR] + chan puts -nonewline $f "ab" + chan seek $f 0 current + set x [chan gets $f] + chan close $f + lappend x [viewFile test3] +} {zzy abzzy} +test chan-io-40.16 {tilde substitution in open} -constraints makeFileInHome -setup { + makeFile {Some text} _test_ ~ +} -body { + file exists [file join $::env(HOME) _test_] +} -cleanup { + removeFile _test_ ~ +} -result 1 +test chan-io-40.17 {tilde substitution in open} { + set home $::env(HOME) + unset ::env(HOME) + set x [list [catch {open ~/foo} msg] $msg] + set ::env(HOME) $home + set x +} {1 {couldn't find HOME environment variable to expand path}} + +test chan-io-41.1 {Tcl_FileeventCmd: errors} {fileevent} { + list [catch {chan event foo} msg] $msg +} {1 {wrong # args: should be "chan event channelId event ?script?"}} +test chan-io-41.2 {Tcl_FileeventCmd: errors} {fileevent} { + list [catch {chan event foo bar baz q} msg] $msg +} {1 {wrong # args: should be "chan event channelId event ?script?"}} +test chan-io-41.3 {Tcl_FileeventCmd: errors} {fileevent} { + list [catch {chan event gorp readable} msg] $msg +} {1 {can not find channel named "gorp"}} +test chan-io-41.4 {Tcl_FileeventCmd: errors} {fileevent} { + list [catch {chan event gorp writable} msg] $msg +} {1 {can not find channel named "gorp"}} +test chan-io-41.5 {Tcl_FileeventCmd: errors} {fileevent} { + list [catch {chan event gorp who-knows} msg] $msg +} {1 {bad event name "who-knows": must be readable or writable}} + +# +# Test chan event on a file +# + +set path(foo) [makeFile {} foo] +set f [open $path(foo) w+] + +test chan-io-42.1 {Tcl_FileeventCmd: creating, deleting, querying} {fileevent} { + list [chan event $f readable] [chan event $f writable] +} {{} {}} +test chan-io-42.2 {Tcl_FileeventCmd: replacing} {fileevent} { + set result {} + chan event $f r "first script" + lappend result [chan event $f readable] + chan event $f r "new script" + lappend result [chan event $f readable] + chan event $f r "yet another" + lappend result [chan event $f readable] + chan event $f r "" + lappend result [chan event $f readable] +} {{first script} {new script} {yet another} {}} +test chan-io-42.3 {Tcl_FileeventCmd: replacing, with NULL chars in script} {fileevent} { + set result {} + chan event $f r "first scr\0ipt" + lappend result [string length [chan event $f readable]] + chan event $f r "new scr\0ipt" + lappend result [string length [chan event $f readable]] + chan event $f r "yet ano\0ther" + lappend result [string length [chan event $f readable]] + chan event $f r "" + lappend result [chan event $f readable] +} {13 11 12 {}} + + +test chan-io-43.1 {Tcl_FileeventCmd: creating, deleting, querying} {stdio unixExecs fileevent} { + set result {} + chan event $f readable "script 1" + lappend result [chan event $f readable] [chan event $f writable] + chan event $f writable "write script" + lappend result [chan event $f readable] [chan event $f writable] + chan event $f readable {} + lappend result [chan event $f readable] [chan event $f writable] + chan event $f writable {} + lappend result [chan event $f readable] [chan event $f writable] +} {{script 1} {} {script 1} {write script} {} {write script} {} {}} +test chan-io-43.2 {Tcl_FileeventCmd: deleting when many present} -setup { + set f2 [open "|[list cat -u]" r+] + set f3 [open "|[list cat -u]" r+] +} -constraints {stdio unixExecs fileevent openpipe} -body { + set result {} + lappend result [chan event $f r] [chan event $f2 r] [chan event $f3 r] + chan event $f r "chan read f" + chan event $f2 r "chan read f2" + chan event $f3 r "chan read f3" + lappend result [chan event $f r] [chan event $f2 r] [chan event $f3 r] + chan event $f2 r {} + lappend result [chan event $f r] [chan event $f2 r] [chan event $f3 r] + chan event $f3 r {} + lappend result [chan event $f r] [chan event $f2 r] [chan event $f3 r] + chan event $f r {} + lappend result [chan event $f r] [chan event $f2 r] [chan event $f3 r] +} -cleanup { + catch {chan close $f2} + catch {chan close $f3} +} -result {{} {} {} {chan read f} {chan read f2} {chan read f3} {chan read f} {} {chan read f3} {chan read f} {} {} {} {} {}} + +test chan-io-44.1 {FileEventProc procedure: normal read event} -setup { + set f2 [open "|[list cat -u]" r+] + set f3 [open "|[list cat -u]" r+] +} -constraints {stdio unixExecs fileevent openpipe} -body { + chan event $f2 readable [namespace code { + set x [chan gets $f2]; chan event $f2 readable {} + }] + chan puts $f2 text; chan flush $f2 + variable x initial + vwait [namespace which -variable x] + set x +} -cleanup { + catch {chan close $f2} + catch {chan close $f3} +} -result {text} +test chan-io-44.2 {FileEventProc procedure: error in read event} -constraints { + stdio unixExecs fileevent openpipe +} -setup { + set f2 [open "|[list cat -u]" r+] + set f3 [open "|[list cat -u]" r+] + proc myHandler {msg options} { + variable x $msg + } + set handler [interp bgerror {}] + interp bgerror {} [namespace which myHandler] +} -body { + chan event $f2 readable {error bogus} + chan puts $f2 text; chan flush $f2 + variable x initial + vwait [namespace which -variable x] + list $x [chan event $f2 readable] +} -cleanup { + interp bgerror {} $handler + catch {chan close $f2} + catch {chan close $f3} +} -result {bogus {}} +test chan-io-44.3 {FileEventProc procedure: normal write event} -setup { + set f2 [open "|[list cat -u]" r+] + set f3 [open "|[list cat -u]" r+] +} -constraints {stdio unixExecs fileevent openpipe} -body { + chan event $f2 writable [namespace code { + lappend x "triggered" + incr count -1 + if {$count <= 0} { + chan event $f2 writable {} + } + }] + variable x initial + set count 3 + vwait [namespace which -variable x] + vwait [namespace which -variable x] + vwait [namespace which -variable x] + set x +} -cleanup { + catch {chan close $f2} + catch {chan close $f3} +} -result {initial triggered triggered triggered} +test chan-io-44.4 {FileEventProc procedure: eror in write event} -constraints { + stdio unixExecs fileevent openpipe +} -setup { + set f2 [open "|[list cat -u]" r+] + set f3 [open "|[list cat -u]" r+] + proc myHandler {msg options} { + variable x $msg + } + set handler [interp bgerror {}] + interp bgerror {} [namespace which myHandler] +} -body { + chan event $f2 writable {error bad-write} + variable x initial + vwait [namespace which -variable x] + list $x [chan event $f2 writable] +} -cleanup { + interp bgerror {} $handler + catch {chan close $f2} + catch {chan close $f3} +} -result {bad-write {}} +test chan-io-44.5 {FileEventProc procedure: end of file} {stdio unixExecs openpipe fileevent} { + set f4 [open "|[list [interpreter] $path(cat) << foo]" r] + chan event $f4 readable [namespace code { + if {[chan gets $f4 line] < 0} { + lappend x eof + chan event $f4 readable {} + } else { + lappend x $line + } + }] + variable x initial + vwait [namespace which -variable x] + vwait [namespace which -variable x] + chan close $f4 + set x +} {initial foo eof} + +chan close $f +makeFile "foo bar" foo + +test chan-io-45.1 {DeleteFileEvent, cleanup on chan close} {fileevent} { + set f [open $path(foo) r] + chan event $f readable [namespace code { + lappend x "binding triggered: \"[chan gets $f]\"" + chan event $f readable {} + }] + chan close $f + set x initial + after 100 [namespace code { set y done }] + variable y + vwait [namespace which -variable y] + set x +} {initial} +test chan-io-45.2 {DeleteFileEvent, cleanup on chan close} {fileevent} { + set f [open $path(foo) r] + set f2 [open $path(foo) r] + chan event $f readable [namespace code { + lappend x "f triggered: \"[chan gets $f]\"" + chan event $f readable {} + }] + chan event $f2 readable [namespace code { + lappend x "f2 triggered: \"[chan gets $f2]\"" + chan event $f2 readable {} + }] + chan close $f + variable x initial + vwait [namespace which -variable x] + chan close $f2 + set x +} {initial {f2 triggered: "foo bar"}} +test chan-io-45.3 {DeleteFileEvent, cleanup on chan close} {fileevent} { + set f [open $path(foo) r] + set f2 [open $path(foo) r] + set f3 [open $path(foo) r] + chan event $f readable {f script} + chan event $f2 readable {f2 script} + chan event $f3 readable {f3 script} + set x {} + chan close $f2 + lappend x [catch {chan event $f readable} msg] $msg \ + [catch {chan event $f2 readable}] \ + [catch {chan event $f3 readable} msg] $msg + chan close $f3 + lappend x [catch {chan event $f readable} msg] $msg \ + [catch {chan event $f2 readable}] \ + [catch {chan event $f3 readable}] + chan close $f + lappend x [catch {chan event $f readable}] \ + [catch {chan event $f2 readable}] \ + [catch {chan event $f3 readable}] +} {0 {f script} 1 0 {f3 script} 0 {f script} 1 1 1 1 1} + +# Execute these tests only if the "testfevent" command is present. + +test chan-io-46.1 {Tcl event loop vs multiple interpreters} {testfevent fileevent} { + testfevent create + set script "set f \[[list open $path(foo) r]]\n" + append script { + set x "no event" + chan event $f readable [namespace code { + set x "f triggered: [chan gets $f]" + chan event $f readable {} + }] + } + testfevent cmd $script + after 1 ;# We must delay because Windows takes a little time to notice + update + testfevent cmd {chan close $f} + list [testfevent cmd {set x}] [testfevent cmd {info commands after}] +} {{f triggered: foo bar} after} +test chan-io-46.2 {Tcl event loop vs multiple interpreters} testfevent { + testfevent create + testfevent cmd { + variable x 0 + after 100 {set x triggered} + vwait [namespace which -variable x] + set x + } +} {triggered} +test chan-io-46.3 {Tcl event loop vs multiple interpreters} testfevent { + testfevent create + testfevent cmd { + set x 0 + after 10 {lappend x timer} + after 30 + set result $x + update idletasks + lappend result $x + update + lappend result $x + } +} {0 0 {0 timer}} + +test chan-io-47.1 {chan event vs multiple interpreters} {testfevent fileevent} { + set f [open $path(foo) r] + set f2 [open $path(foo) r] + set f3 [open $path(foo) r] + chan event $f readable {script 1} + testfevent create + testfevent share $f2 + testfevent cmd "chan event $f2 readable {script 2}" + chan event $f3 readable {sript 3} + set x {} + lappend x [chan event $f2 readable] + testfevent delete + lappend x [chan event $f readable] [chan event $f2 readable] \ + [chan event $f3 readable] + chan close $f + chan close $f2 + chan close $f3 + set x +} {{} {script 1} {} {sript 3}} +test chan-io-47.2 {deleting chan event on interpreter delete} {testfevent fileevent} { + set f [open $path(foo) r] + set f2 [open $path(foo) r] + set f3 [open $path(foo) r] + set f4 [open $path(foo) r] + chan event $f readable {script 1} + testfevent create + testfevent share $f2 + testfevent share $f3 + testfevent cmd "chan event $f2 readable {script 2} + chan event $f3 readable {script 3}" + chan event $f4 readable {script 4} + testfevent delete + set x [list [chan event $f readable] [chan event $f2 readable] \ + [chan event $f3 readable] [chan event $f4 readable]] + chan close $f + chan close $f2 + chan close $f3 + chan close $f4 + set x +} {{script 1} {} {} {script 4}} +test chan-io-47.3 {deleting chan event on interpreter delete} {testfevent fileevent} { + set f [open $path(foo) r] + set f2 [open $path(foo) r] + set f3 [open $path(foo) r] + set f4 [open $path(foo) r] + testfevent create + testfevent share $f3 + testfevent share $f4 + chan event $f readable {script 1} + chan event $f2 readable {script 2} + testfevent cmd "chan event $f3 readable {script 3} + chan event $f4 readable {script 4}" + testfevent delete + set x [list [chan event $f readable] [chan event $f2 readable] \ + [chan event $f3 readable] [chan event $f4 readable]] + chan close $f + chan close $f2 + chan close $f3 + chan close $f4 + set x +} {{script 1} {script 2} {} {}} +test chan-io-47.4 {file events on shared files and multiple interpreters} {testfevent fileevent} { + set f [open $path(foo) r] + set f2 [open $path(foo) r] + testfevent create + testfevent share $f + testfevent cmd "chan event $f readable {script 1}" + chan event $f readable {script 2} + chan event $f2 readable {script 3} + set x [list [chan event $f2 readable] \ + [testfevent cmd "chan event $f readable"] \ + [chan event $f readable]] + testfevent delete + chan close $f + chan close $f2 + set x +} {{script 3} {script 1} {script 2}} +test chan-io-47.5 {file events on shared files, deleting file events} {testfevent fileevent} { + set f [open $path(foo) r] + testfevent create + testfevent share $f + testfevent cmd "chan event $f readable {script 1}" + chan event $f readable {script 2} + testfevent cmd "chan event $f readable {}" + set x [list [testfevent cmd "chan event $f readable"] \ + [chan event $f readable]] + testfevent delete + chan close $f + set x +} {{} {script 2}} +test chan-io-47.6 {file events on shared files, deleting file events} {testfevent fileevent} { + set f [open $path(foo) r] + testfevent create + testfevent share $f + testfevent cmd "chan event $f readable {script 1}" + chan event $f readable {script 2} + chan event $f readable {} + set x [list [testfevent cmd "chan event $f readable"] \ + [chan event $f readable]] + testfevent delete + chan close $f + set x +} {{script 1} {}} + +set path(bar) [makeFile {} bar] + +test chan-io-48.1 {testing readability conditions} {fileevent} { + set f [open $path(bar) w] + chan puts $f abcdefg + chan puts $f abcdefg + chan puts $f abcdefg + chan puts $f abcdefg + chan puts $f abcdefg + chan close $f + set f [open $path(bar) r] + chan event $f readable [namespace code [list consume $f]] + proc consume {f} { + variable l + variable x + lappend l called + if {[chan eof $f]} { + chan close $f + set x done + } else { + chan gets $f + } + } + set l "" + variable x not_done + vwait [namespace which -variable x] + list $x $l +} {done {called called called called called called called}} +test chan-io-48.2 {testing readability conditions} {nonBlockFiles fileevent} { + set f [open $path(bar) w] + chan puts $f abcdefg + chan puts $f abcdefg + chan puts $f abcdefg + chan puts $f abcdefg + chan puts $f abcdefg + chan close $f + set f [open $path(bar) r] + chan event $f readable [namespace code [list consume $f]] + chan configure $f -blocking off + proc consume {f} { + variable x + variable l + lappend l called + if {[chan eof $f]} { + chan close $f + set x done + } else { + chan gets $f + } + } + set l "" + variable x not_done + vwait [namespace which -variable x] + list $x $l +} {done {called called called called called called called}} +set path(my_script) [makeFile {} my_script] +test chan-io-48.3 {testing readability conditions} {stdio unix nonBlockFiles openpipe fileevent} { + set f [open $path(bar) w] + chan puts $f abcdefg + chan puts $f abcdefg + chan puts $f abcdefg + chan puts $f abcdefg + chan puts $f abcdefg + chan close $f + set f [open $path(my_script) w] + chan puts $f { + proc copy_slowly {f} { + while {![chan eof $f]} { + chan puts [chan gets $f] + after 200 + } + chan close $f + } + } + chan close $f + set f [open "|[list [interpreter]]" r+] + chan event $f readable [namespace code [list consume $f]] + chan configure $f -buffering line + chan configure $f -blocking off + proc consume {f} { + variable l + variable x + if {[chan eof $f]} { + set x done + } else { + chan gets $f + lappend l [chan blocked $f] + chan gets $f + lappend l [chan blocked $f] + } + } + set l "" + variable x not_done + chan puts $f [list source $path(my_script)] + chan puts $f "set f \[[list open $path(bar) r]]" + chan puts $f {copy_slowly $f} + chan puts $f {exit} + vwait [namespace which -variable x] + chan close $f + list $x $l +} {done {0 1 0 1 0 1 0 1 0 1 0 1 0 0}} +test chan-io-48.4 {lf write, testing readability, ^Z termination, auto read mode} {fileevent} { + file delete $path(test1) + set f [open $path(test1) w] + chan configure $f -translation lf + variable c [format "abc\ndef\n%c" 26] + chan puts -nonewline $f $c + chan close $f + proc consume {f} { + variable l + variable c + variable x + if {[chan eof $f]} { + set x done + chan close $f + } else { + lappend l [chan gets $f] + incr c + } + } + set c 0 + set l "" + set f [open $path(test1) r] + chan configure $f -translation auto -eofchar \x1a + chan event $f readable [namespace code [list consume $f]] + variable x + vwait [namespace which -variable x] + list $c $l +} {3 {abc def {}}} +test chan-io-48.5 {lf write, testing readability, ^Z in middle, auto read mode} {fileevent} { + file delete $path(test1) + set f [open $path(test1) w] + chan configure $f -translation lf + set c [format "abc\ndef\n%cfoo\nbar\n" 26] + chan puts -nonewline $f $c + chan close $f + proc consume {f} { + variable l + variable x + variable c + if {[chan eof $f]} { + set x done + chan close $f + } else { + lappend l [chan gets $f] + incr c + } + } + set c 0 + set l "" + set f [open $path(test1) r] + chan configure $f -eofchar \x1a -translation auto + chan event $f readable [namespace code [list consume $f]] + variable x + vwait [namespace which -variable x] + list $c $l +} {3 {abc def {}}} +test chan-io-48.6 {cr write, testing readability, ^Z termination, auto read mode} {fileevent} { + file delete $path(test1) + set f [open $path(test1) w] + chan configure $f -translation cr + set c [format "abc\ndef\n%c" 26] + chan puts -nonewline $f $c + chan close $f + proc consume {f} { + variable l + variable x + variable c + if {[chan eof $f]} { + set x done + chan close $f + } else { + lappend l [chan gets $f] + incr c + } + } + set c 0 + set l "" + set f [open $path(test1) r] + chan configure $f -translation auto -eofchar \x1a + chan event $f readable [namespace code [list consume $f]] + variable x + vwait [namespace which -variable x] + list $c $l +} {3 {abc def {}}} +test chan-io-48.7 {cr write, testing readability, ^Z in middle, auto read mode} {fileevent} { + file delete $path(test1) + set f [open $path(test1) w] + chan configure $f -translation cr + set c [format "abc\ndef\n%cfoo\nbar\n" 26] + chan puts -nonewline $f $c + chan close $f + proc consume {f} { + variable l + variable c + variable x + if {[chan eof $f]} { + set x done + chan close $f + } else { + lappend l [chan gets $f] + incr c + } + } + set c 0 + set l "" + set f [open $path(test1) r] + chan configure $f -eofchar \x1a -translation auto + chan event $f readable [namespace code [list consume $f]] + variable x + vwait [namespace which -variable x] + list $c $l +} {3 {abc def {}}} +test chan-io-48.8 {crlf write, testing readability, ^Z termination, auto read mode} {fileevent} { + file delete $path(test1) + set f [open $path(test1) w] + chan configure $f -translation crlf + set c [format "abc\ndef\n%c" 26] + chan puts -nonewline $f $c + chan close $f + proc consume {f} { + variable l + variable x + variable c + if {[chan eof $f]} { + set x done + chan close $f + } else { + lappend l [chan gets $f] + incr c + } + } + set c 0 + set l "" + set f [open $path(test1) r] + chan configure $f -translation auto -eofchar \x1a + chan event $f readable [namespace code [list consume $f]] + variable x + vwait [namespace which -variable x] + list $c $l +} {3 {abc def {}}} +test chan-io-48.9 {crlf write, testing readability, ^Z in middle, auto read mode} {fileevent} { + file delete $path(test1) + set f [open $path(test1) w] + chan configure $f -translation crlf + set c [format "abc\ndef\n%cfoo\nbar\n" 26] + chan puts -nonewline $f $c + chan close $f + proc consume {f} { + variable l + variable c + variable x + if {[chan eof $f]} { + set x done + chan close $f + } else { + lappend l [chan gets $f] + incr c + } + } + set c 0 + set l "" + set f [open $path(test1) r] + chan configure $f -eofchar \x1a -translation auto + chan event $f readable [namespace code [list consume $f]] + variable x + vwait [namespace which -variable x] + list $c $l +} {3 {abc def {}}} +test chan-io-48.10 {lf write, testing readability, ^Z in middle, lf read mode} {fileevent} { + file delete $path(test1) + set f [open $path(test1) w] + chan configure $f -translation lf + set c [format "abc\ndef\n%cfoo\nbar\n" 26] + chan puts -nonewline $f $c + chan close $f + proc consume {f} { + variable l + variable c + variable x + if {[chan eof $f]} { + set x done + chan close $f + } else { + lappend l [chan gets $f] + incr c + } + } + set c 0 + set l "" + set f [open $path(test1) r] + chan configure $f -eofchar \x1a -translation lf + chan event $f readable [namespace code [list consume $f]] + variable x + vwait [namespace which -variable x] + list $c $l +} {3 {abc def {}}} +test chan-io-48.11 {lf write, testing readability, ^Z termination, lf read mode} {fileevent} { + file delete $path(test1) + set f [open $path(test1) w] + chan configure $f -translation lf + set c [format "abc\ndef\n%c" 26] + chan puts -nonewline $f $c + chan close $f + proc consume {f} { + variable l + variable x + variable c + if {[chan eof $f]} { + set x done + chan close $f + } else { + lappend l [chan gets $f] + incr c + } + } + set c 0 + set l "" + set f [open $path(test1) r] + chan configure $f -translation lf -eofchar \x1a + chan event $f readable [namespace code [list consume $f]] + variable x + vwait [namespace which -variable x] + list $c $l +} {3 {abc def {}}} +test chan-io-48.12 {cr write, testing readability, ^Z in middle, cr read mode} {fileevent} { + file delete $path(test1) + set f [open $path(test1) w] + chan configure $f -translation cr + set c [format "abc\ndef\n%cfoo\nbar\n" 26] + chan puts -nonewline $f $c + chan close $f + proc consume {f} { + variable l + variable x + variable c + if {[chan eof $f]} { + set x done + chan close $f + } else { + lappend l [chan gets $f] + incr c + } + } + set c 0 + set l "" + set f [open $path(test1) r] + chan configure $f -eofchar \x1a -translation cr + chan event $f readable [namespace code [list consume $f]] + variable x + vwait [namespace which -variable x] + list $c $l +} {3 {abc def {}}} +test chan-io-48.13 {cr write, testing readability, ^Z termination, cr read mode} {fileevent} { + file delete $path(test1) + set f [open $path(test1) w] + chan configure $f -translation cr + set c [format "abc\ndef\n%c" 26] + chan puts -nonewline $f $c + chan close $f + proc consume {f} { + variable c + variable x + variable l + if {[chan eof $f]} { + set x done + chan close $f + } else { + lappend l [chan gets $f] + incr c + } + } + set c 0 + set l "" + set f [open $path(test1) r] + chan configure $f -translation cr -eofchar \x1a + chan event $f readable [namespace code [list consume $f]] + variable x + vwait [namespace which -variable x] + list $c $l +} {3 {abc def {}}} +test chan-io-48.14 {crlf write, testing readability, ^Z in middle, crlf read mode} {fileevent} { + file delete $path(test1) + set f [open $path(test1) w] + chan configure $f -translation crlf + set c [format "abc\ndef\n%cfoo\nbar\n" 26] + chan puts -nonewline $f $c + chan close $f + proc consume {f} { + variable c + variable x + variable l + if {[chan eof $f]} { + set x done + chan close $f + } else { + lappend l [chan gets $f] + incr c + } + } + set c 0 + set l "" + set f [open $path(test1) r] + chan configure $f -eofchar \x1a -translation crlf + chan event $f readable [namespace code [list consume $f]] + variable x + vwait [namespace which -variable x] + list $c $l +} {3 {abc def {}}} +test chan-io-48.15 {crlf write, testing readability, ^Z termi, crlf read mode} {fileevent} { + file delete $path(test1) + set f [open $path(test1) w] + chan configure $f -translation crlf + set c [format "abc\ndef\n%c" 26] + chan puts -nonewline $f $c + chan close $f + proc consume {f} { + variable c + variable x + variable l + if {[chan eof $f]} { + set x done + chan close $f + } else { + lappend l [chan gets $f] + incr c + } + } + set c 0 + set l "" + set f [open $path(test1) r] + chan configure $f -translation crlf -eofchar \x1a + chan event $f readable [namespace code [list consume $f]] + variable x + vwait [namespace which -variable x] + list $c $l +} {3 {abc def {}}} + +test chan-io-49.1 {testing crlf reading, leftover cr disgorgment} { + file delete $path(test1) + set f [open $path(test1) w] + chan configure $f -translation lf + chan puts -nonewline $f "a\rb\rc\r\n" + chan close $f + set f [open $path(test1) r] + set l "" + lappend l [file size $path(test1)] + chan configure $f -translation crlf + lappend l [chan read $f 1] + lappend l [chan tell $f] + lappend l [chan read $f 1] + lappend l [chan tell $f] + lappend l [chan read $f 1] + lappend l [chan tell $f] + lappend l [chan read $f 1] + lappend l [chan tell $f] + lappend l [chan read $f 1] + lappend l [chan tell $f] + lappend l [chan read $f 1] + lappend l [chan tell $f] + lappend l [chan eof $f] + lappend l [chan read $f 1] + lappend l [chan eof $f] + chan close $f + set l +} "7 a 1 [list \r] 2 b 3 [list \r] 4 c 5 { +} 7 0 {} 1" +test chan-io-49.2 {testing crlf reading, leftover cr disgorgment} { + file delete $path(test1) + set f [open $path(test1) w] + chan configure $f -translation lf + chan puts -nonewline $f "a\rb\rc\r\n" + chan close $f + set f [open $path(test1) r] + set l "" + lappend l [file size $path(test1)] + chan configure $f -translation crlf + lappend l [chan read $f 2] + lappend l [chan tell $f] + lappend l [chan read $f 2] + lappend l [chan tell $f] + lappend l [chan read $f 2] + lappend l [chan tell $f] + lappend l [chan eof $f] + lappend l [chan read $f 2] + lappend l [chan tell $f] + lappend l [chan eof $f] + chan close $f + set l +} "7 [list a\r] 2 [list b\r] 4 [list c\n] 7 0 {} 7 1" +test chan-io-49.3 {testing crlf reading, leftover cr disgorgment} { + file delete $path(test1) + set f [open $path(test1) w] + chan configure $f -translation lf + chan puts -nonewline $f "a\rb\rc\r\n" + chan close $f + set f [open $path(test1) r] + set l "" + lappend l [file size $path(test1)] + chan configure $f -translation crlf + lappend l [chan read $f 3] + lappend l [chan tell $f] + lappend l [chan read $f 3] + lappend l [chan tell $f] + lappend l [chan eof $f] + lappend l [chan read $f 3] + lappend l [chan tell $f] + lappend l [chan eof $f] + chan close $f + set l +} "7 [list a\rb] 3 [list \rc\n] 7 0 {} 7 1" +test chan-io-49.4 {testing crlf reading, leftover cr disgorgment} { + file delete $path(test1) + set f [open $path(test1) w] + chan configure $f -translation lf + chan puts -nonewline $f "a\rb\rc\r\n" + chan close $f + set f [open $path(test1) r] + set l "" + lappend l [file size $path(test1)] + chan configure $f -translation crlf + lappend l [chan read $f 3] + lappend l [chan tell $f] + lappend l [chan gets $f] + lappend l [chan tell $f] + lappend l [chan eof $f] + lappend l [chan gets $f] + lappend l [chan tell $f] + lappend l [chan eof $f] + chan close $f + set l +} "7 [list a\rb] 3 [list \rc] 7 0 {} 7 1" +test chan-io-49.5 {testing crlf reading, leftover cr disgorgment} { + file delete $path(test1) + set f [open $path(test1) w] + chan configure $f -translation lf + chan puts -nonewline $f "a\rb\rc\r\n" + chan close $f + set f [open $path(test1) r] + set l "" + lappend l [file size $path(test1)] + chan configure $f -translation crlf + lappend l [set x [chan gets $f]] + lappend l [chan tell $f] + lappend l [chan gets $f] + lappend l [chan tell $f] + lappend l [chan eof $f] + chan close $f + set l +} [list 7 a\rb\rc 7 {} 7 1] + +test chan-io-50.1 {testing handler deletion} {testchannelevent} { + file delete $path(test1) + set f [open $path(test1) w] + chan close $f + set f [open $path(test1) r] + testchannelevent $f add readable [namespace code [list delhandler $f]] + proc delhandler {f} { + variable z + set z called + testchannelevent $f delete 0 + } + set z not_called + update + chan close $f + set z +} called +test chan-io-50.2 {testing handler deletion with multiple handlers} {testchannelevent} { + file delete $path(test1) + set f [open $path(test1) w] + chan close $f + set f [open $path(test1) r] + testchannelevent $f add readable [namespace code [list delhandler $f 1]] + testchannelevent $f add readable [namespace code [list delhandler $f 0]] + proc delhandler {f i} { + variable z + lappend z "called delhandler $f $i" + testchannelevent $f delete 0 + } + set z "" + update + chan close $f + string compare [string tolower $z] \ + [list [list called delhandler $f 0] [list called delhandler $f 1]] +} 0 +test chan-io-50.3 {testing handler deletion with multiple handlers} {testchannelevent} { + file delete $path(test1) + set f [open $path(test1) w] + chan close $f + set f [open $path(test1) r] + testchannelevent $f add readable [namespace code [list notcalled $f 1]] + testchannelevent $f add readable [namespace code [list delhandler $f 0]] + set z "" + proc notcalled {f i} { + variable z + lappend z "notcalled was called!! $f $i" + } + proc delhandler {f i} { + variable z + testchannelevent $f delete 1 + lappend z "delhandler $f $i called" + testchannelevent $f delete 0 + lappend z "delhandler $f $i deleted myself" + } + set z "" + update + chan close $f + string compare [string tolower $z] \ + [list [list delhandler $f 0 called] \ + [list delhandler $f 0 deleted myself]] +} 0 +test chan-io-50.4 {testing handler deletion vs reentrant calls} {testchannelevent} { + file delete $path(test1) + set f [open $path(test1) w] + chan close $f + set f [open $path(test1) r] + testchannelevent $f add readable [namespace code [list delrecursive $f]] + proc delrecursive {f} { + variable z + variable u + if {"$u" == "recursive"} { + testchannelevent $f delete 0 + lappend z "delrecursive deleting recursive" + } else { + lappend z "delrecursive calling recursive" + set u recursive + update + } + } + variable u toplevel + variable z "" + update + chan close $f + string compare [string tolower $z] \ + {{delrecursive calling recursive} {delrecursive deleting recursive}} +} 0 +test chan-io-50.5 {testing handler deletion vs reentrant calls} {testchannelevent} { + file delete $path(test1) + set f [open $path(test1) w] + chan close $f + set f [open $path(test1) r] + testchannelevent $f add readable [namespace code [list notcalled $f]] + testchannelevent $f add readable [namespace code [list del $f]] + proc notcalled {f} { + variable z + lappend z "notcalled was called!! $f" + } + proc del {f} { + variable u + variable z + if {"$u" == "recursive"} { + testchannelevent $f delete 1 + testchannelevent $f delete 0 + lappend z "del deleted notcalled" + lappend z "del deleted myself" + } else { + set u recursive + lappend z "del calling recursive" + update + lappend z "del after update" + } + } + set z "" + set u toplevel + update + chan close $f + string compare [string tolower $z] \ + [list {del calling recursive} {del deleted notcalled} \ + {del deleted myself} {del after update}] +} 0 +test chan-io-50.6 {testing handler deletion vs reentrant calls} {testchannelevent} { + file delete $path(test1) + set f [open $path(test1) w] + chan close $f + set f [open $path(test1) r] + testchannelevent $f add readable [namespace code [list second $f]] + testchannelevent $f add readable [namespace code [list first $f]] + proc first {f} { + variable u + variable z + if {"$u" == "toplevel"} { + lappend z "first called" + set u first + update + lappend z "first after update" + } else { + lappend z "first called not toplevel" + } + } + proc second {f} { + variable u + variable z + if {"$u" == "first"} { + lappend z "second called, first time" + set u second + testchannelevent $f delete 0 + } elseif {"$u" == "second"} { + lappend z "second called, second time" + testchannelevent $f delete 0 + } else { + lappend z "second called, cannot happen!" + testchannelevent $f removeall + } + } + set z "" + set u toplevel + update + chan close $f + string compare [string tolower $z] \ + [list {first called} {first called not toplevel} \ + {second called, first time} {second called, second time} \ + {first after update}] +} 0 + +test chan-io-51.1 {Test old socket deletion on Macintosh} {socket} { + set x 0 + set result "" + proc accept {s a p} { + variable x + variable wait + chan configure $s -blocking off + chan puts $s "sock[incr x]" + chan close $s + set wait done + } + set ss [socket -server [namespace code accept] -myaddr 127.0.0.1 0] + set port [lindex [chan configure $ss -sockname] 2] + + variable wait "" + set cs [socket 127.0.0.1 $port] + vwait [namespace which -variable wait] + lappend result [chan gets $cs] + chan close $cs + + set wait "" + set cs [socket 127.0.0.1 $port] + vwait [namespace which -variable wait] + lappend result [chan gets $cs] + chan close $cs + + set wait "" + set cs [socket 127.0.0.1 $port] + vwait [namespace which -variable wait] + lappend result [chan gets $cs] + chan close $cs + + set wait "" + set cs [socket 127.0.0.1 $port] + vwait [namespace which -variable wait] + lappend result [chan gets $cs] + chan close $cs + chan close $ss + set result +} {sock1 sock2 sock3 sock4} + +test chan-io-52.1 {TclCopyChannel} {fcopy} { + file delete $path(test1) + set f1 [open $thisScript] + set f2 [open $path(test1) w] + chan copy $f1 $f2 -command { # } + catch { chan copy $f1 $f2 } msg + chan close $f1 + chan close $f2 + string compare $msg "channel \"$f1\" is busy" +} {0} +test chan-io-52.2 {TclCopyChannel} {fcopy} { + file delete $path(test1) + set f1 [open $thisScript] + set f2 [open $path(test1) w] + set f3 [open $thisScript] + chan copy $f1 $f2 -command { # } + catch { chan copy $f3 $f2 } msg + chan close $f1 + chan close $f2 + chan close $f3 + string compare $msg "channel \"$f2\" is busy" +} {0} +test chan-io-52.3 {TclCopyChannel} {fcopy} { + file delete $path(test1) + set f1 [open $thisScript] + set f2 [open $path(test1) w] + chan configure $f1 -translation lf -blocking 0 + chan configure $f2 -translation cr -blocking 0 + set s0 [chan copy $f1 $f2] + set result [list [chan configure $f1 -blocking] [chan configure $f2 -blocking]] + chan close $f1 + chan close $f2 + set s1 [file size $thisScript] + set s2 [file size $path(test1)] + if {("$s1" == "$s2") && ($s0 == $s1)} { + lappend result ok + } + set result +} {0 0 ok} +test chan-io-52.4 {TclCopyChannel} {fcopy} { + file delete $path(test1) + set f1 [open $thisScript] + set f2 [open $path(test1) w] + chan configure $f1 -translation lf -blocking 0 + chan configure $f2 -translation cr -blocking 0 + chan copy $f1 $f2 -size 40 + set result [list [chan configure $f1 -blocking] [chan configure $f2 -blocking]] + chan close $f1 + chan close $f2 + lappend result [file size $path(test1)] +} {0 0 40} +test chan-io-52.5 {TclCopyChannel} {fcopy} { + file delete $path(test1) + set f1 [open $thisScript] + set f2 [open $path(test1) w] + chan configure $f1 -translation lf -blocking 0 + chan configure $f2 -translation lf -blocking 0 + chan copy $f1 $f2 -size -1 + set result [list [chan configure $f1 -blocking] [chan configure $f2 -blocking]] + chan close $f1 + chan close $f2 + set s1 [file size $thisScript] + set s2 [file size $path(test1)] + if {"$s1" == "$s2"} { + lappend result ok + } + set result +} {0 0 ok} +test chan-io-52.6 {TclCopyChannel} {fcopy} { + file delete $path(test1) + set f1 [open $thisScript] + set f2 [open $path(test1) w] + chan configure $f1 -translation lf -blocking 0 + chan configure $f2 -translation lf -blocking 0 + set s0 [chan copy $f1 $f2 -size [expr [file size $thisScript] + 5]] + set result [list [chan configure $f1 -blocking] [chan configure $f2 -blocking]] + chan close $f1 + chan close $f2 + set s1 [file size $thisScript] + set s2 [file size $path(test1)] + if {("$s1" == "$s2") && ($s0 == $s1)} { + lappend result ok + } + set result +} {0 0 ok} +test chan-io-52.7 {TclCopyChannel} {fcopy} { + file delete $path(test1) + set f1 [open $thisScript] + set f2 [open $path(test1) w] + chan configure $f1 -translation lf -blocking 0 + chan configure $f2 -translation lf -blocking 0 + chan copy $f1 $f2 + set result [list [chan configure $f1 -blocking] [chan configure $f2 -blocking]] + set s1 [file size $thisScript] + set s2 [file size $path(test1)] + chan close $f1 + chan close $f2 + if {"$s1" == "$s2"} { + lappend result ok + } + set result +} {0 0 ok} +test chan-io-52.8 {TclCopyChannel} {stdio openpipe fcopy} { + file delete $path(test1) + file delete $path(pipe) + set f1 [open $path(pipe) w] + chan configure $f1 -translation lf + chan puts $f1 " + chan puts ready + chan gets stdin + set f1 \[open [list $thisScript] r\] + chan configure \$f1 -translation lf + chan puts \[chan read \$f1 100\] + chan close \$f1 + " + chan close $f1 + set f1 [open "|[list [interpreter] $path(pipe)]" r+] + chan configure $f1 -translation lf + chan gets $f1 + chan puts $f1 ready + chan flush $f1 + set f2 [open $path(test1) w] + chan configure $f2 -translation lf + set s0 [chan copy $f1 $f2 -size 40] + catch {chan close $f1} + chan close $f2 + list $s0 [file size $path(test1)] +} {40 40} +# Empty files, to register them with the test facility +set path(kyrillic.txt) [makeFile {} kyrillic.txt] +set path(utf8-fcopy.txt) [makeFile {} utf8-fcopy.txt] +set path(utf8-rp.txt) [makeFile {} utf8-rp.txt] +# Create kyrillic file, use lf translation to avoid os eol issues +set out [open $path(kyrillic.txt) w] +chan configure $out -encoding koi8-r -translation lf +chan puts $out "\u0410\u0410" +chan close $out +test chan-io-52.9 {TclCopyChannel & encodings} {fcopy} { + # Copy kyrillic to UTF-8, using chan copy. + + set in [open $path(kyrillic.txt) r] + set out [open $path(utf8-fcopy.txt) w] + + chan configure $in -encoding koi8-r -translation lf + chan configure $out -encoding utf-8 -translation lf + + chan copy $in $out + chan close $in + chan close $out + + # Do the same again, but differently (read/chan puts). + + set in [open $path(kyrillic.txt) r] + set out [open $path(utf8-rp.txt) w] + + chan configure $in -encoding koi8-r -translation lf + chan configure $out -encoding utf-8 -translation lf + + chan puts -nonewline $out [chan read $in] + + chan close $in + chan close $out + + list [file size $path(kyrillic.txt)] \ + [file size $path(utf8-fcopy.txt)] \ + [file size $path(utf8-rp.txt)] +} {3 5 5} +test chan-io-52.10 {TclCopyChannel & encodings} {fcopy} { + # encoding to binary (=> implies that the + # internal utf-8 is written) + + set in [open $path(kyrillic.txt) r] + set out [open $path(utf8-fcopy.txt) w] + + chan configure $in -encoding koi8-r -translation lf + # -translation binary is also -encoding binary + chan configure $out -translation binary + + chan copy $in $out + chan close $in + chan close $out + + file size $path(utf8-fcopy.txt) +} 5 +test chan-io-52.11 {TclCopyChannel & encodings} {fcopy} { + # binary to encoding => the input has to be + # in utf-8 to make sense to the encoder + + set in [open $path(utf8-fcopy.txt) r] + set out [open $path(kyrillic.txt) w] + + # -translation binary is also -encoding binary + chan configure $in -translation binary + chan configure $out -encoding koi8-r -translation lf + + chan copy $in $out + chan close $in + chan close $out + + file size $path(kyrillic.txt) +} 3 + +test chan-io-53.1 {CopyData} {fcopy} { + file delete $path(test1) + set f1 [open $thisScript] + set f2 [open $path(test1) w] + chan configure $f1 -translation lf -blocking 0 + chan configure $f2 -translation cr -blocking 0 + chan copy $f1 $f2 -size 0 + set result [list [chan configure $f1 -blocking] [chan configure $f2 -blocking]] + chan close $f1 + chan close $f2 + lappend result [file size $path(test1)] +} {0 0 0} +test chan-io-53.2 {CopyData} {fcopy} { + file delete $path(test1) + set f1 [open $thisScript] + set f2 [open $path(test1) w] + chan configure $f1 -translation lf -blocking 0 + chan configure $f2 -translation cr -blocking 0 + chan copy $f1 $f2 -command [namespace code {set s0}] + set result [list [chan configure $f1 -blocking] [chan configure $f2 -blocking]] + variable s0 + vwait [namespace which -variable s0] + chan close $f1 + chan close $f2 + set s1 [file size $thisScript] + set s2 [file size $path(test1)] + if {("$s1" == "$s2") && ($s0 == $s1)} { + lappend result ok + } + set result +} {0 0 ok} +test chan-io-53.3 {CopyData: background read underflow} {stdio unix openpipe fcopy} { + file delete $path(test1) + file delete $path(pipe) + set f1 [open $path(pipe) w] + chan puts -nonewline $f1 { + chan puts ready + chan flush stdout ;# Don't assume line buffered! + chan copy stdin stdout -command { set x } + vwait x + set f [} + chan puts $f1 [list open $path(test1) w]] + chan puts $f1 { + chan configure $f -translation lf + chan puts $f "done" + chan close $f + } + chan close $f1 + set f1 [open "|[list [interpreter] $path(pipe)]" r+] + set result [chan gets $f1] + chan puts $f1 line1 + chan flush $f1 + lappend result [chan gets $f1] + chan puts $f1 line2 + chan flush $f1 + lappend result [chan gets $f1] + chan close $f1 + after 500 + set f [open $path(test1)] + lappend result [chan read $f] + chan close $f + set result +} "ready line1 line2 {done\n}" +test chan-io-53.4 {CopyData: background write overflow} {stdio unix openpipe fileevent fcopy} { + set big bbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbb\n + variable x + for {set x 0} {$x < 12} {incr x} { + append big $big + } + file delete $path(test1) + file delete $path(pipe) + set f1 [open $path(pipe) w] + chan puts $f1 { + chan puts ready + chan copy stdin stdout -command { set x } + vwait x + set f [open $path(test1) w] + chan configure $f -translation lf + chan puts $f "done" + chan close $f + } + chan close $f1 + set f1 [open "|[list [interpreter] $path(pipe)]" r+] + set result [chan gets $f1] + chan configure $f1 -blocking 0 + chan puts $f1 $big + chan flush $f1 + after 500 + set result "" + chan event $f1 read [namespace code { + append result [chan read $f1 1024] + if {[string length $result] >= [string length $big]} { + set x done + } + }] + vwait [namespace which -variable x] + chan close $f1 + set big {} + set x +} done +set result {} +proc FcopyTestAccept {sock args} { + after 1000 "chan close $sock" +} +proc FcopyTestDone {bytes {error {}}} { + variable fcopyTestDone + if {[string length $error]} { + set fcopyTestDone 1 + } else { + set fcopyTestDone 0 + } +} +test chan-io-53.5 {CopyData: error during chan copy} {socket fcopy} { + variable fcopyTestDone + set listen [socket -server [namespace code FcopyTestAccept] -myaddr 127.0.0.1 0] + set in [open $thisScript] ;# 126 K + set out [socket 127.0.0.1 [lindex [chan configure $listen -sockname] 2]] + catch {unset fcopyTestDone} + chan close $listen ;# This means the socket open never really succeeds + chan copy $in $out -command [namespace code FcopyTestDone] + variable fcopyTestDone + if ![info exists fcopyTestDone] { + vwait [namespace which -variable fcopyTestDone] ;# The error occurs here in the b.g. + } + chan close $in + chan close $out + set fcopyTestDone ;# 1 for error condition +} 1 +test chan-io-53.6 {CopyData: error during chan copy} {stdio openpipe fcopy} { + variable fcopyTestDone + file delete $path(pipe) + file delete $path(test1) + catch {unset fcopyTestDone} + set f1 [open $path(pipe) w] + chan puts $f1 "exit 1" + chan close $f1 + set in [open "|[list [interpreter] $path(pipe)]" r+] + set out [open $path(test1) w] + chan copy $in $out -command [namespace code FcopyTestDone] + variable fcopyTestDone + if ![info exists fcopyTestDone] { + vwait [namespace which -variable fcopyTestDone] + } + catch {chan close $in} + chan close $out + set fcopyTestDone ;# 0 for plain end of file +} {0} +proc doFcopy {in out {bytes 0} {error {}}} { + variable fcopyTestDone + variable fcopyTestCount + incr fcopyTestCount $bytes + if {[string length $error]} { + set fcopyTestDone 1 + } elseif {[chan eof $in]} { + set fcopyTestDone 0 + } else { + # Delay next chan copy to wait for size>0 input bytes + after 100 [list chan copy $in $out -size 1000 \ + -command [namespace code [list doFcopy $in $out]]] + } +} +test chan-io-53.7 {CopyData: Flooding chan copy from pipe} {stdio openpipe fcopy} { + variable fcopyTestDone + file delete $path(pipe) + catch {unset fcopyTestDone} + set fcopyTestCount 0 + set f1 [open $path(pipe) w] + chan puts $f1 { + # Write 10 bytes / 10 msec + proc Write {count} { + chan puts -nonewline "1234567890" + if {[incr count -1]} { + after 10 [list Write $count] + } else { + set ::ready 1 + } + } + chan configure stdout -buffering none + Write 345 ;# 3450 bytes ~3.45 sec + vwait ready + exit 0 + } + chan close $f1 + set in [open "|[list [interpreter] $path(pipe) &]" r+] + set out [open $path(test1) w] + doFcopy $in $out + variable fcopyTestDone + if ![info exists fcopyTestDone] { + vwait [namespace which -variable fcopyTestDone] + } + catch {chan close $in} + chan close $out + # -1=error 0=script error N=number of bytes + expr ($fcopyTestDone == 0) ? $fcopyTestCount : -1 +} {3450} + +test chan-io-54.1 {Recursive channel events} {socket fileevent} { + # This test checks to see if file events are delivered during recursive + # event loops when there is buffered data on the channel. + + proc accept {s a p} { + variable as + chan configure $s -translation lf + chan puts $s "line 1\nline2\nline3" + chan flush $s + set as $s + } + proc readit {s next} { + variable x + variable result + lappend result $next + if {$next == 1} { + chan event $s readable [namespace code [list readit $s 2]] + vwait [namespace which -variable x] + } + incr x + } + set ss [socket -server [namespace code accept] -myaddr 127.0.0.1 0] + + # We need to delay on some systems until the creation of the + # server socket completes. + + set done 0 + for {set i 0} {$i < 10} {incr i} { + if {![catch {set cs [socket 127.0.0.1 [lindex [chan configure $ss -sockname] 2]]}]} { + set done 1 + break + } + after 100 + } + if {$done == 0} { + chan close $ss + error "failed to connect to server" + } + variable result {} + variable x 0 + variable as + vwait [namespace which -variable as] + chan configure $cs -translation lf + lappend result [chan gets $cs] + chan configure $cs -blocking off + chan event $cs readable [namespace code [list readit $cs 1]] + set a [after 2000 [namespace code { set x failure }]] + vwait [namespace which -variable x] + after cancel $a + chan close $as + chan close $ss + chan close $cs + list $result $x +} {{{line 1} 1 2} 2} +test chan-io-54.2 {Testing for busy-wait in recursive channel events} {socket fileevent} { + set accept {} + set after {} + variable s [socket -server [namespace code accept] -myaddr 127.0.0.1 0] + proc accept {s a p} { + variable counter + variable accept + + set accept $s + set counter 0 + chan configure $s -blocking off -buffering line -translation lf + chan event $s readable [namespace code "doit $s"] + } + proc doit {s} { + variable counter + variable after + + incr counter + set l [chan gets $s] + if {"$l" == ""} { + chan event $s readable [namespace code "doit1 $s"] + set after [after 1000 [namespace code newline]] + } + } + proc doit1 {s} { + variable counter + variable accept + + incr counter + set l [chan gets $s] + chan close $s + set accept {} + } + proc producer {} { + variable s + variable writer + + set writer [socket 127.0.0.1 [lindex [chan configure $s -sockname] 2]] + chan configure $writer -buffering line + chan puts -nonewline $writer hello + chan flush $writer + } + proc newline {} { + variable done + variable writer + + chan puts $writer hello + chan flush $writer + set done 1 + } + producer + variable done + vwait [namespace which -variable done] + chan close $writer + chan close $s + after cancel $after + if {$accept != {}} {chan close $accept} + set counter +} 1 + +set path(fooBar) [makeFile {} fooBar] + +test chan-io-55.1 {ChannelEventScriptInvoker: deletion} -constraints { + fileevent +} -setup { + variable x + proc eventScript {fd} { + variable x + chan close $fd + error "planned error" + set x whoops + } + proc myHandler args { + variable x got_error + } + set handler [interp bgerror {}] + interp bgerror {} [namespace which myHandler] +} -body { + set f [open $path(fooBar) w] + chan event $f writable [namespace code [list eventScript $f]] + variable x not_done + vwait [namespace which -variable x] + set x +} -cleanup { + interp bgerror {} $handler +} -result {got_error} + +test chan-io-56.1 {ChannelTimerProc} {testchannelevent} { + set f [open $path(fooBar) w] + chan puts $f "this is a test" + chan close $f + set f [open $path(fooBar) r] + testchannelevent $f add readable [namespace code { + chan read $f 1 + incr x + }] + variable x 0 + vwait [namespace which -variable x] + vwait [namespace which -variable x] + set result $x + testchannelevent $f set 0 none + after idle [namespace code {set y done}] + variable y + vwait [namespace which -variable y] + chan close $f + lappend result $y +} {2 done} + +test chan-io-57.1 {buffered data and file events, gets} {fileevent} { + proc accept {sock args} { + variable s2 + set s2 $sock + } + set server [socket -server [namespace code accept] -myaddr 127.0.0.1 0] + set s [socket 127.0.0.1 [lindex [chan configure $server -sockname] 2]] + variable s2 + vwait [namespace which -variable s2] + update + chan event $s2 readable [namespace code {lappend result readable}] + chan puts $s "12\n34567890" + chan flush $s + variable result [chan gets $s2] + after 1000 [namespace code {lappend result timer}] + vwait [namespace which -variable result] + lappend result [chan gets $s2] + vwait [namespace which -variable result] + chan close $s + chan close $s2 + chan close $server + set result +} {12 readable 34567890 timer} +test chan-io-57.2 {buffered data and file events, read} {fileevent} { + proc accept {sock args} { + variable s2 + set s2 $sock + } + set server [socket -server [namespace code accept] -myaddr 127.0.0.1 0] + set s [socket 127.0.0.1 [lindex [chan configure $server -sockname] 2]] + variable s2 + vwait [namespace which -variable s2] + update + chan event $s2 readable [namespace code {lappend result readable}] + chan puts -nonewline $s "1234567890" + chan flush $s + variable result [chan read $s2 1] + after 1000 [namespace code {lappend result timer}] + vwait [namespace which -variable result] + lappend result [chan read $s2 9] + vwait [namespace which -variable result] + chan close $s + chan close $s2 + chan close $server + set result +} {1 readable 234567890 timer} + +test chan-io-58.1 {Tcl_NotifyChannel and error when closing} {stdio unixOrPc openpipe fileevent} { + set out [open $path(script) w] + chan puts $out { + chan puts "normal message from pipe" + chan puts stderr "error message from pipe" + exit 1 + } + proc readit {pipe} { + variable x + variable result + if {[chan eof $pipe]} { + set x [catch {chan close $pipe} line] + lappend result catch $line + } else { + chan gets $pipe line + lappend result chan gets $line + } + } + chan close $out + set pipe [open "|[list [interpreter] $path(script)]" r] + chan event $pipe readable [namespace code [list readit $pipe]] + variable x "" + set result "" + vwait [namespace which -variable x] + list $x $result +} {1 {chan gets {normal message from pipe} chan gets {} catch {error message from pipe}}} + +test chan-io-59.1 {Thread reference of channels} {testmainthread testchannel} { + # TIP #10 + # More complicated tests (like that the reference changes as a + # channel is moved from thread to thread) can be done only in the + # extension which fully implements the moving of channels between + # threads, i.e. 'Threads'. Or we have to extend [testthread] as well. + + set f [open $path(longfile) r] + set result [testchannel mthread $f] + chan close $f + string equal $result [testmainthread] +} {1} + +test chan-io-60.1 {writing illegal utf sequences} {openpipe fileevent} { + # This test will hang in older revisions of the core. + + set out [open $path(script) w] + chan puts $out { + chan puts [encoding convertfrom identity \xe2] + exit 1 + } + proc readit {pipe} { + variable x + variable result + if {[chan eof $pipe]} { + set x [catch {chan close $pipe} line] + lappend result catch $line + } else { + chan gets $pipe line + lappend result gets $line + } + } + chan close $out + set pipe [open "|[list [interpreter] $path(script)]" r] + chan event $pipe readable [namespace code [list readit $pipe]] + variable x "" + set result "" + vwait [namespace which -variable x] + + # cut of the remainder of the error stack, especially the filename + set result [lreplace $result 3 3 [lindex [split [lindex $result 3] \n] 0]] + list $x $result +} {1 {gets {} catch {error writing "stdout": invalid argument}}} + +test chan-io-61.1 {Reset eof state after changing the eof char} -setup { + set datafile [makeFile {} eofchar] + set f [open $datafile w] + chan configure $f -translation binary + chan puts -nonewline $f [string repeat "Ho hum\n" 11] + chan puts $f = + set line [string repeat "Ge gla " 4] + chan puts -nonewline $f [string repeat [string trimright $line]\n 834] + chan close $f +} -body { + set f [open $datafile r] + chan configure $f -eofchar = + set res {} + lappend res [chan read $f; chan tell $f] + chan configure $f -eofchar {} + lappend res [chan read $f 1] + lappend res [chan read $f; chan tell $f] + # Any seek zaps the internals into a good state. + #chan seek $f 0 start + #chan seek $f 0 current + #lappend res [chan read $f; chan tell $f] + chan close $f + set res +} -cleanup { + removeFile eofchar +} -result {77 = 23431} + + +# Test the cutting and splicing of channels, this is incidentially the +# attach/detach facility of package Thread, but __without any +# safeguards__. It can also be used to emulate transfer of channels +# between threads, and is used for that here. + +test chan-io-70.0 {Cutting & Splicing channels} {testchannel} { + set f [makeFile {... dummy ...} cutsplice] + set c [open $f r] + + set res {} + lappend res [catch {chan seek $c 0 start}] + testchannel cut $c + + lappend res [catch {chan seek $c 0 start}] + testchannel splice $c + + lappend res [catch {chan seek $c 0 start}] + chan close $c + + removeFile cutsplice + + set res +} {0 1 0} + + +# Duplicate of code in "thread.test". Find a better way of doing this +# without duplication. Maybe placement into a proc which transforms to +# nop after the first call, and placement of its defintion in a +# central location. + +if {[testConstraint testthread]} { + testthread errorproc ThreadError + + proc ThreadError {id info} { + global threadError + set threadError $info + } + + proc ThreadNullError {id info} { + # ignore + } +} + +test chan-io-70.1 {Transfer channel} {testchannel testthread} { + set f [makeFile {... dummy ...} cutsplice] + set c [open $f r] + + set res {} + lappend res [catch {chan seek $c 0 start}] + testchannel cut $c + lappend res [catch {chan seek $c 0 start}] + + set tid [testthread create] + testthread send $tid [list set c $c] + lappend res [testthread send $tid { + testchannel splice $c + set res [catch {chan seek $c 0 start}] + chan close $c + set res + }] + + tcltest::threadReap + removeFile cutsplice + + set res +} {0 1 0} + +# ### ### ### ######### ######### ######### + +foreach {n msg expected} { + 0 {} {} + 1 {{message only}} {{message only}} + 2 {-options x} {-options x} + 3 {-options {x y} {the message}} {-options {x y} {the message}} + + 4 {-code 1 -level 0 -f ba snarf} {-code 1 -level 0 -f ba snarf} + 5 {-code 0 -level 0 -f ba snarf} {-code 1 -level 0 -f ba snarf} + 6 {-code 1 -level 5 -f ba snarf} {-code 1 -level 0 -f ba snarf} + 7 {-code 0 -level 5 -f ba snarf} {-code 1 -level 0 -f ba snarf} + 8 {-code error -level 0 -f ba snarf} {-code error -level 0 -f ba snarf} + 9 {-code ok -level 0 -f ba snarf} {-code 1 -level 0 -f ba snarf} + 10 {-code error -level 5 -f ba snarf} {-code error -level 0 -f ba snarf} + 11 {-code ok -level 5 -f ba snarf} {-code 1 -level 0 -f ba snarf} + 12 {-code boss -level 0 -f ba snarf} {-code 1 -level 0 -f ba snarf} + 13 {-code boss -level 5 -f ba snarf} {-code 1 -level 0 -f ba snarf} + 14 {-code 1 -level 0 -f ba} {-code 1 -level 0 -f ba} + 15 {-code 0 -level 0 -f ba} {-code 1 -level 0 -f ba} + 16 {-code 1 -level 5 -f ba} {-code 1 -level 0 -f ba} + 17 {-code 0 -level 5 -f ba} {-code 1 -level 0 -f ba} + 18 {-code error -level 0 -f ba} {-code error -level 0 -f ba} + 19 {-code ok -level 0 -f ba} {-code 1 -level 0 -f ba} + 20 {-code error -level 5 -f ba} {-code error -level 0 -f ba} + 21 {-code ok -level 5 -f ba} {-code 1 -level 0 -f ba} + 22 {-code boss -level 0 -f ba} {-code 1 -level 0 -f ba} + 23 {-code boss -level 5 -f ba} {-code 1 -level 0 -f ba} + 24 {-code 1 -level X -f ba snarf} {-code 1 -level 0 -f ba snarf} + 25 {-code 0 -level X -f ba snarf} {-code 1 -level 0 -f ba snarf} + 26 {-code error -level X -f ba snarf} {-code error -level 0 -f ba snarf} + 27 {-code ok -level X -f ba snarf} {-code 1 -level 0 -f ba snarf} + 28 {-code boss -level X -f ba snarf} {-code 1 -level 0 -f ba snarf} + 29 {-code 1 -level X -f ba} {-code 1 -level 0 -f ba} + 30 {-code 0 -level X -f ba} {-code 1 -level 0 -f ba} + 31 {-code error -level X -f ba} {-code error -level 0 -f ba} + 32 {-code ok -level X -f ba} {-code 1 -level 0 -f ba} + 33 {-code boss -level X -f ba} {-code 1 -level 0 -f ba} + + 34 {-code 1 -code 1 -level 0 -f ba snarf} {-code 1 -code 1 -level 0 -f ba snarf} + 35 {-code 1 -code 0 -level 0 -f ba snarf} {-code 1 -level 0 -f ba snarf} + 36 {-code 1 -code 1 -level 5 -f ba snarf} {-code 1 -code 1 -level 0 -f ba snarf} + 37 {-code 1 -code 0 -level 5 -f ba snarf} {-code 1 -level 0 -f ba snarf} + 38 {-code 1 -code error -level 0 -f ba snarf} {-code 1 -code error -level 0 -f ba snarf} + 39 {-code 1 -code ok -level 0 -f ba snarf} {-code 1 -level 0 -f ba snarf} + 40 {-code 1 -code error -level 5 -f ba snarf} {-code 1 -code error -level 0 -f ba snarf} + 41 {-code 1 -code ok -level 5 -f ba snarf} {-code 1 -level 0 -f ba snarf} + 42 {-code 1 -code boss -level 0 -f ba snarf} {-code 1 -level 0 -f ba snarf} + 43 {-code 1 -code boss -level 5 -f ba snarf} {-code 1 -level 0 -f ba snarf} + 44 {-code 1 -code 1 -level 0 -f ba} {-code 1 -code 1 -level 0 -f ba} + 45 {-code 1 -code 0 -level 0 -f ba} {-code 1 -level 0 -f ba} + 46 {-code 1 -code 1 -level 5 -f ba} {-code 1 -code 1 -level 0 -f ba} + 47 {-code 1 -code 0 -level 5 -f ba} {-code 1 -level 0 -f ba} + 48 {-code 1 -code error -level 0 -f ba} {-code 1 -code error -level 0 -f ba} + 49 {-code 1 -code ok -level 0 -f ba} {-code 1 -level 0 -f ba} + 50 {-code 1 -code error -level 5 -f ba} {-code 1 -code error -level 0 -f ba} + 51 {-code 1 -code ok -level 5 -f ba} {-code 1 -level 0 -f ba} + 52 {-code 1 -code boss -level 0 -f ba} {-code 1 -level 0 -f ba} + 53 {-code 1 -code boss -level 5 -f ba} {-code 1 -level 0 -f ba} + 54 {-code 1 -code 1 -level X -f ba snarf} {-code 1 -code 1 -level 0 -f ba snarf} + 55 {-code 1 -code 0 -level X -f ba snarf} {-code 1 -level 0 -f ba snarf} + 56 {-code 1 -code error -level X -f ba snarf} {-code 1 -code error -level 0 -f ba snarf} + 57 {-code 1 -code ok -level X -f ba snarf} {-code 1 -level 0 -f ba snarf} + 58 {-code 1 -code boss -level X -f ba snarf} {-code 1 -level 0 -f ba snarf} + 59 {-code 1 -code 1 -level X -f ba} {-code 1 -code 1 -level 0 -f ba} + 60 {-code 1 -code 0 -level X -f ba} {-code 1 -level 0 -f ba} + 61 {-code 1 -code error -level X -f ba} {-code 1 -code error -level 0 -f ba} + 62 {-code 1 -code ok -level X -f ba} {-code 1 -level 0 -f ba} + 63 {-code 1 -code boss -level X -f ba} {-code 1 -level 0 -f ba} + + 64 {-code 0 -code 1 -level 0 -f ba snarf} {-code 1 -level 0 -f ba snarf} + 65 {-code 0 -code 0 -level 0 -f ba snarf} {-code 1 -level 0 -f ba snarf} + 66 {-code 0 -code 1 -level 5 -f ba snarf} {-code 1 -level 0 -f ba snarf} + 67 {-code 0 -code 0 -level 5 -f ba snarf} {-code 1 -level 0 -f ba snarf} + 68 {-code 0 -code error -level 0 -f ba snarf} {-code 1 -level 0 -f ba snarf} + 69 {-code 0 -code ok -level 0 -f ba snarf} {-code 1 -level 0 -f ba snarf} + 70 {-code 0 -code error -level 5 -f ba snarf} {-code 1 -level 0 -f ba snarf} + 71 {-code 0 -code ok -level 5 -f ba snarf} {-code 1 -level 0 -f ba snarf} + 72 {-code 0 -code boss -level 0 -f ba snarf} {-code 1 -level 0 -f ba snarf} + 73 {-code 0 -code boss -level 5 -f ba snarf} {-code 1 -level 0 -f ba snarf} + 74 {-code 0 -code 1 -level 0 -f ba} {-code 1 -level 0 -f ba} + 75 {-code 0 -code 0 -level 0 -f ba} {-code 1 -level 0 -f ba} + 76 {-code 0 -code 1 -level 5 -f ba} {-code 1 -level 0 -f ba} + 77 {-code 0 -code 0 -level 5 -f ba} {-code 1 -level 0 -f ba} + 78 {-code 0 -code error -level 0 -f ba} {-code 1 -level 0 -f ba} + 79 {-code 0 -code ok -level 0 -f ba} {-code 1 -level 0 -f ba} + 80 {-code 0 -code error -level 5 -f ba} {-code 1 -level 0 -f ba} + 81 {-code 0 -code ok -level 5 -f ba} {-code 1 -level 0 -f ba} + 82 {-code 0 -code boss -level 0 -f ba} {-code 1 -level 0 -f ba} + 83 {-code 0 -code boss -level 5 -f ba} {-code 1 -level 0 -f ba} + 84 {-code 0 -code 1 -level X -f ba snarf} {-code 1 -level 0 -f ba snarf} + 85 {-code 0 -code 0 -level X -f ba snarf} {-code 1 -level 0 -f ba snarf} + 86 {-code 0 -code error -level X -f ba snarf} {-code 1 -level 0 -f ba snarf} + 87 {-code 0 -code ok -level X -f ba snarf} {-code 1 -level 0 -f ba snarf} + 88 {-code 0 -code boss -level X -f ba snarf} {-code 1 -level 0 -f ba snarf} + 89 {-code 0 -code 1 -level X -f ba} {-code 1 -level 0 -f ba} + 90 {-code 0 -code 0 -level X -f ba} {-code 1 -level 0 -f ba} + 91 {-code 0 -code error -level X -f ba} {-code 1 -level 0 -f ba} + 92 {-code 0 -code ok -level X -f ba} {-code 1 -level 0 -f ba} + 93 {-code 0 -code boss -level X -f ba} {-code 1 -level 0 -f ba} + + 94 {-code 1 -code 1 -level 0 -f ba snarf} {-code 1 -code 1 -level 0 -f ba snarf} + 95 {-code 0 -code 1 -level 0 -f ba snarf} {-code 1 -level 0 -f ba snarf} + 96 {-code 1 -code 1 -level 5 -f ba snarf} {-code 1 -code 1 -level 0 -f ba snarf} + 97 {-code 0 -code 1 -level 5 -f ba snarf} {-code 1 -level 0 -f ba snarf} + 98 {-code error -code 1 -level 0 -f ba snarf} {-code error -code 1 -level 0 -f ba snarf} + 99 {-code ok -code 1 -level 0 -f ba snarf} {-code 1 -level 0 -f ba snarf} + a0 {-code error -code 1 -level 5 -f ba snarf} {-code error -code 1 -level 0 -f ba snarf} + a1 {-code ok -code 1 -level 5 -f ba snarf} {-code 1 -level 0 -f ba snarf} + a2 {-code boss -code 1 -level 0 -f ba snarf} {-code 1 -level 0 -f ba snarf} + a3 {-code boss -code 1 -level 5 -f ba snarf} {-code 1 -level 0 -f ba snarf} + a4 {-code 1 -code 1 -level 0 -f ba} {-code 1 -code 1 -level 0 -f ba} + a5 {-code 0 -code 1 -level 0 -f ba} {-code 1 -level 0 -f ba} + a6 {-code 1 -code 1 -level 5 -f ba} {-code 1 -code 1 -level 0 -f ba} + a7 {-code 0 -code 1 -level 5 -f ba} {-code 1 -level 0 -f ba} + a8 {-code error -code 1 -level 0 -f ba} {-code error -code 1 -level 0 -f ba} + a9 {-code ok -code 1 -level 0 -f ba} {-code 1 -level 0 -f ba} + b0 {-code error -code 1 -level 5 -f ba} {-code error -code 1 -level 0 -f ba} + b1 {-code ok -code 1 -level 5 -f ba} {-code 1 -level 0 -f ba} + b2 {-code boss -code 1 -level 0 -f ba} {-code 1 -level 0 -f ba} + b3 {-code boss -code 1 -level 5 -f ba} {-code 1 -level 0 -f ba} + b4 {-code 1 -code 1 -level X -f ba snarf} {-code 1 -code 1 -level 0 -f ba snarf} + b5 {-code 0 -code 1 -level X -f ba snarf} {-code 1 -level 0 -f ba snarf} + b6 {-code error -code 1 -level X -f ba snarf} {-code error -code 1 -level 0 -f ba snarf} + b7 {-code ok -code 1 -level X -f ba snarf} {-code 1 -level 0 -f ba snarf} + b8 {-code boss -code 1 -level X -f ba snarf} {-code 1 -level 0 -f ba snarf} + b9 {-code 1 -code 1 -level X -f ba} {-code 1 -code 1 -level 0 -f ba} + c0 {-code 0 -code 1 -level X -f ba} {-code 1 -level 0 -f ba} + c1 {-code error -code 1 -level X -f ba} {-code error -code 1 -level 0 -f ba} + c2 {-code ok -code 1 -level X -f ba} {-code 1 -level 0 -f ba} + c3 {-code boss -code 1 -level X -f ba} {-code 1 -level 0 -f ba} + + c4 {-code 1 -code 0 -level 0 -f ba snarf} {-code 1 -level 0 -f ba snarf} + c5 {-code 0 -code 0 -level 0 -f ba snarf} {-code 1 -level 0 -f ba snarf} + c6 {-code 1 -code 0 -level 5 -f ba snarf} {-code 1 -level 0 -f ba snarf} + c7 {-code 0 -code 0 -level 5 -f ba snarf} {-code 1 -level 0 -f ba snarf} + c8 {-code error -code 0 -level 0 -f ba snarf} {-code 1 -level 0 -f ba snarf} + c9 {-code ok -code 0 -level 0 -f ba snarf} {-code 1 -level 0 -f ba snarf} + d0 {-code error -code 0 -level 5 -f ba snarf} {-code 1 -level 0 -f ba snarf} + d1 {-code ok -code 0 -level 5 -f ba snarf} {-code 1 -level 0 -f ba snarf} + d2 {-code boss -code 0 -level 0 -f ba snarf} {-code 1 -level 0 -f ba snarf} + d3 {-code boss -code 0 -level 5 -f ba snarf} {-code 1 -level 0 -f ba snarf} + d4 {-code 1 -code 0 -level 0 -f ba} {-code 1 -level 0 -f ba} + d5 {-code 0 -code 0 -level 0 -f ba} {-code 1 -level 0 -f ba} + d6 {-code 1 -code 0 -level 5 -f ba} {-code 1 -level 0 -f ba} + d7 {-code 0 -code 0 -level 5 -f ba} {-code 1 -level 0 -f ba} + d8 {-code error -code 0 -level 0 -f ba} {-code 1 -level 0 -f ba} + d9 {-code ok -code 0 -level 0 -f ba} {-code 1 -level 0 -f ba} + e0 {-code error -code 0 -level 5 -f ba} {-code 1 -level 0 -f ba} + e1 {-code ok -code 0 -level 5 -f ba} {-code 1 -level 0 -f ba} + e2 {-code boss -code 0 -level 0 -f ba} {-code 1 -level 0 -f ba} + e3 {-code boss -code 0 -level 5 -f ba} {-code 1 -level 0 -f ba} + e4 {-code 1 -code 0 -level X -f ba snarf} {-code 1 -level 0 -f ba snarf} + e5 {-code 0 -code 0 -level X -f ba snarf} {-code 1 -level 0 -f ba snarf} + e6 {-code error -code 0 -level X -f ba snarf} {-code 1 -level 0 -f ba snarf} + e7 {-code ok -code 0 -level X -f ba snarf} {-code 1 -level 0 -f ba snarf} + e8 {-code boss -code 0 -level X -f ba snarf} {-code 1 -level 0 -f ba snarf} + e9 {-code 1 -code 0 -level X -f ba} {-code 1 -level 0 -f ba} + f0 {-code 0 -code 0 -level X -f ba} {-code 1 -level 0 -f ba} + f1 {-code error -code 0 -level X -f ba} {-code 1 -level 0 -f ba} + f2 {-code ok -code 0 -level X -f ba} {-code 1 -level 0 -f ba} + f3 {-code boss -code 0 -level X -f ba} {-code 1 -level 0 -f ba} +} { + test chan-io-71.$n {Tcl_SetChannelError} {testchannel} { + + set f [makeFile {... dummy ...} cutsplice] + set c [open $f r] + + set res [testchannel setchannelerror $c [lrange $msg 0 end]] + chan close $c + removeFile cutsplice + + set res + } [lrange $expected 0 end] + + test chan-io-72.$n {Tcl_SetChannelErrorInterp} {testchannel} { + + set f [makeFile {... dummy ...} cutsplice] + set c [open $f r] + + set res [testchannel setchannelerrorinterp $c [lrange $msg 0 end]] + chan close $c + removeFile cutsplice + + set res + } [lrange $expected 0 end] +} + +# ### ### ### ######### ######### ######### + +# cleanup +foreach file [list fooBar longfile script output test1 pipe my_script foo \ + bar test2 test3 cat stdout kyrillic.txt utf8-fcopy.txt utf8-rp.txt] { + removeFile $file +} +cleanupTests +} +namespace delete ::tcl::test::io diff --git a/tests/http.test b/tests/http.test index e5aaa19..777fef4 100644 --- a/tests/http.test +++ b/tests/http.test @@ -12,7 +12,7 @@ # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # # -# RCS: @(#) $Id: http.test,v 1.44 2006/11/03 00:34:52 hobbs Exp $ +# RCS: @(#) $Id: http.test,v 1.44.2.1 2007/11/16 07:20:56 dgp Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest 2 @@ -436,30 +436,24 @@ test http-4.13 {http::Event} { } {timeout} # Longer timeout to good host, bad port, gets an error after the # connection "completes" but the socket is bad. -test http-4.14 {http::Event} { - set code [catch { - set token [http::geturl $badurl/?timeout=10 -timeout 10000 -command {#}] - if {[string length $token] == 0} { - error "bogus return from http::geturl" - } - http::wait $token - http::status $token - } err] +test http-4.14 {http::Event} -body { + set token [http::geturl $badurl/?timeout=10 -timeout 10000 -command \#] + if {$token eq ""} { + error "bogus return from http::geturl" + } + http::wait $token + http::status $token # error code varies among platforms. - list $code [regexp {(connect failed|couldn't open socket)} $err] -} {1 1} +} -returnCodes 1 -match regexp -result {(connect failed|couldn't open socket)} # Bogus host -test http-4.15 {http::Event} { - # This test may fail if you use a proxy server. That is to be +test http-4.15 {http::Event} -body { + # This test may fail if you use a proxy server. That is to be # expected and is not a problem with Tcl. - set code [catch { - set token [http::geturl //not_a_host.tcl.tk -timeout 1000 -command {#}] - http::wait $token - http::status $token - } err] - # error code varies among platforms. - list $code [string match "couldn't open socket*" $err] -} {1 1} + set token [http::geturl //not_a_host.tcl.tk -timeout 1000 -command \#] + http::wait $token + http::status $token + # error codes vary among platforms. +} -returnCodes 1 -match glob -result "couldn't open socket*" test http-5.1 {http::formatQuery} { http::formatQuery name1 value1 name2 "value two" diff --git a/tests/io.test b/tests/io.test index 58f160b..f6d7d3d 100644 --- a/tests/io.test +++ b/tests/io.test @@ -13,7 +13,7 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: io.test,v 1.76.2.1 2007/10/16 03:50:33 dgp Exp $ +# RCS: @(#) $Id: io.test,v 1.76.2.2 2007/11/16 07:20:56 dgp Exp $ if {[catch {package require tcltest 2}]} { puts stderr "Skipping tests in [info script]. tcltest 2 required." @@ -4352,7 +4352,7 @@ test io-34.15 {Tcl_Tell combined with seeking} { close $f1 list $c1 $c2 } {10 20} -test io-34.16 {Tcl_tell on pipe: always -1} {stdio openpipe} { +test io-34.16 {Tcl_Tell on pipe: always -1} {stdio openpipe} { set f1 [open "|[list [interpreter]]" r+] set c [tell $f1] close $f1 diff --git a/tests/regexp.test b/tests/regexp.test index 03efa04..c540c6f 100644 --- a/tests/regexp.test +++ b/tests/regexp.test @@ -11,7 +11,7 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: regexp.test,v 1.27 2005/05/10 18:35:23 kennykb Exp $ +# RCS: @(#) $Id: regexp.test,v 1.27.8.1 2007/11/16 07:20:56 dgp Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest 2 @@ -655,6 +655,11 @@ test regexp-21.13 {multiple matches handle newlines} { } {{0 -1} {2 1} {4 3}} +test regexp-22.1 {Bug 1810038} { + regexp ($|^X)* {} +} 1 + + # cleanup ::tcltest::cleanupTests return diff --git a/unix/configure b/unix/configure index 1e01fb3..12e498c 100755 --- a/unix/configure +++ b/unix/configure @@ -852,6 +852,7 @@ Optional Features: --enable-shared build and link with shared libraries (default: on) --enable-64bit enable 64bit support (default: off) --enable-64bit-vis enable 64bit Sparc VIS support (default: off) + --disable-rpath disable rpath support (default: on) --enable-corefoundation use CoreFoundation API on MacOSX (default: on) --enable-load allow dynamic loading and "load" command (default: on) @@ -6414,11 +6415,11 @@ else fi; echo "$as_me:$LINENO: result: $do64bitVIS" >&5 echo "${ECHO_T}$do64bitVIS" >&6 - + # Force 64bit on with VIS if test "$do64bitVIS" = "yes"; then - # Force 64bit on with VIS - do64bit=yes - fi + do64bit=yes +fi + # Step 0.c: Check if visibility support is available. Do this here so # that platform specific alternatives can be used below if this fails. @@ -6484,11 +6485,28 @@ echo "$as_me:$LINENO: result: $tcl_cv_cc_visibility_hidden" >&5 echo "${ECHO_T}$tcl_cv_cc_visibility_hidden" >&6 if test $tcl_cv_cc_visibility_hidden = yes; then + cat >>confdefs.h <<\_ACEOF #define MODULE_SCOPE extern __attribute__((__visibility__("hidden"))) _ACEOF - fi + +fi + + + # Step 0.d: Disable -rpath support? + + echo "$as_me:$LINENO: checking if rpath support is requested" >&5 +echo $ECHO_N "checking if rpath support is requested... $ECHO_C" >&6 + # Check whether --enable-rpath or --disable-rpath was given. +if test "${enable_rpath+set}" = set; then + enableval="$enable_rpath" + doRpath=$enableval +else + doRpath=yes +fi; + echo "$as_me:$LINENO: result: $doRpath" >&5 +echo "${ECHO_T}$doRpath" >&6 # Step 1: set the variable "system" to hold the name and version number # for the system. @@ -6620,11 +6638,14 @@ fi TCL_LIB_VERSIONS_OK=ok CFLAGS_DEBUG=-g CFLAGS_OPTIMIZE=-O - if test "$GCC" = "yes" ; then + if test "$GCC" = yes; then + CFLAGS_WARNING="-Wall -Wno-implicit-int" - else - CFLAGS_WARNING="" - fi + +else + CFLAGS_WARNING="" +fi + TCL_NEEDS_EXP_FILE=0 TCL_BUILD_EXP_FILE="" TCL_EXP_FILE="" @@ -6663,18 +6684,22 @@ else echo "${ECHO_T}no" >&6 fi - if test "${AR}" = "" ; then + if test "${AR}" = ""; then + { { echo "$as_me:$LINENO: error: Required archive tool 'ar' not found on PATH." >&5 echo "$as_me: error: Required archive tool 'ar' not found on PATH." >&2;} { (exit 1); exit 1; }; } - fi + +fi + STLIB_LD='${AR} cr' LD_LIBRARY_PATH_VAR="LD_LIBRARY_PATH" PLAT_OBJS="" PLAT_SRCS="" case $system in AIX-*) - if test "${TCL_THREADS}" = "1" -a "$GCC" != "yes" ; then + if test "${TCL_THREADS}" = "1" -a "$GCC" != "yes"; then + # AIX requires the _r compiler when gcc isn't being used case "${CC}" in *_r) @@ -6686,7 +6711,9 @@ echo "$as_me: error: Required archive tool 'ar' not found on PATH." >&2;} esac echo "$as_me:$LINENO: result: Using $CC for compiling with threads" >&5 echo "${ECHO_T}Using $CC for compiling with threads" >&6 - fi + +fi + LIBS="$LIBS -lc" SHLIB_CFLAGS="" # Note: need the LIBS below, otherwise Tk won't find Tcl's @@ -6698,47 +6725,69 @@ echo "${ECHO_T}Using $CC for compiling with threads" >&6 LD_LIBRARY_PATH_VAR="LIBPATH" # Check to enable 64-bit flags for compiler/linker on AIX 4+ - if test "$do64bit" = "yes" -a "`uname -v`" -gt "3" ; then - if test "$GCC" = "yes" ; then + if test "$do64bit" = yes -a "`uname -v`" -gt 3; then + + if test "$GCC" = yes; then + { echo "$as_me:$LINENO: WARNING: 64bit mode not supported with GCC on $system" >&5 echo "$as_me: WARNING: 64bit mode not supported with GCC on $system" >&2;} - else + +else + do64bit_ok=yes CFLAGS="$CFLAGS -q64" LDFLAGS_ARCH="-q64" RANLIB="${RANLIB} -X64" AR="${AR} -X64" SHLIB_LD_FLAGS="-b64" - fi - fi - if test "`uname -m`" = "ia64" ; then +fi + + +fi + + + if test "`uname -m`" = ia64; then + # AIX-5 uses ELF style dynamic libraries on IA-64, but not PPC SHLIB_LD="/usr/ccs/bin/ld -G -z text" # AIX-5 has dl* in libc.so DL_LIBS="" - if test "$GCC" = "yes" ; then + if test "$GCC" = yes; then + CC_SEARCH_FLAGS='-Wl,-R,${LIB_RUNTIME_DIR}' - else + +else + CC_SEARCH_FLAGS='-R${LIB_RUNTIME_DIR}' - fi + +fi + LD_SEARCH_FLAGS='-R ${LIB_RUNTIME_DIR}' - else - if test "$GCC" = "yes" ; then - SHLIB_LD='${CC} -shared' - else + +else + + if test "$GCC" = yes; then + SHLIB_LD='${CC} -shared' +else + SHLIB_LD="/bin/ld -bhalt:4 -bM:SRE -bE:lib.exp -H512 -T512 -bnoentry" - fi + +fi + SHLIB_LD="${TCL_SRC_DIR}/unix/ldAix ${SHLIB_LD} ${SHLIB_LD_FLAGS}" DL_LIBS="-ldl" CC_SEARCH_FLAGS='-L${LIB_RUNTIME_DIR}' LD_SEARCH_FLAGS=${CC_SEARCH_FLAGS} TCL_NEEDS_EXP_FILE=1 TCL_EXPORT_FILE_SUFFIX='${VERSION}.exp' - fi + +fi + # AIX v<=4.1 has some different flags than 4.2+ - if test "$system" = "AIX-4.1" -o "`uname -v`" -lt "4" ; then + if test "$system" = "AIX-4.1" -o "`uname -v`" -lt 4; then + case $LIBOBJS in "tclLoadAix.$ac_objext" | \ *" tclLoadAix.$ac_objext" | \ @@ -6748,7 +6797,9 @@ echo "$as_me: WARNING: 64bit mode not supported with GCC on $system" >&2;} esac DL_LIBS="-lld" - fi + +fi + # On AIX <=v4 systems, libbsd.a has to be linked in to support # non-blocking file IO. This library has to be linked in after @@ -6833,13 +6884,16 @@ else fi if test $libbsd = yes; then + MATH_LIBS="$MATH_LIBS -lbsd" cat >>confdefs.h <<\_ACEOF #define USE_DELTA_FOR_TZ 1 _ACEOF - fi + +fi + ;; BeOS*) SHLIB_CFLAGS="-fPIC" @@ -6968,11 +7022,16 @@ _ACEOF LIBS="$LIBS -lxnet" # Use the XOPEN network library - if test "`uname -m`" = "ia64" ; then + if test "`uname -m`" = ia64; then + SHLIB_SUFFIX=".so" - else + +else + SHLIB_SUFFIX=".sl" - fi + +fi + echo "$as_me:$LINENO: checking for shl_load in -ldld" >&5 echo $ECHO_N "checking for shl_load in -ldld... $ECHO_C" >&6 if test "${ac_cv_lib_dld_shl_load+set}" = set; then @@ -7044,6 +7103,7 @@ else fi if test "$tcl_ok" = yes; then + SHLIB_CFLAGS="+z" SHLIB_LD="ld -b" SHLIB_LD_LIBS='${LIBS}' @@ -7053,27 +7113,37 @@ fi CC_SEARCH_FLAGS='-Wl,+s,+b,${LIB_RUNTIME_DIR}:.' LD_SEARCH_FLAGS='+s +b ${LIB_RUNTIME_DIR}:.' LD_LIBRARY_PATH_VAR="SHLIB_PATH" - fi - if test "$GCC" = "yes" ; then + +fi + + if test "$GCC" = yes; then + SHLIB_LD='${CC} -shared' SHLIB_LD_LIBS='${LIBS}' LD_SEARCH_FLAGS=${CC_SEARCH_FLAGS} - fi + +fi + # Users may want PA-RISC 1.1/2.0 portable code - needs HP cc #CFLAGS="$CFLAGS +DAportable" # Check to enable 64-bit flags for compiler/linker - if test "$do64bit" = "yes" ; then - if test "$GCC" = "yes" ; then - hpux_arch=`${CC} -dumpmachine` - case $hpux_arch in + if test "$do64bit" = "yes"; then + + if test "$GCC" = yes; then + + case `${CC} -dumpmachine` in hppa64*) # 64-bit gcc in use. Fix flags for GNU ld. do64bit_ok=yes SHLIB_LD='${CC} -shared' SHLIB_LD_LIBS='${LIBS}' - CC_SEARCH_FLAGS='-Wl,-rpath,${LIB_RUNTIME_DIR}' + if test $doRpath = yes; then + + CC_SEARCH_FLAGS='-Wl,-rpath,${LIB_RUNTIME_DIR}' +fi + LD_SEARCH_FLAGS=${CC_SEARCH_FLAGS} ;; *) @@ -7081,13 +7151,18 @@ fi echo "$as_me: WARNING: 64bit mode not supported with GCC on $system" >&2;} ;; esac - else + +else + do64bit_ok=yes CFLAGS="$CFLAGS +DD64" LDFLAGS_ARCH="+DD64" - fi - fi - ;; + +fi + + +fi + ;; HP-UX-*.08.*|HP-UX-*.09.*|HP-UX-*.10.*) SHLIB_SUFFIX=".sl" echo "$as_me:$LINENO: checking for shl_load in -ldld" >&5 @@ -7161,6 +7236,7 @@ else fi if test "$tcl_ok" = yes; then + SHLIB_CFLAGS="+z" SHLIB_LD="ld -b" SHLIB_LD_LIBS="" @@ -7170,8 +7246,9 @@ fi CC_SEARCH_FLAGS='-Wl,+s,+b,${LIB_RUNTIME_DIR}:.' LD_SEARCH_FLAGS='+s +b ${LIB_RUNTIME_DIR}:.' LD_LIBRARY_PATH_VAR="SHLIB_PATH" - fi - ;; + +fi + ;; IRIX-5.*) SHLIB_CFLAGS="" SHLIB_LD="ld -shared -rdata_shared" @@ -7179,8 +7256,12 @@ fi SHLIB_SUFFIX=".so" DL_OBJS="tclLoadDl.o" DL_LIBS="" - CC_SEARCH_FLAGS='-Wl,-rpath,${LIB_RUNTIME_DIR}' - LD_SEARCH_FLAGS='-rpath ${LIB_RUNTIME_DIR}' + if test $doRpath = yes; then + + CC_SEARCH_FLAGS='-Wl,-rpath,${LIB_RUNTIME_DIR}' + LD_SEARCH_FLAGS='-rpath ${LIB_RUNTIME_DIR}' +fi + ;; IRIX-6.*) SHLIB_CFLAGS="" @@ -7189,12 +7270,19 @@ fi SHLIB_SUFFIX=".so" DL_OBJS="tclLoadDl.o" DL_LIBS="" - CC_SEARCH_FLAGS='-Wl,-rpath,${LIB_RUNTIME_DIR}' - LD_SEARCH_FLAGS='-rpath ${LIB_RUNTIME_DIR}' - if test "$GCC" = "yes" ; then + if test $doRpath = yes; then + + CC_SEARCH_FLAGS='-Wl,-rpath,${LIB_RUNTIME_DIR}' + LD_SEARCH_FLAGS='-rpath ${LIB_RUNTIME_DIR}' +fi + + if test "$GCC" = yes; then + CFLAGS="$CFLAGS -mabi=n32" LDFLAGS="$LDFLAGS -mabi=n32" - else + +else + case $system in IRIX-6.3) # Use to build 6.2 compatible binaries on 6.3. @@ -7205,7 +7293,9 @@ fi ;; esac LDFLAGS="$LDFLAGS -n32" - fi + +fi + ;; IRIX64-6.*) SHLIB_CFLAGS="" @@ -7214,22 +7304,34 @@ fi SHLIB_SUFFIX=".so" DL_OBJS="tclLoadDl.o" DL_LIBS="" - CC_SEARCH_FLAGS='-Wl,-rpath,${LIB_RUNTIME_DIR}' - LD_SEARCH_FLAGS='-rpath ${LIB_RUNTIME_DIR}' + if test $doRpath = yes; then + + CC_SEARCH_FLAGS='-Wl,-rpath,${LIB_RUNTIME_DIR}' + LD_SEARCH_FLAGS='-rpath ${LIB_RUNTIME_DIR}' +fi + # Check to enable 64-bit flags for compiler/linker - if test "$do64bit" = "yes" ; then - if test "$GCC" = "yes" ; then + if test "$do64bit" = yes; then + + if test "$GCC" = yes; then + { echo "$as_me:$LINENO: WARNING: 64bit mode not supported by gcc" >&5 echo "$as_me: WARNING: 64bit mode not supported by gcc" >&2;} - else + +else + do64bit_ok=yes SHLIB_LD="ld -64 -shared -rdata_shared" CFLAGS="$CFLAGS -64" LDFLAGS_ARCH="-64" - fi - fi + +fi + + +fi + ;; Linux*) SHLIB_CFLAGS="-fPIC" @@ -7246,12 +7348,18 @@ echo "$as_me: WARNING: 64bit mode not supported by gcc" >&2;} DL_OBJS="tclLoadDl.o" DL_LIBS="-ldl" LDFLAGS="$LDFLAGS -Wl,--export-dynamic" - CC_SEARCH_FLAGS='-Wl,-rpath,${LIB_RUNTIME_DIR}' + if test $doRpath = yes; then + + CC_SEARCH_FLAGS='-Wl,-rpath,${LIB_RUNTIME_DIR}' +fi + LD_SEARCH_FLAGS=${CC_SEARCH_FLAGS} - if test "`uname -m`" = "alpha" ; then - CFLAGS="$CFLAGS -mieee" - fi + if test "`uname -m`" = "alpha"; then + CFLAGS="$CFLAGS -mieee" +fi + if test $do64bit = yes; then + echo "$as_me:$LINENO: checking if compiler accepts -m64 flag" >&5 echo $ECHO_N "checking if compiler accepts -m64 flag... $ECHO_C" >&6 if test "${tcl_cv_cc_m64+set}" = set; then @@ -7311,21 +7419,26 @@ fi echo "$as_me:$LINENO: result: $tcl_cv_cc_m64" >&5 echo "${ECHO_T}$tcl_cv_cc_m64" >&6 if test $tcl_cv_cc_m64 = yes; then + CFLAGS="$CFLAGS -m64" do64bit_ok=yes - fi - fi - # The combo of gcc + glibc has a bug related - # to inlining of functions like strtod(). The - # -fno-builtin flag should address this problem - # but it does not work. The -fno-inline flag - # is kind of overkill but it works. - # Disable inlining only when one of the +fi + + +fi + + + # The combo of gcc + glibc has a bug related to inlining of + # functions like strtod(). The -fno-builtin flag should address + # this problem but it does not work. The -fno-inline flag is kind + # of overkill but it works. Disable inlining only when one of the # files in compat/*.c is being linked in. - if test x"${USE_COMPAT}" != x ; then - CFLAGS="$CFLAGS -fno-inline" - fi + + if test x"${USE_COMPAT}" != x; then + CFLAGS="$CFLAGS -fno-inline" +fi + # XIM peeking works under XFree86. @@ -7346,9 +7459,10 @@ _ACEOF LDFLAGS="$LDFLAGS -Wl,--export-dynamic" CC_SEARCH_FLAGS="" LD_SEARCH_FLAGS="" - if test "`uname -m`" = "alpha" ; then - CFLAGS="$CFLAGS -mieee" - fi + if test "`uname -m`" = "alpha"; then + CFLAGS="$CFLAGS -mieee" +fi + ;; Lynx*) SHLIB_CFLAGS="-fPIC" @@ -7359,8 +7473,12 @@ _ACEOF DL_OBJS="tclLoadDl.o" DL_LIBS="-mshared -ldl" LD_FLAGS="-Wl,--export-dynamic" - CC_SEARCH_FLAGS='-Wl,-rpath,${LIB_RUNTIME_DIR}' - LD_SEARCH_FLAGS='-Wl,-rpath,${LIB_RUNTIME_DIR}' + if test $doRpath = yes; then + + CC_SEARCH_FLAGS='-Wl,-rpath,${LIB_RUNTIME_DIR}' + LD_SEARCH_FLAGS='-Wl,-rpath,${LIB_RUNTIME_DIR}' +fi + ;; MP-RAS-02*) SHLIB_CFLAGS="-K PIC" @@ -7390,8 +7508,12 @@ _ACEOF SHLIB_SUFFIX=".so" DL_OBJS="tclLoadDl.o" DL_LIBS="" - CC_SEARCH_FLAGS='-Wl,-rpath,${LIB_RUNTIME_DIR}' - LD_SEARCH_FLAGS='-rpath ${LIB_RUNTIME_DIR}' + if test $doRpath = yes; then + + CC_SEARCH_FLAGS='-Wl,-rpath,${LIB_RUNTIME_DIR}' + LD_SEARCH_FLAGS='-rpath ${LIB_RUNTIME_DIR}' +fi + echo "$as_me:$LINENO: checking for ELF" >&5 echo $ECHO_N "checking for ELF... $ECHO_C" >&6 if test "${tcl_cv_ld_elf+set}" = set; then @@ -7422,10 +7544,15 @@ fi echo "$as_me:$LINENO: result: $tcl_cv_ld_elf" >&5 echo "${ECHO_T}$tcl_cv_ld_elf" >&6 if test $tcl_cv_ld_elf = yes; then + SHARED_LIB_SUFFIX='${TCL_TRIM_DOTS}.so' - else + +else + SHARED_LIB_SUFFIX='${TCL_TRIM_DOTS}.so.1.0' - fi + +fi + # Ancient FreeBSD doesn't handle version numbers with dots. @@ -7439,7 +7566,11 @@ echo "${ECHO_T}$tcl_cv_ld_elf" >&6 SHLIB_SUFFIX=".so" DL_OBJS="tclLoadDl.o" DL_LIBS="" - CC_SEARCH_FLAGS='-Wl,-rpath,${LIB_RUNTIME_DIR}' + if test $doRpath = yes; then + + CC_SEARCH_FLAGS='-Wl,-rpath,${LIB_RUNTIME_DIR}' +fi + LD_SEARCH_FLAGS=${CC_SEARCH_FLAGS} SHARED_LIB_SUFFIX='${TCL_TRIM_DOTS}.so.1.0' echo "$as_me:$LINENO: checking for ELF" >&5 @@ -7472,10 +7603,13 @@ fi echo "$as_me:$LINENO: result: $tcl_cv_ld_elf" >&5 echo "${ECHO_T}$tcl_cv_ld_elf" >&6 if test $tcl_cv_ld_elf = yes; then + LDFLAGS=-Wl,-export-dynamic - else - LDFLAGS="" - fi + +else + LDFLAGS="" +fi + # OpenBSD doesn't do version numbers with dots. UNSHARED_LIB_SUFFIX='${TCL_TRIM_DOTS}.a' @@ -7491,14 +7625,21 @@ echo "${ECHO_T}$tcl_cv_ld_elf" >&6 DL_OBJS="tclLoadDl.o" DL_LIBS="" LDFLAGS="$LDFLAGS -export-dynamic" - CC_SEARCH_FLAGS='-Wl,-rpath,${LIB_RUNTIME_DIR}' + if test $doRpath = yes; then + + CC_SEARCH_FLAGS='-Wl,-rpath,${LIB_RUNTIME_DIR}' +fi + LD_SEARCH_FLAGS=${CC_SEARCH_FLAGS} - if test "${TCL_THREADS}" = "1" ; then + if test "${TCL_THREADS}" = "1"; then + # The -pthread needs to go in the CFLAGS, not LIBS LIBS=`echo $LIBS | sed s/-pthread//` CFLAGS="$CFLAGS -pthread" LDFLAGS="$LDFLAGS -pthread" - fi + +fi + case $system in FreeBSD-3.*) # FreeBSD-3 doesn't handle version numbers with dots. @@ -7521,6 +7662,7 @@ echo "${ECHO_T}$tcl_cv_ld_elf" >&6 awk 'BEGIN {FS=" +-";ORS=" "}; {for (i=2;i<=NF;i++) \ if (!($i~/^(isysroot|mmacosx-version-min)/)) print "-"$i}'`" if test $do64bit = yes; then + case `arch` in ppc) echo "$as_me:$LINENO: checking if compiler accepts -arch ppc64 flag" >&5 @@ -7582,9 +7724,12 @@ fi echo "$as_me:$LINENO: result: $tcl_cv_cc_arch_ppc64" >&5 echo "${ECHO_T}$tcl_cv_cc_arch_ppc64" >&6 if test $tcl_cv_cc_arch_ppc64 = yes; then + CFLAGS="$CFLAGS -arch ppc64 -mpowerpc64 -mcpu=G5" do64bit_ok=yes - fi;; + +fi +;; i386) echo "$as_me:$LINENO: checking if compiler accepts -arch x86_64 flag" >&5 echo $ECHO_N "checking if compiler accepts -arch x86_64 flag... $ECHO_C" >&6 @@ -7645,19 +7790,29 @@ fi echo "$as_me:$LINENO: result: $tcl_cv_cc_arch_x86_64" >&5 echo "${ECHO_T}$tcl_cv_cc_arch_x86_64" >&6 if test $tcl_cv_cc_arch_x86_64 = yes; then + CFLAGS="$CFLAGS -arch x86_64" do64bit_ok=yes - fi;; + +fi +;; *) { echo "$as_me:$LINENO: WARNING: Don't know how enable 64-bit on architecture \`arch\`" >&5 echo "$as_me: WARNING: Don't know how enable 64-bit on architecture \`arch\`" >&2;};; esac - else + +else + # Check for combined 32-bit and 64-bit fat build - echo "$CFLAGS " | grep -E -q -- '-arch (ppc64|x86_64) ' && \ - echo "$CFLAGS " | grep -E -q -- '-arch (ppc|i386) ' && \ + if echo "$CFLAGS " |grep -E -q -- '-arch (ppc64|x86_64) ' \ + && echo "$CFLAGS " |grep -E -q -- '-arch (ppc|i386) '; then + fat_32_64=yes - fi +fi + + +fi + SHLIB_LD='${CC} -dynamiclib ${CFLAGS} ${LDFLAGS}' echo "$as_me:$LINENO: checking if ld accepts -single_module flag" >&5 echo $ECHO_N "checking if ld accepts -single_module flag... $ECHO_C" >&6 @@ -7718,16 +7873,22 @@ fi echo "$as_me:$LINENO: result: $tcl_cv_ld_single_module" >&5 echo "${ECHO_T}$tcl_cv_ld_single_module" >&6 if test $tcl_cv_ld_single_module = yes; then + SHLIB_LD="${SHLIB_LD} -Wl,-single_module" - fi + +fi + SHLIB_LD_LIBS='${LIBS}' SHLIB_SUFFIX=".dylib" DL_OBJS="tclLoadDyld.o" DL_LIBS="" # Don't use -prebind when building for Mac OS X 10.4 or later only: - test "`echo "${MACOSX_DEPLOYMENT_TARGET}" | awk -F '10\\.' '{print int($2)}'`" -lt 4 -a \ - "`echo "${CPPFLAGS}" | awk -F '-mmacosx-version-min=10\\.' '{print int($2)}'`" -lt 4 && \ + if test "`echo "${MACOSX_DEPLOYMENT_TARGET}" | awk -F '10\\.' '{print int($2)}'`" -lt 4 -a \ + "`echo "${CPPFLAGS}" | awk -F '-mmacosx-version-min=10\\.' '{print int($2)}'`" -lt 4; then + LDFLAGS="$LDFLAGS -prebind" +fi + LDFLAGS="$LDFLAGS -headerpad_max_install_names" echo "$as_me:$LINENO: checking if ld accepts -search_paths_first flag" >&5 echo $ECHO_N "checking if ld accepts -search_paths_first flag... $ECHO_C" >&6 @@ -7788,8 +7949,11 @@ fi echo "$as_me:$LINENO: result: $tcl_cv_ld_search_paths_first" >&5 echo "${ECHO_T}$tcl_cv_ld_search_paths_first" >&6 if test $tcl_cv_ld_search_paths_first = yes; then + LDFLAGS="$LDFLAGS -Wl,-search_paths_first" - fi + +fi + CC_SEARCH_FLAGS="" LD_SEARCH_FLAGS="" LD_LIBRARY_PATH_VAR="DYLD_LIBRARY_PATH" @@ -7807,6 +7971,7 @@ fi; echo "$as_me:$LINENO: result: $tcl_corefoundation" >&5 echo "${ECHO_T}$tcl_corefoundation" >&6 if test $tcl_corefoundation = yes; then + echo "$as_me:$LINENO: checking for CoreFoundation.framework" >&5 echo $ECHO_N "checking for CoreFoundation.framework... $ECHO_C" >&6 if test "${tcl_cv_lib_corefoundation+set}" = set; then @@ -7814,12 +7979,17 @@ if test "${tcl_cv_lib_corefoundation+set}" = set; then else hold_libs=$LIBS - if test "$fat_32_64" = yes; then for v in CFLAGS CPPFLAGS LDFLAGS; do - # On Tiger there is no 64-bit CF, so remove 64-bit archs - # from CFLAGS et al. while testing for presence of CF. - # 64-bit CF is disabled in tclUnixPort.h if necessary. - eval 'hold_'$v'="$'$v'";'$v'="`echo "$'$v' "|sed -e "s/-arch ppc64 / /g" -e "s/-arch x86_64 / /g"`"' - done; fi + if test "$fat_32_64" = yes; then + + for v in CFLAGS CPPFLAGS LDFLAGS; do + # On Tiger there is no 64-bit CF, so remove 64-bit + # archs from CFLAGS et al. while testing for + # presence of CF. 64-bit CF is disabled in + # tclUnixPort.h if necessary. + eval 'hold_'$v'="$'$v'";'$v'="`echo "$'$v' "|sed -e "s/-arch ppc64 / /g" -e "s/-arch x86_64 / /g"`"' + done +fi + LIBS="$LIBS -framework CoreFoundation" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ @@ -7867,23 +8037,32 @@ tcl_cv_lib_corefoundation=no fi rm -f conftest.err conftest.$ac_objext \ conftest$ac_exeext conftest.$ac_ext - if test "$fat_32_64" = yes; then for v in CFLAGS CPPFLAGS LDFLAGS; do - eval $v'="$hold_'$v'"' - done; fi; LIBS=$hold_libs + if test "$fat_32_64" = yes; then + + for v in CFLAGS CPPFLAGS LDFLAGS; do + eval $v'="$hold_'$v'"' + done +fi + + LIBS=$hold_libs fi echo "$as_me:$LINENO: result: $tcl_cv_lib_corefoundation" >&5 echo "${ECHO_T}$tcl_cv_lib_corefoundation" >&6 if test $tcl_cv_lib_corefoundation = yes; then + LIBS="$LIBS -framework CoreFoundation" cat >>confdefs.h <<\_ACEOF #define HAVE_COREFOUNDATION 1 _ACEOF - else - tcl_corefoundation=no - fi + +else + tcl_corefoundation=no +fi + if test "$fat_32_64" = yes -a $tcl_corefoundation = yes; then + echo "$as_me:$LINENO: checking for 64-bit CoreFoundation" >&5 echo $ECHO_N "checking for 64-bit CoreFoundation... $ECHO_C" >&6 if test "${tcl_cv_lib_corefoundation_64+set}" = set; then @@ -7947,21 +8126,31 @@ echo "$as_me:$LINENO: result: $tcl_cv_lib_corefoundation_64" >&5 echo "${ECHO_T}$tcl_cv_lib_corefoundation_64" >&6 if test $tcl_cv_lib_corefoundation_64 = no; then + cat >>confdefs.h <<\_ACEOF #define NO_COREFOUNDATION_64 1 _ACEOF LDFLAGS="$LDFLAGS -Wl,-no_arch_warnings" - fi - fi - fi + +fi + + +fi + + +fi + if test "$tcl_cv_cc_visibility_hidden" != yes; then + cat >>confdefs.h <<\_ACEOF #define MODULE_SCOPE __private_extern__ _ACEOF - fi + +fi + cat >>confdefs.h <<\_ACEOF #define MAC_OSX_TCL 1 @@ -8001,11 +8190,14 @@ _ACEOF OSF1-1.*) # OSF/1 1.3 from OSF using ELF, and derivatives, including AD2 SHLIB_CFLAGS="-fPIC" - if test "$SHARED_BUILD" = "1" ; then - SHLIB_LD="ld -shared" - else + if test "$SHARED_BUILD" = 1; then + SHLIB_LD="ld -shared" +else + SHLIB_LD="ld -non_shared" - fi + +fi + SHLIB_LD_LIBS="" SHLIB_SUFFIX=".so" DL_OBJS="tclLoadDl.o" @@ -8016,34 +8208,52 @@ _ACEOF OSF1-V*) # Digital OSF/1 SHLIB_CFLAGS="" - if test "$SHARED_BUILD" = "1" ; then + if test "$SHARED_BUILD" = 1; then + SHLIB_LD='ld -shared -expect_unresolved "*"' - else + +else + SHLIB_LD='ld -non_shared -expect_unresolved "*"' - fi + +fi + SHLIB_LD_LIBS="" SHLIB_SUFFIX=".so" DL_OBJS="tclLoadDl.o" DL_LIBS="" - CC_SEARCH_FLAGS='-Wl,-rpath,${LIB_RUNTIME_DIR}' - LD_SEARCH_FLAGS='-rpath ${LIB_RUNTIME_DIR}' - if test "$GCC" = "yes" ; then - CFLAGS="$CFLAGS -mieee" - else + if test $doRpath = yes; then + + CC_SEARCH_FLAGS='-Wl,-rpath,${LIB_RUNTIME_DIR}' + LD_SEARCH_FLAGS='-rpath ${LIB_RUNTIME_DIR}' +fi + + if test "$GCC" = yes; then + CFLAGS="$CFLAGS -mieee" +else + CFLAGS="$CFLAGS -DHAVE_TZSET -std1 -ieee" - fi +fi + # see pthread_intro(3) for pthread support on osf1, k.furukawa - if test "${TCL_THREADS}" = "1" ; then + if test "${TCL_THREADS}" = 1; then + CFLAGS="$CFLAGS -DHAVE_PTHREAD_ATTR_SETSTACKSIZE" CFLAGS="$CFLAGS -DTCL_THREAD_STACK_MIN=PTHREAD_STACK_MIN*64" LIBS=`echo $LIBS | sed s/-lpthreads//` - if test "$GCC" = "yes" ; then + if test "$GCC" = yes; then + LIBS="$LIBS -lpthread -lmach -lexc" - else + +else + CFLAGS="$CFLAGS -pthread" LDFLAGS="$LDFLAGS -pthread" - fi - fi + +fi + + +fi ;; QNX-6*) @@ -8063,13 +8273,18 @@ _ACEOF # Note, dlopen is available only on SCO 3.2.5 and greater. However, # this test works, since "uname -s" was non-standard in 3.2.4 and # below. - if test "$GCC" = "yes" ; then + if test "$GCC" = yes; then + SHLIB_CFLAGS="-fPIC -melf" LDFLAGS="$LDFLAGS -melf -Wl,-Bexport" - else + +else + SHLIB_CFLAGS="-Kpic -belf" LDFLAGS="$LDFLAGS -belf -Wl,-Bexport" - fi + +fi + SHLIB_LD="ld -G" SHLIB_LD_LIBS="" SHLIB_SUFFIX=".so" @@ -8133,15 +8348,20 @@ _ACEOF SHLIB_SUFFIX=".so" DL_OBJS="tclLoadDl.o" DL_LIBS="-ldl" - if test "$GCC" = "yes" ; then + if test "$GCC" = yes; then + SHLIB_LD='${CC} -shared' CC_SEARCH_FLAGS='-Wl,-R,${LIB_RUNTIME_DIR}' LD_SEARCH_FLAGS=${CC_SEARCH_FLAGS} - else + +else + SHLIB_LD="/usr/ccs/bin/ld -G -z text" CC_SEARCH_FLAGS='-R ${LIB_RUNTIME_DIR}' LD_SEARCH_FLAGS=${CC_SEARCH_FLAGS} - fi + +fi + ;; SunOS-5*) # Note: If _REENTRANT isn't defined, then Solaris @@ -8161,45 +8381,76 @@ _ACEOF SHLIB_CFLAGS="-KPIC" # Check to enable 64-bit flags for compiler/linker - if test "$do64bit" = "yes" ; then + if test "$do64bit" = yes; then + arch=`isainfo` - if test "$arch" = "sparcv9 sparc" ; then - if test "$GCC" = "yes" ; then - if test "`${CC} -dumpversion | awk -F. '{print $1}'`" -lt "3" ; then - { echo "$as_me:$LINENO: WARNING: 64bit mode not supported with GCC < 3.2 on $system" >&5 + if test "$arch" = "sparcv9 sparc"; then + + if test "$GCC" = yes; then + + if test "`${CC} -dumpversion | awk -F. '{print $1}'`" -lt 3; then + + { echo "$as_me:$LINENO: WARNING: 64bit mode not supported with GCC < 3.2 on $system" >&5 echo "$as_me: WARNING: 64bit mode not supported with GCC < 3.2 on $system" >&2;} - else - do64bit_ok=yes - CFLAGS="$CFLAGS -m64 -mcpu=v9" - LDFLAGS="$LDFLAGS -m64 -mcpu=v9" - SHLIB_CFLAGS="-fPIC" - fi - else + +else + do64bit_ok=yes - if test "$do64bitVIS" = "yes" ; then - CFLAGS="$CFLAGS -xarch=v9a" - LDFLAGS_ARCH="-xarch=v9a" - else - CFLAGS="$CFLAGS -xarch=v9" - LDFLAGS_ARCH="-xarch=v9" - fi - # Solaris 64 uses this as well - #LD_LIBRARY_PATH_VAR="LD_LIBRARY_PATH_64" - fi - elif test "$arch" = "amd64 i386" ; then - if test "$GCC" = "yes" ; then + CFLAGS="$CFLAGS -m64 -mcpu=v9" + LDFLAGS="$LDFLAGS -m64 -mcpu=v9" + SHLIB_CFLAGS="-fPIC" + +fi + + +else + + do64bit_ok=yes + if test "$do64bitVIS" = yes; then + + CFLAGS="$CFLAGS -xarch=v9a" + LDFLAGS_ARCH="-xarch=v9a" + +else + + CFLAGS="$CFLAGS -xarch=v9" + LDFLAGS_ARCH="-xarch=v9" + +fi + + # Solaris 64 uses this as well + #LD_LIBRARY_PATH_VAR="LD_LIBRARY_PATH_64" + +fi + + +else + if test "$arch" = "amd64 i386"; then + + if test "$GCC" = yes; then + { echo "$as_me:$LINENO: WARNING: 64bit mode not supported with GCC on $system" >&5 echo "$as_me: WARNING: 64bit mode not supported with GCC on $system" >&2;} - else + +else + do64bit_ok=yes CFLAGS="$CFLAGS -xarch=amd64" LDFLAGS="$LDFLAGS -xarch=amd64" - fi - else - { echo "$as_me:$LINENO: WARNING: 64bit mode not supported for $arch" >&5 + +fi + + +else + { echo "$as_me:$LINENO: WARNING: 64bit mode not supported for $arch" >&5 echo "$as_me: WARNING: 64bit mode not supported for $arch" >&2;} - fi - fi +fi + +fi + + +fi + # Note: need the LIBS below, otherwise Tk won't find Tcl's # symbols when dynamically loaded into tclsh. @@ -8208,11 +8459,13 @@ echo "$as_me: WARNING: 64bit mode not supported for $arch" >&2;} SHLIB_SUFFIX=".so" DL_OBJS="tclLoadDl.o" DL_LIBS="-ldl" - if test "$GCC" = "yes" ; then + if test "$GCC" = yes; then + SHLIB_LD='${CC} -shared' CC_SEARCH_FLAGS='-Wl,-R,${LIB_RUNTIME_DIR}' LD_SEARCH_FLAGS=${CC_SEARCH_FLAGS} - if test "$do64bit_ok" = "yes" ; then + if test "$do64bit_ok" = yes; then + # We need to specify -static-libgcc or we need to # add the path to the sparv9 libgcc. SHLIB_LD="$SHLIB_LD -m64 -mcpu=v9 -static-libgcc" @@ -8220,8 +8473,12 @@ echo "$as_me: WARNING: 64bit mode not supported for $arch" >&2;} # path, remove so name and append 'sparcv9' #v9gcclibdir="`gcc -print-file-name=libgcc_s.so` | ..." #CC_SEARCH_FLAGS="${CC_SEARCH_FLAGS},-R,$v9gcclibdir" - fi - else + +fi + + +else + case $system in SunOS-5.[1-9][0-9]*) SHLIB_LD='${CC} -G -z text';; @@ -8230,7 +8487,9 @@ echo "$as_me: WARNING: 64bit mode not supported for $arch" >&2;} esac CC_SEARCH_FLAGS='-Wl,-R,${LIB_RUNTIME_DIR}' LD_SEARCH_FLAGS='-R ${LIB_RUNTIME_DIR}' - fi + +fi + ;; UNIX_SV* | UnixWare-5*) SHLIB_CFLAGS="-KPIC" @@ -8300,25 +8559,34 @@ fi echo "$as_me:$LINENO: result: $tcl_cv_ld_Bexport" >&5 echo "${ECHO_T}$tcl_cv_ld_Bexport" >&6 if test $tcl_cv_ld_Bexport = yes; then + LDFLAGS="$LDFLAGS -Wl,-Bexport" - fi + +fi + CC_SEARCH_FLAGS="" LD_SEARCH_FLAGS="" ;; esac - if test "$do64bit" = "yes" -a "$do64bit_ok" = "no" ; then + if test "$do64bit" = yes -a "$do64bit_ok" = no; then + { echo "$as_me:$LINENO: WARNING: 64bit support being disabled -- don't know magic for this platform" >&5 echo "$as_me: WARNING: 64bit support being disabled -- don't know magic for this platform" >&2;} - fi - if test "$do64bit" = "yes" -a "$do64bit_ok" = "yes" ; then +fi + + + if test "$do64bit" = yes -a "$do64bit_ok" = yes; then + cat >>confdefs.h <<\_ACEOF #define TCL_CFG_DO64BIT 1 _ACEOF - fi + +fi + @@ -8331,15 +8599,17 @@ if test "${enable_load+set}" = set; then else tcl_ok=yes fi; - if test "$tcl_ok" = "no"; then - DL_OBJS="" - fi + if test "$tcl_ok" = no; then + DL_OBJS="" +fi - if test "x$DL_OBJS" != "x" ; then - BUILD_DLTEST="\$(DLTEST_TARGETS)" - else - echo "Can't figure out how to do dynamic loading or shared libraries" - echo "on this system." + + if test "x$DL_OBJS" != x; then + BUILD_DLTEST="\$(DLTEST_TARGETS)" +else + + { echo "$as_me:$LINENO: WARNING: Can't figure out how to do dynamic loading or shared libraries on this system." >&5 +echo "$as_me: WARNING: Can't figure out how to do dynamic loading or shared libraries on this system." >&2;} SHLIB_CFLAGS="" SHLIB_LD="" SHLIB_SUFFIX="" @@ -8349,76 +8619,88 @@ fi; CC_SEARCH_FLAGS="" LD_SEARCH_FLAGS="" BUILD_DLTEST="" - fi + +fi + LDFLAGS="$LDFLAGS $LDFLAGS_ARCH" # If we're running gcc, then change the C flags for compiling shared # libraries to the right flags for gcc, instead of those for the # standard manufacturer compiler. - if test "$DL_OBJS" != "tclLoadNone.o" ; then - if test "$GCC" = "yes" ; then - case $system in - AIX-*) - ;; - BSD/OS*) - ;; - IRIX*) - ;; - NetBSD-*|FreeBSD-*) - ;; - Darwin-*) - ;; - SCO_SV-3.2*) - ;; - *) - SHLIB_CFLAGS="-fPIC" - ;; - esac - fi - fi + if test "$DL_OBJS" != "tclLoadNone.o" -a "$GCC" = yes; then + + case $system in + AIX-*) ;; + BSD/OS*) ;; + IRIX*) ;; + NetBSD-*|FreeBSD-*) ;; + Darwin-*) ;; + SCO_SV-3.2*) ;; + *) SHLIB_CFLAGS="-fPIC" ;; + esac +fi + + + if test "$SHARED_LIB_SUFFIX" = ""; then - if test "$SHARED_LIB_SUFFIX" = "" ; then SHARED_LIB_SUFFIX='${VERSION}${SHLIB_SUFFIX}' - fi - if test "$UNSHARED_LIB_SUFFIX" = "" ; then +fi + + if test "$UNSHARED_LIB_SUFFIX" = ""; then + UNSHARED_LIB_SUFFIX='${VERSION}.a' - fi +fi + + + if test "${SHARED_BUILD}" = 1 -a "${SHLIB_SUFFIX}" != ""; then - if test "${SHARED_BUILD}" = "1" && test "${SHLIB_SUFFIX}" != "" ; then LIB_SUFFIX=${SHARED_LIB_SUFFIX} MAKE_LIB='${SHLIB_LD} -o $@ ${OBJS} ${SHLIB_LD_LIBS} ${TCL_SHLIB_LD_EXTRAS} ${TK_SHLIB_LD_EXTRAS} ${LD_SEARCH_FLAGS}' INSTALL_LIB='$(INSTALL_LIBRARY) $(LIB_FILE) $(LIB_INSTALL_DIR)/$(LIB_FILE)' - else + +else + LIB_SUFFIX=${UNSHARED_LIB_SUFFIX} - if test "$RANLIB" = "" ; then + if test "$RANLIB" = ""; then + MAKE_LIB='$(STLIB_LD) $@ ${OBJS}' INSTALL_LIB='$(INSTALL_LIBRARY) $(LIB_FILE) $(LIB_INSTALL_DIR)/$(LIB_FILE)' - else + +else + MAKE_LIB='${STLIB_LD} $@ ${OBJS} ; ${RANLIB} $@' INSTALL_LIB='$(INSTALL_LIBRARY) $(LIB_FILE) $(LIB_INSTALL_DIR)/$(LIB_FILE) ; (cd $(LIB_INSTALL_DIR) ; $(RANLIB) $(LIB_FILE))' - fi - fi +fi + + +fi # Stub lib does not depend on shared/static configuration - if test "$RANLIB" = "" ; then + if test "$RANLIB" = ""; then + MAKE_STUB_LIB='${STLIB_LD} $@ ${STUB_LIB_OBJS}' INSTALL_STUB_LIB='$(INSTALL_LIBRARY) $(STUB_LIB_FILE) $(LIB_INSTALL_DIR)/$(STUB_LIB_FILE)' - else + +else + MAKE_STUB_LIB='${STLIB_LD} $@ ${STUB_LIB_OBJS} ; ${RANLIB} $@' INSTALL_STUB_LIB='$(INSTALL_LIBRARY) $(STUB_LIB_FILE) $(LIB_INSTALL_DIR)/$(STUB_LIB_FILE) ; (cd $(LIB_INSTALL_DIR) ; $(RANLIB) $(STUB_LIB_FILE))' - fi + +fi + # Define TCL_LIBS now that we know what DL_LIBS is. - # The trick here is that we don't want to change - # the value of TCL_LIBS if it is already set when - # tclConfig.sh had been loaded by Tk. - if test "x${TCL_LIBS}" = "x"; then + # The trick here is that we don't want to change the value of TCL_LIBS if + # it is already set when tclConfig.sh had been loaded by Tk. + if test "x${TCL_LIBS}" = x; then + TCL_LIBS="${DL_LIBS} ${LIBS} ${MATH_LIBS}" - fi +fi + # FIXME: This subst was left in only because the TCL_DL_LIBS @@ -10272,6 +10554,171 @@ _ACEOF fi +echo "$as_me:$LINENO: checking for getaddrinfo" >&5 +echo $ECHO_N "checking for getaddrinfo... $ECHO_C" >&6 +if test "${ac_cv_func_getaddrinfo+set}" = set; then + echo $ECHO_N "(cached) $ECHO_C" >&6 +else + cat >conftest.$ac_ext <<_ACEOF +/* confdefs.h. */ +_ACEOF +cat confdefs.h >>conftest.$ac_ext +cat >>conftest.$ac_ext <<_ACEOF +/* end confdefs.h. */ +/* Define getaddrinfo to an innocuous variant, in case <limits.h> declares getaddrinfo. + For example, HP-UX 11i <limits.h> declares gettimeofday. */ +#define getaddrinfo innocuous_getaddrinfo + +/* System header to define __stub macros and hopefully few prototypes, + which can conflict with char getaddrinfo (); below. + Prefer <limits.h> to <assert.h> if __STDC__ is defined, since + <limits.h> exists even on freestanding compilers. */ + +#ifdef __STDC__ +# include <limits.h> +#else +# include <assert.h> +#endif + +#undef getaddrinfo + +/* Override any gcc2 internal prototype to avoid an error. */ +#ifdef __cplusplus +extern "C" +{ +#endif +/* We use char because int might match the return type of a gcc2 + builtin and then its argument prototype would still apply. */ +char getaddrinfo (); +/* The GNU C library defines this for functions which it implements + to always fail with ENOSYS. Some functions are actually named + something starting with __ and the normal name is an alias. */ +#if defined (__stub_getaddrinfo) || defined (__stub___getaddrinfo) +choke me +#else +char (*f) () = getaddrinfo; +#endif +#ifdef __cplusplus +} +#endif + +int +main () +{ +return f != getaddrinfo; + ; + return 0; +} +_ACEOF +rm -f conftest.$ac_objext conftest$ac_exeext +if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 + (eval $ac_link) 2>conftest.er1 + ac_status=$? + grep -v '^ *+' conftest.er1 >conftest.err + rm -f conftest.er1 + cat conftest.err >&5 + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); } && + { ac_try='test -z "$ac_c_werror_flag" + || test ! -s conftest.err' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; } && + { ac_try='test -s conftest$ac_exeext' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; }; then + ac_cv_func_getaddrinfo=yes +else + echo "$as_me: failed program was:" >&5 +sed 's/^/| /' conftest.$ac_ext >&5 + +ac_cv_func_getaddrinfo=no +fi +rm -f conftest.err conftest.$ac_objext \ + conftest$ac_exeext conftest.$ac_ext +fi +echo "$as_me:$LINENO: result: $ac_cv_func_getaddrinfo" >&5 +echo "${ECHO_T}$ac_cv_func_getaddrinfo" >&6 +if test $ac_cv_func_getaddrinfo = yes; then + + echo "$as_me:$LINENO: checking for working getaddrinfo" >&5 +echo $ECHO_N "checking for working getaddrinfo... $ECHO_C" >&6 +if test "${tcl_cv_api_getaddrinfo+set}" = set; then + echo $ECHO_N "(cached) $ECHO_C" >&6 +else + + cat >conftest.$ac_ext <<_ACEOF +/* confdefs.h. */ +_ACEOF +cat confdefs.h >>conftest.$ac_ext +cat >>conftest.$ac_ext <<_ACEOF +/* end confdefs.h. */ + + #include <netdb.h> + +int +main () +{ + + const char *name, *port; + struct addrinfo *aiPtr, hints; + (void)getaddrinfo(name,port, &hints, &aiPtr); + (void)freeaddrinfo(aiPtr); + + ; + return 0; +} +_ACEOF +rm -f conftest.$ac_objext +if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 + (eval $ac_compile) 2>conftest.er1 + ac_status=$? + grep -v '^ *+' conftest.er1 >conftest.err + rm -f conftest.er1 + cat conftest.err >&5 + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); } && + { ac_try='test -z "$ac_c_werror_flag" + || test ! -s conftest.err' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; } && + { ac_try='test -s conftest.$ac_objext' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; }; then + tcl_cv_api_getaddrinfo=yes +else + echo "$as_me: failed program was:" >&5 +sed 's/^/| /' conftest.$ac_ext >&5 + +tcl_cv_getaddrinfo=no +fi +rm -f conftest.err conftest.$ac_objext conftest.$ac_ext +fi +echo "$as_me:$LINENO: result: $tcl_cv_api_getaddrinfo" >&5 +echo "${ECHO_T}$tcl_cv_api_getaddrinfo" >&6 + tcl_ok=$tcl_cv_api_getaddrinfo + if test "$tcl_ok" = yes; then + +cat >>confdefs.h <<\_ACEOF +#define HAVE_GETADDRINFO 1 +_ACEOF + + fi + +fi + + #-------------------------------------------------------------------- # Look for thread-safe variants of some library functions. #-------------------------------------------------------------------- @@ -17900,8 +18347,8 @@ echo "${ECHO_T}$tcl_ok" >&6 # Does the C stack grow upwards or downwards? Or cross-compiling? #-------------------------------------------------------------------- -echo "$as_me:$LINENO: checking does the C stack grow upwards in memory?" >&5 -echo $ECHO_N "checking does the C stack grow upwards in memory?... $ECHO_C" >&6 +echo "$as_me:$LINENO: checking if the C stack grows upwards in memory" >&5 +echo $ECHO_N "checking if the C stack grows upwards in memory... $ECHO_C" >&6 if test "${tcl_cv_stack_grows_up+set}" = set; then echo $ECHO_N "(cached) $ECHO_C" >&6 else @@ -17916,14 +18363,11 @@ cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ - int StackGrowsUp(int *parent) - { + int StackGrowsUp(int *parent) { int here; return (&here < parent); } - - int main (int argc, char *argv[]) - { + int main (int argc, char *argv[]) { int foo; return StackGrowsUp(&foo); } diff --git a/unix/configure.in b/unix/configure.in index 272e466..8f4d212 100644 --- a/unix/configure.in +++ b/unix/configure.in @@ -3,7 +3,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. # -# RCS: @(#) $Id: configure.in,v 1.157.2.9 2007/11/12 19:18:23 dgp Exp $ +# RCS: @(#) $Id: configure.in,v 1.157.2.10 2007/11/16 07:20:57 dgp Exp $ AC_INIT([tcl],[8.5]) AC_PREREQ(2.59) @@ -165,6 +165,8 @@ if test "`uname -s`" = "Darwin" && test "${TCL_THREADS}" = 1 && \ fi AC_CHECK_FUNC(realpath, , [AC_DEFINE(NO_REALPATH, 1, [Do we have realpath()])]) +SC_TCL_GETADDRINFO + #-------------------------------------------------------------------- # Look for thread-safe variants of some library functions. #-------------------------------------------------------------------- @@ -661,29 +663,22 @@ AC_MSG_RESULT([$tcl_ok]) # Does the C stack grow upwards or downwards? Or cross-compiling? #-------------------------------------------------------------------- -AC_CACHE_CHECK([does the C stack grow upwards in memory?], tcl_cv_stack_grows_up, [ +AC_CACHE_CHECK([if the C stack grows upwards in memory], tcl_cv_stack_grows_up, [ AC_TRY_RUN([ - int StackGrowsUp(int *parent) - { + int StackGrowsUp(int *parent) { int here; return (&here < parent); } - - int main (int argc, char *argv[]) - { + int main (int argc, char *argv[]) { int foo; return StackGrowsUp(&foo); } - ], - tcl_cv_stack_grows_up=yes, - tcl_cv_stack_grows_up=no, + ], tcl_cv_stack_grows_up=yes, tcl_cv_stack_grows_up=no, tcl_cv_stack_grows_up=unknown)]) if test $tcl_cv_stack_grows_up = unknown; then - AC_DEFINE(TCL_CROSS_COMPILE, 1, - [Are we cross-compiling?]) + AC_DEFINE(TCL_CROSS_COMPILE, 1, [Are we cross-compiling?]) elif test $tcl_cv_stack_grows_up = yes; then - AC_DEFINE(TCL_STACK_GROWS_UP, 1, - [The C stack grows upwards in memory]) + AC_DEFINE(TCL_STACK_GROWS_UP, 1, [The C stack grows upwards in memory.]) fi #-------------------------------------------------------------------- diff --git a/unix/tcl.m4 b/unix/tcl.m4 index 73c1606..5b6f6eb 100644 --- a/unix/tcl.m4 +++ b/unix/tcl.m4 @@ -1080,11 +1080,8 @@ AC_DEFUN([SC_CONFIG_CFLAGS], [ [enable 64bit Sparc VIS support (default: off)]), [do64bitVIS=$enableval], [do64bitVIS=no]) AC_MSG_RESULT([$do64bitVIS]) - - if test "$do64bitVIS" = "yes"; then - # Force 64bit on with VIS - do64bit=yes - fi + # Force 64bit on with VIS + AS_IF([test "$do64bitVIS" = "yes"], [do64bit=yes]) # Step 0.c: Check if visibility support is available. Do this here so # that platform specific alternatives can be used below if this fails. @@ -1097,11 +1094,20 @@ AC_DEFUN([SC_CONFIG_CFLAGS], [ void f(void) {}], [f();], tcl_cv_cc_visibility_hidden=yes, tcl_cv_cc_visibility_hidden=no) CFLAGS=$hold_cflags]) - if test $tcl_cv_cc_visibility_hidden = yes; then + AS_IF([test $tcl_cv_cc_visibility_hidden = yes], [ AC_DEFINE(MODULE_SCOPE, [extern __attribute__((__visibility__("hidden")))], [Compiler support for module scope symbols]) - fi + ]) + + # Step 0.d: Disable -rpath support? + + AC_MSG_CHECKING([if rpath support is requested]) + AC_ARG_ENABLE(rpath, + AC_HELP_STRING([--disable-rpath], + [disable rpath support (default: on)]), + [doRpath=$enableval], [doRpath=yes]) + AC_MSG_RESULT([$doRpath]) # Step 1: set the variable "system" to hold the name and version number # for the system. @@ -1132,27 +1138,25 @@ AC_DEFUN([SC_CONFIG_CFLAGS], [ TCL_LIB_VERSIONS_OK=ok CFLAGS_DEBUG=-g CFLAGS_OPTIMIZE=-O - if test "$GCC" = "yes" ; then + AS_IF([test "$GCC" = yes], [ CFLAGS_WARNING="-Wall -Wno-implicit-int" - else - CFLAGS_WARNING="" - fi + ], [CFLAGS_WARNING=""]) TCL_NEEDS_EXP_FILE=0 TCL_BUILD_EXP_FILE="" TCL_EXP_FILE="" dnl FIXME: Replace AC_CHECK_PROG with AC_CHECK_TOOL once cross compiling is fixed. dnl AC_CHECK_TOOL(AR, ar) AC_CHECK_PROG(AR, ar, ar) - if test "${AR}" = "" ; then + AS_IF([test "${AR}" = ""], [ AC_MSG_ERROR([Required archive tool 'ar' not found on PATH.]) - fi + ]) STLIB_LD='${AR} cr' LD_LIBRARY_PATH_VAR="LD_LIBRARY_PATH" PLAT_OBJS="" PLAT_SRCS="" case $system in AIX-*) - if test "${TCL_THREADS}" = "1" -a "$GCC" != "yes" ; then + AS_IF([test "${TCL_THREADS}" = "1" -a "$GCC" != "yes"], [ # AIX requires the _r compiler when gcc isn't being used case "${CC}" in *_r) @@ -1163,7 +1167,7 @@ dnl AC_CHECK_TOOL(AR, ar) ;; esac AC_MSG_RESULT([Using $CC for compiling with threads]) - fi + ]) LIBS="$LIBS -lc" SHLIB_CFLAGS="" # Note: need the LIBS below, otherwise Tk won't find Tcl's @@ -1175,49 +1179,47 @@ dnl AC_CHECK_TOOL(AR, ar) LD_LIBRARY_PATH_VAR="LIBPATH" # Check to enable 64-bit flags for compiler/linker on AIX 4+ - if test "$do64bit" = "yes" -a "`uname -v`" -gt "3" ; then - if test "$GCC" = "yes" ; then + AS_IF([test "$do64bit" = yes -a "`uname -v`" -gt 3], [ + AS_IF([test "$GCC" = yes], [ AC_MSG_WARN([64bit mode not supported with GCC on $system]) - else + ], [ do64bit_ok=yes CFLAGS="$CFLAGS -q64" LDFLAGS_ARCH="-q64" RANLIB="${RANLIB} -X64" AR="${AR} -X64" SHLIB_LD_FLAGS="-b64" - fi - fi + ]) + ]) - if test "`uname -m`" = "ia64" ; then + AS_IF([test "`uname -m`" = ia64], [ # AIX-5 uses ELF style dynamic libraries on IA-64, but not PPC SHLIB_LD="/usr/ccs/bin/ld -G -z text" # AIX-5 has dl* in libc.so DL_LIBS="" - if test "$GCC" = "yes" ; then + AS_IF([test "$GCC" = yes], [ CC_SEARCH_FLAGS='-Wl,-R,${LIB_RUNTIME_DIR}' - else + ], [ CC_SEARCH_FLAGS='-R${LIB_RUNTIME_DIR}' - fi + ]) LD_SEARCH_FLAGS='-R ${LIB_RUNTIME_DIR}' - else - if test "$GCC" = "yes" ; then - SHLIB_LD='${CC} -shared' - else + ], [ + AS_IF([test "$GCC" = yes], [SHLIB_LD='${CC} -shared'], [ SHLIB_LD="/bin/ld -bhalt:4 -bM:SRE -bE:lib.exp -H512 -T512 -bnoentry" - fi + ]) SHLIB_LD="${TCL_SRC_DIR}/unix/ldAix ${SHLIB_LD} ${SHLIB_LD_FLAGS}" DL_LIBS="-ldl" CC_SEARCH_FLAGS='-L${LIB_RUNTIME_DIR}' LD_SEARCH_FLAGS=${CC_SEARCH_FLAGS} TCL_NEEDS_EXP_FILE=1 TCL_EXPORT_FILE_SUFFIX='${VERSION}.exp' - fi + ]) # AIX v<=4.1 has some different flags than 4.2+ - if test "$system" = "AIX-4.1" -o "`uname -v`" -lt "4" ; then + AS_IF([test "$system" = "AIX-4.1" -o "`uname -v`" -lt 4], [ AC_LIBOBJ([tclLoadAix]) DL_LIBS="-lld" - fi + ]) # On AIX <=v4 systems, libbsd.a has to be linked in to support # non-blocking file IO. This library has to be linked in after @@ -1232,10 +1234,10 @@ dnl AC_CHECK_TOOL(AR, ar) # known GMT value. AC_CHECK_LIB(bsd, gettimeofday, libbsd=yes, libbsd=no) - if test $libbsd = yes; then + AS_IF([test $libbsd = yes], [ MATH_LIBS="$MATH_LIBS -lbsd" AC_DEFINE(USE_DELTA_FOR_TZ, 1, [Do we need a special AIX hack for timezones?]) - fi + ]) ;; BeOS*) SHLIB_CFLAGS="-fPIC" @@ -1289,13 +1291,13 @@ dnl AC_CHECK_TOOL(AR, ar) AC_DEFINE(_XOPEN_SOURCE_EXTENDED, 1, [Do we want to use the XOPEN network library?]) LIBS="$LIBS -lxnet" # Use the XOPEN network library - if test "`uname -m`" = "ia64" ; then + AS_IF([test "`uname -m`" = ia64], [ SHLIB_SUFFIX=".so" - else + ], [ SHLIB_SUFFIX=".sl" - fi + ]) AC_CHECK_LIB(dld, shl_load, tcl_ok=yes, tcl_ok=no) - if test "$tcl_ok" = yes; then + AS_IF([test "$tcl_ok" = yes], [ SHLIB_CFLAGS="+z" SHLIB_LD="ld -b" SHLIB_LD_LIBS='${LIBS}' @@ -1305,44 +1307,43 @@ dnl AC_CHECK_TOOL(AR, ar) CC_SEARCH_FLAGS='-Wl,+s,+b,${LIB_RUNTIME_DIR}:.' LD_SEARCH_FLAGS='+s +b ${LIB_RUNTIME_DIR}:.' LD_LIBRARY_PATH_VAR="SHLIB_PATH" - fi - if test "$GCC" = "yes" ; then + ]) + AS_IF([test "$GCC" = yes], [ SHLIB_LD='${CC} -shared' SHLIB_LD_LIBS='${LIBS}' LD_SEARCH_FLAGS=${CC_SEARCH_FLAGS} - fi + ]) # Users may want PA-RISC 1.1/2.0 portable code - needs HP cc #CFLAGS="$CFLAGS +DAportable" # Check to enable 64-bit flags for compiler/linker - if test "$do64bit" = "yes" ; then - if test "$GCC" = "yes" ; then - hpux_arch=`${CC} -dumpmachine` - case $hpux_arch in + AS_IF([test "$do64bit" = "yes"], [ + AS_IF([test "$GCC" = yes], [ + case `${CC} -dumpmachine` in hppa64*) # 64-bit gcc in use. Fix flags for GNU ld. do64bit_ok=yes SHLIB_LD='${CC} -shared' SHLIB_LD_LIBS='${LIBS}' - CC_SEARCH_FLAGS='-Wl,-rpath,${LIB_RUNTIME_DIR}' + AS_IF([test $doRpath = yes], [ + CC_SEARCH_FLAGS='-Wl,-rpath,${LIB_RUNTIME_DIR}']) LD_SEARCH_FLAGS=${CC_SEARCH_FLAGS} ;; *) AC_MSG_WARN([64bit mode not supported with GCC on $system]) ;; esac - else + ], [ do64bit_ok=yes CFLAGS="$CFLAGS +DD64" LDFLAGS_ARCH="+DD64" - fi - fi - ;; + ]) + ]) ;; HP-UX-*.08.*|HP-UX-*.09.*|HP-UX-*.10.*) SHLIB_SUFFIX=".sl" AC_CHECK_LIB(dld, shl_load, tcl_ok=yes, tcl_ok=no) - if test "$tcl_ok" = yes; then + AS_IF([test "$tcl_ok" = yes], [ SHLIB_CFLAGS="+z" SHLIB_LD="ld -b" SHLIB_LD_LIBS="" @@ -1352,8 +1353,7 @@ dnl AC_CHECK_TOOL(AR, ar) CC_SEARCH_FLAGS='-Wl,+s,+b,${LIB_RUNTIME_DIR}:.' LD_SEARCH_FLAGS='+s +b ${LIB_RUNTIME_DIR}:.' LD_LIBRARY_PATH_VAR="SHLIB_PATH" - fi - ;; + ]) ;; IRIX-5.*) SHLIB_CFLAGS="" SHLIB_LD="ld -shared -rdata_shared" @@ -1361,8 +1361,9 @@ dnl AC_CHECK_TOOL(AR, ar) SHLIB_SUFFIX=".so" DL_OBJS="tclLoadDl.o" DL_LIBS="" - CC_SEARCH_FLAGS='-Wl,-rpath,${LIB_RUNTIME_DIR}' - LD_SEARCH_FLAGS='-rpath ${LIB_RUNTIME_DIR}' + AS_IF([test $doRpath = yes], [ + CC_SEARCH_FLAGS='-Wl,-rpath,${LIB_RUNTIME_DIR}' + LD_SEARCH_FLAGS='-rpath ${LIB_RUNTIME_DIR}']) ;; IRIX-6.*) SHLIB_CFLAGS="" @@ -1371,12 +1372,13 @@ dnl AC_CHECK_TOOL(AR, ar) SHLIB_SUFFIX=".so" DL_OBJS="tclLoadDl.o" DL_LIBS="" - CC_SEARCH_FLAGS='-Wl,-rpath,${LIB_RUNTIME_DIR}' - LD_SEARCH_FLAGS='-rpath ${LIB_RUNTIME_DIR}' - if test "$GCC" = "yes" ; then + AS_IF([test $doRpath = yes], [ + CC_SEARCH_FLAGS='-Wl,-rpath,${LIB_RUNTIME_DIR}' + LD_SEARCH_FLAGS='-rpath ${LIB_RUNTIME_DIR}']) + AS_IF([test "$GCC" = yes], [ CFLAGS="$CFLAGS -mabi=n32" LDFLAGS="$LDFLAGS -mabi=n32" - else + ], [ case $system in IRIX-6.3) # Use to build 6.2 compatible binaries on 6.3. @@ -1387,7 +1389,7 @@ dnl AC_CHECK_TOOL(AR, ar) ;; esac LDFLAGS="$LDFLAGS -n32" - fi + ]) ;; IRIX64-6.*) SHLIB_CFLAGS="" @@ -1396,21 +1398,22 @@ dnl AC_CHECK_TOOL(AR, ar) SHLIB_SUFFIX=".so" DL_OBJS="tclLoadDl.o" DL_LIBS="" - CC_SEARCH_FLAGS='-Wl,-rpath,${LIB_RUNTIME_DIR}' - LD_SEARCH_FLAGS='-rpath ${LIB_RUNTIME_DIR}' + AS_IF([test $doRpath = yes], [ + CC_SEARCH_FLAGS='-Wl,-rpath,${LIB_RUNTIME_DIR}' + LD_SEARCH_FLAGS='-rpath ${LIB_RUNTIME_DIR}']) # Check to enable 64-bit flags for compiler/linker - if test "$do64bit" = "yes" ; then - if test "$GCC" = "yes" ; then + AS_IF([test "$do64bit" = yes], [ + AS_IF([test "$GCC" = yes], [ AC_MSG_WARN([64bit mode not supported by gcc]) - else + ], [ do64bit_ok=yes SHLIB_LD="ld -64 -shared -rdata_shared" CFLAGS="$CFLAGS -64" LDFLAGS_ARCH="-64" - fi - fi + ]) + ]) ;; Linux*) SHLIB_CFLAGS="-fPIC" @@ -1427,33 +1430,29 @@ dnl AC_CHECK_TOOL(AR, ar) DL_OBJS="tclLoadDl.o" DL_LIBS="-ldl" LDFLAGS="$LDFLAGS -Wl,--export-dynamic" - CC_SEARCH_FLAGS='-Wl,-rpath,${LIB_RUNTIME_DIR}' + AS_IF([test $doRpath = yes], [ + CC_SEARCH_FLAGS='-Wl,-rpath,${LIB_RUNTIME_DIR}']) LD_SEARCH_FLAGS=${CC_SEARCH_FLAGS} - if test "`uname -m`" = "alpha" ; then - CFLAGS="$CFLAGS -mieee" - fi - if test $do64bit = yes; then + AS_IF([test "`uname -m`" = "alpha"], [CFLAGS="$CFLAGS -mieee"]) + AS_IF([test $do64bit = yes], [ AC_CACHE_CHECK([if compiler accepts -m64 flag], tcl_cv_cc_m64, [ hold_cflags=$CFLAGS CFLAGS="$CFLAGS -m64" AC_TRY_LINK(,, tcl_cv_cc_m64=yes, tcl_cv_cc_m64=no) CFLAGS=$hold_cflags]) - if test $tcl_cv_cc_m64 = yes; then + AS_IF([test $tcl_cv_cc_m64 = yes], [ CFLAGS="$CFLAGS -m64" do64bit_ok=yes - fi - fi + ]) + ]) - # The combo of gcc + glibc has a bug related - # to inlining of functions like strtod(). The - # -fno-builtin flag should address this problem - # but it does not work. The -fno-inline flag - # is kind of overkill but it works. - # Disable inlining only when one of the + # The combo of gcc + glibc has a bug related to inlining of + # functions like strtod(). The -fno-builtin flag should address + # this problem but it does not work. The -fno-inline flag is kind + # of overkill but it works. Disable inlining only when one of the # files in compat/*.c is being linked in. - if test x"${USE_COMPAT}" != x ; then - CFLAGS="$CFLAGS -fno-inline" - fi + + AS_IF([test x"${USE_COMPAT}" != x],[CFLAGS="$CFLAGS -fno-inline"]) # XIM peeking works under XFree86. AC_DEFINE(PEEK_XCLOSEIM, 1, [May we use XIM peeking safely?]) @@ -1470,9 +1469,7 @@ dnl AC_CHECK_TOOL(AR, ar) LDFLAGS="$LDFLAGS -Wl,--export-dynamic" CC_SEARCH_FLAGS="" LD_SEARCH_FLAGS="" - if test "`uname -m`" = "alpha" ; then - CFLAGS="$CFLAGS -mieee" - fi + AS_IF([test "`uname -m`" = "alpha"], [CFLAGS="$CFLAGS -mieee"]) ;; Lynx*) SHLIB_CFLAGS="-fPIC" @@ -1483,8 +1480,9 @@ dnl AC_CHECK_TOOL(AR, ar) DL_OBJS="tclLoadDl.o" DL_LIBS="-mshared -ldl" LD_FLAGS="-Wl,--export-dynamic" - CC_SEARCH_FLAGS='-Wl,-rpath,${LIB_RUNTIME_DIR}' - LD_SEARCH_FLAGS='-Wl,-rpath,${LIB_RUNTIME_DIR}' + AS_IF([test $doRpath = yes], [ + CC_SEARCH_FLAGS='-Wl,-rpath,${LIB_RUNTIME_DIR}' + LD_SEARCH_FLAGS='-Wl,-rpath,${LIB_RUNTIME_DIR}']) ;; MP-RAS-02*) SHLIB_CFLAGS="-K PIC" @@ -1514,19 +1512,20 @@ dnl AC_CHECK_TOOL(AR, ar) SHLIB_SUFFIX=".so" DL_OBJS="tclLoadDl.o" DL_LIBS="" - CC_SEARCH_FLAGS='-Wl,-rpath,${LIB_RUNTIME_DIR}' - LD_SEARCH_FLAGS='-rpath ${LIB_RUNTIME_DIR}' + AS_IF([test $doRpath = yes], [ + CC_SEARCH_FLAGS='-Wl,-rpath,${LIB_RUNTIME_DIR}' + LD_SEARCH_FLAGS='-rpath ${LIB_RUNTIME_DIR}']) AC_CACHE_CHECK([for ELF], tcl_cv_ld_elf, [ AC_EGREP_CPP(yes, [ #ifdef __ELF__ yes #endif ], tcl_cv_ld_elf=yes, tcl_cv_ld_elf=no)]) - if test $tcl_cv_ld_elf = yes; then + AS_IF([test $tcl_cv_ld_elf = yes], [ SHARED_LIB_SUFFIX='${TCL_TRIM_DOTS}.so' - else + ], [ SHARED_LIB_SUFFIX='${TCL_TRIM_DOTS}.so.1.0' - fi + ]) # Ancient FreeBSD doesn't handle version numbers with dots. @@ -1540,7 +1539,8 @@ dnl AC_CHECK_TOOL(AR, ar) SHLIB_SUFFIX=".so" DL_OBJS="tclLoadDl.o" DL_LIBS="" - CC_SEARCH_FLAGS='-Wl,-rpath,${LIB_RUNTIME_DIR}' + AS_IF([test $doRpath = yes], [ + CC_SEARCH_FLAGS='-Wl,-rpath,${LIB_RUNTIME_DIR}']) LD_SEARCH_FLAGS=${CC_SEARCH_FLAGS} SHARED_LIB_SUFFIX='${TCL_TRIM_DOTS}.so.1.0' AC_CACHE_CHECK([for ELF], tcl_cv_ld_elf, [ @@ -1549,11 +1549,9 @@ dnl AC_CHECK_TOOL(AR, ar) yes #endif ], tcl_cv_ld_elf=yes, tcl_cv_ld_elf=no)]) - if test $tcl_cv_ld_elf = yes; then + AS_IF([test $tcl_cv_ld_elf = yes], [ LDFLAGS=-Wl,-export-dynamic - else - LDFLAGS="" - fi + ], [LDFLAGS=""]) # OpenBSD doesn't do version numbers with dots. UNSHARED_LIB_SUFFIX='${TCL_TRIM_DOTS}.a' @@ -1569,14 +1567,15 @@ dnl AC_CHECK_TOOL(AR, ar) DL_OBJS="tclLoadDl.o" DL_LIBS="" LDFLAGS="$LDFLAGS -export-dynamic" - CC_SEARCH_FLAGS='-Wl,-rpath,${LIB_RUNTIME_DIR}' + AS_IF([test $doRpath = yes], [ + CC_SEARCH_FLAGS='-Wl,-rpath,${LIB_RUNTIME_DIR}']) LD_SEARCH_FLAGS=${CC_SEARCH_FLAGS} - if test "${TCL_THREADS}" = "1" ; then + AS_IF([test "${TCL_THREADS}" = "1"], [ # The -pthread needs to go in the CFLAGS, not LIBS LIBS=`echo $LIBS | sed s/-pthread//` CFLAGS="$CFLAGS -pthread" LDFLAGS="$LDFLAGS -pthread" - fi + ]) case $system in FreeBSD-3.*) # FreeBSD-3 doesn't handle version numbers with dots. @@ -1598,7 +1597,7 @@ dnl AC_CHECK_TOOL(AR, ar) CFLAGS="`echo " ${CFLAGS}" | \ awk 'BEGIN {FS=" +-";ORS=" "}; {for (i=2;i<=NF;i++) \ if (!([$]i~/^(isysroot|mmacosx-version-min)/)) print "-"[$]i}'`" - if test $do64bit = yes; then + AS_IF([test $do64bit = yes], [ case `arch` in ppc) AC_CACHE_CHECK([if compiler accepts -arch ppc64 flag], @@ -1608,10 +1607,10 @@ dnl AC_CHECK_TOOL(AR, ar) AC_TRY_LINK(,, tcl_cv_cc_arch_ppc64=yes, tcl_cv_cc_arch_ppc64=no) CFLAGS=$hold_cflags]) - if test $tcl_cv_cc_arch_ppc64 = yes; then + AS_IF([test $tcl_cv_cc_arch_ppc64 = yes], [ CFLAGS="$CFLAGS -arch ppc64 -mpowerpc64 -mcpu=G5" do64bit_ok=yes - fi;; + ]);; i386) AC_CACHE_CHECK([if compiler accepts -arch x86_64 flag], tcl_cv_cc_arch_x86_64, [ @@ -1620,45 +1619,47 @@ dnl AC_CHECK_TOOL(AR, ar) AC_TRY_LINK(,, tcl_cv_cc_arch_x86_64=yes, tcl_cv_cc_arch_x86_64=no) CFLAGS=$hold_cflags]) - if test $tcl_cv_cc_arch_x86_64 = yes; then + AS_IF([test $tcl_cv_cc_arch_x86_64 = yes], [ CFLAGS="$CFLAGS -arch x86_64" do64bit_ok=yes - fi;; + ]);; *) AC_MSG_WARN([Don't know how enable 64-bit on architecture `arch`]);; esac - else + ], [ # Check for combined 32-bit and 64-bit fat build - echo "$CFLAGS " | grep -E -q -- '-arch (ppc64|x86_64) ' && \ - echo "$CFLAGS " | grep -E -q -- '-arch (ppc|i386) ' && \ - fat_32_64=yes - fi + AS_IF([echo "$CFLAGS " |grep -E -q -- '-arch (ppc64|x86_64) ' \ + && echo "$CFLAGS " |grep -E -q -- '-arch (ppc|i386) '], [ + fat_32_64=yes]) + ]) SHLIB_LD='${CC} -dynamiclib ${CFLAGS} ${LDFLAGS}' AC_CACHE_CHECK([if ld accepts -single_module flag], tcl_cv_ld_single_module, [ hold_ldflags=$LDFLAGS LDFLAGS="$LDFLAGS -dynamiclib -Wl,-single_module" AC_TRY_LINK(, [int i;], tcl_cv_ld_single_module=yes, tcl_cv_ld_single_module=no) LDFLAGS=$hold_ldflags]) - if test $tcl_cv_ld_single_module = yes; then + AS_IF([test $tcl_cv_ld_single_module = yes], [ SHLIB_LD="${SHLIB_LD} -Wl,-single_module" - fi + ]) SHLIB_LD_LIBS='${LIBS}' SHLIB_SUFFIX=".dylib" DL_OBJS="tclLoadDyld.o" DL_LIBS="" # Don't use -prebind when building for Mac OS X 10.4 or later only: - test "`echo "${MACOSX_DEPLOYMENT_TARGET}" | awk -F '10\\.' '{print int([$]2)}'`" -lt 4 -a \ - "`echo "${CPPFLAGS}" | awk -F '-mmacosx-version-min=10\\.' '{print int([$]2)}'`" -lt 4 && \ - LDFLAGS="$LDFLAGS -prebind" + AS_IF([test "`echo "${MACOSX_DEPLOYMENT_TARGET}" | awk -F '10\\.' '{print int([$]2)}'`" -lt 4 -a \ + "`echo "${CPPFLAGS}" | awk -F '-mmacosx-version-min=10\\.' '{print int([$]2)}'`" -lt 4], [ + LDFLAGS="$LDFLAGS -prebind"]) LDFLAGS="$LDFLAGS -headerpad_max_install_names" - AC_CACHE_CHECK([if ld accepts -search_paths_first flag], tcl_cv_ld_search_paths_first, [ + AC_CACHE_CHECK([if ld accepts -search_paths_first flag], + tcl_cv_ld_search_paths_first, [ hold_ldflags=$LDFLAGS LDFLAGS="$LDFLAGS -Wl,-search_paths_first" - AC_TRY_LINK(, [int i;], tcl_cv_ld_search_paths_first=yes, tcl_cv_ld_search_paths_first=no) + AC_TRY_LINK(, [int i;], tcl_cv_ld_search_paths_first=yes, + tcl_cv_ld_search_paths_first=no) LDFLAGS=$hold_ldflags]) - if test $tcl_cv_ld_search_paths_first = yes; then + AS_IF([test $tcl_cv_ld_search_paths_first = yes], [ LDFLAGS="$LDFLAGS -Wl,-search_paths_first" - fi + ]) CC_SEARCH_FLAGS="" LD_SEARCH_FLAGS="" LD_LIBRARY_PATH_VAR="DYLD_LIBRARY_PATH" @@ -1670,51 +1671,57 @@ dnl AC_CHECK_TOOL(AR, ar) [use CoreFoundation API on MacOSX (default: on)]), [tcl_corefoundation=$enableval], [tcl_corefoundation=yes]) AC_MSG_RESULT([$tcl_corefoundation]) - if test $tcl_corefoundation = yes; then - AC_CACHE_CHECK([for CoreFoundation.framework], tcl_cv_lib_corefoundation, [ + AS_IF([test $tcl_corefoundation = yes], [ + AC_CACHE_CHECK([for CoreFoundation.framework], + tcl_cv_lib_corefoundation, [ hold_libs=$LIBS - if test "$fat_32_64" = yes; then for v in CFLAGS CPPFLAGS LDFLAGS; do - # On Tiger there is no 64-bit CF, so remove 64-bit archs - # from CFLAGS et al. while testing for presence of CF. - # 64-bit CF is disabled in tclUnixPort.h if necessary. - eval 'hold_'$v'="$'$v'";'$v'="`echo "$'$v' "|sed -e "s/-arch ppc64 / /g" -e "s/-arch x86_64 / /g"`"' - done; fi + AS_IF([test "$fat_32_64" = yes], [ + for v in CFLAGS CPPFLAGS LDFLAGS; do + # On Tiger there is no 64-bit CF, so remove 64-bit + # archs from CFLAGS et al. while testing for + # presence of CF. 64-bit CF is disabled in + # tclUnixPort.h if necessary. + eval 'hold_'$v'="$'$v'";'$v'="`echo "$'$v' "|sed -e "s/-arch ppc64 / /g" -e "s/-arch x86_64 / /g"`"' + done]) LIBS="$LIBS -framework CoreFoundation" AC_TRY_LINK([#include <CoreFoundation/CoreFoundation.h>], [CFBundleRef b = CFBundleGetMainBundle();], - tcl_cv_lib_corefoundation=yes, tcl_cv_lib_corefoundation=no) - if test "$fat_32_64" = yes; then for v in CFLAGS CPPFLAGS LDFLAGS; do - eval $v'="$hold_'$v'"' - done; fi; LIBS=$hold_libs]) - if test $tcl_cv_lib_corefoundation = yes; then + tcl_cv_lib_corefoundation=yes, + tcl_cv_lib_corefoundation=no) + AS_IF([test "$fat_32_64" = yes], [ + for v in CFLAGS CPPFLAGS LDFLAGS; do + eval $v'="$hold_'$v'"' + done]) + LIBS=$hold_libs]) + AS_IF([test $tcl_cv_lib_corefoundation = yes], [ LIBS="$LIBS -framework CoreFoundation" AC_DEFINE(HAVE_COREFOUNDATION, 1, [Do we have access to Darwin CoreFoundation.framework?]) - else - tcl_corefoundation=no - fi - if test "$fat_32_64" = yes -a $tcl_corefoundation = yes; then - AC_CACHE_CHECK([for 64-bit CoreFoundation], tcl_cv_lib_corefoundation_64, [ + ], [tcl_corefoundation=no]) + AS_IF([test "$fat_32_64" = yes -a $tcl_corefoundation = yes],[ + AC_CACHE_CHECK([for 64-bit CoreFoundation], + tcl_cv_lib_corefoundation_64, [ for v in CFLAGS CPPFLAGS LDFLAGS; do eval 'hold_'$v'="$'$v'";'$v'="`echo "$'$v' "|sed -e "s/-arch ppc / /g" -e "s/-arch i386 / /g"`"' done AC_TRY_LINK([#include <CoreFoundation/CoreFoundation.h>], [CFBundleRef b = CFBundleGetMainBundle();], - tcl_cv_lib_corefoundation_64=yes, tcl_cv_lib_corefoundation_64=no) + tcl_cv_lib_corefoundation_64=yes, + tcl_cv_lib_corefoundation_64=no) for v in CFLAGS CPPFLAGS LDFLAGS; do eval $v'="$hold_'$v'"' done]) - if test $tcl_cv_lib_corefoundation_64 = no; then + AS_IF([test $tcl_cv_lib_corefoundation_64 = no], [ AC_DEFINE(NO_COREFOUNDATION_64, 1, [Is Darwin CoreFoundation unavailable for 64-bit?]) LDFLAGS="$LDFLAGS -Wl,-no_arch_warnings" - fi - fi - fi - if test "$tcl_cv_cc_visibility_hidden" != yes; then + ]) + ]) + ]) + AS_IF([test "$tcl_cv_cc_visibility_hidden" != yes], [ AC_DEFINE(MODULE_SCOPE, [__private_extern__], [Compiler support for module scope symbols]) - fi + ]) AC_DEFINE(MAC_OSX_TCL, 1, [Is this a Mac I see before me?]) ;; NEXTSTEP-*) @@ -1747,11 +1754,9 @@ dnl AC_CHECK_TOOL(AR, ar) OSF1-1.*) # OSF/1 1.3 from OSF using ELF, and derivatives, including AD2 SHLIB_CFLAGS="-fPIC" - if test "$SHARED_BUILD" = "1" ; then - SHLIB_LD="ld -shared" - else + AS_IF([test "$SHARED_BUILD" = 1], [SHLIB_LD="ld -shared"], [ SHLIB_LD="ld -non_shared" - fi + ]) SHLIB_LD_LIBS="" SHLIB_SUFFIX=".so" DL_OBJS="tclLoadDl.o" @@ -1762,35 +1767,32 @@ dnl AC_CHECK_TOOL(AR, ar) OSF1-V*) # Digital OSF/1 SHLIB_CFLAGS="" - if test "$SHARED_BUILD" = "1" ; then + AS_IF([test "$SHARED_BUILD" = 1], [ SHLIB_LD='ld -shared -expect_unresolved "*"' - else + ], [ SHLIB_LD='ld -non_shared -expect_unresolved "*"' - fi + ]) SHLIB_LD_LIBS="" SHLIB_SUFFIX=".so" DL_OBJS="tclLoadDl.o" DL_LIBS="" - CC_SEARCH_FLAGS='-Wl,-rpath,${LIB_RUNTIME_DIR}' - LD_SEARCH_FLAGS='-rpath ${LIB_RUNTIME_DIR}' - if test "$GCC" = "yes" ; then - CFLAGS="$CFLAGS -mieee" - else - CFLAGS="$CFLAGS -DHAVE_TZSET -std1 -ieee" - fi + AS_IF([test $doRpath = yes], [ + CC_SEARCH_FLAGS='-Wl,-rpath,${LIB_RUNTIME_DIR}' + LD_SEARCH_FLAGS='-rpath ${LIB_RUNTIME_DIR}']) + AS_IF([test "$GCC" = yes], [CFLAGS="$CFLAGS -mieee"], [ + CFLAGS="$CFLAGS -DHAVE_TZSET -std1 -ieee"]) # see pthread_intro(3) for pthread support on osf1, k.furukawa - if test "${TCL_THREADS}" = "1" ; then + AS_IF([test "${TCL_THREADS}" = 1], [ CFLAGS="$CFLAGS -DHAVE_PTHREAD_ATTR_SETSTACKSIZE" CFLAGS="$CFLAGS -DTCL_THREAD_STACK_MIN=PTHREAD_STACK_MIN*64" LIBS=`echo $LIBS | sed s/-lpthreads//` - if test "$GCC" = "yes" ; then + AS_IF([test "$GCC" = yes], [ LIBS="$LIBS -lpthread -lmach -lexc" - else + ], [ CFLAGS="$CFLAGS -pthread" LDFLAGS="$LDFLAGS -pthread" - fi - fi - + ]) + ]) ;; QNX-6*) # QNX RTP @@ -1809,13 +1811,13 @@ dnl AC_CHECK_TOOL(AR, ar) # Note, dlopen is available only on SCO 3.2.5 and greater. However, # this test works, since "uname -s" was non-standard in 3.2.4 and # below. - if test "$GCC" = "yes" ; then + AS_IF([test "$GCC" = yes], [ SHLIB_CFLAGS="-fPIC -melf" LDFLAGS="$LDFLAGS -melf -Wl,-Bexport" - else + ], [ SHLIB_CFLAGS="-Kpic -belf" LDFLAGS="$LDFLAGS -belf -Wl,-Bexport" - fi + ]) SHLIB_LD="ld -G" SHLIB_LD_LIBS="" SHLIB_SUFFIX=".so" @@ -1872,15 +1874,15 @@ dnl AC_CHECK_TOOL(AR, ar) SHLIB_SUFFIX=".so" DL_OBJS="tclLoadDl.o" DL_LIBS="-ldl" - if test "$GCC" = "yes" ; then + AS_IF([test "$GCC" = yes], [ SHLIB_LD='${CC} -shared' CC_SEARCH_FLAGS='-Wl,-R,${LIB_RUNTIME_DIR}' LD_SEARCH_FLAGS=${CC_SEARCH_FLAGS} - else + ], [ SHLIB_LD="/usr/ccs/bin/ld -G -z text" CC_SEARCH_FLAGS='-R ${LIB_RUNTIME_DIR}' LD_SEARCH_FLAGS=${CC_SEARCH_FLAGS} - fi + ]) ;; SunOS-5*) # Note: If _REENTRANT isn't defined, then Solaris @@ -1893,42 +1895,40 @@ dnl AC_CHECK_TOOL(AR, ar) SHLIB_CFLAGS="-KPIC" # Check to enable 64-bit flags for compiler/linker - if test "$do64bit" = "yes" ; then + AS_IF([test "$do64bit" = yes], [ arch=`isainfo` - if test "$arch" = "sparcv9 sparc" ; then - if test "$GCC" = "yes" ; then - if test "`${CC} -dumpversion | awk -F. '{print [$]1}'`" -lt "3" ; then - AC_MSG_WARN([64bit mode not supported with GCC < 3.2 on $system]) - else - do64bit_ok=yes - CFLAGS="$CFLAGS -m64 -mcpu=v9" - LDFLAGS="$LDFLAGS -m64 -mcpu=v9" - SHLIB_CFLAGS="-fPIC" - fi - else + AS_IF([test "$arch" = "sparcv9 sparc"], [ + AS_IF([test "$GCC" = yes], [ + AS_IF([test "`${CC} -dumpversion | awk -F. '{print [$]1}'`" -lt 3], [ + AC_MSG_WARN([64bit mode not supported with GCC < 3.2 on $system]) + ], [ do64bit_ok=yes - if test "$do64bitVIS" = "yes" ; then - CFLAGS="$CFLAGS -xarch=v9a" - LDFLAGS_ARCH="-xarch=v9a" - else - CFLAGS="$CFLAGS -xarch=v9" - LDFLAGS_ARCH="-xarch=v9" - fi - # Solaris 64 uses this as well - #LD_LIBRARY_PATH_VAR="LD_LIBRARY_PATH_64" - fi - elif test "$arch" = "amd64 i386" ; then - if test "$GCC" = "yes" ; then + CFLAGS="$CFLAGS -m64 -mcpu=v9" + LDFLAGS="$LDFLAGS -m64 -mcpu=v9" + SHLIB_CFLAGS="-fPIC" + ]) + ], [ + do64bit_ok=yes + AS_IF([test "$do64bitVIS" = yes], [ + CFLAGS="$CFLAGS -xarch=v9a" + LDFLAGS_ARCH="-xarch=v9a" + ], [ + CFLAGS="$CFLAGS -xarch=v9" + LDFLAGS_ARCH="-xarch=v9" + ]) + # Solaris 64 uses this as well + #LD_LIBRARY_PATH_VAR="LD_LIBRARY_PATH_64" + ]) + ], [AS_IF([test "$arch" = "amd64 i386"], [ + AS_IF([test "$GCC" = yes], [ AC_MSG_WARN([64bit mode not supported with GCC on $system]) - else + ], [ do64bit_ok=yes CFLAGS="$CFLAGS -xarch=amd64" LDFLAGS="$LDFLAGS -xarch=amd64" - fi - else - AC_MSG_WARN([64bit mode not supported for $arch]) - fi - fi + ]) + ], [AC_MSG_WARN([64bit mode not supported for $arch])])]) + ]) # Note: need the LIBS below, otherwise Tk won't find Tcl's # symbols when dynamically loaded into tclsh. @@ -1937,11 +1937,11 @@ dnl AC_CHECK_TOOL(AR, ar) SHLIB_SUFFIX=".so" DL_OBJS="tclLoadDl.o" DL_LIBS="-ldl" - if test "$GCC" = "yes" ; then + AS_IF([test "$GCC" = yes], [ SHLIB_LD='${CC} -shared' CC_SEARCH_FLAGS='-Wl,-R,${LIB_RUNTIME_DIR}' LD_SEARCH_FLAGS=${CC_SEARCH_FLAGS} - if test "$do64bit_ok" = "yes" ; then + AS_IF([test "$do64bit_ok" = yes], [ # We need to specify -static-libgcc or we need to # add the path to the sparv9 libgcc. SHLIB_LD="$SHLIB_LD -m64 -mcpu=v9 -static-libgcc" @@ -1949,8 +1949,8 @@ dnl AC_CHECK_TOOL(AR, ar) # path, remove so name and append 'sparcv9' #v9gcclibdir="`gcc -print-file-name=libgcc_s.so` | ..." #CC_SEARCH_FLAGS="${CC_SEARCH_FLAGS},-R,$v9gcclibdir" - fi - else + ]) + ], [ case $system in SunOS-5.[[1-9]][[0-9]]*) SHLIB_LD='${CC} -G -z text';; @@ -1959,7 +1959,7 @@ dnl AC_CHECK_TOOL(AR, ar) esac CC_SEARCH_FLAGS='-Wl,-R,${LIB_RUNTIME_DIR}' LD_SEARCH_FLAGS='-R ${LIB_RUNTIME_DIR}' - fi + ]) ;; UNIX_SV* | UnixWare-5*) SHLIB_CFLAGS="-KPIC" @@ -1975,21 +1975,21 @@ dnl AC_CHECK_TOOL(AR, ar) LDFLAGS="$LDFLAGS -Wl,-Bexport" AC_TRY_LINK(, [int i;], tcl_cv_ld_Bexport=yes, tcl_cv_ld_Bexport=no) LDFLAGS=$hold_ldflags]) - if test $tcl_cv_ld_Bexport = yes; then + AS_IF([test $tcl_cv_ld_Bexport = yes], [ LDFLAGS="$LDFLAGS -Wl,-Bexport" - fi + ]) CC_SEARCH_FLAGS="" LD_SEARCH_FLAGS="" ;; esac - if test "$do64bit" = "yes" -a "$do64bit_ok" = "no" ; then + AS_IF([test "$do64bit" = yes -a "$do64bit_ok" = no], [ AC_MSG_WARN([64bit support being disabled -- don't know magic for this platform]) - fi + ]) - if test "$do64bit" = "yes" -a "$do64bit_ok" = "yes" ; then + AS_IF([test "$do64bit" = yes -a "$do64bit_ok" = yes], [ AC_DEFINE(TCL_CFG_DO64BIT, 1, [Is this a 64-bit build?]) - fi + ]) dnl # Add any CPPFLAGS set in the environment to our CFLAGS, but delay doing so dnl # until the end of configure, as configure's compile and link tests use @@ -2003,15 +2003,10 @@ dnl # preprocessing tests use only CPPFLAGS. AC_HELP_STRING([--enable-load], [allow dynamic loading and "load" command (default: on)]), [tcl_ok=$enableval], [tcl_ok=yes]) - if test "$tcl_ok" = "no"; then - DL_OBJS="" - fi + AS_IF([test "$tcl_ok" = no], [DL_OBJS=""]) - if test "x$DL_OBJS" != "x" ; then - BUILD_DLTEST="\$(DLTEST_TARGETS)" - else - echo "Can't figure out how to do dynamic loading or shared libraries" - echo "on this system." + AS_IF([test "x$DL_OBJS" != x], [BUILD_DLTEST="\$(DLTEST_TARGETS)"], [ + AC_MSG_WARN([Can't figure out how to do dynamic loading or shared libraries on this system.]) SHLIB_CFLAGS="" SHLIB_LD="" SHLIB_SUFFIX="" @@ -2021,89 +2016,59 @@ dnl # preprocessing tests use only CPPFLAGS. CC_SEARCH_FLAGS="" LD_SEARCH_FLAGS="" BUILD_DLTEST="" - fi + ]) LDFLAGS="$LDFLAGS $LDFLAGS_ARCH" # If we're running gcc, then change the C flags for compiling shared # libraries to the right flags for gcc, instead of those for the # standard manufacturer compiler. - if test "$DL_OBJS" != "tclLoadNone.o" ; then - if test "$GCC" = "yes" ; then - case $system in - AIX-*) - ;; - BSD/OS*) - ;; - IRIX*) - ;; - NetBSD-*|FreeBSD-*) - ;; - Darwin-*) - ;; - SCO_SV-3.2*) - ;; - *) - SHLIB_CFLAGS="-fPIC" - ;; - esac - fi - fi - - if test "$SHARED_LIB_SUFFIX" = "" ; then - SHARED_LIB_SUFFIX='${VERSION}${SHLIB_SUFFIX}' - fi - if test "$UNSHARED_LIB_SUFFIX" = "" ; then - UNSHARED_LIB_SUFFIX='${VERSION}.a' - fi - - if test "${SHARED_BUILD}" = "1" && test "${SHLIB_SUFFIX}" != "" ; then + AS_IF([test "$DL_OBJS" != "tclLoadNone.o" -a "$GCC" = yes], [ + case $system in + AIX-*) ;; + BSD/OS*) ;; + IRIX*) ;; + NetBSD-*|FreeBSD-*) ;; + Darwin-*) ;; + SCO_SV-3.2*) ;; + *) SHLIB_CFLAGS="-fPIC" ;; + esac]) + + AS_IF([test "$SHARED_LIB_SUFFIX" = ""], [ + SHARED_LIB_SUFFIX='${VERSION}${SHLIB_SUFFIX}']) + AS_IF([test "$UNSHARED_LIB_SUFFIX" = ""], [ + UNSHARED_LIB_SUFFIX='${VERSION}.a']) + + AS_IF([test "${SHARED_BUILD}" = 1 -a "${SHLIB_SUFFIX}" != ""], [ LIB_SUFFIX=${SHARED_LIB_SUFFIX} MAKE_LIB='${SHLIB_LD} -o [$]@ ${OBJS} ${SHLIB_LD_LIBS} ${TCL_SHLIB_LD_EXTRAS} ${TK_SHLIB_LD_EXTRAS} ${LD_SEARCH_FLAGS}' INSTALL_LIB='$(INSTALL_LIBRARY) $(LIB_FILE) $(LIB_INSTALL_DIR)/$(LIB_FILE)' - else + ], [ LIB_SUFFIX=${UNSHARED_LIB_SUFFIX} - if test "$RANLIB" = "" ; then + AS_IF([test "$RANLIB" = ""], [ MAKE_LIB='$(STLIB_LD) [$]@ ${OBJS}' INSTALL_LIB='$(INSTALL_LIBRARY) $(LIB_FILE) $(LIB_INSTALL_DIR)/$(LIB_FILE)' - else + ], [ MAKE_LIB='${STLIB_LD} [$]@ ${OBJS} ; ${RANLIB} [$]@' INSTALL_LIB='$(INSTALL_LIBRARY) $(LIB_FILE) $(LIB_INSTALL_DIR)/$(LIB_FILE) ; (cd $(LIB_INSTALL_DIR) ; $(RANLIB) $(LIB_FILE))' - fi - -dnl Not at all clear what this was doing in Tcl's configure.in -dnl or why it was needed was needed. In any event, this sort of -dnl things needs to be done in the big loop above. -dnl REMOVE THIS BLOCK LATER! (mdejong) -dnl case $system in -dnl BSD/OS*) -dnl ;; -dnl AIX-[[1-4]].*) -dnl ;; -dnl *) -dnl SHLIB_LD_LIBS="" -dnl ;; -dnl esac - fi - + ]) + ]) # Stub lib does not depend on shared/static configuration - if test "$RANLIB" = "" ; then + AS_IF([test "$RANLIB" = ""], [ MAKE_STUB_LIB='${STLIB_LD} [$]@ ${STUB_LIB_OBJS}' INSTALL_STUB_LIB='$(INSTALL_LIBRARY) $(STUB_LIB_FILE) $(LIB_INSTALL_DIR)/$(STUB_LIB_FILE)' - else + ], [ MAKE_STUB_LIB='${STLIB_LD} [$]@ ${STUB_LIB_OBJS} ; ${RANLIB} [$]@' INSTALL_STUB_LIB='$(INSTALL_LIBRARY) $(STUB_LIB_FILE) $(LIB_INSTALL_DIR)/$(STUB_LIB_FILE) ; (cd $(LIB_INSTALL_DIR) ; $(RANLIB) $(STUB_LIB_FILE))' - fi + ]) # Define TCL_LIBS now that we know what DL_LIBS is. - # The trick here is that we don't want to change - # the value of TCL_LIBS if it is already set when - # tclConfig.sh had been loaded by Tk. - if test "x${TCL_LIBS}" = "x"; then - TCL_LIBS="${DL_LIBS} ${LIBS} ${MATH_LIBS}" - fi + # The trick here is that we don't want to change the value of TCL_LIBS if + # it is already set when tclConfig.sh had been loaded by Tk. + AS_IF([test "x${TCL_LIBS}" = x], [ + TCL_LIBS="${DL_LIBS} ${LIBS} ${MATH_LIBS}"]) AC_SUBST(TCL_LIBS) # FIXME: This subst was left in only because the TCL_DL_LIBS @@ -3006,6 +2971,37 @@ AC_DEFUN([SC_TCL_GETHOSTBYNAME_R], [AC_CHECK_FUNC(gethostbyname_r, [ ])]) #-------------------------------------------------------------------- +# SC_TCL_GETADDRINFO +# +# Check if we have 'getaddrinfo' +# +# Arguments: +# None +# +# Results: +# Might define the following vars: +# HAVE_GETADDRINFO +# +#-------------------------------------------------------------------- + +AC_DEFUN([SC_TCL_GETADDRINFO], [AC_CHECK_FUNC(getaddrinfo, [ + AC_CACHE_CHECK([for working getaddrinfo], tcl_cv_api_getaddrinfo, [ + AC_TRY_COMPILE([ + #include <netdb.h> + ], [ + const char *name, *port; + struct addrinfo *aiPtr, hints; + (void)getaddrinfo(name,port, &hints, &aiPtr); + (void)freeaddrinfo(aiPtr); + ], tcl_cv_api_getaddrinfo=yes, tcl_cv_getaddrinfo=no)]) + tcl_ok=$tcl_cv_api_getaddrinfo + if test "$tcl_ok" = yes; then + AC_DEFINE(HAVE_GETADDRINFO, 1, + [Define to 1 if getaddrinfo is available.]) + fi +])]) + +#-------------------------------------------------------------------- # SC_TCL_GETPWUID_R # # Check if we have MT-safe variant of getpwuid() and if yes, diff --git a/unix/tclConfig.h.in b/unix/tclConfig.h.in index 0dc1839..7443fd6 100644 --- a/unix/tclConfig.h.in +++ b/unix/tclConfig.h.in @@ -34,6 +34,9 @@ /* Do we have fts functions? */ #undef HAVE_FTS +/* Define to 1 if getaddrinfo is available. */ +#undef HAVE_GETADDRINFO + /* Define to 1 if you have the `getattrlist' function. */ #undef HAVE_GETATTRLIST @@ -379,7 +382,7 @@ /* What is the default extension for shared libraries? */ #undef TCL_SHLIB_EXT -/* The C stack grows upwards in memory */ +/* The C stack grows upwards in memory. */ #undef TCL_STACK_GROWS_UP /* Are we building with threads enabled? */ diff --git a/unix/tclUnixChan.c b/unix/tclUnixChan.c index 368dd20..5d81a57 100644 --- a/unix/tclUnixChan.c +++ b/unix/tclUnixChan.c @@ -10,7 +10,7 @@ * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclUnixChan.c,v 1.77.2.4 2007/11/12 19:18:24 dgp Exp $ + * RCS: @(#) $Id: tclUnixChan.c,v 1.77.2.5 2007/11/16 07:20:58 dgp Exp $ */ #include "tclInt.h" /* Internal definitions for Tcl. */ @@ -237,7 +237,8 @@ static TcpState * CreateSocket(Tcl_Interp *interp, int port, const char *host, int server, const char *myaddr, int myport, int async); static int CreateSocketAddress(struct sockaddr_in *sockaddrPtr, - const char *host, int port); + const char *host, int port, int willBind, + const char **errorMsgPtr); static int FileBlockModeProc(ClientData instanceData, int mode); static int FileCloseProc(ClientData instanceData, Tcl_Interp *interp); @@ -2469,14 +2470,15 @@ CreateSocket( struct sockaddr_in sockaddr; /* socket address */ struct sockaddr_in mysockaddr; /* Socket address for client */ TcpState *statePtr; + const char *errorMsg = NULL; sock = -1; origState = 0; - if (!CreateSocketAddress(&sockaddr, host, port)) { + if (!CreateSocketAddress(&sockaddr, host, port, 0, &errorMsg)) { goto addressError; } if ((myaddr != NULL || myport != 0) && - !CreateSocketAddress(&mysockaddr, myaddr, myport)) { + !CreateSocketAddress(&mysockaddr, myaddr, myport, 1, &errorMsg)) { goto addressError; } @@ -2608,6 +2610,9 @@ CreateSocket( if (interp != NULL) { Tcl_AppendResult(interp, "couldn't open socket: ", Tcl_PosixError(interp), NULL); + if (errorMsg != NULL) { + Tcl_AppendResult(interp, " (", errorMsg, ")", NULL); + } } return NULL; } @@ -2633,9 +2638,67 @@ static int CreateSocketAddress( struct sockaddr_in *sockaddrPtr, /* Socket address */ const char *host, /* Host. NULL implies INADDR_ANY */ - int port) /* Port number */ + int port, /* Port number */ + int willBind, /* Is this an address to bind() to or + * to connect() to? */ + const char **errorMsgPtr) /* Place to store the error message + * detail, if available. */ { - struct hostent *hostent; /* Host database entry */ +#ifdef HAVE_GETADDRINFO + struct addrinfo hints, *resPtr = NULL; + char *native; + Tcl_DString ds; + int result; + + if (host == NULL) { + sockaddrPtr->sin_family = AF_INET; + sockaddrPtr->sin_addr.s_addr = INADDR_ANY; + addPort: + sockaddrPtr->sin_port = htons((unsigned short) (port & 0xFFFF)); + return 1; + } + + (void) memset(&hints, 0, sizeof(struct addrinfo)); + hints.ai_family = AF_INET; + hints.ai_socktype = SOCK_STREAM; + if (willBind) { + hints.ai_flags |= AI_PASSIVE; + } + + /* + * Note that getaddrinfo() *is* thread-safe. If a platform doesn't get + * that right, it shouldn't use this part of the code. + */ + + native = Tcl_UtfToExternalDString(NULL, host, -1, &ds); + result = getaddrinfo(native, NULL, &hints, &resPtr); + Tcl_DStringFree(&ds); + if (result == 0) { + memcpy(sockaddrPtr, resPtr->ai_addr, sizeof(struct sockaddr_in)); + freeaddrinfo(resPtr); + goto addPort; + } + + /* + * Ought to use gai_strerror() here... + */ + + switch (result) { + case EAI_NONAME: + case EAI_SERVICE: + case EAI_ADDRFAMILY: + case EAI_NODATA: + *errorMsgPtr = gai_strerror(result); + errno = EHOSTUNREACH; + return 0; + case EAI_SYSTEM: + return 0; + default: + *errorMsgPtr = gai_strerror(result); + errno = ENXIO; + return 0; + } +#else /* !HAVE_GETADDRINFO */ struct in_addr addr; /* For 64/32 bit madness */ (void) memset(sockaddrPtr, '\0', sizeof(struct sockaddr_in)); @@ -2644,10 +2707,15 @@ CreateSocketAddress( if (host == NULL) { addr.s_addr = INADDR_ANY; } else { + struct hostent *hostent; /* Host database entry */ Tcl_DString ds; const char *native; - native = Tcl_UtfToExternalDString(NULL, host, -1, &ds); + if (host == NULL) { + native = NULL; + } else { + native = Tcl_UtfToExternalDString(NULL, host, -1, &ds); + } addr.s_addr = inet_addr(native); /* INTL: Native. */ /* @@ -2656,8 +2724,11 @@ CreateSocketAddress( */ if (addr.s_addr == 0xFFFFFFFF) { - hostent = gethostbyname(native); /* INTL: Native. */ - if (hostent == NULL) { + hostent = TclpGetHostByName(native); /* INTL: Native. */ + if (hostent != NULL) { + memcpy(&addr, hostent->h_addr_list[0], + (size_t) hostent->h_length); + } else { #ifdef EHOSTUNREACH errno = EHOSTUNREACH; #else /* !EHOSTUNREACH */ @@ -2665,13 +2736,15 @@ CreateSocketAddress( errno = ENXIO; #endif /* ENXIO */ #endif /* EHOSTUNREACH */ - Tcl_DStringFree(&ds); + if (native != NULL) { + Tcl_DStringFree(&ds); + } return 0; /* Error. */ } - memcpy(&addr, (void *) hostent->h_addr_list[0], - (size_t) hostent->h_length); } - Tcl_DStringFree(&ds); + if (native != NULL) { + Tcl_DStringFree(&ds); + } } /* @@ -2683,6 +2756,7 @@ CreateSocketAddress( sockaddrPtr->sin_addr.s_addr = addr.s_addr; return 1; /* Success. */ +#endif /* HAVE_GETADDRINFO */ } /* diff --git a/unix/tclUnixCompat.c b/unix/tclUnixCompat.c index a7ae7ed..9436ae7 100644 --- a/unix/tclUnixCompat.c +++ b/unix/tclUnixCompat.c @@ -6,7 +6,7 @@ * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclUnixCompat.c,v 1.9.2.2 2007/09/07 01:23:38 dgp Exp $ + * RCS: @(#) $Id: tclUnixCompat.c,v 1.9.2.3 2007/11/16 07:20:58 dgp Exp $ * */ @@ -345,12 +345,12 @@ TclpGetHostByName( sizeof(tsdPtr->hbuf), &h_errno); #elif defined(HAVE_GETHOSTBYNAME_R_6) - struct hostent *hePtr; - int h_errno; + struct hostent *hePtr = NULL; + int h_errno, result; - return (gethostbyname_r(name, &tsdPtr->hent, tsdPtr->hbuf, - sizeof(tsdPtr->hbuf), &hePtr, &h_errno) == 0) - ? &tsdPtr->hent : NULL; + result = gethostbyname_r(name, &tsdPtr->hent, tsdPtr->hbuf, + sizeof(tsdPtr->hbuf), &hePtr, &h_errno); + return (result == 0) ? hePtr : NULL; #elif defined(HAVE_GETHOSTBYNAME_R_3) struct hostent_data data; diff --git a/unix/tclUnixInit.c b/unix/tclUnixInit.c index 1e6d8f8..83a2a32 100644 --- a/unix/tclUnixInit.c +++ b/unix/tclUnixInit.c @@ -7,7 +7,7 @@ * Copyright (c) 1999 by Scriptics Corporation. * All rights reserved. * - * RCS: @(#) $Id: tclUnixInit.c,v 1.70.2.2 2007/11/12 19:18:24 dgp Exp $ + * RCS: @(#) $Id: tclUnixInit.c,v 1.70.2.3 2007/11/16 07:20:58 dgp Exp $ */ #include "tclInt.h" @@ -38,12 +38,10 @@ #endif /* - * Define this if you want to revert to the old behavior of never checking the - * stack. + * Define TCL_NO_STACK_CHECK in the compiler options if you want to revert to + * the old behavior of never checking the stack. */ -#undef TCL_NO_STACK_CHECK - /* * Define this if you want to see a lot of output regarding stack checking. */ diff --git a/win/tclWin32Dll.c b/win/tclWin32Dll.c index 76aab7c..ebd43ba 100644 --- a/win/tclWin32Dll.c +++ b/win/tclWin32Dll.c @@ -10,7 +10,7 @@ * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclWin32Dll.c,v 1.48.8.1 2007/11/12 19:18:24 dgp Exp $ + * RCS: @(#) $Id: tclWin32Dll.c,v 1.48.8.2 2007/11/16 07:20:58 dgp Exp $ */ #include "tclWinInt.h" @@ -554,7 +554,7 @@ TclpGetCStackParams( * area in which the stack resides */ if (!tsdPtr->stackBound - || ((DWORD_PTR)&tsdPtr < (DWORD_PTR)tsdPtr->stackBound)) { + || ((UINT_PTR)&tsdPtr < (UINT_PTR)tsdPtr->stackBound)) { /* * Either we haven't determined the stack bound in this thread, @@ -574,8 +574,8 @@ TclpGetCStackParams( if (!tsdPtr->stackBound) { tsdPtr->stackBound = - (int*) ((DWORD_PTR)(&tsdPtr) - & ~ (DWORD_PTR)(si.dwPageSize - 1)); + (int*) ((UINT_PTR)(&tsdPtr) + & ~ (UINT_PTR)(si.dwPageSize - 1)); } } else { @@ -587,8 +587,8 @@ TclpGetCStackParams( */ tsdPtr->stackBound = - (int*) ((DWORD_PTR)(mbi.AllocationBase) - + (DWORD_PTR)(si.dwPageSize) + (int*) ((UINT_PTR)(mbi.AllocationBase) + + (UINT_PTR)(si.dwPageSize) + TCL_WIN_STACK_THRESHOLD); } } |