From 28a15ce481fd0e4b90f5904a64c80aa1d4266c97 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Thu, 15 Jun 2023 15:44:04 +0000 Subject: TIP #653 implementation (with a lot of corrections compared to the py-b8f575aa23 or the other tip-653 branch) --- generic/tclIOCmd.c | 5 ++++- tests/io.test | 33 +++++++++++++++++---------------- 2 files changed, 21 insertions(+), 17 deletions(-) diff --git a/generic/tclIOCmd.c b/generic/tclIOCmd.c index 5a0a8da..f93f11e 100644 --- a/generic/tclIOCmd.c +++ b/generic/tclIOCmd.c @@ -459,7 +459,9 @@ Tcl_ReadObjCmd( TclChannelPreserve(chan); charactersRead = Tcl_ReadChars(chan, resultPtr, toRead, 0); if (charactersRead == TCL_IO_FAILURE) { - Tcl_DecrRefCount(resultPtr); + Tcl_Obj *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 +475,7 @@ Tcl_ReadObjCmd( TclGetString(chanObjPtr), Tcl_PosixError(interp))); } TclChannelRelease(chan); + Tcl_SetReturnOptions(interp, returnOptsPtr); return TCL_ERROR; } diff --git a/tests/io.test b/tests/io.test index 54ccaac..bc03656 100644 --- a/tests/io.test +++ b/tests/io.test @@ -9208,12 +9208,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 data } -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 handling (-profile strict)} -setup { set fn [makeFile {} io-75.8] @@ -9249,18 +9250,17 @@ test io-75.8.eoflater {invalid utf-8 encoding eof handling (-profile strict)} -s fconfigure $f -encoding utf-8 -buffering none -eofchar \x1A \ -translation lf -profile strict } -body { - set res [list [catch {read $f} cres] [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 - catch {read $f 1} cres - lappend res $cres + lappend res [catch {read $f 1} msg data] $msg [dict get $data -data] close $f set res } -cleanup { removeFile io-75.8 -} -match glob -result "1 0 \x81 {error reading \"*\":\ - invalid or incomplete multibyte or wide character}" +} -match glob -result "1 0 A \x81 1 {error reading \"*\":\ + invalid or incomplete multibyte or wide character} {}" test io-strict-multibyte-eof { @@ -9268,7 +9268,6 @@ test io-strict-multibyte-eof { See issue 25cdcb7e8fb381fb } -setup { - set res {} set chan [file tempfile]; fconfigure $chan -encoding binary puts -nonewline $chan \x81\x1A @@ -9276,12 +9275,12 @@ test io-strict-multibyte-eof { seek $chan 0 chan configure $chan -encoding utf-8 -profile strict } -body { - list [catch {read $chan 1} cres] $cres + list [catch {read $chan 1} msg data] $msg [dict get $data -data] } -cleanup { close $chan - unset res + unset msg 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 passes and is replaced by ?} -setup { set fn [makeFile {} io-75.9] @@ -9336,12 +9335,13 @@ test io-75.11 {shiftjis encoding error read results in raw bytes} -setup { } -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 get $data -data] } -cleanup { close $f removeFile io-75.11 + unset d hd msg data } -match glob -result {41 1 {error reading "file*":\ - invalid or incomplete multibyte or wide character}} + invalid or incomplete multibyte or wide character} {}} test io-75.12 {invalid utf-8 encoding read is ignored} -setup { set fn [makeFile {} io-75.12] @@ -9376,12 +9376,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 get $data -data] } -cleanup { close $f removeFile io-75.13 + unset d hd msg data } -match glob -result {41 1 {error reading "file*":\ - invalid or incomplete multibyte or wide character}} + invalid or incomplete multibyte or wide character} {}} test io-75.14 { [gets] succesfully returns lines prior to error @@ -9397,7 +9398,7 @@ test io-75.14 { fconfigure $chan -encoding utf-8 -buffering none -eofchar {} \ -translation auto -profile strict } -body { - lappend res [gets $chan] + set res [gets $chan] lappend res [gets $chan] lappend res [catch {gets $chan} cres] $cres chan configure $chan -profile tcl8 -- cgit v0.12 From b072039e2175a46e30af3538857dd83f656b5ea4 Mon Sep 17 00:00:00 2001 From: oehhar Date: Mon, 6 Nov 2023 15:47:32 +0000 Subject: Document tip-653 changes on read: Key "-data" for already decoded data on encoding error --- doc/read.n | 15 +++++++++++---- 1 file changed, 11 insertions(+), 4 deletions(-) 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 -- cgit v0.12 From 436509ded2037b6ff1e430320e2f3cfddcfa937f Mon Sep 17 00:00:00 2001 From: oehhar Date: Tue, 7 Nov 2023 12:42:54 +0000 Subject: TIP 653: adopted implementation to new text to only return "-data" if potential data loss. Check for non-blocking missing --- generic/tclIOCmd.c | 14 ++++++++------ tests/io.test | 20 ++++++++++---------- 2 files changed, 18 insertions(+), 16 deletions(-) diff --git a/generic/tclIOCmd.c b/generic/tclIOCmd.c index cd7fbff..0827858 100644 --- a/generic/tclIOCmd.c +++ b/generic/tclIOCmd.c @@ -318,9 +318,7 @@ Tcl_GetsObjCmd( lineLen = Tcl_GetsObj(chan, linePtr); if (lineLen == TCL_IO_FAILURE) { if (!Tcl_Eof(chan) && !Tcl_InputBlocked(chan)) { - Tcl_Obj *returnOptsPtr = Tcl_NewDictObj(); - Tcl_DictObjPut(NULL, returnOptsPtr, Tcl_NewStringObj("-data", -1), - linePtr); + Tcl_DecrRefCount(linePtr); /* * TIP #219. @@ -335,7 +333,6 @@ Tcl_GetsObjCmd( TclGetString(chanObjPtr), Tcl_PosixError(interp))); } code = TCL_ERROR; - Tcl_SetReturnOptions(interp, returnOptsPtr); goto done; } lineLen = TCL_IO_FAILURE; @@ -462,9 +459,14 @@ Tcl_ReadObjCmd( TclChannelPreserve(chan); charactersRead = Tcl_ReadChars(chan, resultPtr, toRead, 0); if (charactersRead == TCL_IO_FAILURE) { + Tcl_Obj *returnOptsPtr = Tcl_NewDictObj(); - Tcl_DictObjPut(NULL, returnOptsPtr, Tcl_NewStringObj("-data", -1), - resultPtr); + /* check for blocking and encoding error */ + /* TODO: check for blocking missing */ + if ( Tcl_GetErrno() == EILSEQ ) { + Tcl_DictObjPut(NULL, returnOptsPtr, Tcl_NewStringObj("-data", -1), + resultPtr); + } /* * TIP #219. * Capture error messages put by the driver into the bypass area and diff --git a/tests/io.test b/tests/io.test index 997dadd..a427541 100644 --- a/tests/io.test +++ b/tests/io.test @@ -1560,7 +1560,7 @@ test io-12.9 {ReadChars: multibyte chars split} -body { read $f scan [string index $in end] %c } -cleanup { - close $f + catch {close $f} } -result 194 test io-12.10 {ReadChars: multibyte chars split} -body { set f [open $path(test1) w] @@ -9212,7 +9212,7 @@ test io-75.6 {invalid utf-8 encoding, gets is not ignored (-profile strict)} -se invalid or incomplete multibyte or wide character} test io-75.7 { - invalid utf-8 encoding gets is not ignored (-profile strict) + invalid utf-8 encoding read is not ignored (-profile strict) } -setup { set fn [makeFile {} io-75.7] set f [open $fn w+] @@ -9340,7 +9340,7 @@ test io-75.10 {incomplete multibyte encoding read is ignored} -setup { # As utf-8 has a special treatment in multi-byte decoding, also test another # one. -test io-75.11 {shiftjis encoding error read results in raw bytes} -setup { +test io-75.11 {shiftjis encoding error read results in error (strict profile)} -setup { set fn [makeFile {} io-75.11] set f [open $fn w+] fconfigure $f -encoding binary @@ -9395,13 +9395,13 @@ test io-75.13 { } -body { set d [read $f] binary scan $d H* hd - lappend hd [catch {read $f} msg data] $msg [dict get $data -data] + lappend hd [catch {read $f} msg data] $msg [dict exists $data -data] } -cleanup { close $f removeFile io-75.13 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 @@ -9419,7 +9419,7 @@ test io-75.14 { } -body { set res [gets $chan] lappend res [gets $chan] - lappend res [catch {gets $chan} msg data] $msg [dict get $data -data] + 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] @@ -9428,7 +9428,7 @@ test io-75.14 { close $chan unset chan res msg data } -match glob -result {a b 1 {error reading "*":\ - invalid or incomplete multibyte or wide character} c cÀ d} + invalid or incomplete multibyte or wide character} 0 cÀ d} test io-75.15 { invalid utf-8 encoding strict @@ -9446,8 +9446,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 data] $msg [dict get $data -data] - lappend res [catch {gets $chan} msg data] $msg [dict get $data -data] + 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 {}] { @@ -9462,7 +9462,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}\ - CD 1 {error reading "*": invalid or incomplete multibyte or wide character} CD 43 44 c0 40 EF GHI} + 0 1 {error reading "*": invalid or incomplete multibyte or wide character} 0 43 44 c0 40 EF GHI} # ### ### ### ######### ######### ######### -- cgit v0.12 From b50cf76d6fd8274a93a5d041ec2a568a549293fe Mon Sep 17 00:00:00 2001 From: dgp Date: Wed, 8 Nov 2023 21:46:48 +0000 Subject: In the zipfs archive initialization, use Tcl_SetPreInitScript() to equip the creation of every interp by the Tcl library with the knowledge of where in the archive the script library is to be found. This is the **documented example usage** for Tcl_SetPreInitScript. POSTSCRIPT: Moved to development branch. Still needs some verification. --- generic/tclZipfs.c | 58 ++++++++++++++++++++++++++++++++++++++++++------------ 1 file changed, 45 insertions(+), 13 deletions(-) diff --git a/generic/tclZipfs.c b/generic/tclZipfs.c index 842d51a..4d95973 100644 --- a/generic/tclZipfs.c +++ b/generic/tclZipfs.c @@ -91,6 +91,17 @@ 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" /* @@ -313,6 +324,7 @@ 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 */ @@ -4231,6 +4243,28 @@ 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); @@ -4268,13 +4302,12 @@ TclZipfs_TclLibrary(void) * Look for the library file system within the executable. */ - vfsInitScript = Tcl_NewStringObj(ZIPFS_APP_MOUNT "/tcl_library/init.tcl", - -1); + vfsInitScript = Tcl_NewStringObj(ZIPFS_TCL_LIBRARY_1 "/init.tcl", -1); 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"; + zipfs_literal_tcl_library = ZIPFS_TCL_LIBRARY_1; return ScriptLibrarySetup(zipfs_literal_tcl_library); } @@ -6283,22 +6316,21 @@ ZipfsAppHookFindTclInit( return TCL_ERROR; } - TclNewLiteralStringObj(vfsInitScript, ZIPFS_ZIP_MOUNT "/init.tcl"); + TclNewLiteralStringObj(vfsInitScript, ZIPFS_TCL_LIBRARY_2 "/init.tcl"); Tcl_IncrRefCount(vfsInitScript); found = Tcl_FSAccess(vfsInitScript, F_OK); Tcl_DecrRefCount(vfsInitScript); if (found == 0) { - zipfs_literal_tcl_library = ZIPFS_ZIP_MOUNT; + zipfs_literal_tcl_library = ZIPFS_TCL_LIBRARY_2; return TCL_OK; } - TclNewLiteralStringObj(vfsInitScript, - ZIPFS_ZIP_MOUNT "/tcl_library/init.tcl"); + TclNewLiteralStringObj(vfsInitScript, ZIPFS_TCL_LIBRARY_3 "/init.tcl"); Tcl_IncrRefCount(vfsInitScript); found = Tcl_FSAccess(vfsInitScript, F_OK); Tcl_DecrRefCount(vfsInitScript); if (found == 0) { - zipfs_literal_tcl_library = ZIPFS_ZIP_MOUNT "/tcl_library"; + zipfs_literal_tcl_library = ZIPFS_TCL_LIBRARY_3; return TCL_OK; } @@ -6415,12 +6447,12 @@ TclZipfs_AppHook( if (!zipfs_literal_tcl_library) { TclNewLiteralStringObj(vfsInitScript, - ZIPFS_APP_MOUNT "/tcl_library/init.tcl"); + 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_APP_MOUNT "/tcl_library"; + zipfs_literal_tcl_library = ZIPFS_TCL_LIBRARY_1; return version; } } @@ -6449,7 +6481,7 @@ TclZipfs_AppHook( TclZipfs_TclLibrary(); TclNewLiteralStringObj(vfsInitScript, - ZIPFS_ZIP_MOUNT "/tcl_library/install.tcl"); + ZIPFS_TCL_LIBRARY_3 "install.tcl"); Tcl_IncrRefCount(vfsInitScript); if (Tcl_FSAccess(vfsInitScript, F_OK) == 0) { Tcl_SetStartupScript(vfsInitScript, NULL); @@ -6472,12 +6504,12 @@ TclZipfs_AppHook( } /* Set Tcl Encodings */ TclNewLiteralStringObj(vfsInitScript, - ZIPFS_APP_MOUNT "/tcl_library/init.tcl"); + 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_APP_MOUNT "/tcl_library"; + zipfs_literal_tcl_library = ZIPFS_TCL_LIBRARY_1; return version; } } -- cgit v0.12 From 4c391a13ae96bbc5307b97af37bafa4e58ab5b86 Mon Sep 17 00:00:00 2001 From: dgp Date: Mon, 13 Nov 2023 19:24:20 +0000 Subject: Make calls early to find the script library in zipfs archive and alert the Tcl library to its location so that all interps find it when created. --- generic/tclZipfs.c | 22 ++++++++++++++-------- 1 file changed, 14 insertions(+), 8 deletions(-) diff --git a/generic/tclZipfs.c b/generic/tclZipfs.c index adb7802..36fc82a 100644 --- a/generic/tclZipfs.c +++ b/generic/tclZipfs.c @@ -6453,6 +6453,7 @@ TclZipfs_AppHook( Tcl_DecrRefCount(vfsInitScript); if (found == TCL_OK) { zipfs_literal_tcl_library = ZIPFS_TCL_LIBRARY_1; + Tcl_DecrRefCount(TclZipfs_TclLibrary()); return version; } } @@ -6479,7 +6480,7 @@ TclZipfs_AppHook( * wants it. */ - TclZipfs_TclLibrary(); + Tcl_DecrRefCount(TclZipfs_TclLibrary()); TclNewLiteralStringObj(vfsInitScript, ZIPFS_TCL_LIBRARY_3 "install.tcl"); Tcl_IncrRefCount(vfsInitScript); @@ -6491,6 +6492,17 @@ 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) { @@ -6502,14 +6514,8 @@ TclZipfs_AppHook( } else { Tcl_DecrRefCount(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; return version; } } -- cgit v0.12 From 480e67920e6d8c3b9c536cfc1683f6349a9b319a Mon Sep 17 00:00:00 2001 From: dgp Date: Mon, 13 Nov 2023 19:36:30 +0000 Subject: Now that the robust, early method of directing Tcl to find its script library in the zipfs archive is in place, we can yank out the hacky approach of defining a semi-secret command to extend a search path. Re-open the feature branch. Integration was pulled back when some reports of failures on some build configurations came in. --- generic/tclInterp.c | 1 - generic/tclZipfs.c | 40 ---------------------------------------- 2 files changed, 41 deletions(-) diff --git a/generic/tclInterp.c b/generic/tclInterp.c index ed3c527..b023615 100644 --- a/generic/tclInterp.c +++ b/generic/tclInterp.c @@ -402,7 +402,6 @@ 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" diff --git a/generic/tclZipfs.c b/generic/tclZipfs.c index 36fc82a..adabcda 100644 --- a/generic/tclZipfs.c +++ b/generic/tclZipfs.c @@ -4356,44 +4356,6 @@ 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. @@ -6286,8 +6248,6 @@ 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; -- cgit v0.12 From 2e628b79d9fe0fe590cbab9bea27c1fdf11082f9 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Tue, 14 Nov 2023 11:07:13 +0000 Subject: Add test for blocking mode --- generic/tclIO.c | 29 ++++++++++++++++++++++++++++- generic/tclIOCmd.c | 12 ++++++------ generic/tclInt.h | 1 + tests/io.test | 4 ++-- 4 files changed, 37 insertions(+), 9 deletions(-) diff --git a/generic/tclIO.c b/generic/tclIO.c index bc1b1c6..0047f0b 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; +} + /* *---------------------------------------------------------------------- * diff --git a/generic/tclIOCmd.c b/generic/tclIOCmd.c index 0827858..9667419 100644 --- a/generic/tclIOCmd.c +++ b/generic/tclIOCmd.c @@ -459,11 +459,9 @@ Tcl_ReadObjCmd( TclChannelPreserve(chan); charactersRead = Tcl_ReadChars(chan, resultPtr, toRead, 0); if (charactersRead == TCL_IO_FAILURE) { - - Tcl_Obj *returnOptsPtr = Tcl_NewDictObj(); - /* check for blocking and encoding error */ - /* TODO: check for blocking missing */ - if ( Tcl_GetErrno() == EILSEQ ) { + Tcl_Obj *returnOptsPtr = NULL; + if (TclChannelGetBlockingMode(chan)) { + returnOptsPtr = Tcl_NewDictObj(); Tcl_DictObjPut(NULL, returnOptsPtr, Tcl_NewStringObj("-data", -1), resultPtr); } @@ -480,7 +478,9 @@ Tcl_ReadObjCmd( TclGetString(chanObjPtr), Tcl_PosixError(interp))); } TclChannelRelease(chan); - Tcl_SetReturnOptions(interp, returnOptsPtr); + 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/tests/io.test b/tests/io.test index 0737c2d..75e30aa 100644 --- a/tests/io.test +++ b/tests/io.test @@ -9432,13 +9432,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 data] $msg [dict get $data -data] + 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 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] -- cgit v0.12 From 67bbadafbae88f80f3ed23b4a0d0dec7e9cac82b Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Fri, 17 Nov 2023 07:58:25 +0000 Subject: make Tcl_GetByteArrayFromObj() macro work without stubs as well (in statically linked extensions) --- generic/tclDecls.h | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/generic/tclDecls.h b/generic/tclDecls.h index 9055a14..a62aeb6 100644 --- a/generic/tclDecls.h +++ b/generic/tclDecls.h @@ -4304,7 +4304,7 @@ extern const TclStubs *tclStubsPtr; #else /* defined(TCL_NO_DEPRECATED) */ # undef Tcl_GetByteArrayFromObj # define Tcl_GetByteArrayFromObj(objPtr, sizePtr) \ - tclStubsPtr->tcl_GetBytesFromObj(NULL, (objPtr), (sizePtr)) + Tcl_GetBytesFromObj(NULL, (objPtr), (sizePtr)) #endif /* !defined(TCL_NO_DEPRECATED) */ #endif /* _TCLDECLS */ -- cgit v0.12 From ecd68b90c6406241b80d97c6691812d24bcec707 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Fri, 17 Nov 2023 08:01:29 +0000 Subject: Don't bother testing the compatibility macro's any more. --- generic/tclTest.c | 29 +++-------------------------- 1 file changed, 3 insertions(+), 26 deletions(-) diff --git a/generic/tclTest.c b/generic/tclTest.c index e5f3650..3fa2dc7 100644 --- a/generic/tclTest.c +++ b/generic/tclTest.c @@ -5769,20 +5769,7 @@ TestbytestringObjCmd( int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* The argument objects. */ { - struct { -#if !defined(TCL_NO_DEPRECATED) -# if defined(_MSC_VER) && !defined(NDEBUG) -# pragma warning(disable:4133) -# elif defined(__clang__) -# pragma clang diagnostic push -# pragma clang diagnostic ignored "-Wincompatible-pointer-types" -# endif - int n; /* On purpose, not Tcl_Size, in order to demonstrate what happens */ -#else - Tcl_Size n; -#endif - int m; /* This variable should not be overwritten */ - } x = {0, 1}; + Tcl_Size n; const char *p; if (objc != 2) { @@ -5790,21 +5777,11 @@ TestbytestringObjCmd( return TCL_ERROR; } - /* Next line produces a "warning: passing argument 3 of ... from incompatible pointer type", - * but that's on purpose: It's exactly what we are testing here */ - p = (const char *)Tcl_GetBytesFromObj(interp, objv[1], &x.n); + p = (const char *)Tcl_GetBytesFromObj(interp, objv[1], &n); if (p == NULL) { return TCL_ERROR; } -#if !defined(TCL_NO_DEPRECATED) && defined(__clang__) -# pragma clang diagnostic pop -#endif - - if (x.m != 1) { - Tcl_AppendResult(interp, "Tcl_GetBytesFromObj() overwrites variable", (void *)NULL); - return TCL_ERROR; - } - Tcl_SetObjResult(interp, Tcl_NewStringObj(p, x.n)); + Tcl_SetObjResult(interp, Tcl_NewStringObj(p, n)); return TCL_OK; } -- cgit v0.12 From 0d75817bea5cb6ff2ce05f74d915a609b00f04de Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Fri, 17 Nov 2023 12:15:57 +0000 Subject: Add "knownBug" constraint to new testcase: io-52.20.1 --- tests/io.test | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/tests/io.test b/tests/io.test index f3402f3..c2a82b0 100644 --- a/tests/io.test +++ b/tests/io.test @@ -7655,12 +7655,12 @@ test io-52.20 {TclCopyChannel & encodings} -setup { close $out } -returnCodes 1 -match glob -result {error reading "file*": invalid or incomplete multibyte or wide character} -test io-52.20.1 {TclCopyChannel & read encoding error & tell position} -setup { +test io-52.20.1 {TclCopyChannel & read encoding error & tell position, bug [a173f9229]} -setup { set out [open $path(utf8-fcopy.txt) w] fconfigure $out -encoding utf-8 -translation lf puts $out "AÁ" close $out -} -constraints {fcopy} -body { +} -constraints {fcopy knownBug} -body { # binary to encoding => the input has to be # in utf-8 to make sense to the encoder -- cgit v0.12 From 5dd218ca607b888641a28ce7ec6ec5f9a0535305 Mon Sep 17 00:00:00 2001 From: dgp Date: Fri, 17 Nov 2023 15:19:36 +0000 Subject: silence compiler warning --- generic/tclInterp.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/generic/tclInterp.c b/generic/tclInterp.c index ed3c527..3d2c009 100644 --- a/generic/tclInterp.c +++ b/generic/tclInterp.c @@ -3604,7 +3604,7 @@ static void WrapFree( void *ptr) { - Tcl_Free(ptr); + ckfree(ptr); } void -- cgit v0.12 From b286637e28ec3f7a0cb2808088840ac7c2a0e613 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Fri, 17 Nov 2023 15:35:13 +0000 Subject: Cherry-pick [90e09ca320]: silence compiler warning --- generic/tclInterp.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/generic/tclInterp.c b/generic/tclInterp.c index 42d8ec3..f33aeed 100644 --- a/generic/tclInterp.c +++ b/generic/tclInterp.c @@ -3504,7 +3504,7 @@ static void WrapFree( void *ptr) { - Tcl_Free(ptr); + ckfree(ptr); } void -- cgit v0.12 From 64b0714cce3dbecaa78cd113cdf1dfe4da5d1ef5 Mon Sep 17 00:00:00 2001 From: dgp Date: Fri, 17 Nov 2023 15:49:56 +0000 Subject: test suite debugging. [removeFile] matches [makeFile] and not [writeFile]. --- tests/ioCmd.test | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/tests/ioCmd.test b/tests/ioCmd.test index 619db31..2b9aed6 100644 --- a/tests/ioCmd.test +++ b/tests/ioCmd.test @@ -3999,7 +3999,7 @@ test iocmd.writeFile-2.1 "readFile procedure: behaviour" -setup { return $text }} $f] } -cleanup { - removeFile $f + file delete $f } -result [list {} "File\nContents\n"] test iocmd.writeFile-2.2 "readFile procedure: behaviour" -setup { set f [makeFile "" writeFile22.txt] @@ -4013,7 +4013,7 @@ test iocmd.writeFile-2.2 "readFile procedure: behaviour" -setup { return $text }} $f } -cleanup { - removeFile $f + file delete $f } -result "File\nContents\n" test iocmd.writeFile-2.3 "readFile procedure: behaviour" -setup { set f [makeFile "" writeFile23.txt] @@ -4028,7 +4028,7 @@ test iocmd.writeFile-2.3 "readFile procedure: behaviour" -setup { return $x }} $f } -cleanup { - removeFile $f + file delete $f } -result {0 1 2 3 4 26 27 13 10 0} # Tests of foreachLine -- cgit v0.12 From 0650f4e76a34cf5f5f5f21de00ebbe34748c5377 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Fri, 17 Nov 2023 21:58:53 +0000 Subject: Remove binary-80.5 testcase. This testcase was testing the error-reporting capability of the 32-bit compabitility function. Will be useless after TIP #661 --- tests/binary.test | 3 --- 1 file changed, 3 deletions(-) diff --git a/tests/binary.test b/tests/binary.test index 299e1e0..d6a8195 100644 --- a/tests/binary.test +++ b/tests/binary.test @@ -3048,9 +3048,6 @@ test binary-80.3 {Tcl_GetBytesFromObj} -constraints testbytestring -returnCodes test binary-80.4 {Tcl_GetBytesFromObj} -constraints testbytestring -returnCodes 1 -body { testbytestring [testbytestring "\xC0\x80\xA0\xA0\xA0\xF0\x9F\x98\x81"] } -result "expected byte sequence but character 4 was '\U01F601' (U+01F601)" -test binary-80.5 {Tcl_GetBytesFromObj} -constraints {testbytestring pointerIs64bit deprecated} -body { - testbytestring [string repeat A [expr 2**31]] -} -returnCodes 1 -result "byte sequence length exceeds INT_MAX" # ---------------------------------------------------------------------- # cleanup -- cgit v0.12 From df18d9393c3f1336334fa37742e09461296575e7 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Fri, 17 Nov 2023 22:43:58 +0000 Subject: [f8c52a8c53]: CI: Add 32-bit Linux job --- .github/workflows/linux-build.yml | 7 +++++++ 1 file changed, 7 insertions(+) diff --git a/.github/workflows/linux-build.yml b/.github/workflows/linux-build.yml index 65ca764..f881b47 100644 --- a/.github/workflows/linux-build.yml +++ b/.github/workflows/linux-build.yml @@ -23,6 +23,8 @@ jobs: - "CFLAGS=-ftrapv" - "CFLAGS=-DTCL_UTF_MAX=4" - "CFLAGS=-DTCL_UTF_MAX=6" + # Duplicated below + - "CFLAGS=-m32 CPPFLAGS=-m32 LDFLAGS=-m32 --disable-64bit" defaults: run: shell: bash @@ -30,6 +32,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 -- cgit v0.12 From 44259e9b29f0a9923c3f251c3c1f7115b0196a96 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Sat, 18 Nov 2023 15:17:45 +0000 Subject: "stoponerror" == "profilestrict" (and not used anyway) --- generic/tclTest.c | 1 - 1 file changed, 1 deletion(-) diff --git a/generic/tclTest.c b/generic/tclTest.c index 0decc21..2f244a2 100644 --- a/generic/tclTest.c +++ b/generic/tclTest.c @@ -2092,7 +2092,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}, -- cgit v0.12 From 6a9b725dfc4ae4fdcd33bbb1273d05df6aae843b Mon Sep 17 00:00:00 2001 From: oehhar Date: Sat, 18 Nov 2023 17:18:42 +0000 Subject: Remove currently failing test io-52.20.1 to check right file position after fcopy encoding read error --- tests/io.test | 30 ------------------------------ 1 file changed, 30 deletions(-) diff --git a/tests/io.test b/tests/io.test index c2a82b0..341eee0 100644 --- a/tests/io.test +++ b/tests/io.test @@ -7655,36 +7655,6 @@ test io-52.20 {TclCopyChannel & encodings} -setup { close $out } -returnCodes 1 -match glob -result {error reading "file*": invalid or incomplete multibyte or wide character} -test io-52.20.1 {TclCopyChannel & read encoding error & tell position, bug [a173f9229]} -setup { - set out [open $path(utf8-fcopy.txt) w] - fconfigure $out -encoding utf-8 -translation lf - puts $out "AÁ" - close $out -} -constraints {fcopy knownBug} -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 - - set l {} - # should fail, so 1 is added - lappend l [catch {fcopy $in $out}] - # should be at position 1, after the first correct byte, so 1 is read. - lappend l [tell $in] - # not sure, if flush required, but anyway - flush $out - # should be at position 1, after the first correct byte, so 1 is written. - lappend l [tell $out] -} -cleanup { - close $in - close $out -} -returnCodes 0 -result {1 1 1} - test io-52.21 {TclCopyChannel & encodings} -setup { set out [open $path(utf8-fcopy.txt) w] fconfigure $out -encoding utf-8 -translation lf -- cgit v0.12