Fix most of incompatibilities (Implementation & tests) with Tcl9

flightaware · May 13, 2020 · 7997bbc · resuna · May 13, 2020 · resuna
1 parent 45f5f89
commit 7997bbc
Show file tree

Hide file tree

Showing 13 changed files with 24 additions and 34 deletions.
diff --git a/generic/tclXchmod.c b/generic/tclXchmod.c
@@ -313,7 +313,6 @@ TclX_ChmodObjCmd (ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *
     Tcl_Obj     **fileObjv;
     char         *fileIdsString;
     char         *modeString;
-    int          modeBits;
 
     /*
      * Options are not parsable just looking for "-", since modes can
@@ -334,10 +333,7 @@ TclX_ChmodObjCmd (ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *
 
     modeString = Tcl_GetStringFromObj (objv [objIdx], NULL);
     if (ISDIGIT (modeString[0])) {
-        if (Tcl_GetIntFromObj (interp, objv [objIdx], &modeBits) 
-	  != TCL_OK)
-            return TCL_ERROR;
-	modeInfo.absMode = modeBits;
+	    modeInfo.absMode = strtol(modeString, 0, 0);
         modeInfo.symMode = NULL;
     } else {
         modeInfo.symMode = modeString;

diff --git a/generic/tclXdup.c b/generic/tclXdup.c
@@ -208,18 +208,11 @@ TclX_DupObjCmd (ClientData clientData,
      * If a number is supplied, bind it to a file handle rather than doing
      * a dup.
      */
-    if (objv [1]->typePtr == Tcl_GetObjType ("int")) {
-        bindFnum = TRUE;
-    } else {
-        srcChannelId = Tcl_GetStringFromObj (objv [1], NULL);
-        if (ISDIGIT (srcChannelId [0])) {
-            if (Tcl_ConvertToType (interp, objv [1],
-                                   Tcl_GetObjType ("int")) != TCL_OK)
-                goto badFnum;
+
+    bindFnum = FALSE;
+    srcChannelId = Tcl_GetStringFromObj (objv [1], NULL);
+    if (ISDIGIT (srcChannelId [0])) {
             bindFnum = TRUE;
-        } else {
-            bindFnum = FALSE;
-        }
     }
     if (bindFnum) {
         if (objc != 2)

diff --git a/generic/tclXfilescan.c b/generic/tclXfilescan.c
@@ -641,7 +641,7 @@ ScanFile (Tcl_Interp *interp, scanContext_t *contextPtr, Tcl_Channel channel)
 
         data.offset = (off_t) Tcl_Tell (channel);
         Tcl_DStringSetLength (&lineBuf, 0);
-        if (Tcl_Gets (channel, &lineBuf) < 0) {
+        if (Tcl_Gets (channel, &lineBuf) < 0 || lineBuf.length == 0) {
             if (Tcl_Eof (channel) || Tcl_InputBlocked (channel))
                 goto scanExit;
             Tcl_SetStringObj (Tcl_GetObjResult (interp),

diff --git a/generic/tclXutil.c b/generic/tclXutil.c
@@ -333,7 +333,7 @@ TclX_RelativeExpr (Tcl_Interp  *interp,
     long longResult;
     char staticBuf [32];
 
-    if (exprPtr->typePtr == Tcl_GetObjType ("int")) {
+    if (exprPtr != NULL && exprPtr->typePtr != NULL && exprPtr->typePtr == Tcl_GetObjType ("int")) {
         if (Tcl_GetIntFromObj (interp, exprPtr, exprResultPtr) != TCL_OK)
             return TCL_ERROR;
         return TCL_OK;

diff --git a/library/globrecur.tcl b/library/globrecur.tcl
@@ -76,7 +76,7 @@ proc for_recursive_glob {var dirlist globlist cmd {depth 1}} {
             return -code $code $result
         }
 
-        foreach file [lsort [readdir $dir]] {
+        foreach file [readdir $dir] {
             set file [file join $dir $file]
             if [file isdirectory $file] {
                 set fileTail [file tail $file]

diff --git a/failing_tclx9_tests/chmod.test → tests/chmod.test b/failing_tclx9_tests/chmod.test → tests/chmod.test
@@ -35,7 +35,8 @@ if [cequal $tcl_platform(platform) windows] {
 
 proc GetMode {filename} {
     file stat $filename stat
-    return [format "%o" [expr {$stat(mode) & 07777}]]
+    # 4095 is decimal represenation of octal 07777
+    return [format "%o" [expr {$stat(mode) & 4095}]]
 }
 
 #-----------------------------------------------------------------------------

diff --git a/failing_tclx9_tests/dup.test → tests/dup.test b/failing_tclx9_tests/dup.test → tests/dup.test
diff --git a/tests/filescan.test b/tests/filescan.test
@@ -31,10 +31,10 @@ proc IncrName {Name args} {
     set Begin [csubstr $Name 0 $Last]
     set Digit [cindex $Name $Last]
     set Recurse 0
-    switch $Digit in {
-        {9}     {set Digit A}
-        {Z}     {if {$Upper} {set Recurse 1} else {set Digit a}}
-        {z}     {set Recurse 1}
+    switch $Digit {
+        9     {set Digit A}
+        Z     {if {$Upper} {set Recurse 1} else {set Digit a}}
+        z     {set Recurse 1}
         default {set Digit [ctype char [expr [ctype ord $Digit]+1]]}
     }
     if {$Recurse} {
@@ -146,11 +146,11 @@ foreach scanInfo $scanList {
     set key [keylget scanInfo key]
     set matchType [keylget scanInfo matchType]
     set cmd "global matchInfo; ValMatch [list $scanInfo] 1.1" 
-    switch $matchType in {
-      {0} {scanmatch -nocase $testCH [string toupper $key] $cmd}
-      {1} {scanmatch $testCH ^$key  $cmd}
-      {2} {scanmatch $testCH $key\$ $cmd}
-      {3} {scanmatch $testCH $key   $cmd}
+    switch $matchType {
+      0 {scanmatch -nocase $testCH [string toupper $key] $cmd}
+      1 {scanmatch $testCH ^$key  $cmd}
+      2 {scanmatch $testCH $key\$ $cmd}
+      3 {scanmatch $testCH $key   $cmd}
     }
 }
 

diff --git a/failing_tclx9_tests/fstat.test → tests/fstat.test b/failing_tclx9_tests/fstat.test → tests/fstat.test
@@ -44,7 +44,7 @@ if [cequal $tcl_platform(platform) windows] {
 test fstat-1.2 {array return} {
     catch {unset stat}
     fstat $gorpFH stat stat
-    list $stat(nlink) $stat(size) [expr $stat(mode)&0777] $stat(type) \
+    list $stat(nlink) $stat(size) [expr $stat(mode)&511] $stat(type) \
 	    $stat(tty)
 } $expect
 
@@ -74,7 +74,7 @@ if [cequal $tcl_platform(platform) windows] {
 test fstat-2.2 {keyed list returns} {
     set stat [fstat $gorpFH]
     list [keylget stat nlink] [keylget stat size] \
-         [expr [keylget stat mode ]&0777] [keylget stat type]
+         [expr [keylget stat mode ]&511] [keylget stat type]
 } $expect
 
 if [cequal $tcl_platform(platform) windows] {

diff --git a/failing_tclx9_tests/lgets.test → tests/lgets.test b/failing_tclx9_tests/lgets.test → tests/lgets.test
@@ -60,7 +60,7 @@ test lgets-1.6 {lgets command with long line} {
 
 test lgets-1.7 {lgets command with EOF in list element} {
     set f [open test2.tmp w]
-    puts $f "Test1  \{Test2 " nonewline
+    puts -nonewline $f "Test1  \{Test2 " 
     close $f
     set f [open test2.tmp]
     list [catch {lgets $f} msg] $msg
@@ -70,7 +70,7 @@ catch {close $f}
 
 test lgets-1.8 {lgets command with EOF in list} {
     set f [open test2.tmp w]
-    puts $f "Test1\nTest2" nonewline
+    puts -nonewline $f "Test1\nTest2" 
     close $f
     set f [open test2.tmp]
     set x {}

diff --git a/failing_tclx9_tests/list.test → tests/list.test b/failing_tclx9_tests/list.test → tests/list.test
diff --git a/failing_tclx9_tests/string.test → tests/string.test b/failing_tclx9_tests/string.test → tests/string.test
diff --git a/failing_tclx9_tests/stringfil.test → tests/stringfil.test b/failing_tclx9_tests/stringfil.test → tests/stringfil.test
@@ -47,7 +47,7 @@ Test stringfile-2.3 {read_file command} {
 } 0 [crange $stringfileTestVar 0 2]
 
 Test stringfile-2.4 {read_file command} {
-    read_file STRINGFIL.DAT nonewline
+    read_file -nonewline STRINGFIL.DAT 
 } 0 $stringfileTestVar
 
 TestRemove STRINGFIL.DAT