Tcl Source Code

Check-in [372ad13f77]
Login

Many hyperlinks are disabled.
Use anonymous login to enable hyperlinks.

Overview
Comment:Merge 8.6
Downloads: Tarball | ZIP archive | SQL archive
Timelines: family | ancestors | descendants | both | core-8-branch
Files: files | file ages | folders
SHA3-256:372ad13f77accaf8be667ca299fb467648f82bceef720759628b2c3141525c16
User & Date: jan.nijtmans 2019-01-13 15:43:53
Context
2019-01-14
19:48
fCmd-9.4.a: restore constraint for winXP (mistakenly removed, should replace 8.6th constraint "win20... check-in: 38eca27069 user: sebres tags: core-8-branch
2019-01-13
15:47
Merge 8.7 check-in: b7639c0e3d user: jan.nijtmans tags: trunk
15:43
Merge 8.6 check-in: 372ad13f77 user: jan.nijtmans tags: core-8-branch
15:37
Slightly simpler test for empty string, still covering all cases. Also prepare testpurebytesobj for ... check-in: e94a8f9c8f user: jan.nijtmans tags: core-8-6-branch
2019-01-09
10:10
merge 8.6 (regression bug-[cc1e91552c], etc) check-in: f9979ea137 user: sebres tags: core-8-branch
Changes
Hide Diffs Side-by-Side Diffs Ignore Whitespace Patch

Changes to generic/tclExecute.c.

  1450   1450   
  1451   1451       /*
  1452   1452        * Get the expression ByteCode from the object. If it exists, make sure it
  1453   1453        * is valid in the current context.
  1454   1454        */
  1455   1455   
  1456   1456       ByteCodeGetIntRep(objPtr, &exprCodeType, codePtr);
  1457         -    
         1457  +
  1458   1458       if (codePtr != NULL) {
  1459   1459   	Namespace *namespacePtr = iPtr->varFramePtr->nsPtr;
  1460   1460   
  1461   1461   	if (((Interp *) *codePtr->interpHandle != iPtr)
  1462   1462   		|| (codePtr->compileEpoch != iPtr->compileEpoch)
  1463   1463   		|| (codePtr->nsPtr != namespacePtr)
  1464   1464   		|| (codePtr->nsEpoch != namespacePtr->resolverEpoch)
................................................................................
  4960   4960   	    NEXT_INST_F(10, 1, 0);
  4961   4961   	}
  4962   4962   #endif
  4963   4963   
  4964   4964   	/* Every range of an empty list is an empty list */
  4965   4965   	if (objc == 0) {
  4966   4966   	    /* avoid return of not canonical list (e. g. spaces in string repr.) */
  4967         -	    if (ListObjIsCanonical(valuePtr)) {
         4967  +	    if (!valuePtr->bytes || !valuePtr->bytes[0]) {
  4968   4968   		TRACE_APPEND(("\n"));
  4969   4969   		NEXT_INST_F(9, 0, 0);
  4970   4970   	    }
  4971   4971   	    goto emptyList;
  4972   4972   	}
  4973   4973   
  4974   4974   	/* Decode index value operands. */

Changes to generic/tclTest.c.

   222    222   static void		PrintParse(Tcl_Interp *interp, Tcl_Parse *parsePtr);
   223    223   static void		SpecialFree(char *blockPtr);
   224    224   static int		StaticInitProc(Tcl_Interp *interp);
   225    225   static int		TestasyncCmd(void *dummy,
   226    226   			    Tcl_Interp *interp, int argc, const char **argv);
   227    227   static int		TestbytestringObjCmd(void *clientData,
   228    228   			    Tcl_Interp *interp, int objc,
          229  +			    Tcl_Obj *const objv[]);
          230  +static int		TestpurebytesobjObjCmd(ClientData clientData,
          231  +			    Tcl_Interp *interp, int objc,
   229    232   			    Tcl_Obj *const objv[]);
   230    233   static int		TeststringbytesObjCmd(void *clientData,
   231    234   			    Tcl_Interp *interp, int objc,
   232    235   			    Tcl_Obj *const objv[]);
   233    236   static int		TestcmdinfoCmd(void *dummy,
   234    237   			    Tcl_Interp *interp, int argc, const char **argv);
   235    238   static int		TestcmdtokenCmd(void *dummy,
................................................................................
   243    246   static int		TestdcallCmd(void *dummy,
   244    247   			    Tcl_Interp *interp, int argc, const char **argv);
   245    248   static int		TestdelCmd(void *dummy,
   246    249   			    Tcl_Interp *interp, int argc, const char **argv);
   247    250   static int		TestdelassocdataCmd(void *dummy,
   248    251   			    Tcl_Interp *interp, int argc, const char **argv);
   249    252   static int		TestdoubledigitsObjCmd(void *dummy,
   250         -					       Tcl_Interp* interp,
   251         -					       int objc, Tcl_Obj* const objv[]);
          253  +			    Tcl_Interp* interp, int objc,
          254  +			    Tcl_Obj* const objv[]);
   252    255   static int		TestdstringCmd(void *dummy,
   253    256   			    Tcl_Interp *interp, int argc, const char **argv);
   254    257   static int		TestencodingObjCmd(void *dummy,
   255    258   			    Tcl_Interp *interp, int objc,
   256    259   			    Tcl_Obj *const objv[]);
   257    260   static int		TestevalexObjCmd(void *dummy,
   258    261   			    Tcl_Interp *interp, int objc,
................................................................................
   575    578       /*
   576    579        * Create additional commands and math functions for testing Tcl.
   577    580        */
   578    581   
   579    582       Tcl_CreateObjCommand(interp, "gettimes", GetTimesObjCmd, NULL, NULL);
   580    583       Tcl_CreateCommand(interp, "noop", NoopCmd, NULL, NULL);
   581    584       Tcl_CreateObjCommand(interp, "noop", NoopObjCmd, NULL, NULL);
          585  +    Tcl_CreateObjCommand(interp, "testpurebytesobj", TestpurebytesobjObjCmd, NULL, NULL);
   582    586       Tcl_CreateObjCommand(interp, "testbytestring", TestbytestringObjCmd, NULL, NULL);
   583    587       Tcl_CreateObjCommand(interp, "teststringbytes", TeststringbytesObjCmd, NULL, NULL);
   584    588       Tcl_CreateObjCommand(interp, "testwrongnumargs", TestWrongNumArgsObjCmd,
   585    589   	    NULL, NULL);
   586    590       Tcl_CreateObjCommand(interp, "testfilesystem", TestFilesystemObjCmd,
   587    591   	    NULL, NULL);
   588    592       Tcl_CreateObjCommand(interp, "testsimplefilesystem", TestSimpleFilesystemObjCmd,
................................................................................
  2091   2095       Tcl_Obj *const objv[])	/* Argument objects. */
  2092   2096   {
  2093   2097       int length, flags;
  2094   2098       const char *script;
  2095   2099   
  2096   2100       flags = 0;
  2097   2101       if (objc == 3) {
  2098         -	const char *global = Tcl_GetStringFromObj(objv[2], &length);
         2102  +	const char *global = Tcl_GetString(objv[2]);
  2099   2103   	if (strcmp(global, "global") != 0) {
  2100   2104   	    Tcl_AppendResult(interp, "bad value \"", global,
  2101   2105   		    "\": must be global", NULL);
  2102   2106   	    return TCL_ERROR;
  2103   2107   	}
  2104   2108   	flags = TCL_EVAL_GLOBAL;
  2105   2109       } else if (objc != 2) {
................................................................................
  4929   4933   	Tcl_WrongNumArgs(interp, 1, objv, "value");
  4930   4934   	return TCL_ERROR;
  4931   4935       }
  4932   4936       p = (const unsigned char *)Tcl_GetStringFromObj(objv[1], &n);
  4933   4937       Tcl_SetObjResult(interp, Tcl_NewByteArrayObj(p, n));
  4934   4938       return TCL_OK;
  4935   4939   }
         4940  +
         4941  +/*
         4942  + *----------------------------------------------------------------------
         4943  + *
         4944  + * TestpurebytesobjObjCmd --
         4945  + *
         4946  + *	This object-based procedure constructs a pure bytes object
         4947  + *	without type and with internal representation containing NULL's.
         4948  + *
         4949  + *	If no argument supplied it returns empty object with tclEmptyStringRep,
         4950  + *	otherwise it returns this as pure bytes object with bytes value equal
         4951  + *	string.
         4952  + *
         4953  + * Results:
         4954  + *	Returns the TCL_OK result code.
         4955  + *
         4956  + * Side effects:
         4957  + *	None.
         4958  + *
         4959  + *----------------------------------------------------------------------
         4960  + */
         4961  +
         4962  +static int
         4963  +TestpurebytesobjObjCmd(
         4964  +    ClientData unused,		/* Not used. */
         4965  +    Tcl_Interp *interp,		/* Current interpreter. */
         4966  +    int objc,			/* Number of arguments. */
         4967  +    Tcl_Obj *const objv[])	/* The argument objects. */
         4968  +{
         4969  +    Tcl_Obj *objPtr;
         4970  +
         4971  +    if (objc > 2) {
         4972  +	Tcl_WrongNumArgs(interp, 1, objv, "?string?");
         4973  +	return TCL_ERROR;
         4974  +    }
         4975  +    objPtr = Tcl_NewObj();
         4976  +    /*
         4977  +    objPtr->internalRep.twoPtrValue.ptr1 = NULL;
         4978  +    objPtr->internalRep.twoPtrValue.ptr2 = NULL;
         4979  +    */
         4980  +    memset(&objPtr->internalRep, 0, sizeof(objPtr->internalRep));
         4981  +    if (objc == 2) {
         4982  +	const char *s = Tcl_GetString(objv[1]);
         4983  +	objPtr->length = objv[1]->length;
         4984  +	objPtr->bytes = ckalloc(objPtr->length + 1);
         4985  +	memcpy(objPtr->bytes, s, objPtr->length);
         4986  +	objPtr->bytes[objPtr->length] = 0;
         4987  +    }
         4988  +    Tcl_SetObjResult(interp, objPtr);
         4989  +    return TCL_OK;
         4990  +}
  4936   4991   
  4937   4992   /*
  4938   4993    *----------------------------------------------------------------------
  4939   4994    *
  4940   4995    * TestbytestringObjCmd --
  4941   4996    *
  4942   4997    *	This object-based procedure constructs a string which can

Changes to tests/lrange.test.

    11     11   # See the file "license.terms" for information on usage and redistribution
    12     12   # of this file, and for a DISCLAIMER OF ALL WARRANTIES.
    13     13   
    14     14   if {[lsearch [namespace children] ::tcltest] == -1} {
    15     15       package require tcltest
    16     16       namespace import -force ::tcltest::*
    17     17   }
           18  +
           19  +::tcltest::loadTestedCommands
           20  +catch [list package require -exact Tcltest [info patchlevel]]
           21  +
           22  +testConstraint testpurebytesobj [llength [info commands testpurebytesobj]]
           23  +
    18     24   
    19     25   test lrange-1.1 {range of list elements} {
    20     26       lrange {a b c d} 1 2
    21     27   } {b c}
    22     28   test lrange-1.2 {range of list elements} {
    23     29       lrange {a {bcd e {f g {}}} l14 l15 d} 1 1
    24     30   } {{bcd e {f g {}}}}
................................................................................
   112    118   	 [lrange { } 0-1 end+1] [lrange [format %c 32] 0-1 end+1] [lrange $a 0-1 end+1]
   113    119   } [lrepeat 6 {}]
   114    120   test lrange-3.7b {not compiled on empty not canonical list (with static and dynamic indices), regression test, bug [cc1e91552c]} {
   115    121       set cmd lrange
   116    122       list [$cmd { } 0 1] [$cmd [format %c 32] 0 1] [$cmd [set a { }] 0 1] \
   117    123   	 [$cmd { } 0-1 end+1] [$cmd [format %c 32] 0-1 end+1] [$cmd $a 0-1 end+1]
   118    124   } [lrepeat 6 {}]
          125  +# following 4 tests could cause a segfault on empty non-lists with tclEmptyStringRep
          126  +# (as before the fix [58c46e74b931d3a1]):
          127  +test lrange-3.7a.2 {compiled on empty not list object, 2nd regression test, bug [cc1e91552c]} {
          128  +    list [lrange {} 0 1] [lrange [lindex a -1] 0 1] [lrange [set a {}] 0 1] \
          129  +	 [lrange {} 0-1 end+1] [lrange [lindex a -1] 0-1 end+1] [lrange $a 0-1 end+1]
          130  +} [lrepeat 6 {}]
          131  +test lrange-3.7b.2 {not compiled on empty not list object, 2nd regression test, bug [cc1e91552c]} {
          132  +    set cmd lrange
          133  +    list [$cmd {} 0 1] [$cmd [lindex a -1] 0 1] [$cmd [set a {}] 0 1] \
          134  +	 [$cmd {} 0-1 end+1] [$cmd [lindex a -1] 0-1 end+1] [$cmd $a 0-1 end+1]
          135  +} [lrepeat 6 {}]
          136  +test lrange-3.7c.2 {compiled on empty pure bytes object, 2nd regression test, bug [cc1e91552c]} {
          137  +    list [lrange [testpurebytesobj] 0 1] [lrange [testpurebytesobj { }] 0 1] [lrange [set a [testpurebytesobj {}]] 0 1] \
          138  +	 [lrange [testpurebytesobj] 0-1 end+1] [lrange [testpurebytesobj { }] 0-1 end+1] [lrange $a 0-1 end+1]
          139  +} [lrepeat 6 {}]
          140  +test lrange-3.7d.2 {not compiled on empty pure bytes object, 2nd regression test, bug [cc1e91552c]} {
          141  +    set cmd lrange
          142  +    list [$cmd [testpurebytesobj] 0 1] [$cmd [testpurebytesobj { }] 0 1] [$cmd [set a [testpurebytesobj {}]] 0 1] \
          143  +	 [$cmd [testpurebytesobj] 0-1 end+1] [$cmd [testpurebytesobj { }] 0-1 end+1] [$cmd $a 0-1 end+1]
          144  +} [lrepeat 6 {}]
   119    145   
   120    146   test lrange-4.1 {lrange pure promise} -body {
   121    147       set ll1 [list $tcl_version 2 3 4]
   122    148       # Shared
   123    149       set ll2 $ll1
   124    150       # With string rep
   125    151       string length $ll1

Changes to win/tclWinTest.c.

   568    568   
   569    569       /*
   570    570        * Apply the new ACL. Note PROTECTED_DACL_SECURITY_INFORMATION can be used
   571    571        * to remove inherited ACL (we need to overwrite the default ACL's in this case)
   572    572        */
   573    573   
   574    574       if (set_readOnly == acl_readOnly_found || SetNamedSecurityInfoA(
   575         -	    (LPSTR) nativePath, SE_FILE_OBJECT, 
          575  +	    (LPSTR) nativePath, SE_FILE_OBJECT,
   576    576   	    DACL_SECURITY_INFORMATION /*| PROTECTED_DACL_SECURITY_INFORMATION*/,
   577    577   	    NULL, NULL, newAcl, NULL) == ERROR_SUCCESS) {
   578    578   	res = 0;
   579    579       }
   580    580   
   581    581     done:
   582    582       if (secDesc) {