Tcl Source Code

Changes On Branch tip-278
Login
Bounty program for improvements to Tcl and certain Tcl packages.

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

Changes In Branch tip-278 Excluding Merge-Ins

This is equivalent to a diff from 76eaf9a16b to 8103b8c9fd

2017-11-03
18:44
TIP 278 Implementation check-in: 580ef6f047 user: dgp tags: trunk
2017-11-01
21:05
Fix bug 3c32a3f8bd, segmentation fault in TclOO.c/ReleaseClassContents() for a class mixed into one ... check-in: 5f178e7f03 user: pooryorick tags: trunk
14:46
TIP 422 implementation (rebase of branch novem-remove-va to trunk). check-in: e090a04f00 user: dgp tags: tip-422
2017-10-30
14:56
Patch to make changes to Tcl 9 prescribed by TIPs 330 and 336. This makes the Tcl_Interp struct full... check-in: 70e9e38504 user: dgp tags: tip-330-336
14:01
Preliminary (non working at this point) implementation of tip479 check-in: c8c3341810 user: hypnotoad tags: tip479
12:48
TIP 278 into novem. check-in: 48a7a3af50 user: dgp tags: novem
12:41
Rebase tip-278 branch to workaround CVS conversion woes. Closed-Leaf check-in: 8103b8c9fd user: dgp tags: tip-278
12:08
merge trunk Closed-Leaf check-in: 42c669a1e0 user: dgp tags: tip-278
12:03
merge trunk check-in: bc43c864d7 user: dgp tags: tip-445
12:02
merge trunk Closed-Leaf check-in: 848a10e460 user: dgp tags: tip-345
12:02
merge trunk Closed-Leaf check-in: a2d4cd2f93 user: dgp tags: tip-114
08:47
Experimental branch meant to eliminate the "wideint" type, just merge it to a single "int" type. No ... check-in: c2abe1efd0 user: jan.nijtmans tags: no-wideint
05:25
merge bug-fc1409fc91. check-in: 76eaf9a16b user: pooryorick tags: trunk
05:19
Fix for issue 9fd5c629c1, TclOO - aborts when a trace on command deletion deletes the object's names... Closed-Leaf check-in: bee7f97ad6 user: pooryorick tags: bug-fc1409fc91
03:23
merge 8.6 check-in: 0c0de52be7 user: dgp tags: trunk

Changes to generic/tclVar.c.

   812    812   		|| (cxtNsPtr == iPtr->globalNsPtr)
   813    813   		|| ((*varName == ':') && (*(varName+1) == ':'));
   814    814   
   815    815   	if (lookGlobal) {
   816    816   	    *indexPtr = -1;
   817    817   	    flags = (flags | TCL_GLOBAL_ONLY) & ~TCL_NAMESPACE_ONLY;
   818    818   	} else {
   819         -	    if (flags & TCL_AVOID_RESOLVERS) {
   820         -		flags = (flags | TCL_NAMESPACE_ONLY);
   821         -	    }
   822         -	    if (flags & TCL_NAMESPACE_ONLY) {
   823         -		*indexPtr = -2;
   824         -	    }
          819  +	    flags = (flags | TCL_NAMESPACE_ONLY);
          820  +	    *indexPtr = -2;
   825    821   	}
   826    822   
   827    823   	/*
   828    824   	 * Don't pass TCL_LEAVE_ERR_MSG, we may yet create the variable, or
   829    825   	 * otherwise generate our own error!
   830    826   	 */
   831    827   
................................................................................
  5704   5700   	    return NULL;
  5705   5701   	}
  5706   5702       }
  5707   5703   
  5708   5704       /*
  5709   5705        * Find the namespace(s) that contain the variable.
  5710   5706        */
         5707  +
         5708  +    if (!(flags & TCL_GLOBAL_ONLY)) {
         5709  +	flags |= TCL_NAMESPACE_ONLY;
         5710  +    }
  5711   5711   
  5712   5712       TclGetNamespaceForQualName(interp, name, (Namespace *) contextNsPtr,
  5713   5713   	    flags, &nsPtr[0], &nsPtr[1], &cxtNsPtr, &simpleName);
  5714   5714   
  5715   5715       /*
  5716   5716        * Look for the variable in the variable table of its namespace. Be sure
  5717   5717        * to check both possible search paths: from the specified namespace

Changes to tests/namespace-old.test.

   289    289           proc test_ns_show {} {return "[namespace current]: 2"}
   290    290   	namespace eval test_ns_hier3a {}
   291    291   	namespace eval test_ns_hier3b {}
   292    292       }
   293    293       namespace eval test_ns_hier2a {}
   294    294       namespace eval test_ns_hier2b {}
   295    295   }
          296  +# TIP 278: secondary lookup disabled for vars, tests disabled with #
   296    297   test namespace-old-5.4 {nested namespaces can access global namespace} {
   297         -    list [namespace eval test_ns_hier1 {set test_ns_var_global}] \
          298  +    list [namespace eval test_ns_hier1 {#set test_ns_var_global}] \
   298    299            [namespace eval test_ns_hier1 {test_ns_cmd_global}] \
   299         -         [namespace eval test_ns_hier1::test_ns_hier2 {set test_ns_var_global}] \
          300  +         [namespace eval test_ns_hier1::test_ns_hier2 {#set test_ns_var_global}] \
   300    301            [namespace eval test_ns_hier1::test_ns_hier2 {test_ns_cmd_global}]
   301         -} {{var in ::} {cmd in ::} {var in ::} {cmd in ::}}
          302  +} {{} {cmd in ::} {} {cmd in ::}}
   302    303   test namespace-old-5.5 {variables in different namespaces don't conflict} {
   303    304       list [set test_ns_hier1::test_ns_level] \
   304    305            [set test_ns_hier1::test_ns_hier2::test_ns_level]
   305    306   } {1 2}
   306    307   test namespace-old-5.6 {commands in different namespaces don't conflict} {
   307    308       list [test_ns_hier1::test_ns_show] \
   308    309            [test_ns_hier1::test_ns_hier2::test_ns_show]
................................................................................
   464    465   }
   465    466   test namespace-old-6.11 {commands affect all parent namespaces} {
   466    467       proc test_ns_cache1::test_ns_cache2::test_ns_cache_cmd {} {
   467    468           return "cache2 version"
   468    469       }
   469    470       list [test_ns_cache1::trigger] [test_ns_cache1::test_ns_cache2::trigger]
   470    471   } {{cache2 version} {cache2 version}}
          472  +# TIP 278: secondary lookup disabled, catch added, result changed from {global version}
   471    473   test namespace-old-6.12 {define test variables} {
   472    474       variable test_ns_cache_var "global version"
   473    475       set trigger {set test_ns_cache_var}
   474         -    namespace eval test_ns_cache1 $trigger
   475         -} {global version}
          476  +    list [catch {namespace eval test_ns_cache1 $trigger} msg] $msg
          477  +} {1 {can't read "test_ns_cache_var": no such variable}}
   476    478       set trigger {set test_ns_cache_var}
   477    479   test namespace-old-6.13 {one-level check for variable shadowing} {
   478    480       namespace eval test_ns_cache1 {
   479    481           variable test_ns_cache_var "cache1 version"
   480    482       }
   481    483       namespace eval test_ns_cache1 $trigger
   482    484   } {cache1 version}
   483    485   variable ::test_ns_cache_var "global version"
          486  +# TIP 278: secondary lookup disabled, catch added, result changed from {global version}
   484    487   test namespace-old-6.14 {deleting variables changes variable epoch} {
   485    488       namespace eval test_ns_cache1 {
   486    489           variable test_ns_cache_var "cache1 version"
   487    490       }
   488    491       list [namespace eval test_ns_cache1 $trigger] \
   489    492   	[namespace eval test_ns_cache1 {unset test_ns_cache_var}] \
   490         -	[namespace eval test_ns_cache1 $trigger]
   491         -} {{cache1 version} {} {global version}}
          493  +	[catch {namespace eval test_ns_cache1 $trigger}]
          494  +} {{cache1 version} {} 1}
          495  +# TIP 278: secondary lookup disabled, catch added, result changed
   492    496   test namespace-old-6.15 {define test namespaces} {
   493    497       namespace eval test_ns_cache2 {
   494    498           variable test_ns_cache_var "global cache2 version"
   495    499       }
   496    500       set trigger2 {set test_ns_cache2::test_ns_cache_var}
   497         -    list [namespace eval test_ns_cache1 $trigger2] \
   498         -         [namespace eval test_ns_cache1::test_ns_cache2 $trigger]
   499         -} {{global cache2 version} {global version}}
          501  +    catch {list [namespace eval test_ns_cache1 $trigger2] \
          502  +	       [namespace eval test_ns_cache1::test_ns_cache2 $trigger]}
          503  +} 1
   500    504   set trigger2 {set test_ns_cache2::test_ns_cache_var}
   501    505   test namespace-old-6.16 {public variables affect all parent namespaces} {
   502    506       variable test_ns_cache1::test_ns_cache2::test_ns_cache_var "cache2 version"
   503    507       list [namespace eval test_ns_cache1 $trigger2] \
   504    508            [namespace eval test_ns_cache1::test_ns_cache2 $trigger]
   505    509   } {{cache2 version} {cache2 version}}
   506    510   test namespace-old-6.17 {usage for "namespace which"} {

Changes to tests/namespace.test.

    42     42       list [namespace current] [namespace eval {} {namespace current}] \
    43     43           [namespace eval {} {namespace current}]
    44     44   } {:: :: ::}
    45     45   test namespace-2.2 {Tcl_GetCurrentNamespace} {
    46     46       set l {}
    47     47       lappend l [namespace current]
    48     48       namespace eval test_ns_1 {
    49         -        lappend l [namespace current]
           49  +        lappend ::l [namespace current]
    50     50           namespace eval foo {
    51         -            lappend l [namespace current]
           51  +            lappend ::l [namespace current]
    52     52           }
    53     53       }
    54     54       lappend l [namespace current]
    55     55   } {:: ::test_ns_1 ::test_ns_1::foo ::}
    56     56   
    57     57   test namespace-3.1 {Tcl_GetGlobalNamespace} {
    58     58       namespace eval test_ns_1 {namespace eval foo {namespace eval bar {} } }
................................................................................
   629    629       }
   630    630   } -body {
   631    631       namespace eval test_ns_1 {
   632    632           list [catch {set ::test_ns_777::v} msg] $msg \
   633    633                [catch {namespace children test_ns_777} msg] $msg
   634    634       }
   635    635   } -result {1 {can't read "::test_ns_777::v": no such variable} 1 {namespace "test_ns_777" not found in "::test_ns_1"}}
          636  +
          637  +# TIP 278: secondary lookup disabled, results changed from {10 20}
   636    638   test namespace-14.3 {TclGetNamespaceForQualName, relative names} -setup {
   637    639       catch {namespace delete {*}[namespace children :: test_ns_*]}
   638    640       variable v 10
   639    641       namespace eval test_ns_1::test_ns_2 {
   640    642           variable v 20
   641    643       }
   642    644       namespace eval test_ns_2 {
   643    645           variable v 30
   644    646       }
   645    647   } -body {
   646    648       namespace eval test_ns_1 {
   647         -        list $v $test_ns_2::v
          649  +        # list $v $test_ns_2::v
          650  +        list [catch {set v} msg] $msg  [catch {set test_ns_2::v} msg] $msg
   648    651       }
   649         -} -result {10 20}
          652  +} -result {1 {can't read "v": no such variable} 0 20}
          653  +
   650    654   test namespace-14.4 {TclGetNamespaceForQualName, relative ns names looked up only in current ns} {
   651    655       namespace eval test_ns_1::test_ns_2 {
   652    656           namespace eval foo {}
   653    657       }
   654    658       namespace eval test_ns_1 {
   655    659           list [namespace children test_ns_2] \
   656    660                [catch {namespace children test_ns_1} msg] $msg
................................................................................
   703    707       catch {rename test_ns_1::test_ns_2:: {}}
   704    708       set l {}
   705    709   } -body {
   706    710       lappend l [catch {test_ns_1::test_ns_2:: hello} msg] $msg
   707    711       proc test_ns_1::test_ns_2:: {args} {return "\{\}: $args"}
   708    712       lappend l [test_ns_1::test_ns_2:: hello]
   709    713   } -result {1 {invalid command name "test_ns_1::test_ns_2::"} {{}: hello}}
          714  +
          715  +# TIP 278: secondary lookup disabled, added catch, result changed from y
   710    716   test namespace-14.12 {TclGetNamespaceForQualName, extra ::s are significant for vars} -setup {
   711    717       catch {namespace delete {*}[namespace children :: test_ns_*]}
   712    718   } -body {
   713    719       namespace eval test_ns_1 {
   714    720           variable {}
   715         -        set test_ns_1::(x) y
          721  +        catch {set test_ns_1::(x) y} ::msg
   716    722       }
   717         -    set test_ns_1::(x)
   718         -} -result y
          723  +    list $::msg [catch {set test_ns_1::(x)} msg] $msg
          724  +} -result {{can't set "test_ns_1::(x)": parent namespace doesn't exist} 1 {can't read "test_ns_1::(x)": no such variable}}
   719    725   test namespace-14.13 {TclGetNamespaceForQualName, namespace other than global ns can't have empty name} -setup {
   720    726       catch {namespace delete {*}[namespace children :: test_ns_*]}
   721    727   } -returnCodes error -body {
   722    728       namespace eval test_ns_1 {
   723    729   	proc {} {} {}
   724    730   	namespace eval {} {}
   725    731   	{}
................................................................................
   884    890           variable x 777
   885    891       }
   886    892   } -body {
   887    893       namespace eval test_ns_1 {
   888    894           set x
   889    895       }
   890    896   } -result {777}
          897  +
          898  +# TIP 278: secondary lookup disabled, catch added, result changed from 314159
   891    899   test namespace-17.7 {Tcl_FindNamespaceVar, relative name found} {
   892    900       namespace eval test_ns_1 {
   893    901   	variable x 777
   894    902           unset x
   895         -        set x  ;# must be global x now
          903  +        list [catch {set x} msg] $msg  ;# must not be global x now
   896    904       }
   897         -} {314159}
          905  +} {1 {can't read "x": no such variable}}
   898    906   test namespace-17.8 {Tcl_FindNamespaceVar, relative name not found} -body {
   899    907       namespace eval test_ns_1 {
   900    908           set wuzzat
   901    909       }
   902    910   } -returnCodes error -result {can't read "wuzzat": no such variable}
   903    911   test namespace-17.9 {Tcl_FindNamespaceVar, relative name and TCL_GLOBAL_ONLY} {
   904    912       namespace eval test_ns_1 {
   905    913           variable a hello
   906    914       }
   907    915       set test_ns_1::a
   908    916   } {hello}
          917  +
          918  +# TIP 278: secondary lookup disabled, result changed from 1
   909    919   test namespace-17.10 {Tcl_FindNamespaceVar, interference with cached varNames} -setup {
   910    920       namespace eval test_ns_1 {}
   911    921   } -body {
   912    922       proc test_ns {} {
   913    923   	set ::test_ns_1::a 0
   914    924       }
   915    925       test_ns
   916    926       rename test_ns {}
   917    927       namespace eval test_ns_1 unset a
   918    928       set a 0
   919    929       namespace eval test_ns_1 set a 1
   920    930       namespace delete test_ns_1
   921    931       return $a
   922         -} -result 1
          932  +} -result 0
   923    933   catch {unset a}
   924    934   catch {unset x}
   925    935   
   926    936   catch {unset l}
   927    937   catch {rename foo {}}
   928    938   test namespace-18.1 {TclResetShadowedCmdRefs, one-level check for command shadowing} -setup {
   929    939       catch {namespace delete {*}[namespace children :: test_ns_*]}
................................................................................
  1536   1546       namespace eval test_ns_3 {
  1537   1547           list [namespace which foreach] \
  1538   1548                [namespace which p] \
  1539   1549                [namespace which cmd1] \
  1540   1550                [namespace which ::test_ns_2::cmd2]
  1541   1551       }
  1542   1552   } -result {::foreach ::test_ns_3::p ::test_ns_3::cmd1 ::test_ns_2::cmd2}
         1553  +
         1554  +# TIP 278: secondary lookup disabled, catch added, result changed
  1543   1555   test namespace-34.7 {NamespaceWhichCmd, variable lookup} -setup {
  1544   1556       catch {namespace delete {*}[namespace children test_ns_*]}
  1545   1557       namespace eval test_ns_1 {
  1546   1558           namespace export cmd*
  1547   1559           proc cmd1 {args} {return "cmd1: $args"}
  1548   1560           proc cmd2 {args} {return "cmd2: $args"}
  1549   1561       }
................................................................................
  1555   1567       }
  1556   1568       namespace eval test_ns_3 {
  1557   1569           variable v3 333
  1558   1570           namespace import ::test_ns_2::*
  1559   1571       }
  1560   1572   } -body {
  1561   1573       namespace eval test_ns_3 {
  1562         -        list [namespace which -variable env] \
         1574  +        list [catch {namespace which -variable env } msg] $msg \
  1563   1575                [namespace which -variable v3] \
  1564   1576                [namespace which -variable ::test_ns_2::v2] \
  1565   1577                [catch {namespace which -variable ::test_ns_2::noSuchVar} msg] $msg
  1566   1578       }
  1567         -} -result {::env ::test_ns_3::v3 ::test_ns_2::v2 0 {}}
         1579  +} -result {0 {} ::test_ns_3::v3 ::test_ns_2::v2 0 {}}
  1568   1580   
  1569   1581   test namespace-35.1 {FreeNsNameInternalRep, resulting ref count > 0} -setup {
  1570   1582       catch {namespace delete {*}[namespace children :: test_ns_*]}
  1571   1583   } -body {
  1572   1584       namespace eval test_ns_1 {
  1573   1585           proc p {} {
  1574   1586               namespace delete [namespace current]

Changes to tests/parse.test.

   372    372   	variable ::aresult
   373    373   	variable ::acode
   374    374   	set aresult $result
   375    375   	set acode $code
   376    376   	return "new result"
   377    377       }
   378    378       set handler1 [testasync create async1]
   379         -    set aresult xxx
   380         -    set acode yyy
          379  +    set ::aresult xxx
          380  +    set ::acode yyy
   381    381   } -cleanup {
   382    382       testasync delete
   383    383   } -body {
   384         -    list [testevalobjv 0 testasync mark $handler1 original 0] $acode $aresult
          384  +    list [testevalobjv 0 testasync mark $handler1 original 0] $::acode $::aresult
   385    385   } -result {{new result} 0 original}
   386    386   test parse-8.9 {Tcl_EvalObjv procedure, exceptional return} testevalobjv {
   387    387       list [catch {testevalobjv 0 error message} msg] $msg
   388    388   } {1 message}
   389    389   test parse-8.10 {Tcl_EvalObjv procedure, TCL_EVAL_GLOBAL} testevalobjv {
   390    390       rename ::unknown unknown.save
   391    391       proc ::unknown args {lappend ::info [info level]}

Changes to tests/tcltest.test.

   540    540       -match glob
   541    541   }
   542    542   # Test non-writeable directories, non-readable directories with directory flags
   543    543   set notReadableDir [file join [temporaryDirectory] notreadable]
   544    544   set notWriteableDir [file join [temporaryDirectory] notwriteable]
   545    545   makeDirectory notreadable
   546    546   makeDirectory notwriteable
          547  +
   547    548   switch -- $::tcl_platform(platform) {
   548    549       unix {
   549    550   	file attributes $notReadableDir -permissions 00333
   550    551   	file attributes $notWriteableDir -permissions 00555
   551    552       }
   552    553       default {
   553    554   	catch {file attributes $notWriteableDir -readonly 1}

Changes to tests/var.test.

   243    243       catch {unset a}
   244    244   } -constraints testupvar -body {
   245    245       set a 456
   246    246       namespace eval test_ns_var {
   247    247   	catch {unset ::test_ns_var::vv}
   248    248   	proc p {} {
   249    249   	    # create namespace var vv linked to global a
   250         -	    testupvar 1 a {} vv namespace
          250  +	    testupvar 2 a {} vv namespace 
   251    251   	}
   252    252   	p
   253    253       }
          254  +    # Modified: that should create a global var according to the docs!
   254    255       list $test_ns_var::vv [set test_ns_var::vv 123] $a
   255    256   } -result {456 123 123}
   256    257   test var-3.5 {MakeUpvar, no call frame so my var will be in global :: ns} -setup {
   257    258       catch {unset aaaaa}
   258    259       catch {unset xxxxx}
   259    260   } -body {
   260    261       set aaaaa 77777
................................................................................
   438    439       catch {unset six}
   439    440   } -body {
   440    441       set a ""
   441    442       set five 555
   442    443       set six  666
   443    444       namespace eval test_ns_var {
   444    445           variable five 5 six
   445         -        lappend a $five
          446  +        lappend ::a $five
   446    447       }
   447    448       lappend a $test_ns_var::five \
   448    449           [set test_ns_var::six 6] [set test_ns_var::six] $six
   449    450   } -cleanup {
   450    451       catch {unset five}
   451    452       catch {unset six}
   452    453   } -result {5 5 6 6 666}
................................................................................
   465    466           variable sev:::en 7
   466    467       }
   467    468   } -result {can't define "sev:::en": parent namespace doesn't exist}
   468    469   test var-7.8 {Tcl_VariableObjCmd, if var already exists and no value is given, leave value unchanged} {
   469    470       set a ""
   470    471       namespace eval test_ns_var {
   471    472           variable eight 8
   472         -        lappend a $eight
          473  +        lappend ::a $eight
   473    474           variable eight
   474         -        lappend a $eight
          475  +        lappend ::a $eight
   475    476       }
   476    477       set a
   477    478   } {8 8}
   478    479   test var-7.9 {Tcl_VariableObjCmd, mark as namespace var so var persists until namespace is destroyed or var is unset} -setup {
   479    480       catch {namespace delete test_ns_var2}
   480    481   } -body {
   481    482       set a ""