summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
Diffstat
-rw-r--r--.github/workflows/linux-build.yml7
-rw-r--r--doc/coroutine.n5
-rw-r--r--doc/fcopy.n57
-rw-r--r--doc/library.n40
-rw-r--r--doc/read.n15
-rw-r--r--generic/regc_lex.c5
-rw-r--r--generic/tclClock.c2
-rw-r--r--generic/tclIO.c47
-rw-r--r--generic/tclIOCmd.c10
-rw-r--r--generic/tclInt.h1
-rw-r--r--generic/tclInterp.c3
-rw-r--r--generic/tclOODefineCmds.c44
-rw-r--r--generic/tclTest.c7
-rw-r--r--generic/tclTestObj.c6
-rw-r--r--generic/tclZipfs.c116
-rw-r--r--library/foreachline.tcl25
-rw-r--r--library/readfile.tcl23
-rw-r--r--library/tclIndex3
-rw-r--r--library/writefile.tcl37
-rw-r--r--tests/io.test103
-rw-r--r--tests/ioCmd.test206
-rw-r--r--tests/oo.test69
-rw-r--r--tests/ooUtil.test23
-rw-r--r--tests/reg.test4
24 files changed, 704 insertions, 154 deletions
diff --git a/.github/workflows/linux-build.yml b/.github/workflows/linux-build.yml
index a17751c..41b41d0 100644
--- a/.github/workflows/linux-build.yml
+++ b/.github/workflows/linux-build.yml
@@ -22,6 +22,8 @@ jobs:
- "--enable-symbols=mem"
- "--enable-symbols=all"
- "CFLAGS=-ftrapv"
+ # Duplicated below
+ - "CFLAGS=-m32 CPPFLAGS=-m32 LDFLAGS=-m32 --disable-64bit"
defaults:
run:
shell: bash
@@ -29,6 +31,11 @@ jobs:
steps:
- name: Checkout
uses: actions/checkout@v4
+ - name: Install 32-bit dependencies if needed
+ # Duplicated from above
+ if: ${{ matrix.cfgopt == 'CFLAGS=-m32 CPPFLAGS=-m32 LDFLAGS=-m32 --disable-64bit' }}
+ run: |
+ sudo apt install gcc-multilib libc6-dev-i386
- name: Prepare
run: |
touch tclStubInit.c tclOOStubInit.c tclOOScript.h
diff --git a/doc/coroutine.n b/doc/coroutine.n
index 11f9069..8110628 100644
--- a/doc/coroutine.n
+++ b/doc/coroutine.n
@@ -119,7 +119,10 @@ The injection is a one-off. It is not retained once it has been executed. It
may \fByield\fR or \fByieldto\fR as part of its execution.
.PP
Note that running coroutines may be neither probed nor injected; the
-operations may only be applied to
+operations may only be applied to coroutines that are suspended. (If a
+coroutine is running then any introspection code would be merely inspecting
+the state of where it is currently running; \fBcoroinject\fR/\fBcoroprobe\fR
+are unnecessary in that case.)
.VE "8.7, TIP383"
.SH EXAMPLES
.PP
diff --git a/doc/fcopy.n b/doc/fcopy.n
index 57f9968..dc6d8ea 100644
--- a/doc/fcopy.n
+++ b/doc/fcopy.n
@@ -12,7 +12,7 @@
.SH NAME
fcopy \- Copy data from one channel to another
.SH SYNOPSIS
-\fBfcopy \fIinchan\fR \fIoutchan\fR ?\fB\-size \fIsize\fR? ?\fB\-command \fIcallback\fR?
+\fBfcopy \fIinputChan\fR \fIoutputChan\fR ?\fB\-size \fIsize\fR? ?\fB\-command \fIcallback\fR?
.BE
.SH DESCRIPTION
@@ -20,22 +20,29 @@ fcopy \- Copy data from one channel to another
The \fBfcopy\fR command copies data from one I/O channel, \fIinchan\fR to another I/O channel, \fIoutchan\fR.
The \fBfcopy\fR command leverages the buffering in the Tcl I/O system to
avoid extra copies and to avoid buffering too much data in
-main memory when copying large files to slow destinations like
+main memory when copying large files to destinations like
network sockets.
-.PP
-The \fBfcopy\fR
-command transfers data from \fIinchan\fR until end of file
-or \fIsize\fR bytes or characters have been
-transferred; \fIsize\fR is in bytes if the input channel is in binary mode,
-or if the two channels are using the same encoding and -strict is not specified.
-Otherwise, size is in characters.
-If no \fB\-size\fR argument is given,
-then the copy goes until end of file.
-All the data read from \fIinchan\fR is copied to \fIoutchan\fR.
+.
+.SS "DATA QUANTITY"
+All data until \fIEOF\fR is copied.
+In addition, the quantity of copied data may be specified by the option \fB-size\fR.
+The given size is in bytes, if the input channel is in binary mode.
+Otherwise, it is in characters.
+.PP
+The transfer is treated as a binary transfer, if the encoding
+profile is set to
+.QW tcl8
+and the input encoding matches the output encoding.
+In this case, eventual encoding errors are not handled.
+An eventually given size is in bytes in this case.
+This feature is depreciated in TCL 9.
+.
+.SS "BLOCKING OPERATION MODE"
Without the \fB\-command\fR option, \fBfcopy\fR blocks until the copy is complete
and returns the number of bytes or characters (using the same rules as
for the \fB\-size\fR option) written to \fIoutchan\fR.
-.PP
+.
+.SS "BACKGROUND OPERATION MODE"
The \fB\-command\fR argument makes \fBfcopy\fR work in the background.
In this case it returns immediately and the \fIcallback\fR is invoked
later when the copy completes.
@@ -67,7 +74,8 @@ copy so those handlers do not interfere with the copy.
Any wrong-sided I/O attempted (by a \fBfileevent\fR handler or otherwise) will get a
.QW "channel busy"
error.
-.PP
+.
+.SS "CHANNEL TRANSLATION OPTIONS"
\fBFcopy\fR translates end-of-line sequences in \fIinchan\fR and \fIoutchan\fR
according to the \fB\-translation\fR option
for these channels.
@@ -78,13 +86,13 @@ can be different than the number of bytes written to \fIoutchan\fR.
Only the number of bytes written to \fIoutchan\fR is reported,
either as the return value of a synchronous \fBfcopy\fR or
as the argument to the callback for an asynchronous \fBfcopy\fR.
-.PP
-\fBFcopy\fR obeys the encodings and character translations configured
+.SS "CHANNEL ENCODING OPTIONS"
+\fBFcopy\fR obeys the encodings, profiles and character translations configured
for the channels. This
means that the incoming characters are converted internally first
UTF-8 and then into the encoding of the channel \fBfcopy\fR writes
to. See the manual entry for \fBfconfigure\fR for details on the
-\fB\-encoding\fR and \fB\-translation\fR options. No conversion is
+\fB\-encoding\fR and \fB\-profile\fR options. No conversion is
done if both channels are
set to encoding
.QW binary
@@ -97,6 +105,21 @@ the system will assume that the incoming
bytes are valid UTF-8 characters and convert them according to the
output encoding. The behaviour of the system for bytes which are not
valid UTF-8 characters is undefined in this case.
+.PP
+\fBFcopy\fR may throw encoding errors (error code \fBEILSEQ\fR), if input or output
+channel is configured to the
+.QW strict
+encoding profile.
+.PP
+If an encoding error arises on the input channel, any data before the error byte is
+written to the output channel. The input file pointer is located just before the
+values causing the encoding error.
+Error inspection or recovery is possible by changing the encoding parameters and
+invoking a file command (\fBread\fR, \fBfcopy\fR).
+.PP
+If an encoding error arises on the output channel, the errorneous data is lost.
+To make the difference between the input error case and the output error case, only the
+error message may be inspected (read or write), as both throw the error code \fIEILSEQ\fR.
.SH EXAMPLES
.PP
The first example transfers the contents of one channel exactly to
diff --git a/doc/library.n b/doc/library.n
index fb43364..0342cbe 100644
--- a/doc/library.n
+++ b/doc/library.n
@@ -25,6 +25,11 @@ auto_execok, auto_import, auto_load, auto_mkindex, auto_qualify, auto_reset, tcl
\fBtcl_startOfPreviousWord \fIstr start\fR
\fBtcl_wordBreakAfter \fIstr start\fR
\fBtcl_wordBreakBefore \fIstr start\fR
+.VS "Tcl 8.7, TIP 670"
+\fBforeachLine \fIfilename varName body\fR
+\fBreadFile \fIfilename\fR ?\fBtext\fR|\fBbinary\fR?
+\fBwriteFile \fIfilename\fR ?\fBtext\fR|\fBbinary\fR? \fIcontents\fR
+.VE "Tcl 8.7, TIP 670"
.BE
.SH INTRODUCTION
.PP
@@ -306,6 +311,41 @@ Returns the index of the first word boundary before the starting index
boundaries before the starting point in the given string. The index
returned refers to the second character of the pair that comprises a
boundary.
+.TP
+\fBforeachLine \fIvarName filename body\fR
+.VS "Tcl 8.7, TIP 670"
+This reads in the text file named \fIfilename\fR one line at a time
+(using system defaults for reading text files). It writes that line to the
+variable named by \fIvarName\fR and then executes \fIbody\fR for that line.
+The result value of \fIbody\fR is ignored, but \fBerror\fR, \fBreturn\fR,
+\fBbreak\fR and \fBcontinue\fR may be used within it to produce an error,
+return from the calling context, stop the loop, or go to the next line
+respectively.
+The overall result of \fBforeachLine\fR is the empty string (assuming no
+errors from I/O or from evaluating the body of the loop); the file will be
+closed prior to the procedure returning.
+.VE "Tcl 8.7, TIP 670"
+.TP
+\fBreadFile \fIfilename\fR ?\fBtext\fR|\fBbinary\fR?
+.VS "Tcl 8.7, TIP 670"
+Reads in the file named in \fIfilename\fR and returns its contents.
+The second argument says how to read in the file, either as \fBtext\fR
+(using the system defaults for reading text files) or as \fBbinary\fR
+(as uninterpreted bytes). The default is \fBtext\fR. When read as text, this
+will include any trailing newline.
+The file will be closed prior to the procedure returning.
+.VE "Tcl 8.7, TIP 670"
+.TP
+\fBwriteFile \fIfilename\fR ?\fBtext\fR|\fBbinary\fR? \fIcontents\fR
+.VS "Tcl 8.7, TIP 670"
+Writes the \fIcontents\fR to the file named in \fIfilename\fR.
+The optional second argument says how to write to the file, either as
+\fBtext\fR (using the system defaults for writing text files) or as
+\fBbinary\fR (as uninterpreted bytes). The default is \fBtext\fR.
+If a trailing newline is required, it will need to be provided in
+\fIcontents\fR. The result of this command is the empty string; the file will
+be closed prior to the procedure returning.
+.VE "Tcl 8.7, TIP 670"
.SH "VARIABLES"
.PP
The following global variables are defined or used by the procedures in
diff --git a/doc/read.n b/doc/read.n
index 2add683..7c0c155 100644
--- a/doc/read.n
+++ b/doc/read.n
@@ -61,13 +61,15 @@ An encoding error is reported by the POSIX error code \fBEILSEQ\fR.
In blocking mode, the error is directly thrown, even, if there is a
leading decodable data portion.
The file pointer is advanced just before the encoding error.
-An eventual well decoded data chunk before the encoding error is lost.
-It is proposed to return this portion within the additional key \fB-data\fR
-in the error dictionary.
+An eventual well decoded data chunk before the encoding error is returned
+in the error option dictionary key \fB-data\fR.
+The value of the key contains the empty string, if the error arises at the
+first data position.
.PP
In non blocking mode, first, any data without encoding error is returned
(without error state).
In the next call, no data is returned and the \fBEILSEQ\fR error state is set.
+The key \fB-data\fR is not present.
.PP
Here is an example with an encoding error in UTF-8 encoding, which is then
introspected by a switch to the binary encoding. The test file contains a not
@@ -87,7 +89,7 @@ file35a65a0
% catch {read $f} e d
1
% set d
--code 1 -level 0
+-data A -code 1 -level 0
-errorstack {INNER {invokeStk1 read file35a65a0}}
-errorcode {POSIX EILSEQ {invalid or incomplete multibyte or wide character}}
-errorinfo {...} -errorline 1
@@ -98,6 +100,11 @@ file35a65a0
ÃB
% close $f
.CE
+The already decoded data "A" is returned in the error options dictionary key
+\fB-data\fR.
+The file position is advanced on the encoding error position 1.
+The data at the error position is thus recovered by the next \fBread\fR command.
+.PP
Non blocking example
.
.CS
diff --git a/generic/regc_lex.c b/generic/regc_lex.c
index eb068b4..28ae821 100644
--- a/generic/regc_lex.c
+++ b/generic/regc_lex.c
@@ -843,11 +843,6 @@ lexescape(
if (ISERR()) {
FAILW(REG_EESCAPE);
}
- if (i > 0xFFFF) {
- /* TODO: output a Surrogate pair
- */
- i = 0xFFFD;
- }
RETV(PLAIN, (uchr) i);
break;
case CHR('v'):
diff --git a/generic/tclClock.c b/generic/tclClock.c
index ab6d23f..228937e 100644
--- a/generic/tclClock.c
+++ b/generic/tclClock.c
@@ -894,7 +894,7 @@ ConvertLocalToUTCUsingC(
Tcl_MutexLock(&clockMutex);
errno = 0;
fields->seconds = (Tcl_WideInt) mktime(&timeVal);
- localErrno = errno;
+ localErrno = (fields->seconds == -1) ? errno : 0;
Tcl_MutexUnlock(&clockMutex);
/*
diff --git a/generic/tclIO.c b/generic/tclIO.c
index bc1b1c6..3b36457 100644
--- a/generic/tclIO.c
+++ b/generic/tclIO.c
@@ -4934,7 +4934,7 @@ Tcl_GetsObj(
* two times, as gs.bytesWrote is not 0 on the first pass. This feels
* once to much, as the data is anyway not used.
*/
-
+
/* Set eol to the position that caused the encoding error, and then
* continue to gotEOL, which stores the data that was decoded
* without error to objPtr. This allows the caller to do something
@@ -7616,6 +7616,33 @@ Tcl_Eof(
return GotFlag(statePtr, CHANNEL_EOF) ? 1 : 0;
}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclChannelGetBlockingMode --
+ *
+ * Returns 1 if the channel is in blocking mode (default), 0 otherwise.
+ *
+ * Results:
+ * 1 or 0, always.
+ *
+ * Side effects:
+ * None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+TclChannelGetBlockingMode(
+ Tcl_Channel chan)
+{
+ ChannelState *statePtr = ((Channel *) chan)->state;
+ /* State of real channel structure. */
+
+ return GotFlag(statePtr, CHANNEL_NONBLOCKING) ? 0 : 1;
+}
+
/*
*----------------------------------------------------------------------
*
@@ -9802,6 +9829,7 @@ CopyData(
ChannelState *inStatePtr, *outStatePtr;
int result = TCL_OK;
Tcl_Size sizeb;
+ Tcl_Size sizePart;
Tcl_WideInt total;
int size;
const char *buffer;
@@ -9888,6 +9916,23 @@ CopyData(
size = DoReadChars(inStatePtr->topChanPtr, bufObj, sizeb,
!GotFlag(inStatePtr, CHANNEL_NONBLOCKING)
,0 /* No append */);
+ /*
+ * In case of a recoverable encoding error, any data before
+ * the error should be written. This data is in the bufObj.
+ * Program flow for this case:
+ * - Check, if there are any remaining bytes to write
+ * - If yes, simulate a successful read to write them out
+ * - Come back here by the outer loop and read again
+ * - Do not enter in the if below, as there are no pending
+ * writes
+ * - Fail below with a read error
+ */
+ if (size < 0 && Tcl_GetErrno() == EILSEQ) {
+ Tcl_GetStringFromObj(bufObj, &sizePart);
+ if (sizePart > 0) {
+ size = sizePart;
+ }
+ }
}
underflow = (size >= 0) && (size < sizeb); /* Input underflow */
}
diff --git a/generic/tclIOCmd.c b/generic/tclIOCmd.c
index 938fa01..9667419 100644
--- a/generic/tclIOCmd.c
+++ b/generic/tclIOCmd.c
@@ -459,7 +459,12 @@ Tcl_ReadObjCmd(
TclChannelPreserve(chan);
charactersRead = Tcl_ReadChars(chan, resultPtr, toRead, 0);
if (charactersRead == TCL_IO_FAILURE) {
- Tcl_DecrRefCount(resultPtr);
+ Tcl_Obj *returnOptsPtr = NULL;
+ if (TclChannelGetBlockingMode(chan)) {
+ returnOptsPtr = Tcl_NewDictObj();
+ Tcl_DictObjPut(NULL, returnOptsPtr, Tcl_NewStringObj("-data", -1),
+ resultPtr);
+ }
/*
* TIP #219.
* Capture error messages put by the driver into the bypass area and
@@ -473,6 +478,9 @@ Tcl_ReadObjCmd(
TclGetString(chanObjPtr), Tcl_PosixError(interp)));
}
TclChannelRelease(chan);
+ if (returnOptsPtr) {
+ Tcl_SetReturnOptions(interp, returnOptsPtr);
+ }
return TCL_ERROR;
}
diff --git a/generic/tclInt.h b/generic/tclInt.h
index 3d8a702..f696ad2 100644
--- a/generic/tclInt.h
+++ b/generic/tclInt.h
@@ -3112,6 +3112,7 @@ MODULE_SCOPE int TclByteArrayMatch(const unsigned char *string,
MODULE_SCOPE double TclCeil(const void *a);
MODULE_SCOPE void TclChannelPreserve(Tcl_Channel chan);
MODULE_SCOPE void TclChannelRelease(Tcl_Channel chan);
+MODULE_SCOPE int TclChannelGetBlockingMode(Tcl_Channel chan);
MODULE_SCOPE int TclCheckArrayTraces(Tcl_Interp *interp, Var *varPtr,
Var *arrayPtr, Tcl_Obj *name, int index);
MODULE_SCOPE int TclCheckBadOctal(Tcl_Interp *interp,
diff --git a/generic/tclInterp.c b/generic/tclInterp.c
index b023615..3d2c009 100644
--- a/generic/tclInterp.c
+++ b/generic/tclInterp.c
@@ -402,6 +402,7 @@ Tcl_Init(
"if {$tail eq [info tclversion]} continue\n"
"file join [file dirname $env(TCL_LIBRARY)] tcl[info tclversion]}\n"
" }\n"
+" lappend scripts {::tcl::zipfs::tcl_library_init}\n"
" if {[info exists tclDefaultLibrary]} {\n"
" lappend scripts {set tclDefaultLibrary}\n"
" } else {\n"
@@ -3603,7 +3604,7 @@ static void
WrapFree(
void *ptr)
{
- Tcl_Free(ptr);
+ ckfree(ptr);
}
void
diff --git a/generic/tclOODefineCmds.c b/generic/tclOODefineCmds.c
index 034c877..5f10475 100644
--- a/generic/tclOODefineCmds.c
+++ b/generic/tclOODefineCmds.c
@@ -2455,9 +2455,13 @@ ClassMixinSet(
Tcl_Obj *const *objv)
{
Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp);
- int mixinc, i;
+ int mixinc, i, isNew;
Tcl_Obj **mixinv;
- Class **mixins;
+ Class **mixins;; /* The references to the classes to actually
+ * install. */
+ Tcl_HashTable uniqueCheck; /* Note that this hash table is just used as a
+ * set of class references; it has no payload
+ * values and keys are always pointers. */
if (Tcl_ObjectContextSkippedArgs(context) + 1 != objc) {
Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv,
@@ -2479,6 +2483,7 @@ ClassMixinSet(
}
mixins = (Class **)TclStackAlloc(interp, sizeof(Class *) * mixinc);
+ Tcl_InitHashTable(&uniqueCheck, TCL_ONE_WORD_KEYS);
for (i = 0; i < mixinc; i++) {
mixins[i] = GetClassInOuterContext(interp, mixinv[i],
@@ -2487,6 +2492,13 @@ ClassMixinSet(
i--;
goto freeAndError;
}
+ (void) Tcl_CreateHashEntry(&uniqueCheck, (void *) mixins[i], &isNew);
+ if (!isNew) {
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "class should only be a direct mixin once", -1));
+ Tcl_SetErrorCode(interp, "TCL", "OO", "REPETITIOUS",NULL);
+ goto freeAndError;
+ }
if (TclOOIsReachable(oPtr->classPtr, mixins[i])) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"may not mix a class into itself", -1));
@@ -2496,10 +2508,12 @@ ClassMixinSet(
}
TclOOClassSetMixins(interp, oPtr->classPtr, mixinc, mixins);
+ Tcl_DeleteHashTable(&uniqueCheck);
TclStackFree(interp, mixins);
return TCL_OK;
freeAndError:
+ Tcl_DeleteHashTable(&uniqueCheck);
TclStackFree(interp, mixins);
return TCL_ERROR;
}
@@ -2906,10 +2920,13 @@ ObjMixinSet(
Tcl_Obj *const *objv)
{
Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp);
- int mixinc;
+ int mixinc, i, isNew;
Tcl_Obj **mixinv;
- Class **mixins;
- int i;
+ Class **mixins; /* The references to the classes to actually
+ * install. */
+ Tcl_HashTable uniqueCheck; /* Note that this hash table is just used as a
+ * set of class references; it has no payload
+ * values and keys are always pointers. */
if (Tcl_ObjectContextSkippedArgs(context) + 1 != objc) {
Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv,
@@ -2925,19 +2942,32 @@ ObjMixinSet(
}
mixins = (Class **)TclStackAlloc(interp, sizeof(Class *) * mixinc);
+ Tcl_InitHashTable(&uniqueCheck, TCL_ONE_WORD_KEYS);
for (i = 0; i < mixinc; i++) {
mixins[i] = GetClassInOuterContext(interp, mixinv[i],
"may only mix in classes");
if (mixins[i] == NULL) {
- TclStackFree(interp, mixins);
- return TCL_ERROR;
+ goto freeAndError;
+ }
+ (void) Tcl_CreateHashEntry(&uniqueCheck, (void *) mixins[i], &isNew);
+ if (!isNew) {
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "class should only be a direct mixin once", -1));
+ Tcl_SetErrorCode(interp, "TCL", "OO", "REPETITIOUS",NULL);
+ goto freeAndError;
}
}
TclOOObjectSetMixins(oPtr, mixinc, mixins);
TclStackFree(interp, mixins);
+ Tcl_DeleteHashTable(&uniqueCheck);
return TCL_OK;
+
+ freeAndError:
+ TclStackFree(interp, mixins);
+ Tcl_DeleteHashTable(&uniqueCheck);
+ return TCL_ERROR;
}
/*
diff --git a/generic/tclTest.c b/generic/tclTest.c
index efa045e..02e1fac 100644
--- a/generic/tclTest.c
+++ b/generic/tclTest.c
@@ -2086,7 +2086,6 @@ static int UtfExtWrapper(
} flagMap[] = {
{"start", TCL_ENCODING_START},
{"end", TCL_ENCODING_END},
- {"stoponerror", TCL_ENCODING_PROFILE_STRICT},
{"noterminate", TCL_ENCODING_NO_TERMINATE},
{"charlimit", TCL_ENCODING_CHAR_LIMIT},
{"profiletcl8", TCL_ENCODING_PROFILE_TCL8},
@@ -3813,7 +3812,7 @@ TestlistrepCmd(
Tcl_Obj *const objv[]) /* Argument objects. */
{
/* Subcommands supported by this command */
- const char* subcommands[] = {
+ static const char *const subcommands[] = {
"new",
"describe",
"config",
@@ -4624,11 +4623,11 @@ TestregexpObjCmd(
} else {
if (ii == TCL_INDEX_NONE) {
TclRegExpRangeUniChar(regExpr, ii, &start, &end);
- newPtr = Tcl_GetRange(objPtr, start, end);
+ newPtr = TclGetRange(objPtr, start, end);
} else if (ii > info.nsubs || info.matches[ii].end <= 0) {
newPtr = Tcl_NewObj();
} else {
- newPtr = Tcl_GetRange(objPtr, info.matches[ii].start,
+ newPtr = TclGetRange(objPtr, info.matches[ii].start,
info.matches[ii].end - 1);
}
}
diff --git a/generic/tclTestObj.c b/generic/tclTestObj.c
index 3b958dd..9f31cff 100644
--- a/generic/tclTestObj.c
+++ b/generic/tclTestObj.c
@@ -153,7 +153,7 @@ TestbignumobjCmd(
int objc, /* Argument count */
Tcl_Obj *const objv[]) /* Argument vector */
{
- const char *const subcmds[] = {
+ static const char *const subcmds[] = {
"set", "get", "mult10", "div10", "iseven", "radixsize", NULL
};
enum options {
@@ -887,7 +887,7 @@ TestlistobjCmd(
Tcl_Obj *const objv[]) /* Argument objects */
{
/* Subcommands supported by this command */
- const char* const subcommands[] = {
+ static const char* const subcommands[] = {
"set",
"get",
"replace",
@@ -1062,7 +1062,7 @@ TestobjCmd(
int i;
const Tcl_ObjType *targetType;
Tcl_Obj **varPtr;
- const char *subcommands[] = {
+ static const char *const subcommands[] = {
"freeallvars", "bug3598580",
"types", "objtype", "newobj", "set",
"assign", "convert", "duplicate",
diff --git a/generic/tclZipfs.c b/generic/tclZipfs.c
index adabcda..5df300a 100644
--- a/generic/tclZipfs.c
+++ b/generic/tclZipfs.c
@@ -91,17 +91,6 @@ static const z_crc_t* crc32tab;
#define ZIPFS_VOLUME_LEN 9
#define ZIPFS_APP_MOUNT ZIPFS_VOLUME "app"
#define ZIPFS_ZIP_MOUNT ZIPFS_VOLUME "lib/tcl"
-
-#define ZIPFS_SCRIPT_PREFIX "set ::tcl_library "
-#define ZIPFS_TCL_LIBRARY_1 ZIPFS_APP_MOUNT "/tcl_library"
-#define ZIPFS_INIT_SCRIPT_1 ZIPFS_SCRIPT_PREFIX ZIPFS_TCL_LIBRARY_1
-
-#define ZIPFS_TCL_LIBRARY_2 ZIPFS_ZIP_MOUNT
-#define ZIPFS_INIT_SCRIPT_2 ZIPFS_SCRIPT_PREFIX ZIPFS_TCL_LIBRARY_2
-
-#define ZIPFS_TCL_LIBRARY_3 ZIPFS_ZIP_MOUNT "/tcl_library"
-#define ZIPFS_INIT_SCRIPT_3 ZIPFS_SCRIPT_PREFIX ZIPFS_TCL_LIBRARY_3
-
#define ZIPFS_FALLBACK_ENCODING "cp437"
/*
@@ -324,7 +313,6 @@ static const char pwrot[17] =
"\x10\x90\x50\xD0\x30\xB0\x70\xF0";
static const char *zipfs_literal_tcl_library = NULL;
-static const char *zipfs_init_script = NULL;
/* Function prototypes */
@@ -4243,28 +4231,6 @@ ScriptLibrarySetup(
Tcl_Obj *libDirObj = Tcl_NewStringObj(dirName, -1);
Tcl_Obj *subDirObj, *searchPathObj;
- /*
- * We know where the init.tcl is located in the attached script library
- * archive. Use a pre-init script to tell every Tcl interp as it gets
- * created where that is, so none of them need to construct and then
- * iterate through some search path. That's the literal documented
- * purpose of Tcl_SetPreInitScript(). Use it.
- *
- * TODO: Examine why we need so many variations and eliminate as many
- * as possible.
- */
-
- if (0 == strcmp(zipfs_literal_tcl_library, ZIPFS_TCL_LIBRARY_1)) {
- zipfs_init_script = ZIPFS_INIT_SCRIPT_1;
- } else if (0 == strcmp(zipfs_literal_tcl_library, ZIPFS_TCL_LIBRARY_2)) {
- zipfs_init_script = ZIPFS_INIT_SCRIPT_2;
- } else if (0 == strcmp(zipfs_literal_tcl_library, ZIPFS_TCL_LIBRARY_3)) {
- zipfs_init_script = ZIPFS_INIT_SCRIPT_3;
- }
- if (zipfs_init_script) {
- Tcl_SetPreInitScript(zipfs_init_script);
- }
-
TclNewLiteralStringObj(subDirObj, "encoding");
Tcl_IncrRefCount(subDirObj);
TclNewObj(searchPathObj);
@@ -4302,12 +4268,13 @@ TclZipfs_TclLibrary(void)
* Look for the library file system within the executable.
*/
- vfsInitScript = Tcl_NewStringObj(ZIPFS_TCL_LIBRARY_1 "/init.tcl", -1);
+ vfsInitScript = Tcl_NewStringObj(ZIPFS_APP_MOUNT "/tcl_library/init.tcl",
+ -1);
Tcl_IncrRefCount(vfsInitScript);
found = Tcl_FSAccess(vfsInitScript, F_OK);
Tcl_DecrRefCount(vfsInitScript);
if (found == TCL_OK) {
- zipfs_literal_tcl_library = ZIPFS_TCL_LIBRARY_1;
+ zipfs_literal_tcl_library = ZIPFS_APP_MOUNT "/tcl_library";
return ScriptLibrarySetup(zipfs_literal_tcl_library);
}
@@ -4356,6 +4323,44 @@ TclZipfs_TclLibrary(void)
/*
*-------------------------------------------------------------------------
*
+ * ZipFSTclLibraryObjCmd --
+ *
+ * This procedure is invoked to process the
+ * [::tcl::zipfs::tcl_library_init] command, usually called during the
+ * execution of Tcl's interpreter startup. It returns the root that Tcl's
+ * library files are mounted under.
+ *
+ * Results:
+ * A standard Tcl result.
+ *
+ * Side effects:
+ * May initialise the cache of where such library files are to be found.
+ * This cache is never cleared.
+ *
+ *-------------------------------------------------------------------------
+ */
+
+static int
+ZipFSTclLibraryObjCmd(
+ TCL_UNUSED(void *),
+ Tcl_Interp *interp, /* Current interpreter. */
+ TCL_UNUSED(int) /*objc*/,
+ TCL_UNUSED(Tcl_Obj *const *)) /*objv*/
+{
+ if (!Tcl_IsSafe(interp)) {
+ Tcl_Obj *pResult = TclZipfs_TclLibrary();
+
+ if (!pResult) {
+ TclNewObj(pResult);
+ }
+ Tcl_SetObjResult(interp, pResult);
+ }
+ return TCL_OK;
+}
+
+/*
+ *-------------------------------------------------------------------------
+ *
* ZipChannelClose --
*
* This function is called to close a channel.
@@ -6248,6 +6253,8 @@ TclZipfs_Init(
Tcl_GetEnsembleMappingDict(NULL, ensemble, &mapObj);
Tcl_DictObjPut(NULL, mapObj, Tcl_NewStringObj("find", -1),
Tcl_NewStringObj("::tcl::zipfs::find", -1));
+ Tcl_CreateObjCommand(interp, "::tcl::zipfs::tcl_library_init",
+ ZipFSTclLibraryObjCmd, NULL, NULL);
Tcl_PkgProvide(interp, "tcl::zipfs", "2.0");
}
return TCL_OK;
@@ -6276,21 +6283,22 @@ ZipfsAppHookFindTclInit(
return TCL_ERROR;
}
- TclNewLiteralStringObj(vfsInitScript, ZIPFS_TCL_LIBRARY_2 "/init.tcl");
+ TclNewLiteralStringObj(vfsInitScript, ZIPFS_ZIP_MOUNT "/init.tcl");
Tcl_IncrRefCount(vfsInitScript);
found = Tcl_FSAccess(vfsInitScript, F_OK);
Tcl_DecrRefCount(vfsInitScript);
if (found == 0) {
- zipfs_literal_tcl_library = ZIPFS_TCL_LIBRARY_2;
+ zipfs_literal_tcl_library = ZIPFS_ZIP_MOUNT;
return TCL_OK;
}
- TclNewLiteralStringObj(vfsInitScript, ZIPFS_TCL_LIBRARY_3 "/init.tcl");
+ TclNewLiteralStringObj(vfsInitScript,
+ ZIPFS_ZIP_MOUNT "/tcl_library/init.tcl");
Tcl_IncrRefCount(vfsInitScript);
found = Tcl_FSAccess(vfsInitScript, F_OK);
Tcl_DecrRefCount(vfsInitScript);
if (found == 0) {
- zipfs_literal_tcl_library = ZIPFS_TCL_LIBRARY_3;
+ zipfs_literal_tcl_library = ZIPFS_ZIP_MOUNT "/tcl_library";
return TCL_OK;
}
@@ -6407,13 +6415,12 @@ TclZipfs_AppHook(
if (!zipfs_literal_tcl_library) {
TclNewLiteralStringObj(vfsInitScript,
- ZIPFS_TCL_LIBRARY_1 "/init.tcl");
+ ZIPFS_APP_MOUNT "/tcl_library/init.tcl");
Tcl_IncrRefCount(vfsInitScript);
found = Tcl_FSAccess(vfsInitScript, F_OK);
Tcl_DecrRefCount(vfsInitScript);
if (found == TCL_OK) {
- zipfs_literal_tcl_library = ZIPFS_TCL_LIBRARY_1;
- Tcl_DecrRefCount(TclZipfs_TclLibrary());
+ zipfs_literal_tcl_library = ZIPFS_APP_MOUNT "/tcl_library";
return version;
}
}
@@ -6440,9 +6447,9 @@ TclZipfs_AppHook(
* wants it.
*/
- Tcl_DecrRefCount(TclZipfs_TclLibrary());
+ TclZipfs_TclLibrary();
TclNewLiteralStringObj(vfsInitScript,
- ZIPFS_TCL_LIBRARY_3 "install.tcl");
+ ZIPFS_ZIP_MOUNT "/tcl_library/install.tcl");
Tcl_IncrRefCount(vfsInitScript);
if (Tcl_FSAccess(vfsInitScript, F_OK) == 0) {
Tcl_SetStartupScript(vfsInitScript, NULL);
@@ -6452,17 +6459,6 @@ TclZipfs_AppHook(
int found;
Tcl_Obj *vfsInitScript;
- /* Set Tcl Encodings */
- TclNewLiteralStringObj(vfsInitScript,
- ZIPFS_TCL_LIBRARY_1 "/init.tcl");
- Tcl_IncrRefCount(vfsInitScript);
- found = Tcl_FSAccess(vfsInitScript, F_OK);
- Tcl_DecrRefCount(vfsInitScript);
- if (found == TCL_OK) {
- zipfs_literal_tcl_library = ZIPFS_TCL_LIBRARY_1;
- Tcl_DecrRefCount(TclZipfs_TclLibrary());
- }
-
TclNewLiteralStringObj(vfsInitScript, ZIPFS_APP_MOUNT "/main.tcl");
Tcl_IncrRefCount(vfsInitScript);
if (Tcl_FSAccess(vfsInitScript, F_OK) == 0) {
@@ -6474,8 +6470,14 @@ TclZipfs_AppHook(
} else {
Tcl_DecrRefCount(vfsInitScript);
}
-
+ /* Set Tcl Encodings */
+ TclNewLiteralStringObj(vfsInitScript,
+ ZIPFS_APP_MOUNT "/tcl_library/init.tcl");
+ Tcl_IncrRefCount(vfsInitScript);
+ found = Tcl_FSAccess(vfsInitScript, F_OK);
+ Tcl_DecrRefCount(vfsInitScript);
if (found == TCL_OK) {
+ zipfs_literal_tcl_library = ZIPFS_APP_MOUNT "/tcl_library";
return version;
}
}
diff --git a/library/foreachline.tcl b/library/foreachline.tcl
new file mode 100644
index 0000000..aacbd5b
--- /dev/null
+++ b/library/foreachline.tcl
@@ -0,0 +1,25 @@
+# foreachLine:
+# Iterate over the contents of a file, a line at a time.
+# The body script is run for each, with variable varName set to the line
+# contents.
+#
+# Copyright © 2023 Donal K Fellows.
+#
+# See the file "license.terms" for information on usage and redistribution
+# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+#
+
+proc foreachLine {varName filename body} {
+ upvar 1 $varName line
+ set f [open $filename "r"]
+ try {
+ while {[gets $f line] >= 0} {
+ uplevel 1 $body
+ }
+ } on return {msg opt} {
+ dict incr opt -level
+ return -options $opt $msg
+ } finally {
+ close $f
+ }
+}
diff --git a/library/readfile.tcl b/library/readfile.tcl
new file mode 100644
index 0000000..c1d5b84
--- /dev/null
+++ b/library/readfile.tcl
@@ -0,0 +1,23 @@
+# readFile:
+# Read the contents of a file.
+#
+# Copyright © 2023 Donal K Fellows.
+#
+# See the file "license.terms" for information on usage and redistribution
+# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+#
+
+proc readFile {filename {mode text}} {
+ # Parse the arguments
+ set MODES {binary text}
+ set ERR [list -level 1 -errorcode [list TCL LOOKUP MODE $mode]]
+ set mode [tcl::prefix match -message "mode" -error $ERR $MODES $mode]
+
+ # Read the file
+ set f [open $filename [dict get {text r binary rb} $mode]]
+ try {
+ return [read $f]
+ } finally {
+ close $f
+ }
+}
diff --git a/library/tclIndex b/library/tclIndex
index a8db3cb..8fd5a89 100644
--- a/library/tclIndex
+++ b/library/tclIndex
@@ -19,6 +19,7 @@ set auto_index(::auto_mkindex_parser::childhook) [list ::tcl::Pkg::source [file
set auto_index(::auto_mkindex_parser::command) [list ::tcl::Pkg::source [file join $dir auto.tcl]]
set auto_index(::auto_mkindex_parser::commandInit) [list ::tcl::Pkg::source [file join $dir auto.tcl]]
set auto_index(::auto_mkindex_parser::fullname) [list ::tcl::Pkg::source [file join $dir auto.tcl]]
+set auto_index(foreachLine) [list ::tcl::Pkg::source [file join $dir foreachline.tcl]]
set auto_index(history) [list ::tcl::Pkg::source [file join $dir history.tcl]]
set auto_index(::tcl::HistAdd) [list ::tcl::Pkg::source [file join $dir history.tcl]]
set auto_index(::tcl::HistKeep) [list ::tcl::Pkg::source [file join $dir history.tcl]]
@@ -34,6 +35,7 @@ set auto_index(tclPkgUnknown) [list ::tcl::Pkg::source [file join $dir package.t
set auto_index(::tcl::MacOSXPkgUnknown) [list ::tcl::Pkg::source [file join $dir package.tcl]]
set auto_index(::pkg::create) [list ::tcl::Pkg::source [file join $dir package.tcl]]
set auto_index(parray) [list ::tcl::Pkg::source [file join $dir parray.tcl]]
+set auto_index(readFile) [list ::tcl::Pkg::source [file join $dir readfile.tcl]]
set auto_index(::safe::InterpStatics) [list ::tcl::Pkg::source [file join $dir safe.tcl]]
set auto_index(::safe::InterpNested) [list ::tcl::Pkg::source [file join $dir safe.tcl]]
set auto_index(::safe::interpCreate) [list ::tcl::Pkg::source [file join $dir safe.tcl]]
@@ -67,6 +69,7 @@ set auto_index(tcl_wordBreakBefore) [list ::tcl::Pkg::source [file join $dir wor
set auto_index(tcl_endOfWord) [list ::tcl::Pkg::source [file join $dir word.tcl]]
set auto_index(tcl_startOfNextWord) [list ::tcl::Pkg::source [file join $dir word.tcl]]
set auto_index(tcl_startOfPreviousWord) [list ::tcl::Pkg::source [file join $dir word.tcl]]
+set auto_index(writeFile) [list ::tcl::Pkg::source [file join $dir writefile.tcl]]
set auto_index(::tcl::tm::add) [list ::tcl::Pkg::source [file join $dir tm.tcl]]
set auto_index(::tcl::tm::remove) [list ::tcl::Pkg::source [file join $dir tm.tcl]]
set auto_index(::tcl::tm::list) [list ::tcl::Pkg::source [file join $dir tm.tcl]]
diff --git a/library/writefile.tcl b/library/writefile.tcl
new file mode 100644
index 0000000..fbd9138
--- /dev/null
+++ b/library/writefile.tcl
@@ -0,0 +1,37 @@
+# writeFile:
+# Write the contents of a file.
+#
+# Copyright © 2023 Donal K Fellows.
+#
+# See the file "license.terms" for information on usage and redistribution
+# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+#
+
+proc writeFile {args} {
+ # Parse the arguments
+ switch [llength $args] {
+ 2 {
+ lassign $args filename data
+ set mode text
+ }
+ 3 {
+ lassign $args filename mode data
+ set MODES {binary text}
+ set ERR [list -level 1 -errorcode [list TCL LOOKUP MODE $mode]]
+ set mode [tcl::prefix match -message "mode" -error $ERR $MODES $mode]
+ }
+ default {
+ set COMMAND [lindex [info level 0] 0]
+ return -code error -errorcode {TCL WRONGARGS} \
+ "wrong # args: should be \"$COMMAND filename ?mode? data\""
+ }
+ }
+
+ # Write the file
+ set f [open $filename [dict get {text w binary wb} $mode]]
+ try {
+ puts -nonewline $f $data
+ } finally {
+ close $f
+ }
+}
diff --git a/tests/io.test b/tests/io.test
index 7e62e6b..00ae8f86 100644
--- a/tests/io.test
+++ b/tests/io.test
@@ -7654,6 +7654,29 @@ test io-52.20 {TclCopyChannel & encodings} -setup {
close $in
close $out
} -returnCodes 1 -match glob -result {error reading "file*": invalid or incomplete multibyte or wide character}
+
+test io-52.20.2 {TclCopyChannel & encoding error on same encoding} -setup {
+ set out [open $path(utf8-fcopy.txt) w]
+ fconfigure $out -encoding utf-8 -translation lf
+ puts $out "AÁ"
+ close $out
+} -constraints {fcopy} -body {
+ # 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]
+
+ # Using "-encoding ascii" means reading the "Á" gives an error
+ fconfigure $in -encoding ascii -profile strict
+ fconfigure $out -encoding ascii -translation lf
+
+ fcopy $in $out
+} -cleanup {
+ close $in
+ close $out
+} -returnCodes 1 -match glob -result {error reading "file*": invalid or incomplete multibyte or wide character}
+
test io-52.21 {TclCopyChannel & encodings} -setup {
set out [open $path(utf8-fcopy.txt) w]
fconfigure $out -encoding utf-8 -translation lf
@@ -7675,6 +7698,7 @@ test io-52.21 {TclCopyChannel & encodings} -setup {
close $in
close $out
} -returnCodes 1 -match glob -result {error writing "file*": invalid or incomplete multibyte or wide character}
+
test io-52.22 {TclCopyChannel & encodings} -setup {
set out [open $path(utf8-fcopy.txt) w]
fconfigure $out -encoding utf-8 -translation lf
@@ -7702,6 +7726,35 @@ test io-52.22 {TclCopyChannel & encodings} -setup {
close $out
unset ::s0
} -match glob -result {0 {error reading "file*": invalid or incomplete multibyte or wide character}}
+
+test io-52.22.1 {TclCopyChannel & encodings & tell position} -setup {
+ set out [open $path(utf8-fcopy.txt) w]
+ fconfigure $out -encoding utf-8 -translation lf
+ puts $out "AÁ"
+ close $out
+} -constraints {fcopy} -body {
+ # 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]
+
+ # Using "-encoding ascii" means reading the "Á" gives an error
+ fconfigure $in -encoding ascii -profile strict
+ fconfigure $out -encoding koi8-r -translation lf
+ proc ::xxx args {
+ set ::s0 $args
+ }
+
+ fcopy $in $out -command ::xxx
+ vwait ::s0
+ list [tell $in] [tell $out] {*}[set ::s0]
+} -cleanup {
+ close $in
+ close $out
+ unset ::s0
+} -match glob -result {1 1 1 {error reading "file*": invalid or incomplete multibyte or wide character}}
+
test io-52.23 {TclCopyChannel & encodings} -setup {
set out [open $path(utf8-fcopy.txt) w]
fconfigure $out -encoding utf-8 -translation lf
@@ -7730,7 +7783,6 @@ test io-52.23 {TclCopyChannel & encodings} -setup {
unset ::s0
} -match glob -result {0 {error writing "file*": invalid or incomplete multibyte or wide character}}
-
test io-53.1 {CopyData} {fcopy} {
file delete $path(test1)
set f1 [open $thisScript]
@@ -9302,13 +9354,13 @@ test io-75.7 {
fconfigure $f -encoding utf-8 -buffering none -eofchar {} -translation lf \
-profile strict
} -body {
- list [catch {read $f} msg] $msg
+ list [catch {read $f} msg data] $msg [dict get $data -data]
} -cleanup {
close $f
removeFile io-75.7
- unset msg f fn
+ unset msg data f fn
} -match glob -result {1 {error reading "file*":\
- invalid or incomplete multibyte or wide character}}
+ invalid or incomplete multibyte or wide character} A}
test io-75.8 {invalid utf-8 encoding eof first handling (-profile strict)} -setup {
set fn [makeFile {} io-75.8]
@@ -9326,10 +9378,11 @@ test io-75.8 {invalid utf-8 encoding eof first handling (-profile strict)} -setu
binary scan $d H* hd
lappend hd [eof $f]
lappend hd [read $f]
- close $f
set hd
} -cleanup {
+ close $f
removeFile io-75.8
+ unset f d hd
} -result {41 1 {}}
test io-75.8.eoflater {invalid utf-8 encoding eof after handling (-profile strict)} -setup {
@@ -9344,17 +9397,17 @@ test io-75.8.eoflater {invalid utf-8 encoding eof after handling (-profile stric
fconfigure $f -encoding utf-8 -buffering none -eofchar \x1A \
-translation lf -profile strict
} -body {
- set res [list [catch {read $f} msg] [eof $f]]
+ set res [list [catch {read $f} msg data] [eof $f] [dict get $data -data]]
chan configure $f -encoding iso8859-1
lappend res [read $f 1]
chan configure $f -encoding utf-8
- lappend res [catch {read $f 1} msg] $msg
+ lappend res [catch {read $f 1} msg data] $msg [dict get $data -data]
} -cleanup {
close $f
removeFile io-75.8
- unset res msg fn f
-} -match glob -result "1 0 \x81 1 {error reading \"*\":\
- invalid or incomplete multibyte or wide character}"
+ unset res msg data fn f
+} -match glob -result "1 0 A \x81 1 {error reading \"*\":\
+ invalid or incomplete multibyte or wide character} {}"
test io-strict-multibyte-eof {
@@ -9369,12 +9422,12 @@ test io-strict-multibyte-eof {
seek $chan 0
chan configure $chan -encoding utf-8 -profile strict
} -body {
- list [catch {read $chan 1} msg] $msg
+ list [catch {read $chan 1} msg data] $msg [dict get $data -data]
} -cleanup {
close $chan
- unset msg chan
+ unset msg chan data
} -match glob -result {1 {error reading "*":\
- invalid or incomplete multibyte or wide character}}
+ invalid or incomplete multibyte or wide character} {}}
test io-75.9 {unrepresentable character write throws error in strict profile} -setup {
set fn [makeFile {} io-75.9]
@@ -9431,13 +9484,13 @@ test io-75.11 {shiftjis encoding error read results in error (strict profile)} -
} -body {
set d [read $f]
binary scan $d H* hd
- lappend hd [catch {set d [read $f]} msg] $msg
+ lappend hd [catch {set d [read $f]} msg data] $msg [dict exists $data -data]
} -cleanup {
close $f
removeFile io-75.11
- unset d hd msg f
+ unset d hd msg data f
} -match glob -result {41 1 {error reading "file*":\
- invalid or incomplete multibyte or wide character}}
+ invalid or incomplete multibyte or wide character} 0}
test io-75.12 {invalid utf-8 encoding read is ignored} -setup {
set fn [makeFile {} io-75.12]
@@ -9472,13 +9525,13 @@ test io-75.13 {
} -body {
set d [read $f]
binary scan $d H* hd
- lappend hd [catch {read $f} msg] $msg
+ lappend hd [catch {read $f} msg data] $msg [dict exists $data -data]
} -cleanup {
close $f
removeFile io-75.13
- unset d hd msg f fn
+ unset d hd msg data f fn
} -match glob -result {41 1 {error reading "file*":\
- invalid or incomplete multibyte or wide character}}
+ invalid or incomplete multibyte or wide character} 0}
test io-75.14 {
[gets] succesfully returns lines prior to error
@@ -9496,16 +9549,16 @@ test io-75.14 {
} -body {
set res [gets $chan]
lappend res [gets $chan]
- lappend res [catch {gets $chan} msg] $msg
+ lappend res [catch {gets $chan} msg data] $msg [dict exists $data -data]
chan configure $chan -profile tcl8
lappend res [gets $chan]
lappend res [gets $chan]
return $res
} -cleanup {
close $chan
- unset chan res msg
+ unset chan res msg data
} -match glob -result {a b 1 {error reading "*":\
- invalid or incomplete multibyte or wide character} cÀ d}
+ invalid or incomplete multibyte or wide character} 0 cÀ d}
test io-75.15 {
invalid utf-8 encoding strict
@@ -9523,8 +9576,8 @@ test io-75.15 {
fconfigure $chan -encoding utf-8 -profile strict
lappend res [gets $chan]
lappend res [gets $chan]
- lappend res [catch {gets $chan} msg] $msg
- lappend res [catch {gets $chan} msg] $msg
+ lappend res [catch {gets $chan} msg data] $msg [dict exists $data -data]
+ lappend res [catch {gets $chan} msg data] $msg [dict exists $data -data]
chan configure $chan -translation binary
set data [read $chan 4]
foreach char [split $data {}] {
@@ -9539,7 +9592,7 @@ test io-75.15 {
close $chan
unset chan res msg data
} -match glob -result {hello AB 1 {error reading "*": invalid or incomplete multibyte or wide character}\
- 1 {error reading "*": invalid or incomplete multibyte or wide character} 43 44 c0 40 EF GHI}
+ 0 1 {error reading "*": invalid or incomplete multibyte or wide character} 0 43 44 c0 40 EF GHI}
# ### ### ### ######### ######### #########
diff --git a/tests/ioCmd.test b/tests/ioCmd.test
index 678700f..2b9aed6 100644
--- a/tests/ioCmd.test
+++ b/tests/ioCmd.test
@@ -1,6 +1,7 @@
# -*- tcl -*-
# Commands covered: open, close, gets, read, puts, seek, tell, eof, flush,
-# fblocked, fconfigure, open, channel, fcopy
+# fblocked, fconfigure, open, channel, fcopy,
+# readFile, writeFile, foreachLine
#
# 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
@@ -3927,6 +3928,209 @@ test iocmd.tf-32.1 {origin thread of moved channel destroyed during access} -mat
} -constraints {testchannel thread notValgrind} \
-result {Owner lost}
+# Tests of readFile
+
+set BIN_DATA "\u0000\u0001\u0002\u0003\u0004\u001a\u001b\u000d\u000a\u0000"
+
+test iocmd.readFile-1.1 "readFile procedure: syntax" -body {
+ readFile
+} -returnCodes error -result {wrong # args: should be "readFile filename ?mode?"}
+test iocmd.readFile-1.2 "readFile procedure: syntax" -body {
+ readFile a b c
+} -returnCodes error -result {wrong # args: should be "readFile filename ?mode?"}
+test iocmd.readFile-1.3 "readFile procedure: syntax" -body {
+ readFile gorp gorp2
+} -returnCodes error -result {bad mode "gorp2": must be binary or text}
+
+test iocmd.readFile-2.1 "readFile procedure: behaviour" -setup {
+ set f [makeFile "File\nContents" readFile21.txt]
+} -body {
+ readFile $f
+} -cleanup {
+ removeFile $f
+} -result "File\nContents\n"
+test iocmd.readFile-2.2 "readFile procedure: behaviour" -setup {
+ set f [makeFile "File\nContents" readFile22.txt]
+} -body {
+ readFile $f text
+} -cleanup {
+ removeFile $f
+} -result "File\nContents\n"
+test iocmd.readFile-2.3 "readFile procedure: behaviour" -setup {
+ set f [makeFile "" readFile23.bindata]
+ apply {filename {
+ global BIN_DATA
+ set ff [open $filename wb]
+ puts -nonewline $ff $BIN_DATA
+ close $ff
+ }} $f
+} -body {
+ list [binary scan [readFile $f binary] c* x] $x
+} -cleanup {
+ removeFile $f
+} -result {1 {0 1 2 3 4 26 27 13 10 0}}
+# Need to set up ahead of the test
+set f [makeFile "" readFile24.txt]
+removeFile $f
+test iocmd.readFile-2.4 "readFile procedure: behaviour" -body {
+ readFile $f
+} -returnCodes error -result "couldn't open \"$f\": no such file or directory"
+
+# Tests of writeFile
+
+test iocmd.writeFile-1.1 "writeFile procedure: syntax" -body {
+ writeFile
+} -returnCodes error -result {wrong # args: should be "writeFile filename ?mode? data"}
+test iocmd.writeFile-1.2 "writeFile procedure: syntax" -body {
+ writeFile a b c d
+} -returnCodes error -result {wrong # args: should be "writeFile filename ?mode? data"}
+test iocmd.writeFile-1.3 "writeFile procedure: syntax" -body {
+ writeFile gorp gorp2 gorp3
+} -returnCodes error -result {bad mode "gorp2": must be binary or text}
+
+test iocmd.writeFile-2.1 "readFile procedure: behaviour" -setup {
+ set f [makeFile "" writeFile21.txt]
+ removeFile $f
+} -body {
+ list [writeFile $f "File\nContents\n"] [apply {filename {
+ set f [open $filename]
+ set text [read $f]
+ close $f
+ return $text
+ }} $f]
+} -cleanup {
+ file delete $f
+} -result [list {} "File\nContents\n"]
+test iocmd.writeFile-2.2 "readFile procedure: behaviour" -setup {
+ set f [makeFile "" writeFile22.txt]
+ removeFile $f
+} -body {
+ writeFile $f text "File\nContents\n"
+ apply {filename {
+ set f [open $filename]
+ set text [read $f]
+ close $f
+ return $text
+ }} $f
+} -cleanup {
+ file delete $f
+} -result "File\nContents\n"
+test iocmd.writeFile-2.3 "readFile procedure: behaviour" -setup {
+ set f [makeFile "" writeFile23.txt]
+ removeFile $f
+} -body {
+ writeFile $f binary $BIN_DATA
+ apply {filename {
+ set f [open $filename rb]
+ set bytes [read $f]
+ close $f
+ binary scan $bytes c* x
+ return $x
+ }} $f
+} -cleanup {
+ file delete $f
+} -result {0 1 2 3 4 26 27 13 10 0}
+
+# Tests of foreachLine
+
+test iocmd.foreachLine-1.1 "foreachLine procedure: syntax" -returnCodes error -body {
+ foreachLine
+} -result {wrong # args: should be "foreachLine varName filename body"}
+test iocmd.foreachLine-1.2 "foreachLine procedure: syntax" -returnCodes error -body {
+ foreachLine a b c d
+} -result {wrong # args: should be "foreachLine varName filename body"}
+test iocmd.foreachLine-1.3 "foreachLine procedure: basic errors" -setup {
+ set f [makeFile "" foreachLine13.txt]
+} -body {
+ apply {filename {
+ array set b {1 1}
+ foreachLine b $filename {}
+ }} $f
+} -cleanup {
+ removeFile $f
+} -returnCodes error -result {can't set "line": variable is array}
+set f [makeFile "" foreachLine14.txt]
+removeFile $f
+test iocmd.foreachLine-1.4 "foreachLine procedure: basic errors" -body {
+ apply {filename {
+ foreachLine var $filename {}
+ }} $f
+} -returnCodes error -result "couldn't open \"$f\": no such file or directory"
+
+test iocmd.foreachLine-2.1 "foreachLine procedure: behaviour" -setup {
+ set f [makeFile "a\nb\nc" foreachLine21.txt]
+} -body {
+ apply {filename {
+ set lines {}
+ foreachLine var $filename {
+ lappend lines $var
+ }
+ return $lines
+ }} $f
+} -cleanup {
+ removeFile $f
+} -result {a b c}
+test iocmd.foreachLine-2.2 "foreachLine procedure: behaviour" -setup {
+ set f [makeFile "a\nbb\nc\ndd" foreachLine22.txt]
+} -body {
+ apply {filename {
+ set lines {}
+ foreachLine var $filename {
+ if {[string length $var] == 1} continue
+ lappend lines $var
+ }
+ return $lines
+ }} $f
+} -cleanup {
+ removeFile $f
+} -result {bb dd}
+test iocmd.foreachLine-2.3 "foreachLine procedure: behaviour" -setup {
+ set f [makeFile "a\nbb\nccc\ndd\ne" foreachLine23.txt]
+} -body {
+ apply {filename {
+ set lines {}
+ foreachLine var $filename {
+ if {[string length $var] > 2} break
+ lappend lines $var
+ }
+ return $lines
+ }} $f
+} -cleanup {
+ removeFile $f
+} -result {a bb}
+test iocmd.foreachLine-2.4 "foreachLine procedure: behaviour" -setup {
+ set f [makeFile "a\nbb\nccc\ndd\ne" foreachLine24.txt]
+} -body {
+ apply {filename {
+ set lines {}
+ foreachLine var $filename {
+ if {[string length $var] > 2} {
+ return $var
+ }
+ lappend lines $var
+ }
+ return $lines
+ }} $f
+} -cleanup {
+ removeFile $f
+} -result {ccc}
+test iocmd.foreachLine-2.5 "foreachLine procedure: behaviour" -setup {
+ set f [makeFile "a\nbb\nccc\ndd\ne" foreachLine25.txt]
+} -body {
+ apply {filename {
+ set lines {}
+ foreachLine var $filename {
+ if {[string length $var] > 2} {
+ error "line too long"
+ }
+ lappend lines $var
+ }
+ return $lines
+ }} $f
+} -cleanup {
+ removeFile $f
+} -returnCodes error -result {line too long}
+
# ### ### ### ######### ######### #########
# ### ### ### ######### ######### #########
diff --git a/tests/oo.test b/tests/oo.test
index 291060d..cf8b710 100644
--- a/tests/oo.test
+++ b/tests/oo.test
@@ -1685,9 +1685,7 @@ test oo-11.5 {OO: cleanup} {
return done
} done
-test oo-11.6.1 {
- OO: cleanup of when an class is mixed into itself
-} -constraints memory -body {
+test oo-11.6.1 {OO: cleanup of when an class is mixed into itself} -constraints memory -body {
leaktest {
interp create interp1
oo::class create obj1
@@ -1695,13 +1693,8 @@ test oo-11.6.1 {
rename obj1 {}
interp delete interp1
}
-} -result 0 -cleanup {
-}
-
-test oo-11.6.2 {
- OO: cleanup ReleaseClassContents() where class is mixed into one of its
- instances
-} -constraints memory -body {
+} -result 0
+test oo-11.6.2 {OO: cleanup ReleaseClassContents() where class is mixed into one of its instances} -constraints memory -body {
leaktest {
interp create interp1
interp1 eval {
@@ -1712,13 +1705,8 @@ test oo-11.6.2 {
}
interp delete interp1
}
-} -result 0 -cleanup {
-}
-
-test oo-11.6.3 {
- OO: cleanup ReleaseClassContents() where class is mixed into one of its
- instances
-} -constraints memory -body {
+} -result 0
+test oo-11.6.3 {OO: cleanup ReleaseClassContents() where class is mixed into one of its instances} -constraints memory -body {
leaktest {
interp create interp1
interp1 eval {
@@ -1731,13 +1719,8 @@ test oo-11.6.3 {
}
interp delete interp1
}
-} -result 0 -cleanup {
-}
-
-test oo-11.6.4 {
- OO: cleanup ReleaseClassContents() where class is mixed into one of its
- instances
-} -body {
+} -result 0
+test oo-11.6.4 {OO: cleanup ReleaseClassContents() where class is mixed into one of its instances} -body {
oo::class create obj1
::oo::define obj1 {self mixin [self]}
@@ -2218,6 +2201,31 @@ test oo-14.8 {OO: class mixin order - Bug 1998221} -setup {
}
[cls new] test
} -result {mix cls}
+test oo-14.9 {OO: class mixins must be unique in list} -setup {
+ oo::class create parent
+} -body {
+ oo::class create A {superclass parent}
+ oo::class create B {
+ superclass parent
+ mixin A
+ }
+ oo::define B mixin -append A
+} -returnCodes error -cleanup {
+ parent destroy
+} -result {class should only be a direct mixin once}
+test oo-14.10 {OO: instance mixins must be unique in list} -setup {
+ oo::class create parent
+} -body {
+ oo::class create A {superclass parent}
+ oo::class create B {
+ superclass parent
+ constructor {} {oo::objdefine [self] mixin A}
+ }
+ B create obj
+ oo::objdefine obj {mixin -append A}
+} -returnCodes error -cleanup {
+ parent destroy
+} -result {class should only be a direct mixin once}
test oo-15.1 {OO: object cloning} {
oo::class create Aclass
@@ -4198,6 +4206,19 @@ test oo-33.4 {TIP 380: slots - errors} -setup [SampleSlotSetup {
rename $s {}
}] -result \
{unknown method "-grill": must be -append, -appendifnew, -clear, -prepend, -remove, -set, contents or ops}
+test oo-33.5 {TIP 567: slots -appendifnew} -setup [SampleSlotSetup {
+ set s [SampleSlot new]
+}] -body {
+ list \
+ [$s -clear
+ $s contents] \
+ [$s -append p q r
+ $s contents] \
+ [$s -appendifnew q s r t p
+ $s contents]
+} -cleanup [SampleSlotCleanup {
+ rename $s {}
+}] -result {{} {p q r} {p q r s t}}
test oo-34.1 {TIP 380: slots - presence} -setup {
set obj [oo::object new]
diff --git a/tests/ooUtil.test b/tests/ooUtil.test
index f41c668..9e1de8f 100644
--- a/tests/ooUtil.test
+++ b/tests/ooUtil.test
@@ -527,6 +527,29 @@ test ooUtil-7.2 {TIP 478: link removed when [my] disappears} -setup {
parent destroy
} -result {{in foo of ::o} {in foo of ::o} {} 1 {invalid command name "pqr"}}
+# Tests a very weird combination of things (with a key problem locus in
+# MixinClassDelegates) that TIP 567 fixes
+test ooUtil-8.1 {TIP 567: call oo::define twice from metaclass constructor} -setup {
+ oo::class create parent
+} -body {
+ ::oo::class create A {
+ superclass parent
+ }
+ ::oo::class create B {
+ superclass ::oo::class parent
+ constructor {{definitionScript ""}} {
+ next $definitionScript
+ next {superclass ::A}
+ }
+ }
+ B create C {
+ superclass A
+ }
+ C create instance
+} -cleanup {
+ parent destroy
+} -result ::instance
+
# Tests that verify issues detected with the tcllib version of the code
test ooUtil-tcllib-ticket-b3577ed586 {test scoping of delegation in oo::class.Delegate } -setup {
oo::class create animal {}
diff --git a/tests/reg.test b/tests/reg.test
index b6198d8..67973ea 100644
--- a/tests/reg.test
+++ b/tests/reg.test
@@ -643,8 +643,8 @@ expectMatch 13.29 P "a\\U0001234x" "a\u1234x" "a\u1234x"
expectMatch 13.30 P {a\U0001234x} "a\u1234x" "a\u1234x"
expectMatch 13.31 P "a\\U000012345x" "a\u12345x" "a\u12345x"
expectMatch 13.32 P {a\U000012345x} "a\u12345x" "a\u12345x"
-expectMatch 13.33 P "a\\U1000000x" "a\uFFFD0x" "a\uFFFD0x"
-expectMatch 13.34 P {a\U1000000x} "a\uFFFD0x" "a\uFFFD0x"
+expectMatch 13.33 P "a\\U100000x" "a\U100000x" "a\U100000x"
+expectMatch 13.34 P {a\U100000x} "a\U100000x" "a\U100000x"
doing 14 "back references"
generated by cgit v0.12 at 2025-12-04 10:20:30 (GMT)