From e0becc6161a79eee0bcac49c6424690002100cd8 Mon Sep 17 00:00:00 2001 From: apnadkarni Date: Thu, 17 Nov 2022 04:54:02 +0000 Subject: TIP 651 implementation --- doc/DString.3 | 17 +++++++++++++++++ generic/tcl.decls | 8 ++++---- generic/tclDecls.h | 14 ++++++++++++++ generic/tclInt.h | 3 ++- generic/tclStubInit.c | 4 ++++ generic/tclTest.c | 9 +++++++-- generic/tclUtil.c | 2 +- tests/dstring.test | 39 +++++++++++++++++++++++++++++++++++++++ 8 files changed, 88 insertions(+), 8 deletions(-) diff --git a/doc/DString.3 b/doc/DString.3 index 00f1b8a..66323a7 100644 --- a/doc/DString.3 +++ b/doc/DString.3 @@ -41,6 +41,10 @@ char * \fBTcl_DStringResult\fR(\fIinterp, dsPtr\fR) .sp \fBTcl_DStringGetResult\fR(\fIinterp, dsPtr\fR) +.sp +Tcl_Obj * +\fBTcl_DStringToObj\fR(\fIdsPtr\fR) +.sp .SH ARGUMENTS .AS Tcl_DString newLength in/out .AP Tcl_DString *dsPtr in/out @@ -142,12 +146,25 @@ a pointer from \fIdsPtr\fR to the interpreter's result. This saves the cost of allocating new memory and copying the string. \fBTcl_DStringResult\fR also reinitializes the dynamic string to an empty string. +Since the dynamic string is reinitialized, there is no need to +further call \fBTcl_DStringFree\fR on it and it can be reused without +calling \fBTcl_DStringInit\fR. .PP \fBTcl_DStringGetResult\fR does the opposite of \fBTcl_DStringResult\fR. It sets the value of \fIdsPtr\fR to the result of \fIinterp\fR and it clears \fIinterp\fR's result. If possible it does this by moving a pointer rather than by copying the string. +.PP +\fBTcl_DStringToObj\fR returns a \fBTcl_Obj\fR containing the value of +the dynamic string given by \fIdsPtr\fR. It does this by moving +a pointer from \fIdsPtr\fR to a newly allocated \fBTcl_Obj\fR +and reinitializing to dynamic string to an empty string. +This saves the cost of allocating new memory and copying the string. +Since the dynamic string is reinitialized, there is no need to +further call \fBTcl_DStringFree\fR on it and it can be reused without +calling \fBTcl_DStringInit\fR. +The returned \fBTcl_Obj\fR has a reference count of 0. .SH KEYWORDS append, dynamic string, free, result diff --git a/generic/tcl.decls b/generic/tcl.decls index 3f4103f..59d0ece 100644 --- a/generic/tcl.decls +++ b/generic/tcl.decls @@ -2566,10 +2566,10 @@ declare 683 { # Tcl_WideUInt *uwidePtr) #} -# TIP 651 (reserved) -#declare 687 { -# Tcl_Obj *Tcl_DStringToObj(Tcl_DString *dsPtr) -#} +# TIP 651 +declare 687 { + Tcl_Obj *Tcl_DStringToObj(Tcl_DString *dsPtr) +} # ----- BASELINE -- FOR -- 8.7.0 / 9.0.0 ----- # diff --git a/generic/tclDecls.h b/generic/tclDecls.h index 0888ecf..3a57b2f 100644 --- a/generic/tclDecls.h +++ b/generic/tclDecls.h @@ -2040,6 +2040,11 @@ EXTERN int Tcl_RemoveChannelMode(Tcl_Interp *interp, Tcl_Channel chan, int mode); /* 683 */ EXTERN int Tcl_GetEncodingNulLength(Tcl_Encoding encoding); +/* Slot 684 is reserved */ +/* Slot 685 is reserved */ +/* Slot 686 is reserved */ +/* 687 */ +EXTERN Tcl_Obj * Tcl_DStringToObj(Tcl_DString *dsPtr); typedef struct { const struct TclPlatStubs *tclPlatStubs; @@ -2759,6 +2764,10 @@ typedef struct TclStubs { int (*tcl_GetNumber) (Tcl_Interp *interp, const char *bytes, size_t numBytes, void **clientDataPtr, int *typePtr); /* 681 */ int (*tcl_RemoveChannelMode) (Tcl_Interp *interp, Tcl_Channel chan, int mode); /* 682 */ int (*tcl_GetEncodingNulLength) (Tcl_Encoding encoding); /* 683 */ + void (*reserved684)(void); + void (*reserved685)(void); + void (*reserved686)(void); + Tcl_Obj * (*tcl_DStringToObj) (Tcl_DString *dsPtr); /* 687 */ } TclStubs; extern const TclStubs *tclStubsPtr; @@ -4157,6 +4166,11 @@ extern const TclStubs *tclStubsPtr; (tclStubsPtr->tcl_RemoveChannelMode) /* 682 */ #define Tcl_GetEncodingNulLength \ (tclStubsPtr->tcl_GetEncodingNulLength) /* 683 */ +/* Slot 684 is reserved */ +/* Slot 685 is reserved */ +/* Slot 686 is reserved */ +#define Tcl_DStringToObj \ + (tclStubsPtr->tcl_DStringToObj) /* 687 */ #endif /* defined(USE_TCL_STUBS) */ diff --git a/generic/tclInt.h b/generic/tclInt.h index 2d29e1d..9f0eef0 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -3128,7 +3128,6 @@ MODULE_SCOPE char * TclDStringAppendObj(Tcl_DString *dsPtr, Tcl_Obj *objPtr); MODULE_SCOPE char * TclDStringAppendDString(Tcl_DString *dsPtr, Tcl_DString *toAppendPtr); -MODULE_SCOPE Tcl_Obj * TclDStringToObj(Tcl_DString *dsPtr); MODULE_SCOPE Tcl_Obj *const *TclFetchEnsembleRoot(Tcl_Interp *interp, Tcl_Obj *const *objv, int objc, int *objcPtr); MODULE_SCOPE Tcl_Obj *const *TclEnsembleGetRewriteValues(Tcl_Interp *interp); @@ -4946,6 +4945,8 @@ MODULE_SCOPE Tcl_LibraryInitProc Procbodytest_SafeInit; Tcl_DStringAppend((dsPtr), (sLiteral), sizeof(sLiteral "") - 1) #define TclDStringClear(dsPtr) \ Tcl_DStringSetLength((dsPtr), 0) +/* Backward compatibility for TclDStringToObj which is now exported */ +#define TclDStringToObj Tcl_DStringToObj /* *---------------------------------------------------------------- diff --git a/generic/tclStubInit.c b/generic/tclStubInit.c index ad60fc3..b3eb0de 100644 --- a/generic/tclStubInit.c +++ b/generic/tclStubInit.c @@ -2055,6 +2055,10 @@ const TclStubs tclStubs = { Tcl_GetNumber, /* 681 */ Tcl_RemoveChannelMode, /* 682 */ Tcl_GetEncodingNulLength, /* 683 */ + 0, /* 684 */ + 0, /* 685 */ + 0, /* 686 */ + Tcl_DStringToObj, /* 687 */ }; /* !END!: Do not edit above this line. */ diff --git a/generic/tclTest.c b/generic/tclTest.c index c9bad56..86fd965 100644 --- a/generic/tclTest.c +++ b/generic/tclTest.c @@ -1934,6 +1934,11 @@ TestdstringCmd( goto wrongNumArgs; } Tcl_DStringResult(interp, &dstring); + } else if (strcmp(argv[1], "toobj") == 0) { + if (argc != 2) { + goto wrongNumArgs; + } + Tcl_SetObjResult(interp, Tcl_DStringToObj(&dstring)); } else if (strcmp(argv[1], "trunc") == 0) { if (argc != 3) { goto wrongNumArgs; @@ -1949,8 +1954,8 @@ TestdstringCmd( Tcl_DStringStartSublist(&dstring); } else { Tcl_AppendResult(interp, "bad option \"", argv[1], - "\": must be append, element, end, free, get, length, " - "result, trunc, or start", NULL); + "\": must be append, element, end, free, get, gresult, length, " + "result, start, toobj, or trunc", NULL); return TCL_ERROR; } return TCL_OK; diff --git a/generic/tclUtil.c b/generic/tclUtil.c index ab97461..fc5d1cc 100644 --- a/generic/tclUtil.c +++ b/generic/tclUtil.c @@ -3107,7 +3107,7 @@ Tcl_DStringGetResult( */ Tcl_Obj * -TclDStringToObj( +Tcl_DStringToObj( Tcl_DString *dsPtr) { Tcl_Obj *result; diff --git a/tests/dstring.test b/tests/dstring.test index 11c5754..314cee8 100644 --- a/tests/dstring.test +++ b/tests/dstring.test @@ -473,6 +473,45 @@ test dstring-6.5 {Tcl_DStringGetResult} -constraints testdstring -body { } -cleanup { testdstring free } -result {{} {This is a specially-allocated stringz}} + +test dstring-7.1 {copying to Tcl_Obj} -constraints testdstring -setup { + testdstring free +} -body { + testdstring append xyz -1 + list [testdstring toobj] [testdstring length] +} -cleanup { + testdstring free +} -result {xyz 0} +test dstring-7.2 {copying to a Tcl_Obj} -constraints testdstring -setup { + testdstring free + unset -nocomplain a +} -body { + foreach l {a b c d e f g h i j k l m n o p} { + testdstring append $l$l$l$l$l$l$l$l$l$l$l$l$l$l$l$l$l$l$l$l$l\n -1 + } + set a [testdstring toobj] + testdstring append abc -1 + list $a [testdstring get] +} -cleanup { + testdstring free +} -result {{aaaaaaaaaaaaaaaaaaaaa +bbbbbbbbbbbbbbbbbbbbb +ccccccccccccccccccccc +ddddddddddddddddddddd +eeeeeeeeeeeeeeeeeeeee +fffffffffffffffffffff +ggggggggggggggggggggg +hhhhhhhhhhhhhhhhhhhhh +iiiiiiiiiiiiiiiiiiiii +jjjjjjjjjjjjjjjjjjjjj +kkkkkkkkkkkkkkkkkkkkk +lllllllllllllllllllll +mmmmmmmmmmmmmmmmmmmmm +nnnnnnnnnnnnnnnnnnnnn +ooooooooooooooooooooo +ppppppppppppppppppppp +} abc} + # cleanup if {[testConstraint testdstring]} { -- cgit v0.12 From 3e4ac217aab55243d9096d19d611bfd368a4aa9b Mon Sep 17 00:00:00 2001 From: dgp Date: Fri, 18 Nov 2022 17:53:54 +0000 Subject: Bring back the common facilities of the tcltests "package", but use a less fragile method to gain access to them. --- tests/chanio.test | 1 + tests/env.test | 2 ++ tests/exec.test | 4 +--- tests/fileSystemEncoding.test | 15 +-------------- tests/io.test | 1 + tests/ioCmd.test | 1 + tests/platform.test | 1 + tests/tcltests.tcl | 3 +++ tests/thread.test | 2 +- 9 files changed, 12 insertions(+), 18 deletions(-) diff --git a/tests/chanio.test b/tests/chanio.test index 0f45819..1c689fb 100644 --- a/tests/chanio.test +++ b/tests/chanio.test @@ -34,6 +34,7 @@ namespace eval ::tcl::test::io { package require -exact Tcltest [info patchlevel] set ::tcltestlib [lindex [package ifneeded Tcltest [info patchlevel]] 1] } + source [file join [file dirname [info script]] tcltests.tcl] testConstraint testbytestring [llength [info commands testbytestring]] testConstraint testchannel [llength [info commands testchannel]] diff --git a/tests/env.test b/tests/env.test index 6c46532..bc1d7e9 100644 --- a/tests/env.test +++ b/tests/env.test @@ -16,6 +16,8 @@ if {"::tcltest" ni [namespace children]} { namespace import -force ::tcltest::* } +source [file join [file dirname [info script]] tcltests.tcl] + # [exec] is required here to see the actual environment received by child # processes. proc getenv {} { diff --git a/tests/exec.test b/tests/exec.test index 4cc4a05..3c445e8 100644 --- a/tests/exec.test +++ b/tests/exec.test @@ -18,10 +18,8 @@ if {"::tcltest" ni [namespace children]} { package require tcltest 2.5 namespace import -force ::tcltest::* } +source [file join [file dirname [info script]] tcltests.tcl] -# All tests require the "exec" command. -# Skip them if exec is not defined. -testConstraint exec [llength [info commands exec]] # Some skips when running in a macOS CI environment testConstraint noosxCI [expr {![info exists ::env(MAC_CI)]}] diff --git a/tests/fileSystemEncoding.test b/tests/fileSystemEncoding.test index 6561bef..24003b8 100644 --- a/tests/fileSystemEncoding.test +++ b/tests/fileSystemEncoding.test @@ -15,20 +15,7 @@ namespace eval ::tcl::test::fileSystemEncoding { variable fname1 \u767b\u9e1b\u9d72\u6a13 - proc autopath {} { - global auto_path - set scriptpath [info script] - set scriptpathnorm [file dirname [file normalize $scriptpath/...]] - set dirnorm [file dirname $scriptpathnorm] - set idx [lsearch -exact $auto_path $dirnorm] - if {$idx >= 0} { - set auto_path [lreplace $auto_path[set auto_path {}] $idx $idx {}] - } - set auto_path [linsert $auto_path[set auto_path {}] 0 0 $dirnorm] - } - autopath - - package require tcltests + source [file join [file dirname [info script]] tcltests.tcl] test filesystemEncoding-1.0 { issue bcd100410465 diff --git a/tests/io.test b/tests/io.test index cd4c954..ca7bd0c 100644 --- a/tests/io.test +++ b/tests/io.test @@ -34,6 +34,7 @@ namespace eval ::tcl::test::io { package require -exact Tcltest [info patchlevel] set ::tcltestlib [lindex [package ifneeded Tcltest [info patchlevel]] 1] } + source [file join [file dirname [info script]] tcltests.tcl] testConstraint testbytestring [llength [info commands testbytestring]] testConstraint testchannel [llength [info commands testchannel]] diff --git a/tests/ioCmd.test b/tests/ioCmd.test index 99bb464..d17dce3 100644 --- a/tests/ioCmd.test +++ b/tests/ioCmd.test @@ -17,6 +17,7 @@ if {"::tcltest" ni [namespace children]} { package require tcltest 2.5 namespace import -force ::tcltest::* } +source [file join [file dirname [info script]] tcltests.tcl] ::tcltest::loadTestedCommands catch [list package require -exact Tcltest [info patchlevel]] diff --git a/tests/platform.test b/tests/platform.test index 6b775cf..faab6d9 100644 --- a/tests/platform.test +++ b/tests/platform.test @@ -10,6 +10,7 @@ # of this file, and for a DISCLAIMER OF ALL WARRANTIES. package require tcltest 2.5 +source [file join [file dirname [info script]] tcltests.tcl] namespace eval ::tcl::test::platform { namespace import ::tcltest::testConstraint diff --git a/tests/tcltests.tcl b/tests/tcltests.tcl index 58e6bfb..1a473e9 100644 --- a/tests/tcltests.tcl +++ b/tests/tcltests.tcl @@ -1,5 +1,8 @@ #! /usr/bin/env tclsh +# Don't overwrite tcltests facilities already present +if {[package provide tcltests] ne {}} return + package require tcltest 2.5 namespace import ::tcltest::* diff --git a/tests/thread.test b/tests/thread.test index 28934a2..92f3a06 100644 --- a/tests/thread.test +++ b/tests/thread.test @@ -16,7 +16,7 @@ # be fully finalized, which avoids valgrind "still reachable" reports. package require tcltest 2.5 -namespace import ::tcltest::* +source [file join [file dirname [info script]] tcltests.tcl] ::tcltest::loadTestedCommands catch [list package require -exact Tcltest [info patchlevel]] -- cgit v0.12 From 124340611ed97ad4347b3ce4bc6aa1d76a99f1b0 Mon Sep 17 00:00:00 2001 From: dgp Date: Sun, 20 Nov 2022 14:16:36 +0000 Subject: Newest tests must have most recent releases of http to pass. --- tests/http.test | 22 +++++++++++++--------- 1 file changed, 13 insertions(+), 9 deletions(-) diff --git a/tests/http.test b/tests/http.test index b0f5144..498621b 100644 --- a/tests/http.test +++ b/tests/http.test @@ -30,6 +30,8 @@ if {[catch {package require http 2} version]} { return } } +testConstraint http2.9.7 [package vsatisfies [package provide http] 2.9.7] +testConstraint http2.9.8 [package vsatisfies [package provide http] 2.9.8] proc bgerror {args} { global errorInfo @@ -119,25 +121,25 @@ test http-1.6 {http::config} -setup { test http-2.1 {http::reset} { catch {http::reset http#1} } 0 -test http-2.2 {http::CharsetToEncoding} { +test http-2.2 {http::CharsetToEncoding} http2.9.7 { http::CharsetToEncoding iso-8859-11 } iso8859-11 -test http-2.3 {http::CharsetToEncoding} { +test http-2.3 {http::CharsetToEncoding} http2.9.7 { http::CharsetToEncoding iso-2022-kr } iso2022-kr -test http-2.4 {http::CharsetToEncoding} { +test http-2.4 {http::CharsetToEncoding} http2.9.7 { http::CharsetToEncoding shift-jis } shiftjis -test http-2.5 {http::CharsetToEncoding} { +test http-2.5 {http::CharsetToEncoding} http2.9.7 { http::CharsetToEncoding windows-437 } cp437 -test http-2.6 {http::CharsetToEncoding} { +test http-2.6 {http::CharsetToEncoding} http2.9.7 { http::CharsetToEncoding latin5 } iso8859-9 -test http-2.7 {http::CharsetToEncoding} { +test http-2.7 {http::CharsetToEncoding} http2.9.7 { http::CharsetToEncoding latin1 } iso8859-1 -test http-2.8 {http::CharsetToEncoding} { +test http-2.8 {http::CharsetToEncoding} http2.9.7 { http::CharsetToEncoding latin4 } binary @@ -468,12 +470,14 @@ test http-3.33 {http::geturl application/xml is text} -body { } -cleanup { catch { http::cleanup $token } } -result {test 4660 /test} + + test http-3.34 {http::geturl -headers not a list} -returnCodes error -body { http::geturl http://test/t -headers \" -} -result {Bad value for -headers ("), must be list} +} -constraints http2.9.8 -result {Bad value for -headers ("), must be list} test http-3.35 {http::geturl -headers not even number of elements} -returnCodes error -body { http::geturl http://test/t -headers {List Length 3} -} -result {Bad value for -headers (List Length 3), number of list elements must be even} +} -constraints http2.9.8 -result {Bad value for -headers (List Length 3), number of list elements must be even} test http-4.1 {http::Event} -body { set token [http::geturl $url -keepalive 0] -- cgit v0.12