From aa4f7bcd47ef35e83a3a5a6c3f16398bf3758e49 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Fri, 9 Apr 2021 15:19:51 +0000 Subject: Deprecate/remove "string bytelength" --- doc/string.n | 12 ++++++------ generic/tclCmdMZ.c | 4 ++++ library/init.tcl | 4 ++-- tests/info.test | 4 ++-- tests/regexp.test | 3 ++- tests/regexpComp.test | 4 +++- tests/string.test | 19 ++++++++++--------- 7 files changed, 29 insertions(+), 21 deletions(-) diff --git a/doc/string.n b/doc/string.n index 7cd53ca..f1a0592 100644 --- a/doc/string.n +++ b/doc/string.n @@ -404,7 +404,7 @@ Formally, the \fBstring bytelength\fR operation returns the content of the \fIlength\fR field of the \fBTcl_Obj\fR structure, after calling \fBTcl_GetString\fR to ensure that the \fIbytes\fR field is populated. This is highly unlikely to be useful to Tcl scripts, as Tcl's internal -encoding is not strict UTF\-8, but rather a modified CESU\-8 with a +encoding is not strict UTF\-8, but rather a modified WTF\-8 with a denormalized NUL (identical to that used in a number of places by Java's serialization mechanism) to enable basic processing with non-Unicode-aware C functions. As this representation should only @@ -413,13 +413,13 @@ store the representation is of very low value (except to C extension code, which has direct access for the purpose of memory management, etc.) .PP -\fICompatibility note:\fR it is likely that this subcommand will be -withdrawn in a future version of Tcl. It is better to use the -\fBencoding convertto\fR command to convert a string to a known -encoding and then apply \fBstring length\fR to that. +\fICompatibility note:\fR This subcommand is deprecated and will +be removed in Tcl 9.0. It is better to use the \fBencoding convertto\fR +command to convert a string to a known encoding (e.g. "wtf-8" or "tcl-8") +and then apply \fBstring length\fR to that. .PP .CS -\fBstring length\fR [encoding convertto utf-8 $theString] +\fBstring length\fR [encoding convertto wtf-8 $theString] .CE .RE .TP diff --git a/generic/tclCmdMZ.c b/generic/tclCmdMZ.c index 61d1010..6f71198 100644 --- a/generic/tclCmdMZ.c +++ b/generic/tclCmdMZ.c @@ -2835,6 +2835,7 @@ StringCatCmd( * *---------------------------------------------------------------------- */ +#if TCL_MAJOR_VERSION < 9 && !defined(TCL_NO_DEPRECATED) static int StringBytesCmd( TCL_UNUSED(ClientData), @@ -2853,6 +2854,7 @@ StringBytesCmd( Tcl_SetObjResult(interp, Tcl_NewWideIntObj(length)); return TCL_OK; } +#endif /* *---------------------------------------------------------------------- @@ -3309,7 +3311,9 @@ TclInitStringCmd( Tcl_Interp *interp) /* Current interpreter. */ { static const EnsembleImplMap stringImplMap[] = { +#if TCL_MAJOR_VERSION < 9 && !defined(TCL_NO_DEPRECATED) {"bytelength", StringBytesCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0}, +#endif {"cat", StringCatCmd, TclCompileStringCatCmd, NULL, NULL, 0}, {"compare", StringCmpCmd, TclCompileStringCmpCmd, NULL, NULL, 0}, {"equal", StringEqualCmd, TclCompileStringEqualCmd, NULL, NULL, 0}, diff --git a/library/init.tcl b/library/init.tcl index c9bfff6..749eed9 100644 --- a/library/init.tcl +++ b/library/init.tcl @@ -214,9 +214,9 @@ proc unknown args { set errInfo [dict get $opts -errorinfo] set errCode [dict get $opts -errorcode] set cinfo $args - if {[string bytelength $cinfo] > 150} { + if {[string length [encoding convertto wtf-8 $cinfo]] > 150} { set cinfo [string range $cinfo 0 150] - while {[string bytelength $cinfo] > 150} { + while {[string length [encoding convertto wtf-8 $cinfo]] > 150} { set cinfo [string range $cinfo 0 end-1] } append cinfo ... diff --git a/tests/info.test b/tests/info.test index d9a4f54..ced4435 100644 --- a/tests/info.test +++ b/tests/info.test @@ -22,7 +22,7 @@ if {{::tcltest} ni [namespace children]} { ::tcltest::loadTestedCommands catch [list package require -exact tcl::test [info patchlevel]] testConstraint zlib [llength [info commands zlib]] - +testConstraint nodep [info exists tcl_precision] # Set up namespaces needed to test operation of "info args", "info body", # "info default", and "info procs" with imported procedures. @@ -101,7 +101,7 @@ test info-2.5 {info body option, returning bytecompiled bodies} -body { # Fix for problem tested for in info-2.5 caused problems when # procedure body had no string rep (i.e. was not yet bytecode) # causing an empty string to be returned [Bug #545644] -test info-2.6 {info body option, returning list bodies} { +test info-2.6 {info body option, returning list bodies} nodep { proc foo args [list subst bar] list [string bytelength [info body foo]] \ [foo; string bytelength [info body foo]] diff --git a/tests/regexp.test b/tests/regexp.test index e788b7f..6bed21e 100644 --- a/tests/regexp.test +++ b/tests/regexp.test @@ -19,6 +19,7 @@ if {"::tcltest" ni [namespace children]} { unset -nocomplain foo testConstraint exec [llength [info commands exec]] +testConstraint nodep [info exists tcl_precision] # Used for constraining memory leak tests testConstraint memory [llength [info commands memory]] @@ -765,7 +766,7 @@ test regexp-19.2 {regsub null replacement} { string equal $result $expected } 1 -test regexp-20.1 {regsub shared object shimmering} -body { +test regexp-20.1 {regsub shared object shimmering} -constraints nodep -body { # Bug #461322 set a abcdefghijklmnopqurstuvwxyz set b $a diff --git a/tests/regexpComp.test b/tests/regexpComp.test index 76e708d..1587c72 100644 --- a/tests/regexpComp.test +++ b/tests/regexpComp.test @@ -16,6 +16,8 @@ if {"::tcltest" ni [namespace children]} { namespace import -force ::tcltest::* } +testConstraint nodep [info exists tcl_precision] + # Procedure to evaluate a script within a proc, to test compilation # functionality @@ -791,7 +793,7 @@ test regexpComp-19.1 {regsub null replacement} { } } "\0a\0hel\0a\0lo\0a\0 14" -test regexpComp-20.1 {regsub shared object shimmering} { +test regexpComp-20.1 {regsub shared object shimmering} nodep { evalInProc { # Bug #461322 set a abcdefghijklmnopqurstuvwxyz diff --git a/tests/string.test b/tests/string.test index 72aeb43..99c1517 100644 --- a/tests/string.test +++ b/tests/string.test @@ -33,6 +33,7 @@ testConstraint testindexobj [expr {[info commands testindexobj] ne {}}] testConstraint testevalex [expr {[info commands testevalex] ne {}}] testConstraint utf16 [expr {[string length \U010000] == 2}] testConstraint testbytestring [llength [info commands testbytestring]] +testConstraint nodep [info exists tcl_precision] # Used for constraining memory leak tests testConstraint memory [llength [info commands memory]] @@ -72,9 +73,9 @@ if {$noComp} { } -test string-1.1.$noComp {error conditions} { +test string-1.1.$noComp {error conditions} -body { list [catch {run {string gorp a b}} msg] $msg -} {1 {unknown or ambiguous subcommand "gorp": must be bytelength, cat, compare, equal, first, index, insert, is, last, length, map, match, range, repeat, replace, reverse, tolower, totitle, toupper, trim, trimleft, trimright, wordend, or wordstart}} +} -match glob -result {1 {unknown or ambiguous subcommand "gorp": must be *cat, compare, equal, first, index, insert, is, last, length, map, match, range, repeat, replace, reverse, tolower, totitle, toupper, trim, trimleft, trimright, wordend, or wordstart}} test string-1.2.$noComp {error conditions} { list [catch {run {string}} msg] $msg } {1 {wrong # args: should be "string subcommand ?arg ...?"}} @@ -1035,16 +1036,16 @@ test string-7.16.$noComp {string last, start index} { run {string last Üa ÜadÜad end-1} } 3 -test string-8.1.$noComp {string bytelength} { +test string-8.1.$noComp {string bytelength} nodep { list [catch {run {string bytelength}} msg] $msg } {1 {wrong # args: should be "string bytelength string"}} -test string-8.2.$noComp {string bytelength} { +test string-8.2.$noComp {string bytelength} nodep { list [catch {run {string bytelength a b}} msg] $msg } {1 {wrong # args: should be "string bytelength string"}} -test string-8.3.$noComp {string bytelength} { +test string-8.3.$noComp {string bytelength} nodep { run {string bytelength "\xC7"} } 2 -test string-8.4.$noComp {string bytelength} { +test string-8.4.$noComp {string bytelength} nodep { run {string b ""} } 0 @@ -1827,9 +1828,9 @@ test string-19.3.$noComp {string trimleft, unicode default} { test string-20.1.$noComp {string trimright errors} { list [catch {run {string trimright}} msg] $msg } {1 {wrong # args: should be "string trimright string ?chars?"}} -test string-20.2.$noComp {string trimright errors} { +test string-20.2.$noComp {string trimright errors} -body { list [catch {run {string trimg a}} msg] $msg -} {1 {unknown or ambiguous subcommand "trimg": must be bytelength, cat, compare, equal, first, index, insert, is, last, length, map, match, range, repeat, replace, reverse, tolower, totitle, toupper, trim, trimleft, trimright, wordend, or wordstart}} +} -match glob -result {1 {unknown or ambiguous subcommand "trimg": must be *cat, compare, equal, first, index, insert, is, last, length, map, match, range, repeat, replace, reverse, tolower, totitle, toupper, trim, trimleft, trimright, wordend, or wordstart}} test string-20.3.$noComp {string trimright} { run {string trimright " XYZ "} } { XYZ} @@ -1949,7 +1950,7 @@ test string-21.25.$noComp {string trimright, unicode} { test string-22.1.$noComp {string wordstart} -body { list [catch {run {string word a}} msg] $msg -} -result {1 {unknown or ambiguous subcommand "word": must be bytelength, cat, compare, equal, first, index, insert, is, last, length, map, match, range, repeat, replace, reverse, tolower, totitle, toupper, trim, trimleft, trimright, wordend, or wordstart}} +} -match glob -result {1 {unknown or ambiguous subcommand "word": must be *cat, compare, equal, first, index, insert, is, last, length, map, match, range, repeat, replace, reverse, tolower, totitle, toupper, trim, trimleft, trimright, wordend, or wordstart}} test string-22.2.$noComp {string wordstart} -body { list [catch {run {string wordstart a}} msg] $msg } -result {1 {wrong # args: should be "string wordstart string index"}} -- cgit v0.12