From 645b420b4f7e757d9539b4a93d684a1965426c54 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Wed, 11 May 2011 15:23:01 +0000 Subject: If your compiler already defines _WIN64, assume --enable-64bit --- win/configure | 63 ++++++++++++++++++++++++++++++++++++++++++-------------- win/configure.in | 14 ++++++++----- win/tcl.m4 | 15 ++++++++++++++ 3 files changed, 71 insertions(+), 21 deletions(-) diff --git a/win/configure b/win/configure index ac2284a..ed0f21d 100755 --- a/win/configure +++ b/win/configure @@ -905,7 +905,7 @@ fi fi #-------------------------------------------------------------------- -# Checks to see if the make progeam sets the $MAKE variable. +# Checks to see if the make program sets the $MAKE variable. #-------------------------------------------------------------------- echo $ac_n "checking whether ${MAKE-make} sets \${MAKE}""... $ac_c" 1>&6 @@ -1035,7 +1035,7 @@ fi # # Check to see if the excpt.h include file provided contains the # definition for EXCEPTION_DISPOSITION; if not, which is the case -# with Cygwin's version as of 2002-04-10, define it to be int, +# with Cygwin's version as of 2002-04-10, define it to be int, # sufficient for getting the current code to work. # echo $ac_n "checking for EXCEPTION_DISPOSITION support in include files""... $ac_c" 1>&6 @@ -1470,7 +1470,7 @@ EOF #-------------------------------------------------------------------- -# The statements below define a collection of compile flags. This +# The statements below define a collection of compile flags. This # macro depends on the value of SHARED_BUILD, and should be called # after SC_ENABLE_SHARED checks the configure switches. #-------------------------------------------------------------------- @@ -1704,6 +1704,36 @@ echo "configure:1596: checking compiler flags" >&5 MACHINE="IA64" echo "$ac_t"" Using 64-bit $MACHINE mode" 1>&6 ;; + *) + cat > conftest.$ac_ext <&5; (eval $ac_compile) 2>&5; }; then + rm -rf conftest* + tcl_win_64bit=no +else + echo "configure: failed program was:" >&5 + cat conftest.$ac_ext >&5 + rm -rf conftest* + tcl_win_64bit=yes + +fi +rm -f conftest* + if test "$tcl_win_64bit" = "yes" ; then + do64bit=amd64 + MACHINE="AMD64" + echo "$ac_t"" Using 64-bit $MACHINE mode" 1>&6 + fi + ;; esac else if test "${SHARED_BUILD}" = "0" ; then @@ -1933,14 +1963,14 @@ EOF #-------------------------------------------------------------------- -# Set the default compiler switches based on the --enable-symbols +# Set the default compiler switches based on the --enable-symbols # option. This macro depends on C flags, and should be called # after SC_CONFIG_CFLAGS macro is called. #-------------------------------------------------------------------- echo $ac_n "checking for build with symbols""... $ac_c" 1>&6 -echo "configure:1944: checking for build with symbols" >&5 +echo "configure:1974: checking for build with symbols" >&5 # Check whether --enable-symbols or --disable-symbols was given. if test "${enable_symbols+set}" = set; then enableval="$enable_symbols" @@ -2000,7 +2030,7 @@ TCL_DBGX=${DBGX} #-------------------------------------------------------------------- echo $ac_n "checking how to run the C preprocessor""... $ac_c" 1>&6 -echo "configure:2004: checking how to run the C preprocessor" >&5 +echo "configure:2034: checking how to run the C preprocessor" >&5 # On Suns, sometimes $CPP names a directory. if test -n "$CPP" && test -d "$CPP"; then CPP= @@ -2015,13 +2045,13 @@ else # On the NeXT, cc -E runs the code through the compiler's parser, # not just through cpp. cat > conftest.$ac_ext < Syntax Error EOF ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out" -{ (eval echo configure:2025: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } +{ (eval echo configure:2055: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } ac_err=`grep -v '^ *+' conftest.out | grep -v "^conftest.${ac_ext}\$"` if test -z "$ac_err"; then : @@ -2032,13 +2062,13 @@ else rm -rf conftest* CPP="${CC-cc} -E -traditional-cpp" cat > conftest.$ac_ext < Syntax Error EOF ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out" -{ (eval echo configure:2042: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } +{ (eval echo configure:2072: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } ac_err=`grep -v '^ *+' conftest.out | grep -v "^conftest.${ac_ext}\$"` if test -z "$ac_err"; then : @@ -2049,13 +2079,13 @@ else rm -rf conftest* CPP="${CC-cc} -nologo -E" cat > conftest.$ac_ext < Syntax Error EOF ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out" -{ (eval echo configure:2059: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } +{ (eval echo configure:2089: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } ac_err=`grep -v '^ *+' conftest.out | grep -v "^conftest.${ac_ext}\$"` if test -z "$ac_err"; then : @@ -2081,17 +2111,17 @@ echo "$ac_t""$CPP" 1>&6 ac_safe=`echo "errno.h" | sed 'y%./+-%__p_%'` echo $ac_n "checking for errno.h""... $ac_c" 1>&6 -echo "configure:2085: checking for errno.h" >&5 +echo "configure:2115: checking for errno.h" >&5 if eval "test \"`echo '$''{'ac_cv_header_$ac_safe'+set}'`\" = set"; then echo $ac_n "(cached) $ac_c" 1>&6 else cat > conftest.$ac_ext < EOF ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out" -{ (eval echo configure:2095: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } +{ (eval echo configure:2125: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } ac_err=`grep -v '^ *+' conftest.out | grep -v "^conftest.${ac_ext}\$"` if test -z "$ac_err"; then rm -rf conftest* @@ -2185,7 +2215,7 @@ fi # another for platform-independent scripts. #-------------------------------------------------------------------- -if test "$prefix" != "$exec_prefix"; then +if test "$prefix/lib" != "$libdir"; then TCL_PACKAGE_PATH="${libdir} ${prefix}/lib" else TCL_PACKAGE_PATH="${prefix}/lib" @@ -2613,3 +2643,4 @@ chmod +x $CONFIG_STATUS rm -fr confdefs* $ac_clean_files test "$no_create" = yes || ${CONFIG_SHELL-/bin/sh} $CONFIG_STATUS || exit 1 + diff --git a/win/configure.in b/win/configure.in index 3e6561e..378ca5b 100644 --- a/win/configure.in +++ b/win/configure.in @@ -74,7 +74,7 @@ if test "${GCC}" = "yes" ; then fi #-------------------------------------------------------------------- -# Checks to see if the make progeam sets the $MAKE variable. +# Checks to see if the make program sets the $MAKE variable. #-------------------------------------------------------------------- AC_PROG_MAKE_SET @@ -122,7 +122,7 @@ fi # # Check to see if the excpt.h include file provided contains the # definition for EXCEPTION_DISPOSITION; if not, which is the case -# with Cygwin's version as of 2002-04-10, define it to be int, +# with Cygwin's version as of 2002-04-10, define it to be int, # sufficient for getting the current code to work. # AC_CACHE_CHECK(for EXCEPTION_DISPOSITION support in include files, @@ -281,7 +281,7 @@ SC_ENABLE_THREADS SC_ENABLE_SHARED #-------------------------------------------------------------------- -# The statements below define a collection of compile flags. This +# The statements below define a collection of compile flags. This # macro depends on the value of SHARED_BUILD, and should be called # after SC_ENABLE_SHARED checks the configure switches. #-------------------------------------------------------------------- @@ -289,7 +289,7 @@ SC_ENABLE_SHARED SC_CONFIG_CFLAGS #-------------------------------------------------------------------- -# Set the default compiler switches based on the --enable-symbols +# Set the default compiler switches based on the --enable-symbols # option. This macro depends on C flags, and should be called # after SC_CONFIG_CFLAGS macro is called. #-------------------------------------------------------------------- @@ -375,7 +375,7 @@ fi # another for platform-independent scripts. #-------------------------------------------------------------------- -if test "$prefix" != "$exec_prefix"; then +if test "$prefix/lib" != "$libdir"; then TCL_PACKAGE_PATH="${libdir} ${prefix}/lib" else TCL_PACKAGE_PATH="${prefix}/lib" @@ -470,3 +470,7 @@ AC_SUBST(RC_DEFINES) AC_SUBST(RES) AC_OUTPUT(Makefile tclConfig.sh tcl.hpj) + +dnl Local Variables: +dnl mode: autoconf; +dnl End: diff --git a/win/tcl.m4 b/win/tcl.m4 index a766b7c..26a7036 100644 --- a/win/tcl.m4 +++ b/win/tcl.m4 @@ -553,6 +553,21 @@ AC_DEFUN([SC_CONFIG_CFLAGS], [ MACHINE="IA64" AC_MSG_RESULT([ Using 64-bit $MACHINE mode]) ;; + *) + AC_TRY_COMPILE([ + #ifdef _WIN64 + #error 64-bit + #endif + ], [], + tcl_win_64bit=no, + tcl_win_64bit=yes + ) + if test "$tcl_win_64bit" = "yes" ; then + do64bit=amd64 + MACHINE="AMD64" + AC_MSG_RESULT([ Using 64-bit $MACHINE mode]) + fi + ;; esac else if test "${SHARED_BUILD}" = "0" ; then -- cgit v0.12 From f457d73c6c66e6b751cd6bc28efd8a88f56daadc Mon Sep 17 00:00:00 2001 From: max Date: Wed, 11 May 2011 15:43:06 +0000 Subject: * unix/tclUnixSock.c (TcpWatchProc): No need to check for server sockets here, as the generic server code already takes care of that. * tests/socket.test (accept): Add tests to make sure that this remains so. --- ChangeLog | 8 ++++++++ tests/socket.test | 18 ++++++++++++++++++ unix/tclUnixSock.c | 27 +++++++++------------------ 3 files changed, 35 insertions(+), 18 deletions(-) diff --git a/ChangeLog b/ChangeLog index 47b9a2d..41cf780 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,11 @@ +2011-05-11 Reinhard Max + + * unix/tclUnixSock.c (TcpWatchProc): No need to check for server + sockets here, as the generic server code already takes care of + that. + * tests/socket.test (accept): Add tests to make sure that this + remains so. + 2011-05-10 Don Porter * generic/tclInt.h: New internal routines TclScanElement() and diff --git a/tests/socket.test b/tests/socket.test index 09b34ad..f1acedc 100644 --- a/tests/socket.test +++ b/tests/socket.test @@ -800,6 +800,24 @@ test socket_$af-6.1 {accept callback error} -constraints [list socket supported_ interp bgerror {} $handler } -result {divide by zero} +test socket_$af-6.2 { + readable fileevent on server socket +} -setup { + set sock [socket -server dummy 0] +} -body { + fileevent $sock readable dummy +} -cleanup { + close $sock +} -returnCodes 1 -result "channel is not readable" + +test socket_$af-6.3 {writable fileevent on server socket} -setup { + set sock [socket -server dummy 0] +} -body { + fileevent $sock writable dummy +} -cleanup { + close $sock +} -returnCodes 1 -result "channel is not writable" + test socket_$af-7.1 {testing socket specific options} -setup { file delete $path(script) set f [open $path(script) w] diff --git a/unix/tclUnixSock.c b/unix/tclUnixSock.c index 35728e1..cb72759 100644 --- a/unix/tclUnixSock.c +++ b/unix/tclUnixSock.c @@ -785,25 +785,16 @@ TcpWatchProc( * TCL_EXCEPTION. */ { TcpState *statePtr = (TcpState *) instanceData; + TcpFdList *fds; - /* - * Make sure we don't mess with server sockets since they will never be - * readable or writable at the Tcl level. This keeps Tcl scripts from - * interfering with the -accept behavior. - */ - - if (!statePtr->acceptProc) { - TcpFdList *fds; - - for (fds = statePtr->fds; fds != NULL; fds = fds->next) { - if (mask) { - Tcl_CreateFileHandler(fds->fd, mask, - (Tcl_FileProc *) Tcl_NotifyChannel, - (ClientData) statePtr->channel); - } else { - Tcl_DeleteFileHandler(fds->fd); - } - } + for (fds = statePtr->fds; fds != NULL; fds = fds->next) { + if (mask) { + Tcl_CreateFileHandler(fds->fd, mask, + (Tcl_FileProc *) Tcl_NotifyChannel, + (ClientData) statePtr->channel); + } else { + Tcl_DeleteFileHandler(fds->fd); + } } } -- cgit v0.12 From 96524bb4dd0127496d2baf6792d0de093157297b Mon Sep 17 00:00:00 2001 From: patthoyts Date: Thu, 12 May 2011 21:07:47 +0000 Subject: [Bug 2715421] fix backported from 8.6 to remove extra newline from POSTs. Package version incremented to 2.7.6. Signed-off-by: Pat Thoyts --- library/http/http.tcl | 3 +-- library/http/pkgIndex.tcl | 2 +- unix/Makefile.in | 4 ++-- win/Makefile.in | 4 ++-- 4 files changed, 6 insertions(+), 7 deletions(-) diff --git a/library/http/http.tcl b/library/http/http.tcl index 87af637..aaef2b8 100644 --- a/library/http/http.tcl +++ b/library/http/http.tcl @@ -11,7 +11,7 @@ package require Tcl 8.4 # Keep this in sync with pkgIndex.tcl and with the install directories in # Makefiles -package provide http 2.7.5 +package provide http 2.7.6 namespace eval http { # Allow resourcing to not clobber existing data @@ -900,7 +900,6 @@ proc http::Write {token} { incr state(queryoffset) $state(-queryblocksize) if {$state(queryoffset) >= $state(querylength)} { set state(queryoffset) $state(querylength) - puts $sock "" set done 1 } } else { diff --git a/library/http/pkgIndex.tcl b/library/http/pkgIndex.tcl index 1eec2b6..fed5829 100644 --- a/library/http/pkgIndex.tcl +++ b/library/http/pkgIndex.tcl @@ -1,4 +1,4 @@ # Tcl package index file, version 1.1 if {![package vsatisfies [package provide Tcl] 8.4]} {return} -package ifneeded http 2.7.5 [list tclPkgSetup $dir http 2.7.5 {{http.tcl source {::http::config ::http::formatQuery ::http::geturl ::http::reset ::http::wait ::http::register ::http::unregister ::http::mapReply}}}] +package ifneeded http 2.7.6 [list tclPkgSetup $dir http 2.7.6 {{http.tcl source {::http::config ::http::formatQuery ::http::geturl ::http::reset ::http::wait ::http::register ::http::unregister ::http::mapReply}}}] diff --git a/unix/Makefile.in b/unix/Makefile.in index 782a89b..398ce55 100644 --- a/unix/Makefile.in +++ b/unix/Makefile.in @@ -771,8 +771,8 @@ install-libraries: libraries $(INSTALL_TZDATA) install-msgs do \ $(INSTALL_DATA) $$i "$(SCRIPT_INSTALL_DIR)"/http1.0; \ done; - @echo "Installing package http 2.7.5 as a Tcl Module"; - @$(INSTALL_DATA) $(TOP_DIR)/library/http/http.tcl "$(SCRIPT_INSTALL_DIR)"/../tcl8/8.4/http-2.7.5.tm; + @echo "Installing package http 2.7.6 as a Tcl Module"; + @$(INSTALL_DATA) $(TOP_DIR)/library/http/http.tcl "$(SCRIPT_INSTALL_DIR)"/../tcl8/8.4/http-2.7.6.tm; @echo "Installing library opt0.4 directory"; @for i in $(TOP_DIR)/library/opt/*.tcl ; \ do \ diff --git a/win/Makefile.in b/win/Makefile.in index bb71186..aa9620c 100644 --- a/win/Makefile.in +++ b/win/Makefile.in @@ -638,8 +638,8 @@ install-libraries: libraries install-tzdata install-msgs do \ $(COPY) "$$j" "$(SCRIPT_INSTALL_DIR)/http1.0"; \ done; - @echo "Installing package http 2.7.5 as a Tcl Module"; - @$(COPY) $(ROOT_DIR)/library/http/http.tcl $(SCRIPT_INSTALL_DIR)/../tcl8/8.4/http-2.7.5.tm; + @echo "Installing package http 2.7.6 as a Tcl Module"; + @$(COPY) $(ROOT_DIR)/library/http/http.tcl $(SCRIPT_INSTALL_DIR)/../tcl8/8.4/http-2.7.6.tm; @echo "Installing library opt0.4 directory"; @for j in $(ROOT_DIR)/library/opt/*.tcl; \ do \ -- cgit v0.12 From ae8c7e936a3c00a11a29a50f2b80df021acbea51 Mon Sep 17 00:00:00 2001 From: andreask Date: Tue, 17 May 2011 21:26:26 +0000 Subject: * generic/tclCompile.c (TclFixupForwardJump): Tracked down and fixed * generic/tclBasic.c (TclArgumentBCEnter): the cause of a violation of my assertion that 'ePtr->nline == objc' in TclArgumentBCEnter. When a bytecode was grown during jump fixup the pc -> command line mapping was not updated. When things aligned just wrong the mapping would direct command A to the data for command B, with a different number of arguments. --- ChangeLog | 10 ++++++++ generic/tclBasic.c | 4 ++++ generic/tclCompile.c | 64 ++++++++++++++++++++++++++++++++++++++++++++++++++++ 3 files changed, 78 insertions(+) diff --git a/ChangeLog b/ChangeLog index 98af3b4..a79456b 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,13 @@ +2011-05-17 Andreas Kupries + + * generic/tclCompile.c (TclFixupForwardJump): Tracked down and fixed + * generic/tclBasic.c (TclArgumentBCEnter): the cause of a violation + of my assertion that 'ePtr->nline == objc' in TclArgumentBCEnter. + When a bytecode was grown during jump fixup the pc -> command line + mapping was not updated. When things aligned just wrong the mapping + would direct command A to the data for command B, with a different + number of arguments. + 2011-05-10 Don Porter * generic/tclInt.h: New internal routines TclScanElement() and diff --git a/generic/tclBasic.c b/generic/tclBasic.c index 71bd45c..750c9e2 100644 --- a/generic/tclBasic.c +++ b/generic/tclBasic.c @@ -4764,6 +4764,10 @@ TclArgumentBCEnter(interp,objv,objc,codePtr,cfPtr,pc) * have to save them at compile time. */ + if (ePtr->nline != objc) { + Tcl_Panic ("TIP 280 data structure inconsistency"); + } + for (word = 1; word < objc; word++) { if (ePtr->line[word] >= 0) { int isnew; diff --git a/generic/tclCompile.c b/generic/tclCompile.c index 2d8d58c..8a7cbf8 100644 --- a/generic/tclCompile.c +++ b/generic/tclCompile.c @@ -3020,6 +3020,70 @@ TclFixupForwardJump( rangePtr->type); } } + + /* + * TIP #280: Adjust the mapping from PC values to the per-command + * information about arguments and their line numbers. + * + * Note: We cannot simply remove an out-of-date entry and then reinsert + * with the proper PC, because then we might overwrite another entry which + * was at that location. Therefore we pull (copy + delete) all effected + * entries (beyond the fixed PC) into an array, update them there, and at + * last reinsert them all. + */ + + { + ExtCmdLoc* eclPtr = envPtr->extCmdMapPtr; + + /* A helper structure */ + + typedef struct { + int pc; + int cmd; + } MAP; + + /* + * And the helper array. At most the whole hashtable is placed into + * this. + */ + + MAP *map = (MAP*) ckalloc (sizeof(MAP) * eclPtr->litInfo.numEntries); + + Tcl_HashSearch hSearch; + Tcl_HashEntry* hPtr; + int n, k, isnew; + + /* + * Phase I: Locate the affected entries, and save them in adjusted + * form to the array. This removes them from the hash. + */ + + for (n = 0, hPtr = Tcl_FirstHashEntry(&eclPtr->litInfo, &hSearch); + hPtr != NULL; + hPtr = Tcl_NextHashEntry(&hSearch)) { + + map [n].cmd = PTR2INT(Tcl_GetHashValue(hPtr)); + map [n].pc = PTR2INT(Tcl_GetHashKey (&eclPtr->litInfo,hPtr)); + + if (map[n].pc >= (jumpFixupPtr->codeOffset + 2)) { + Tcl_DeleteHashEntry(hPtr); + map [n].pc += 3; + n++; + } + } + + /* + * Phase II: Re-insert the modified entries into the hash. + */ + + for (k=0;klitInfo, INT2PTR(map[k].pc), &isnew); + Tcl_SetHashValue(hPtr, INT2PTR(map[k].cmd)); + } + + ckfree (map); + } + return 1; /* the jump was grown */ } -- cgit v0.12 From 5bd6dd53b688d13a70275daa5ae14814b8c69221 Mon Sep 17 00:00:00 2001 From: dkf Date: Tue, 24 May 2011 12:23:52 +0000 Subject: Remove some useless code from mcset and mcmset: [dict set] builds dictionary levels for us. --- ChangeLog | 5 +++++ generic/tclInt.h | 7 +++++-- library/msgcat/msgcat.tcl | 14 -------------- 3 files changed, 10 insertions(+), 16 deletions(-) diff --git a/ChangeLog b/ChangeLog index 6e64b7c..83fa590 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,8 @@ +2011-05-24 Donal K. Fellows + + * library/msgcat/msgcat.tcl (msgcat::mcset, msgcat::mcmset): Remove + some useless code; [dict set] builds dictionary levels for us. + 2011-05-17 Andreas Kupries * generic/tclCompile.c (TclFixupForwardJump): Tracked down and fixed diff --git a/generic/tclInt.h b/generic/tclInt.h index 8f003be..75f894f 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -4227,8 +4227,11 @@ MODULE_SCOPE void TclDbInitNewObj(Tcl_Obj *objPtr, const char *file, */ #define TclInvalidateNsCmdLookup(nsPtr) \ - if ((nsPtr)->numExportPatterns) { \ - (nsPtr)->exportLookupEpoch++; \ + if ((nsPtr)->numExportPatterns) { \ + (nsPtr)->exportLookupEpoch++; \ + } \ + if ((nsPtr)->commandPathLength) { \ + (nsPtr)->cmdRefEpoch++; \ } /* diff --git a/library/msgcat/msgcat.tcl b/library/msgcat/msgcat.tcl index a9b4533..b39820a 100644 --- a/library/msgcat/msgcat.tcl +++ b/library/msgcat/msgcat.tcl @@ -313,13 +313,6 @@ proc msgcat::mcset {locale src {dest ""}} { set locale [string tolower $locale] - # create nested dictionaries if they do not exist - if {![dict exists $Msgs $locale]} { - dict set Msgs $locale [dict create] - } - if {![dict exists $Msgs $locale $ns]} { - dict set Msgs $locale $ns [dict create] - } dict set Msgs $locale $ns $src $dest return $dest } @@ -347,13 +340,6 @@ proc msgcat::mcmset {locale pairs } { set locale [string tolower $locale] set ns [uplevel 1 [list ::namespace current]] - # create nested dictionaries if they do not exist - if {![dict exists $Msgs $locale]} { - dict set Msgs $locale [dict create] - } - if {![dict exists $Msgs $locale $ns]} { - dict set Msgs $locale $ns [dict create] - } foreach {src dest} $pairs { dict set Msgs $locale $ns $src $dest } -- cgit v0.12 From 8d3db05308f4171d5df9cc39c19a8914ab6b651d Mon Sep 17 00:00:00 2001 From: dkf Date: Tue, 24 May 2011 12:36:20 +0000 Subject: Undo mistaken commit --- generic/tclInt.h | 7 ++----- 1 file changed, 2 insertions(+), 5 deletions(-) diff --git a/generic/tclInt.h b/generic/tclInt.h index 75f894f..8f003be 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -4227,11 +4227,8 @@ MODULE_SCOPE void TclDbInitNewObj(Tcl_Obj *objPtr, const char *file, */ #define TclInvalidateNsCmdLookup(nsPtr) \ - if ((nsPtr)->numExportPatterns) { \ - (nsPtr)->exportLookupEpoch++; \ - } \ - if ((nsPtr)->commandPathLength) { \ - (nsPtr)->cmdRefEpoch++; \ + if ((nsPtr)->numExportPatterns) { \ + (nsPtr)->exportLookupEpoch++; \ } /* -- cgit v0.12 From 2810f5f2cc04f2626b2df581112e345b934065f1 Mon Sep 17 00:00:00 2001 From: venkat Date: Tue, 24 May 2011 14:55:38 +0000 Subject: Update to Olson tzdata2011g --- ChangeLog | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/ChangeLog b/ChangeLog index a79456b..bae32ee 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,7 @@ +2011-05-24 Venkat Iyer + + * library/tzdata/Africa/Cairo: Update to Olson tzdata2011g + 2011-05-17 Andreas Kupries * generic/tclCompile.c (TclFixupForwardJump): Tracked down and fixed -- cgit v0.12 From 1d49ca67e112ecdac5812541cf20613f4147a0e9 Mon Sep 17 00:00:00 2001 From: dkf Date: Wed, 25 May 2011 13:35:37 +0000 Subject: Implementation of TIP #381: Call Chain Introspection and Control --- ChangeLog | 10 + doc/info.n | 66 +++++ doc/next.n | 8 + doc/self.n | 33 +++ generic/tclOO.c | 2 + generic/tclOOBasic.c | 120 +++++++- generic/tclOOCall.c | 223 ++++++++++++++- generic/tclOOInfo.c | 90 ++++++ generic/tclOOInt.h | 7 + tests/oo.test | 4 +- tests/ooNext2.test | 765 +++++++++++++++++++++++++++++++++++++++++++++++++++ 11 files changed, 1313 insertions(+), 15 deletions(-) create mode 100644 tests/ooNext2.test diff --git a/ChangeLog b/ChangeLog index af7fab6..3118f82 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,13 @@ +2011-05-25 Donal K. Fellows + + IMPLEMENTATION OF TIP#381. + + * doc/next.n, doc/ooInfo.n, doc/self.n, generic/tclOO.c, + * generic/tclOOBasic.c, generic/tclOOCall.c, generic/tclOOInfo.c, + * generic/tclOOInt.h, tests/oo.test, tests/ooNext2.test: Added + introspection of call chains ([self call], [info object call], [info + class call]) and ability to skip ahead in chain ([nextto]). + 2011-05-24 Venkat Iyer * library/tzdata/Africa/Cairo: Update to Olson tzdata2011g diff --git a/doc/info.n b/doc/info.n index 2126b21..cb5c6e6 100644 --- a/doc/info.n +++ b/doc/info.n @@ -399,6 +399,29 @@ been set (e.g. a variable declared but not set by \fBvariable\fR). The following \fIsubcommand\fR values are supported by \fBinfo class\fR: .VE 8.6 .TP +\fBinfo class call\fI class method\fR +.VS +Returns a description of the method implementations that are used to provide a +stereotypical instance of \fIclass\fR's implementation of \fImethod\fR +(stereotypical instances being objects instantiated by a class without having +any object-specific definitions added). This consists of a list of lists of +four elements, where each sublist consists of a word that describes the +general type of method implementation (being one of \fBmethod\fR for an +ordinary method, \fBfilter\fR for an applied filter, and \fBunknown\fR for a +method that is invoked as part of unknown method handling), a word giving the +name of the particular method invoked (which is always the same as +\fImethod\fR for the \fBmethod\fR type, and +.QW \fBunknown\fR +for the \fBunknown\fR type), a word giving the fully qualified name of the +class that defined the method, and a word describing the type of method +implementation (see \fBinfo class methodtype\fR). +.RS +.PP +Note that there is no inspection of whether the method implementations +actually use \fBnext\fR to transfer control along the call chain. +.RE +.VE 8.6 +.TP \fBinfo class constructor\fI class\fR .VS 8.6 This subcommand returns a description of the definition of the constructor of @@ -504,6 +527,28 @@ class's methods, constructor and destructor). The following \fIsubcommand\fR values are supported by \fBinfo object\fR: .VE 8.6 .TP +\fBinfo object call\fI object method\fR +.VS 8.6 +Returns a description of the method implementations that are used to provide +\fIobject\fR's implementation of \fImethod\fR. This consists of a list of +lists of four elements, where each sublist consists of a word that describes +the general type of method implementation (being one of \fBmethod\fR for an +ordinary method, \fBfilter\fR for an applied filter, and \fBunknown\fR for a +method that is invoked as part of unknown method handling), a word giving the +name of the particular method invoked (which is always the same as +\fImethod\fR for the \fBmethod\fR type, and +.QW \fBunknown\fR +for the \fBunknown\fR type), a word giving what defined the method (the fully +qualified name of the class, or the literal string \fBobject\fR if the method +implementation is on an instance), and a word describing the type of method +implementation (see \fBinfo object methodtype\fR). +.RS +.PP +Note that there is no inspection of whether the method implementations +actually use \fBnext\fR to transfer control along the call chain. +.RE +.VE 8.6 +.TP \fBinfo object class\fI object\fR ?\fIclassName\fR? .VS 8.6 If \fIclassName\fR is unspecified, this subcommand returns class of the @@ -672,6 +717,27 @@ method and get how it is defined. This procedure illustrates how: .PP .CS proc getDef {obj method} { + foreach inf [\fBinfo object call\fR $obj $method] { + lassign $inf calltype name locus methodtype + # Assume no forwards or filters, and hence no $calltype + # or $methodtype checks... + if {$locus eq "object"} { + return [\fBinfo object definition\fR $obj $name] + } else { + return [\fBinfo class definition\fR $locus $name] + } + } + error "no definition for $method" +} +.CE +.PP +This is an alternate way of implementing the definition lookup is by manually +scanning the list of methods up the inheritance tree. This code assumes that +only single inheritance is in use, and that there is no complex use of +mixed-in classes: +.PP +.CS +proc getDef {obj method} { if {$method in [\fBinfo object methods\fR $obj]} { # Assume no forwards return [\fBinfo object definition\fR $obj $method] diff --git a/doc/next.n b/doc/next.n index c8b098e..222d8b3 100644 --- a/doc/next.n +++ b/doc/next.n @@ -15,6 +15,7 @@ next \- invoke superclass method implementations package require TclOO \fBnext\fR ?\fIarg ...\fR? +\fBnextto\fI class\fR ?\fIarg ...\fR? .fi .BE @@ -30,6 +31,13 @@ of the next method in the method chain; if there are no further methods in the method chain, the result of \fBnext\fR will be an error. The arguments, \fIarg\fR, to \fBnext\fR are the arguments to pass to the next method in the chain. +.PP +The \fBnextto\fR command is the same as the \fBnext\fR command, except that it +takes an additional \fIclass\fR argument that identifies a class whose +implementation of the current method chain (see \fBinfo object call\fR) should +be used; the method implementation selected will be the one provided by the +given class, and it must refer to an existing non-filter invocation that lies +further along the chain than the current implementation. .SH "THE METHOD CHAIN" .PP When a method of an object is invoked, things happen in several stages: diff --git a/doc/self.n b/doc/self.n index f01a607..11779ff 100644 --- a/doc/self.n +++ b/doc/self.n @@ -25,6 +25,17 @@ takes an argument, \fIsubcommand\fR, that tells it what sort of information is actually desired; if omitted the result will be the same as if \fBself object\fR was invoked. The supported subcommands are: .TP +\fBself call\fR +. +This returns a two-element list describing the method implementations used to +implement the current call chain. The first element is the same as would be +reported by \fBinfo object call\fR for the current method (except that this +also reports useful values from within constructors and destructors, whose +names are reported as \fB\fR and \fB\fR +respectively), and the second element is an index into the first element's +list that indicates which actual implementation is currently executing (the +first implementation to execute is always at index 0). +.TP \fBself caller\fR . When the method was invoked from inside another object method, this subcommand @@ -109,6 +120,28 @@ c create b a foo \fI\(-> prints "this is the ::a object"\fR b foo \fI\(-> prints "this is the ::b object"\fR .CE +.PP +This demonstrates what a method call chain looks like, and how traversing +along it changes the index into it: +.PP +.CS +oo::class create c { + method x {} { + puts "Cls: [\fBself call\fR]" + } +} +c create a +oo::objdefine a { + method x {} { + puts "Obj: [\fBself call\fR]" + next + puts "Obj: [\fBself call\fR]" + } +} +a x \fI\(-> Obj: {{method x object method} {method x ::c method}} 0\fR + \fI\(-> Cls: {{method x object method} {method x ::c method}} 1\fR + \fI\(-> Obj: {{method x object method} {method x ::c method}} 0\fR +.CE .SH "SEE ALSO" info(n), next(n) .SH KEYWORDS diff --git a/generic/tclOO.c b/generic/tclOO.c index 6ae82d1..9df3f53 100644 --- a/generic/tclOO.c +++ b/generic/tclOO.c @@ -346,6 +346,8 @@ InitFoundation( Tcl_CreateObjCommand(interp, "::oo::Helpers::next", TclOONextObjCmd, NULL, NULL); + Tcl_CreateObjCommand(interp, "::oo::Helpers::nextto", TclOONextToObjCmd, + NULL, NULL); Tcl_CreateObjCommand(interp, "::oo::Helpers::self", TclOOSelfObjCmd, NULL, NULL); Tcl_CreateObjCommand(interp, "::oo::define", TclOODefineObjCmd, NULL, diff --git a/generic/tclOOBasic.c b/generic/tclOOBasic.c index 0d38dcd..b286088 100644 --- a/generic/tclOOBasic.c +++ b/generic/tclOOBasic.c @@ -680,10 +680,11 @@ TclOO_Object_VarName( /* * ---------------------------------------------------------------------- * - * TclOONextObjCmd -- + * TclOONextObjCmd, TclOONextToObjCmd -- * - * Implementation of the [next] command. Note that this command is only - * ever to be used inside the body of a procedure-like method. + * Implementation of the [next] and [nextto] commands. Note that these + * commands are only ever to be used inside the body of a procedure-like + * method. * * ---------------------------------------------------------------------- */ @@ -723,6 +724,97 @@ TclOONextObjCmd( return TclNRObjectContextInvokeNext(interp, context, objc, objv, 1); } +int +TclOONextToObjCmd( + ClientData clientData, + Tcl_Interp *interp, + int objc, + Tcl_Obj *const *objv) +{ + Interp *iPtr = (Interp *) interp; + CallFrame *framePtr = iPtr->varFramePtr; + Class *classPtr; + CallContext *contextPtr; + int i; + Tcl_Object object; + + /* + * Start with sanity checks on the calling context to make sure that we + * are invoked from a suitable method context. If so, we can safely + * retrieve the handle to the object call context. + */ + + if (framePtr == NULL || !(framePtr->isProcCallFrame & FRAME_IS_METHOD)) { + Tcl_AppendResult(interp, TclGetString(objv[0]), + " may only be called from inside a method", NULL); + Tcl_SetErrorCode(interp, "TCL", "OO", "CONTEXT_REQUIRED", NULL); + return TCL_ERROR; + } + contextPtr = framePtr->clientData; + + /* + * Sanity check the arguments; we need the first one to refer to a class. + */ + + if (objc < 2) { + Tcl_WrongNumArgs(interp, 1, objv, "class ?arg...?"); + return TCL_ERROR; + } + object = Tcl_GetObjectFromObj(interp, objv[1]); + if (object == NULL) { + return TCL_ERROR; + } + classPtr = ((Object *)object)->classPtr; + if (classPtr == NULL) { + Tcl_AppendResult(interp, "\"", TclGetString(objv[1]), + "\" is not a class", NULL); + return TCL_ERROR; + } + + /* + * Search for an implementation of a method associated with the current + * call on the call chain past the point where we currently are. Do not + * allow jumping backwards! + */ + + for (i=contextPtr->index+1 ; icallPtr->numChain ; i++) { + struct MInvoke *miPtr = contextPtr->callPtr->chain + i; + + if (!miPtr->isFilter && miPtr->mPtr->declaringClassPtr == classPtr) { + /* + * Invoke the (advanced) method call context in the caller + * context. Note that this is like [uplevel 1] and not [eval]. + */ + + TclNRAddCallback(interp, RestoreFrame, framePtr, contextPtr, + INT2PTR(contextPtr->index), NULL); + contextPtr->index = i-1; + iPtr->varFramePtr = framePtr->callerVarPtr; + return TclNRObjectContextInvokeNext(interp, + (Tcl_ObjectContext) contextPtr, objc, objv, 2); + } + } + + /* + * Generate an appropriate error message, depending on whether the value + * is on the chain but unreachable, or not on the chain at all. + */ + + for (i=contextPtr->index ; i>=0 ; i--) { + struct MInvoke *miPtr = contextPtr->callPtr->chain + i; + + if (!miPtr->isFilter && miPtr->mPtr->declaringClassPtr == classPtr) { + Tcl_AppendResult(interp, "method implementation by \"", + TclGetString(objv[1]), "\" not reachable from here", + NULL); + return TCL_ERROR; + } + } + Tcl_AppendResult(interp, "method has no non-filter implementation by \"", + TclGetString(objv[1]), "\"", NULL); + return TCL_ERROR; +} + static int RestoreFrame( ClientData data[], @@ -730,8 +822,12 @@ RestoreFrame( int result) { Interp *iPtr = (Interp *) interp; + CallContext *contextPtr = data[1]; iPtr->varFramePtr = data[0]; + if (contextPtr != NULL) { + contextPtr->index = PTR2INT(data[2]); + } return result; } @@ -754,16 +850,17 @@ TclOOSelfObjCmd( Tcl_Obj *const *objv) { static const char *const subcmds[] = { - "caller", "class", "filter", "method", "namespace", "next", "object", - "target", NULL + "call", "caller", "class", "filter", "method", "namespace", "next", + "object", "target", NULL }; enum SelfCmds { - SELF_CALLER, SELF_CLASS, SELF_FILTER, SELF_METHOD, SELF_NS, SELF_NEXT, - SELF_OBJECT, SELF_TARGET + SELF_CALL, SELF_CALLER, SELF_CLASS, SELF_FILTER, SELF_METHOD, SELF_NS, + SELF_NEXT, SELF_OBJECT, SELF_TARGET }; Interp *iPtr = (Interp *) interp; CallFrame *framePtr = iPtr->varFramePtr; CallContext *contextPtr; + Tcl_Obj *result[3]; int index; #define CurrentlyInvoked(contextPtr) \ @@ -834,7 +931,6 @@ TclOOSelfObjCmd( return TCL_ERROR; } else { register struct MInvoke *miPtr = &CurrentlyInvoked(contextPtr); - Tcl_Obj *result[3]; Object *oPtr; const char *type; @@ -862,7 +958,6 @@ TclOOSelfObjCmd( CallContext *callerPtr = framePtr->callerVarPtr->clientData; Method *mPtr = callerPtr->callPtr->chain[callerPtr->index].mPtr; Object *declarerPtr; - Tcl_Obj *result[3]; if (mPtr->declaringClassPtr != NULL) { declarerPtr = mPtr->declaringClassPtr->thisPtr; @@ -894,7 +989,6 @@ TclOOSelfObjCmd( Method *mPtr = contextPtr->callPtr->chain[contextPtr->index+1].mPtr; Object *declarerPtr; - Tcl_Obj *result[2]; if (mPtr->declaringClassPtr != NULL) { declarerPtr = mPtr->declaringClassPtr->thisPtr; @@ -928,7 +1022,6 @@ TclOOSelfObjCmd( } else { Method *mPtr; Object *declarerPtr; - Tcl_Obj *result[2]; int i; for (i=contextPtr->index ; icallPtr->numChain ; i++){ @@ -957,6 +1050,11 @@ TclOOSelfObjCmd( Tcl_SetObjResult(interp, Tcl_NewListObj(2, result)); return TCL_OK; } + case SELF_CALL: + result[0] = TclOORenderCallChain(interp, contextPtr->callPtr); + result[1] = Tcl_NewIntObj(contextPtr->index); + Tcl_SetObjResult(interp, Tcl_NewListObj(2, result)); + return TCL_OK; } return TCL_ERROR; } diff --git a/generic/tclOOCall.c b/generic/tclOOCall.c index 1e8d1a3..3954a6b 100644 --- a/generic/tclOOCall.c +++ b/generic/tclOOCall.c @@ -104,8 +104,10 @@ TclOODeleteContext( register Object *oPtr = contextPtr->oPtr; TclOODeleteChain(contextPtr->callPtr); - TclStackFree(oPtr->fPtr->interp, contextPtr); - DelRef(oPtr); + if (oPtr != NULL) { + TclStackFree(oPtr->fPtr->interp, contextPtr); + DelRef(oPtr); + } } /* @@ -1099,6 +1101,137 @@ TclOOGetCallContext( /* * ---------------------------------------------------------------------- * + * TclOOGetStereotypeCallChain -- + * + * Construct a call-chain for a method that would be used by a + * stereotypical instance of the given class (i.e., where the object has + * no definitions special to itself). + * + * ---------------------------------------------------------------------- + */ + +CallChain * +TclOOGetStereotypeCallChain( + Class *clsPtr, /* The object to get the context for. */ + Tcl_Obj *methodNameObj, /* The name of the method to get the context + * for. NULL when getting a constructor or + * destructor chain. */ + int flags) /* What sort of context are we looking for. + * Only the bits PUBLIC_METHOD, CONSTRUCTOR, + * PRIVATE_METHOD, DESTRUCTOR and + * FILTER_HANDLING are useful. */ +{ + CallChain *callPtr; + struct ChainBuilder cb; + int i, count; + Foundation *fPtr = clsPtr->thisPtr->fPtr; + Tcl_HashEntry *hPtr; + Tcl_HashTable doneFilters; + Object obj; + + /* + * Synthesize a temporary stereotypical object so that we can use existing + * machinery to produce the stereotypical call chain. + */ + + memset(&obj, 0, sizeof(Object)); + obj.fPtr = fPtr; + obj.selfCls = clsPtr; + obj.refCount = 1; + obj.flags = USE_CLASS_CACHE; + + /* + * Check if we can get the chain out of the Tcl_Obj method name or out of + * the cache. This is made a bit more complex by the fact that there are + * multiple different layers of cache (in the Tcl_Obj, in the object, and + * in the class). + */ + + if (clsPtr->classChainCache != NULL) { + hPtr = Tcl_FindHashEntry(clsPtr->classChainCache, + (char *) methodNameObj); + if (hPtr != NULL && Tcl_GetHashValue(hPtr) != NULL) { + const int reuseMask = + ((flags & PUBLIC_METHOD) ? ~0 : ~PUBLIC_METHOD); + + callPtr = Tcl_GetHashValue(hPtr); + if (IsStillValid(callPtr, &obj, flags, reuseMask)) { + callPtr->refCount++; + return callPtr; + } + Tcl_SetHashValue(hPtr, NULL); + TclOODeleteChain(callPtr); + } + } else { + hPtr = NULL; + } + + callPtr = (CallChain *) ckalloc(sizeof(CallChain)); + memset(callPtr, 0, sizeof(CallChain)); + callPtr->flags = flags & (PUBLIC_METHOD|PRIVATE_METHOD|FILTER_HANDLING); + callPtr->epoch = fPtr->epoch; + callPtr->objectCreationEpoch = fPtr->tsdPtr->nsCount; + callPtr->objectEpoch = clsPtr->thisPtr->epoch; + callPtr->refCount = 1; + callPtr->chain = callPtr->staticChain; + + cb.callChainPtr = callPtr; + cb.filterLength = 0; + cb.oPtr = &obj; + + /* + * Add all defined filters (if any, and if we're going to be processing + * them; they're not processed for constructors, destructors or when we're + * in the middle of processing a filter). + */ + + Tcl_InitObjHashTable(&doneFilters); + AddClassFiltersToCallContext(&obj, clsPtr, &cb, &doneFilters); + Tcl_DeleteHashTable(&doneFilters); + count = cb.filterLength = callPtr->numChain; + + /* + * Add the actual method implementations. + */ + + AddSimpleChainToCallContext(&obj, methodNameObj, &cb, NULL, flags, NULL); + + /* + * Check to see if the method has no implementation. If so, we probably + * need to add in a call to the unknown method. Otherwise, set up the + * cacheing of the method implementation (if relevant). + */ + + if (count == callPtr->numChain) { + AddSimpleChainToCallContext(&obj, fPtr->unknownMethodNameObj, &cb, + NULL, 0, NULL); + callPtr->flags |= OO_UNKNOWN_METHOD; + callPtr->epoch = -1; + if (count == callPtr->numChain) { + TclOODeleteChain(callPtr); + return NULL; + } + } else { + if (hPtr == NULL) { + if (clsPtr->classChainCache == NULL) { + clsPtr->classChainCache = (Tcl_HashTable *) + ckalloc(sizeof(Tcl_HashTable)); + + Tcl_InitObjHashTable(clsPtr->classChainCache); + } + hPtr = Tcl_CreateHashEntry(clsPtr->classChainCache, + (char *) methodNameObj, &i); + } + callPtr->refCount++; + Tcl_SetHashValue(hPtr, callPtr); + StashCallChain(methodNameObj, callPtr); + } + return callPtr; +} + +/* + * ---------------------------------------------------------------------- + * * AddClassFiltersToCallContext -- * * Logic to make extracting all the filters from the class context much @@ -1256,6 +1389,92 @@ AddSimpleClassChainToCallContext( } /* + * ---------------------------------------------------------------------- + * + * TclOORenderCallChain -- + * + * Create a description of a call chain. Used in [info object call], + * [info class call], and [self call]. + * + * ---------------------------------------------------------------------- + */ + +Tcl_Obj * +TclOORenderCallChain( + Tcl_Interp *interp, + CallChain *callPtr) +{ + Tcl_Obj *filterLiteral, *methodLiteral, *objectLiteral; + Tcl_Obj *resultObj, *descObjs[4], **objv; + Foundation *fPtr = TclOOGetFoundation(interp); + int i; + + /* + * Allocate the literals (potentially) used in our description. + */ + + filterLiteral = Tcl_NewStringObj("filter", -1); + Tcl_IncrRefCount(filterLiteral); + methodLiteral = Tcl_NewStringObj("method", -1); + Tcl_IncrRefCount(methodLiteral); + objectLiteral = Tcl_NewStringObj("object", -1); + Tcl_IncrRefCount(objectLiteral); + + /* + * Do the actual construction of the descriptions. They consist of a list + * of triples that describe the details of how a method is understood. For + * each triple, the first word is the type of invokation ("method" is + * normal, "unknown" is special because it adds the method name as an + * extra argument when handled by some method types, and "filter" is + * special because it's a filter method). The second word is the name of + * the method in question (which differs for "unknown" and "filter" types) + * and the third word is the full name of the class that declares the + * method (or "object" if it is declared on the instance). + */ + + objv = TclStackAlloc(interp, callPtr->numChain * sizeof(Tcl_Obj *)); + for (i=0 ; inumChain ; i++) { + struct MInvoke *miPtr = &callPtr->chain[i]; + + descObjs[0] = miPtr->isFilter + ? filterLiteral + : callPtr->flags & OO_UNKNOWN_METHOD + ? fPtr->unknownMethodNameObj + : methodLiteral; + descObjs[1] = callPtr->flags & CONSTRUCTOR + ? fPtr->constructorName + : callPtr->flags & DESTRUCTOR + ? fPtr->destructorName + : miPtr->mPtr->namePtr; + descObjs[2] = miPtr->mPtr->declaringClassPtr + ? Tcl_GetObjectName(interp, + (Tcl_Object) miPtr->mPtr->declaringClassPtr->thisPtr) + : objectLiteral; + descObjs[3] = Tcl_NewStringObj(miPtr->mPtr->typePtr->name, -1); + + objv[i] = Tcl_NewListObj(4, descObjs); + Tcl_IncrRefCount(objv[i]); + } + + /* + * Drop the local references to the literals; if they're actually used, + * they'll live on the description itself. + */ + + Tcl_DecrRefCount(filterLiteral); + Tcl_DecrRefCount(methodLiteral); + Tcl_DecrRefCount(objectLiteral); + + /* + * Finish building the description and return it. + */ + + resultObj = Tcl_NewListObj(callPtr->numChain, objv); + TclStackFree(interp, objv); + return resultObj; +} + +/* * Local Variables: * mode: c * c-basic-offset: 4 diff --git a/generic/tclOOInfo.c b/generic/tclOOInfo.c index 4f25772..ac8ae46 100644 --- a/generic/tclOOInfo.c +++ b/generic/tclOOInfo.c @@ -17,6 +17,7 @@ #include "tclOOInt.h" static inline Class * GetClassFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr); +static Tcl_ObjCmdProc InfoObjectCallCmd; static Tcl_ObjCmdProc InfoObjectClassCmd; static Tcl_ObjCmdProc InfoObjectDefnCmd; static Tcl_ObjCmdProc InfoObjectFiltersCmd; @@ -28,6 +29,7 @@ static Tcl_ObjCmdProc InfoObjectMixinsCmd; static Tcl_ObjCmdProc InfoObjectNsCmd; static Tcl_ObjCmdProc InfoObjectVarsCmd; static Tcl_ObjCmdProc InfoObjectVariablesCmd; +static Tcl_ObjCmdProc InfoClassCallCmd; static Tcl_ObjCmdProc InfoClassConstrCmd; static Tcl_ObjCmdProc InfoClassDefnCmd; static Tcl_ObjCmdProc InfoClassDestrCmd; @@ -48,6 +50,7 @@ struct NameProcMap { const char *name; Tcl_ObjCmdProc *proc; }; */ static const struct NameProcMap infoObjectCmds[] = { + {"::oo::InfoObject::call", InfoObjectCallCmd}, {"::oo::InfoObject::class", InfoObjectClassCmd}, {"::oo::InfoObject::definition", InfoObjectDefnCmd}, {"::oo::InfoObject::filters", InfoObjectFiltersCmd}, @@ -67,6 +70,7 @@ static const struct NameProcMap infoObjectCmds[] = { */ static const struct NameProcMap infoClassCmds[] = { + {"::oo::InfoClass::call", InfoClassCallCmd}, {"::oo::InfoClass::constructor", InfoClassConstrCmd}, {"::oo::InfoClass::definition", InfoClassDefnCmd}, {"::oo::InfoClass::destructor", InfoClassDestrCmd}, @@ -1456,6 +1460,92 @@ InfoClassVariablesCmd( } /* + * ---------------------------------------------------------------------- + * + * InfoObjectCallCmd -- + * + * Implements [info object call $objName $methodName] + * + * ---------------------------------------------------------------------- + */ + +static int +InfoObjectCallCmd( + ClientData clientData, + Tcl_Interp *interp, + int objc, + Tcl_Obj *const objv[]) +{ + Object *oPtr; + CallContext *contextPtr; + + if (objc != 3) { + Tcl_WrongNumArgs(interp, 1, objv, "objName methodName"); + return TCL_ERROR; + } + oPtr = (Object *) Tcl_GetObjectFromObj(interp, objv[1]); + if (oPtr == NULL) { + return TCL_ERROR; + } + + /* + * Get the call context and render its call chain. + */ + + contextPtr = TclOOGetCallContext(oPtr, objv[2], PUBLIC_METHOD, NULL); + if (contextPtr == NULL) { + Tcl_AppendResult(interp, "cannot construct any call chain", NULL); + return TCL_ERROR; + } + Tcl_SetObjResult(interp, + TclOORenderCallChain(interp, contextPtr->callPtr)); + TclOODeleteContext(contextPtr); + return TCL_OK; +} + +/* + * ---------------------------------------------------------------------- + * + * InfoClassCallCmd -- + * + * Implements [info class call $clsName $methodName] + * + * ---------------------------------------------------------------------- + */ + +static int +InfoClassCallCmd( + ClientData clientData, + Tcl_Interp *interp, + int objc, + Tcl_Obj *const objv[]) +{ + Class *clsPtr; + CallChain *callPtr; + + if (objc != 3) { + Tcl_WrongNumArgs(interp, 1, objv, "className methodName"); + return TCL_ERROR; + } + clsPtr = GetClassFromObj(interp, objv[1]); + if (clsPtr == NULL) { + return TCL_ERROR; + } + + /* + * Get an render the stereotypical call chain. + */ + + callPtr = TclOOGetStereotypeCallChain(clsPtr, objv[2], PUBLIC_METHOD); + if (callPtr == NULL) { + Tcl_AppendResult(interp, "cannot construct any call chain", NULL); + return TCL_ERROR; + } + Tcl_SetObjResult(interp, TclOORenderCallChain(interp, callPtr)); + return TCL_OK; +} + +/* * Local Variables: * mode: c * c-basic-offset: 4 diff --git a/generic/tclOOInt.h b/generic/tclOOInt.h index bd32f22..b151183 100644 --- a/generic/tclOOInt.h +++ b/generic/tclOOInt.h @@ -465,6 +465,9 @@ MODULE_SCOPE int TclOOCopyObjectCmd(ClientData clientData, MODULE_SCOPE int TclOONextObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const *objv); +MODULE_SCOPE int TclOONextToObjCmd(ClientData clientData, + Tcl_Interp *interp, int objc, + Tcl_Obj *const *objv); MODULE_SCOPE int TclOOSelfObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const *objv); @@ -518,6 +521,8 @@ MODULE_SCOPE void TclOODelMethodRef(Method *method); MODULE_SCOPE CallContext *TclOOGetCallContext(Object *oPtr, Tcl_Obj *methodNameObj, int flags, Tcl_Obj *cacheInThisObj); +MODULE_SCOPE CallChain *TclOOGetStereotypeCallChain(Class *clsPtr, + Tcl_Obj *methodNameObj, int flags); MODULE_SCOPE Foundation *TclOOGetFoundation(Tcl_Interp *interp); MODULE_SCOPE Tcl_Obj * TclOOGetFwdFromMethod(Method *mPtr); MODULE_SCOPE Proc * TclOOGetProcFromMethod(Method *mPtr); @@ -544,6 +549,8 @@ MODULE_SCOPE void TclOORemoveFromMixinSubs(Class *subPtr, Class *mixinPtr); MODULE_SCOPE void TclOORemoveFromSubclasses(Class *subPtr, Class *superPtr); +MODULE_SCOPE Tcl_Obj * TclOORenderCallChain(Tcl_Interp *interp, + CallChain *callPtr); MODULE_SCOPE void TclOOStashContext(Tcl_Obj *objPtr, CallContext *contextPtr); MODULE_SCOPE void TclOOSetupVariableResolver(Tcl_Namespace *nsPtr); diff --git a/tests/oo.test b/tests/oo.test index 60d0077..078d888 100644 --- a/tests/oo.test +++ b/tests/oo.test @@ -1524,7 +1524,7 @@ test oo-16.2 {OO: object introspection} -body { } -returnCodes 1 -result {NOTANOBJECT does not refer to an object} test oo-16.3 {OO: object introspection} -body { info object gorp oo::object -} -returnCodes 1 -result {unknown or ambiguous subcommand "gorp": must be class, definition, filters, forward, isa, methods, methodtype, mixins, namespace, variables, or vars} +} -returnCodes 1 -result {unknown or ambiguous subcommand "gorp": must be call, class, definition, filters, forward, isa, methods, methodtype, mixins, namespace, variables, or vars} test oo-16.4 {OO: object introspection} -setup { oo::class create meta { superclass oo::class } [meta create instance1] create instance2 @@ -1646,7 +1646,7 @@ test oo-17.3 {OO: class introspection} -setup { } -result {"foo" is not a class} test oo-17.4 {OO: class introspection} -body { info class gorp oo::object -} -returnCodes 1 -result {unknown or ambiguous subcommand "gorp": must be constructor, definition, destructor, filters, forward, instances, methods, methodtype, mixins, subclasses, superclasses, or variables} +} -returnCodes 1 -result {unknown or ambiguous subcommand "gorp": must be call, constructor, definition, destructor, filters, forward, instances, methods, methodtype, mixins, subclasses, superclasses, or variables} test oo-17.5 {OO: class introspection} -setup { oo::class create testClass } -body { diff --git a/tests/ooNext2.test b/tests/ooNext2.test new file mode 100644 index 0000000..624a9d9 --- /dev/null +++ b/tests/ooNext2.test @@ -0,0 +1,765 @@ +# This file contains a collection of tests for Tcl's built-in object system. +# Sourcing this file into Tcl runs the tests and generates output for errors. +# No output means no errors were found. +# +# Copyright (c) 2006-2008 Donal K. Fellows +# +# See the file "license.terms" for information on usage and redistribution of +# this file, and for a DISCLAIMER OF ALL WARRANTIES. +# +# RCS: @(#) $Id: oo.test,v 1.59 2011/01/18 16:10:48 dkf Exp $ + +package require -exact TclOO 0.6.2 ;# Must match value in configure.in +if {[lsearch [namespace children] ::tcltest] == -1} { + package require tcltest 2 + namespace import -force ::tcltest::* +} + +testConstraint memory [llength [info commands memory]] +if {[testConstraint memory]} { + proc getbytes {} { + set lines [split [memory info] \n] + return [lindex $lines 3 3] + } + proc leaktest {script {iterations 3}} { + set end [getbytes] + for {set i 0} {$i < $iterations} {incr i} { + uplevel 1 $script + set tmp $end + set end [getbytes] + } + return [expr {$end - $tmp}] + } +} + +test oo-nextto-1.1 {basic nextto functionality} -setup { + oo::class create root +} -body { + oo::class create A { + superclass root + method x args { + lappend ::result ==A== $args + } + } + oo::class create B { + superclass A + method x args { + lappend ::result ==B== $args + nextto A B -> A {*}$args + } + } + oo::class create C { + superclass A + method x args { + lappend ::result ==C== $args + nextto A C -> A {*}$args + } + } + oo::class create D { + superclass B C + method x args { + lappend ::result ==D== $args + next foo + nextto C bar + } + } + set ::result {} + [D new] x + return $::result +} -cleanup { + root destroy +} -result {==D== {} ==B== foo ==A== {B -> A foo} ==C== bar ==A== {C -> A bar}} +test oo-nextto-1.2 {basic nextto functionality} -setup { + oo::class create root +} -body { + oo::class create A { + superclass root + method x args { + lappend ::result ==A== $args + } + } + oo::class create B { + superclass A + method x args { + lappend ::result ==B== $args + nextto A B -> A {*}$args + } + } + oo::class create C { + superclass A + method x args { + lappend ::result ==C== $args + nextto A C -> A {*}$args + } + } + oo::class create D { + superclass B C + method x args { + lappend ::result ==D== $args + nextto B foo {*}$args + nextto C bar {*}$args + } + } + set ::result {} + [D new] x 123 + return $::result +} -cleanup { + root destroy +} -result {==D== 123 ==B== {foo 123} ==A== {B -> A foo 123} ==C== {bar 123} ==A== {C -> A bar 123}} +test oo-nextto-1.3 {basic nextto functionality: constructors} -setup { + oo::class create root +} -body { + oo::class create A { + superclass root + variable result + constructor {a c} { + lappend result ==A== a=$a,c=$c + } + } + oo::class create B { + superclass root + variable result + constructor {b} { + lappend result ==B== b=$b + } + } + oo::class create C { + superclass A B + variable result + constructor {p q r} { + lappend result ==C== p=$p,q=$q,r=$r + # Route arguments to superclasses, in non-trival pattern + nextto B $q + nextto A $p $r + } + method result {} {return $result} + } + [C new x y z] result +} -cleanup { + root destroy +} -result {==C== p=x,q=y,r=z ==B== b=y ==A== a=x,c=z} +test oo-nextto-1.4 {basic nextto functionality: destructors} -setup { + oo::class create root {destructor return} +} -body { + oo::class create A { + superclass root + destructor { + lappend ::result ==A== + next + } + } + oo::class create B { + superclass root + destructor { + lappend ::result ==B== + next + } + } + oo::class create C { + superclass A B + destructor { + lappend ::result ==C== + lappend ::result | + nextto B + lappend ::result | + nextto A + lappend ::result | + next + } + } + set ::result "" + [C new] destroy + return $::result +} -cleanup { + root destroy +} -result {==C== | ==B== | ==A== ==B== | ==A== ==B==} + +test oo-nextto-2.1 {errors in nextto} -setup { + oo::class create root +} -body { + oo::class create A { + superclass root + method x y {error $y} + } + oo::class create B { + superclass A + method x y {nextto A $y} + } + [B new] x boom +} -cleanup { + root destroy +} -result boom -returnCodes error +test oo-nextto-2.2 {errors in nextto} -setup { + oo::class create root +} -body { + oo::class create A { + superclass root + method x y {error $y} + } + oo::class create B { + superclass root + method x y {nextto A $y} + } + [B new] x boom +} -returnCodes error -cleanup { + root destroy +} -result {method has no non-filter implementation by "A"} +test oo-nextto-2.3 {errors in nextto} -setup { + oo::class create root +} -body { + oo::class create A { + superclass root + method x y {nextto $y} + } + oo::class create B { + superclass A + method x y {nextto A $y} + } + [B new] x B +} -returnCodes error -cleanup { + root destroy +} -result {method implementation by "B" not reachable from here} +test oo-nextto-2.4 {errors in nextto} -setup { + oo::class create root +} -body { + oo::class create A { + superclass root + method x y {nextto $y} + } + oo::class create B { + superclass A + method x y {nextto} + } + [B new] x B +} -returnCodes error -cleanup { + root destroy +} -result {wrong # args: should be "nextto class ?arg...?"} +test oo-nextto-2.5 {errors in nextto} -setup { + oo::class create root +} -body { + oo::class create A { + superclass root + method x y {nextto $y} + } + oo::class create B { + superclass A + method x y {nextto $y $y $y} + } + [B new] x A +} -cleanup { + root destroy +} -result {wrong # args: should be "nextto A y"} -returnCodes error +test oo-nextto-2.6 {errors in nextto} -setup { + oo::class create root +} -body { + oo::class create A { + superclass root + method x y {nextto $y} + } + oo::class create B { + superclass A + method x y {nextto $y $y $y} + } + [B new] x [root create notAClass] +} -cleanup { + root destroy +} -result {"::notAClass" is not a class} -returnCodes error +test oo-nextto-2.7 {errors in nextto} -setup { + oo::class create root +} -body { + oo::class create A { + superclass root + method x y {nextto $y} + } + oo::class create B { + superclass A + filter Y + method Y args {next {*}$args} + } + oo::class create C { + superclass B + method x y {nextto $y $y $y} + } + [C new] x B +} -returnCodes error -cleanup { + root destroy +} -result {method has no non-filter implementation by "B"} + +test oo-call-1.1 {object call introspection} -setup { + oo::class create root +} -body { + oo::class create ::A { + superclass root + method x {} {} + } + A create y + info object call y x +} -cleanup { + root destroy +} -result {{method x ::A method}} +test oo-call-1.2 {object call introspection} -setup { + oo::class create root +} -body { + oo::class create ::A { + superclass root + method x {} {} + } + oo::class create ::B { + superclass A + method x {} {} + } + B create y + info object call y x +} -cleanup { + root destroy +} -result {{method x ::B method} {method x ::A method}} +test oo-call-1.3 {object call introspection} -setup { + oo::class create root +} -body { + oo::class create ::A { + superclass root + method x {} {} + } + A create y + oo::objdefine y method x {} {} + info object call y x +} -cleanup { + root destroy +} -result {{method x object method} {method x ::A method}} +test oo-call-1.4 {object object call introspection - unknown} -setup { + oo::class create root +} -body { + oo::class create ::A { + superclass root + method x {} {} + } + A create y + info object call y z +} -cleanup { + root destroy +} -result {{unknown unknown ::oo::object {core method: "unknown"}}} +test oo-call-1.5 {object call introspection - filters} -setup { + oo::class create root +} -body { + oo::class create ::A { + superclass root + method x {} {} + method y {} {} + filter y + } + A create y + info object call y x +} -cleanup { + root destroy +} -result {{filter y ::A method} {method x ::A method}} +test oo-call-1.6 {object call introspection - filters} -setup { + oo::class create root +} -body { + oo::class create ::A { + superclass root + method x {} {} + method y {} {} + filter y + } + oo::class create ::B { + superclass A + method x {} {} + } + B create y + info object call y x +} -cleanup { + root destroy +} -result {{filter y ::A method} {method x ::B method} {method x ::A method}} +test oo-call-1.7 {object call introspection - filters} -setup { + oo::class create root +} -body { + oo::class create ::A { + superclass root + method x {} {} + method y {} {} + filter y + } + oo::class create ::B { + superclass A + method x {} {} + method y {} {} + } + B create y + info object call y x +} -cleanup { + root destroy +} -result {{filter y ::B method} {filter y ::A method} {method x ::B method} {method x ::A method}} +test oo-call-1.8 {object call introspection - filters} -setup { + oo::class create root +} -body { + oo::class create ::A { + superclass root + method x {} {} + method y {} {} + filter y + } + oo::class create ::B { + superclass A + method x {} {} + method y {} {} + method z {} {} + filter z + } + B create y + info object call y x +} -cleanup { + root destroy +} -result {{filter z ::B method} {filter y ::B method} {filter y ::A method} {method x ::B method} {method x ::A method}} +test oo-call-1.9 {object call introspection - filters} -setup { + oo::class create root +} -body { + oo::class create ::A { + superclass root + method x {} {} + method y {} {} + filter y + } + oo::class create ::B { + superclass A + method x {} {} + method y {} {} + method z {} {} + filter z + } + B create y + info object call y y +} -cleanup { + root destroy +} -result {{filter z ::B method} {filter y ::B method} {filter y ::A method} {method y ::B method} {method y ::A method}} +test oo-call-1.10 {object call introspection - filters + unknown} -setup { + oo::class create root +} -body { + oo::class create ::A { + superclass root + method y {} {} + filter y + } + oo::class create ::B { + superclass A + method y {} {} + method unknown {} {} + } + B create y + info object call y x +} -cleanup { + root destroy +} -result {{filter y ::B method} {filter y ::A method} {unknown unknown ::B method} {unknown unknown ::oo::object {core method: "unknown"}}} +test oo-call-1.11 {object call introspection - filters + unknown} -setup { + oo::class create root +} -body { + oo::class create ::A { + superclass root + method y {} {} + filter y + } + A create y + oo::objdefine y method unknown {} {} + info object call y x +} -cleanup { + root destroy +} -result {{filter y ::A method} {unknown unknown object method} {unknown unknown ::oo::object {core method: "unknown"}}} +test oo-call-1.12 {object call introspection - filters + unknown} -setup { + oo::class create root +} -body { + oo::class create ::A { + superclass root + method y {} {} + } + A create y + oo::objdefine y { + method unknown {} {} + filter y + } + info object call y x +} -cleanup { + root destroy +} -result {{filter y ::A method} {unknown unknown object method} {unknown unknown ::oo::object {core method: "unknown"}}} +test oo-call-1.13 {object call introspection - filters + unknown} -setup { + oo::class create root +} -body { + oo::class create ::A { + superclass root + method y {} {} + } + A create y + oo::objdefine y { + method unknown {} {} + method x {} {} + filter y + } + info object call y x +} -cleanup { + root destroy +} -result {{filter y ::A method} {method x object method}} +test oo-call-1.14 {object call introspection - errors} -body { + info object call +} -returnCodes error -result {wrong # args: should be "info object call objName methodName"} +test oo-call-1.15 {object call introspection - errors} -body { + info object call a +} -returnCodes error -result {wrong # args: should be "info object call objName methodName"} +test oo-call-1.16 {object call introspection - errors} -body { + info object call a b c +} -returnCodes error -result {wrong # args: should be "info object call objName methodName"} +test oo-call-1.17 {object call introspection - errors} -body { + info object call notanobject x +} -returnCodes error -result {notanobject does not refer to an object} +test oo-call-1.18 {object call introspection - memory leaks} -body { + leaktest { + info object call oo::object destroy + } +} -constraints memory -result 0 + +test oo-call-2.1 {class call introspection} -setup { + oo::class create root +} -body { + oo::class create ::A { + superclass root + method x {} {} + } + info class call A x +} -cleanup { + root destroy +} -result {{method x ::A method}} +test oo-call-2.2 {class call introspection} -setup { + oo::class create root +} -body { + oo::class create ::A { + superclass root + method x {} {} + } + oo::class create ::B { + superclass A + method x {} {} + } + list [info class call A x] [info class call B x] +} -cleanup { + root destroy +} -result {{{method x ::A method}} {{method x ::B method} {method x ::A method}}} +test oo-call-2.3 {class call introspection} -setup { + oo::class create root +} -body { + oo::class create ::A { + superclass root + method x {} {} + } + oo::class create ::B { + superclass A + method x {} {} + } + oo::class create ::C { + superclass A + method x {} {} + } + oo::class create ::D { + superclass C B + method x {} {} + } + info class call D x +} -cleanup { + root destroy +} -result {{method x ::D method} {method x ::C method} {method x ::B method} {method x ::A method}} +test oo-call-2.4 {class call introspection - mixin} -setup { + oo::class create root +} -body { + oo::class create ::A { + superclass root + method x {} {} + } + oo::class create ::B { + superclass A + method x {} {} + } + oo::class create ::C { + superclass A + method x {} {} + } + oo::class create ::D { + superclass C + mixin B + method x {} {} + } + info class call D x +} -cleanup { + root destroy +} -result {{method x ::B method} {method x ::D method} {method x ::C method} {method x ::A method}} +test oo-call-2.5 {class call introspection - mixin + filter} -setup { + oo::class create root +} -body { + oo::class create ::A { + superclass root + method x {} {} + } + oo::class create ::B { + superclass A + method x {} {} + method y {} {} + filter y + } + oo::class create ::C { + superclass A + method x {} {} + method y {} {} + } + oo::class create ::D { + superclass C + mixin B + method x {} {} + } + info class call D x +} -cleanup { + root destroy +} -result {{filter y ::B method} {filter y ::C method} {method x ::B method} {method x ::D method} {method x ::C method} {method x ::A method}} +test oo-call-2.6 {class call introspection - mixin + filter + unknown} -setup { + oo::class create root +} -body { + oo::class create ::A { + superclass root + method x {} {} + method unknown {} {} + } + oo::class create ::B { + superclass A + method x {} {} + method y {} {} + filter y + } + oo::class create ::C { + superclass A + method x {} {} + method y {} {} + } + oo::class create ::D { + superclass C + mixin B + method x {} {} + method unknown {} {} + } + info class call D z +} -cleanup { + root destroy +} -result {{filter y ::B method} {filter y ::C method} {unknown unknown ::D method} {unknown unknown ::A method} {unknown unknown ::oo::object {core method: "unknown"}}} +test oo-call-2.7 {class call introspection - mixin + filter + unknown} -setup { + oo::class create root +} -body { + oo::class create ::A { + superclass root + method x {} {} + } + oo::class create ::B { + superclass A + method x {} {} + filter x + } + info class call B x +} -cleanup { + root destroy +} -result {{filter x ::B method} {filter x ::A method} {method x ::B method} {method x ::A method}} +test oo-call-2.8 {class call introspection - errors} -body { + info class call +} -returnCodes error -result {wrong # args: should be "info class call className methodName"} +test oo-call-2.9 {class call introspection - errors} -body { + info class call a +} -returnCodes error -result {wrong # args: should be "info class call className methodName"} +test oo-call-2.10 {class call introspection - errors} -body { + info class call a b c +} -returnCodes error -result {wrong # args: should be "info class call className methodName"} +test oo-call-2.11 {class call introspection - errors} -body { + info class call notaclass x +} -returnCodes error -result {notaclass does not refer to an object} +test oo-call-2.11 {class call introspection - errors} -setup { + oo::class create root +} -body { + root create notaclass + info class call notaclass x +} -returnCodes error -cleanup { + root destroy +} -result {"notaclass" is not a class} +test oo-call-2.13 {class call introspection - memory leaks} -body { + leaktest { + info class call oo::class destroy + } +} -constraints memory -result 0 + +test oo-call-3.1 {current call introspection} -setup { + oo::class create root +} -body { + oo::class create A { + superclass root + method x {} {lappend ::result [self call]} + } + oo::class create B { + superclass A + method x {} {lappend ::result [self call];next} + } + B create y + oo::objdefine y method x {} {lappend ::result [self call];next} + set ::result {} + y x +} -cleanup { + root destroy +} -result {{{{method x object method} {method x ::B method} {method x ::A method}} 0} {{{method x object method} {method x ::B method} {method x ::A method}} 1} {{{method x object method} {method x ::B method} {method x ::A method}} 2}} +test oo-call-3.2 {current call introspection} -setup { + oo::class create root +} -constraints memory -body { + oo::class create A { + superclass root + method x {} {self call} + } + oo::class create B { + superclass A + method x {} {self call;next} + } + B create y + oo::objdefine y method x {} {self call;next} + leaktest { + y x + } +} -cleanup { + root destroy +} -result 0 +test oo-call-3.3 {current call introspection: in constructors} -setup { + oo::class create root +} -body { + oo::class create A { + superclass root + constructor {} {lappend ::result [self call]} + } + oo::class create B { + superclass A + constructor {} {lappend ::result [self call]; next} + } + set ::result {} + [B new] destroy + return $::result +} -cleanup { + root destroy +} -result {{{{method ::B method} {method ::A method}} 0} {{{method ::B method} {method ::A method}} 1}} +test oo-call-3.4 {current call introspection: in destructors} -setup { + oo::class create root +} -body { + oo::class create A { + superclass root + destructor {lappend ::result [self call]} + } + oo::class create B { + superclass A + destructor {lappend ::result [self call]; next} + } + set ::result {} + [B new] destroy + return $::result +} -cleanup { + root destroy +} -result {{{{method ::B method} {method ::A method}} 0} {{{method ::B method} {method ::A method}} 1}} + +cleanupTests +return + +# Local Variables: +# mode: tcl +# End: -- cgit v0.12 From de8bdfc20fd21d16aa5e73fa0fb0ed8c88a2d18d Mon Sep 17 00:00:00 2001 From: dkf Date: Wed, 25 May 2011 13:40:44 +0000 Subject: Bump TclOO version. --- ChangeLog | 2 ++ generic/tclOO.h | 2 +- tests/oo.test | 2 +- tests/ooNext2.test | 2 +- unix/tclooConfig.sh | 2 +- win/tclooConfig.sh | 2 +- 6 files changed, 7 insertions(+), 5 deletions(-) diff --git a/ChangeLog b/ChangeLog index 3118f82..6c90987 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,5 +1,7 @@ 2011-05-25 Donal K. Fellows + * generic/tclOO.h (TCLOO_VERSION): Bump version. + IMPLEMENTATION OF TIP#381. * doc/next.n, doc/ooInfo.n, doc/self.n, generic/tclOO.c, diff --git a/generic/tclOO.h b/generic/tclOO.h index ed70c08..c791930 100644 --- a/generic/tclOO.h +++ b/generic/tclOO.h @@ -24,7 +24,7 @@ * win/tclooConfig.sh */ -#define TCLOO_VERSION "0.6.2" +#define TCLOO_VERSION "0.6.3" #define TCLOO_PATCHLEVEL TCLOO_VERSION /* diff --git a/tests/oo.test b/tests/oo.test index 078d888..e8f770c 100644 --- a/tests/oo.test +++ b/tests/oo.test @@ -7,7 +7,7 @@ # See the file "license.terms" for information on usage and redistribution of # this file, and for a DISCLAIMER OF ALL WARRANTIES. -package require -exact TclOO 0.6.2 ;# Must match value in generic/tclOO.h +package require -exact TclOO 0.6.3 ;# Must match value in generic/tclOO.h package require tcltest 2 if {"::tcltest" in [namespace children]} { namespace import -force ::tcltest::* diff --git a/tests/ooNext2.test b/tests/ooNext2.test index 624a9d9..fc0423f 100644 --- a/tests/ooNext2.test +++ b/tests/ooNext2.test @@ -9,7 +9,7 @@ # # RCS: @(#) $Id: oo.test,v 1.59 2011/01/18 16:10:48 dkf Exp $ -package require -exact TclOO 0.6.2 ;# Must match value in configure.in +package require -exact TclOO 0.6.3 ;# Must match value in configure.in if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest 2 namespace import -force ::tcltest::* diff --git a/unix/tclooConfig.sh b/unix/tclooConfig.sh index 07fb45b..68de106 100644 --- a/unix/tclooConfig.sh +++ b/unix/tclooConfig.sh @@ -16,4 +16,4 @@ TCLOO_STUB_LIB_SPEC="" TCLOO_INCLUDE_SPEC="" TCLOO_PRIVATE_INCLUDE_SPEC="" TCLOO_CFLAGS=-DUSE_TCLOO_STUBS -TCLOO_VERSION=0.6.2 +TCLOO_VERSION=0.6.3 diff --git a/win/tclooConfig.sh b/win/tclooConfig.sh index 07fb45b..68de106 100644 --- a/win/tclooConfig.sh +++ b/win/tclooConfig.sh @@ -16,4 +16,4 @@ TCLOO_STUB_LIB_SPEC="" TCLOO_INCLUDE_SPEC="" TCLOO_PRIVATE_INCLUDE_SPEC="" TCLOO_CFLAGS=-DUSE_TCLOO_STUBS -TCLOO_VERSION=0.6.2 +TCLOO_VERSION=0.6.3 -- cgit v0.12 From 3e9a791d0a2bb61dd97ba787e57ebb24c6f75f50 Mon Sep 17 00:00:00 2001 From: dgp Date: Wed, 25 May 2011 13:42:22 +0000 Subject: silence compiler warning --- generic/tclCompile.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/generic/tclCompile.c b/generic/tclCompile.c index 8a7cbf8..7f11e0e 100644 --- a/generic/tclCompile.c +++ b/generic/tclCompile.c @@ -3081,7 +3081,7 @@ TclFixupForwardJump( Tcl_SetHashValue(hPtr, INT2PTR(map[k].cmd)); } - ckfree (map); + ckfree ((char *) map); } return 1; /* the jump was grown */ -- cgit v0.12 From 4c605ddbd4558895723babef100d5b41f2cce7eb Mon Sep 17 00:00:00 2001 From: dgp Date: Wed, 25 May 2011 14:15:28 +0000 Subject: Bump to msgcat 1.4.4. --- ChangeLog | 7 +++++++ library/msgcat/msgcat.tcl | 36 +++++++++++------------------------- library/msgcat/pkgIndex.tcl | 2 +- unix/Makefile.in | 4 ++-- win/Makefile.in | 4 ++-- 5 files changed, 23 insertions(+), 30 deletions(-) diff --git a/ChangeLog b/ChangeLog index bae32ee..9fe71c5 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,10 @@ +2011-05-25 Don Porter + + * library/msgcat/msgcat.tcl: Backport improvements to msgcat + * library/msgcat/pkgIndex.tcl: package. Bump to 1.4.4 + * unix/Makefile.in + * win/Makefile.in + 2011-05-24 Venkat Iyer * library/tzdata/Africa/Cairo: Update to Olson tzdata2011g diff --git a/library/msgcat/msgcat.tcl b/library/msgcat/msgcat.tcl index 231eaa1..369ed52 100644 --- a/library/msgcat/msgcat.tcl +++ b/library/msgcat/msgcat.tcl @@ -13,7 +13,7 @@ package require Tcl 8.5 # When the version number changes, be sure to update the pkgIndex.tcl file, # and the installation directory in the Makefiles. -package provide msgcat 1.4.3 +package provide msgcat 1.4.4 namespace eval msgcat { namespace export mc mcload mclocale mcmax mcmset mcpreferences mcset \ @@ -175,7 +175,7 @@ namespace eval msgcat { # args Args to pass to the format command # # Results: -# Returns the translated string. Propagates errors thrown by the +# Returns the translated string. Propagates errors thrown by the # format command. proc msgcat::mc {src args} { @@ -187,7 +187,7 @@ proc msgcat::mc {src args} { variable Locale set ns [uplevel 1 [list ::namespace current]] - + while {$ns != ""} { foreach loc $Loclist { if {[dict exists $Msgs $loc $ns $src]} { @@ -310,16 +310,9 @@ proc msgcat::mcset {locale src {dest ""}} { } set ns [uplevel 1 [list ::namespace current]] - + set locale [string tolower $locale] - - # create nested dictionaries if they do not exist - if {![dict exists $Msgs $locale]} { - dict set Msgs $locale [dict create] - } - if {![dict exists $Msgs $locale $ns]} { - dict set Msgs $locale $ns [dict create] - } + dict set Msgs $locale $ns $src $dest return $dest } @@ -343,17 +336,10 @@ proc msgcat::mcmset {locale pairs } { return -code error "bad translation list:\ should be \"[lindex [info level 0] 0] locale {src dest ...}\"" } - + set locale [string tolower $locale] set ns [uplevel 1 [list ::namespace current]] - # create nested dictionaries if they do not exist - if {![dict exists $Msgs $locale]} { - dict set Msgs $locale [dict create] - } - if {![dict exists $Msgs $locale $ns]} { - dict set Msgs $locale $ns [dict create] - } foreach {src dest} $pairs { dict set Msgs $locale $ns $src $dest } @@ -366,7 +352,7 @@ proc msgcat::mcmset {locale pairs } { # This routine is called by msgcat::mc if a translation cannot # be found for a string. This routine is intended to be replaced # by an application specific routine for error reporting -# purposes. The default behavior is to return the source string. +# purposes. The default behavior is to return the source string. # If additional args are specified, the format command will be used # to work them into the traslated string. # @@ -388,7 +374,7 @@ proc msgcat::mcunknown {locale src args} { # msgcat::mcmax -- # -# Calculates the maximum length of the translated strings of the given +# Calculates the maximum length of the translated strings of the given # list. # # Arguments: @@ -474,14 +460,14 @@ proc msgcat::Init {} { } # # On Windows, try to set locale depending on registry settings, - # or fall back on locale of "C". + # or fall back on locale of "C". # - set key {HKEY_CURRENT_USER\Control Panel\International} if {[catch { package require registry + set key {HKEY_CURRENT_USER\Control Panel\International} set locale [registry get $key "locale"] }]} { - mclocale C + mclocale C return } # diff --git a/library/msgcat/pkgIndex.tcl b/library/msgcat/pkgIndex.tcl index 63ed8ed..17ad5db 100644 --- a/library/msgcat/pkgIndex.tcl +++ b/library/msgcat/pkgIndex.tcl @@ -1,2 +1,2 @@ if {![package vsatisfies [package provide Tcl] 8.5]} {return} -package ifneeded msgcat 1.4.3 [list source [file join $dir msgcat.tcl]] +package ifneeded msgcat 1.4.4 [list source [file join $dir msgcat.tcl]] diff --git a/unix/Makefile.in b/unix/Makefile.in index 398ce55..96d5062 100644 --- a/unix/Makefile.in +++ b/unix/Makefile.in @@ -778,8 +778,8 @@ install-libraries: libraries $(INSTALL_TZDATA) install-msgs do \ $(INSTALL_DATA) $$i "$(SCRIPT_INSTALL_DIR)"/opt0.4; \ done; - @echo "Installing package msgcat 1.4.3 as a Tcl Module"; - @$(INSTALL_DATA) $(TOP_DIR)/library/msgcat/msgcat.tcl "$(SCRIPT_INSTALL_DIR)"/../tcl8/8.5/msgcat-1.4.3.tm; + @echo "Installing package msgcat 1.4.4 as a Tcl Module"; + @$(INSTALL_DATA) $(TOP_DIR)/library/msgcat/msgcat.tcl "$(SCRIPT_INSTALL_DIR)"/../tcl8/8.5/msgcat-1.4.4.tm; @echo "Installing package tcltest 2.3.2 as a Tcl Module"; @$(INSTALL_DATA) $(TOP_DIR)/library/tcltest/tcltest.tcl "$(SCRIPT_INSTALL_DIR)"/../tcl8/8.5/tcltest-2.3.2.tm; diff --git a/win/Makefile.in b/win/Makefile.in index aa9620c..97a7e7b 100644 --- a/win/Makefile.in +++ b/win/Makefile.in @@ -645,8 +645,8 @@ install-libraries: libraries install-tzdata install-msgs do \ $(COPY) "$$j" "$(SCRIPT_INSTALL_DIR)/opt0.4"; \ done; - @echo "Installing package msgcat 1.4.3 as a Tcl Module"; - @$(COPY) $(ROOT_DIR)/library/msgcat/msgcat.tcl $(SCRIPT_INSTALL_DIR)/../tcl8/8.5/msgcat-1.4.3.tm; + @echo "Installing package msgcat 1.4.4 as a Tcl Module"; + @$(COPY) $(ROOT_DIR)/library/msgcat/msgcat.tcl $(SCRIPT_INSTALL_DIR)/../tcl8/8.5/msgcat-1.4.4.tm; @echo "Installing package tcltest 2.3.2 as a Tcl Module"; @$(COPY) $(ROOT_DIR)/library/tcltest/tcltest.tcl $(SCRIPT_INSTALL_DIR)/../tcl8/8.5/tcltest-2.3.2.tm; @echo "Installing package platform 1.0.9 as a Tcl Module"; -- cgit v0.12 From 62704b0bfde72fbf8ffc6f2653b715346cf9e1c4 Mon Sep 17 00:00:00 2001 From: Kevin B Kenny Date: Wed, 25 May 2011 14:34:41 +0000 Subject: committed missing tzdata/Africa/Cairo from venkat's last commit --- library/tzdata/Africa/Cairo | 178 -------------------------------------------- 1 file changed, 178 deletions(-) diff --git a/library/tzdata/Africa/Cairo b/library/tzdata/Africa/Cairo index 10d7193..165d8c4 100644 --- a/library/tzdata/Africa/Cairo +++ b/library/tzdata/Africa/Cairo @@ -125,182 +125,4 @@ set TZData(:Africa/Cairo) { {1281474000 7200 0 EET} {1284069600 10800 1 EEST} {1285880400 7200 0 EET} - {1304028000 10800 1 EEST} - {1317330000 7200 0 EET} - {1335477600 10800 1 EEST} - {1348779600 7200 0 EET} - {1366927200 10800 1 EEST} - {1380229200 7200 0 EET} - {1398376800 10800 1 EEST} - {1411678800 7200 0 EET} - {1429826400 10800 1 EEST} - {1443128400 7200 0 EET} - {1461880800 10800 1 EEST} - {1475182800 7200 0 EET} - {1493330400 10800 1 EEST} - {1506632400 7200 0 EET} - {1524780000 10800 1 EEST} - {1538082000 7200 0 EET} - {1556229600 10800 1 EEST} - {1569531600 7200 0 EET} - {1587679200 10800 1 EEST} - {1600981200 7200 0 EET} - {1619733600 10800 1 EEST} - {1633035600 7200 0 EET} - {1651183200 10800 1 EEST} - {1664485200 7200 0 EET} - {1682632800 10800 1 EEST} - {1695934800 7200 0 EET} - {1714082400 10800 1 EEST} - {1727384400 7200 0 EET} - {1745532000 10800 1 EEST} - {1758834000 7200 0 EET} - {1776981600 10800 1 EEST} - {1790283600 7200 0 EET} - {1809036000 10800 1 EEST} - {1822338000 7200 0 EET} - {1840485600 10800 1 EEST} - {1853787600 7200 0 EET} - {1871935200 10800 1 EEST} - {1885237200 7200 0 EET} - {1903384800 10800 1 EEST} - {1916686800 7200 0 EET} - {1934834400 10800 1 EEST} - {1948136400 7200 0 EET} - {1966888800 10800 1 EEST} - {1980190800 7200 0 EET} - {1998338400 10800 1 EEST} - {2011640400 7200 0 EET} - {2029788000 10800 1 EEST} - {2043090000 7200 0 EET} - {2061237600 10800 1 EEST} - {2074539600 7200 0 EET} - {2092687200 10800 1 EEST} - {2105989200 7200 0 EET} - {2124136800 10800 1 EEST} - {2137438800 7200 0 EET} - {2156191200 10800 1 EEST} - {2169493200 7200 0 EET} - {2187640800 10800 1 EEST} - {2200942800 7200 0 EET} - {2219090400 10800 1 EEST} - {2232392400 7200 0 EET} - {2250540000 10800 1 EEST} - {2263842000 7200 0 EET} - {2281989600 10800 1 EEST} - {2295291600 7200 0 EET} - {2313439200 10800 1 EEST} - {2326741200 7200 0 EET} - {2345493600 10800 1 EEST} - {2358795600 7200 0 EET} - {2376943200 10800 1 EEST} - {2390245200 7200 0 EET} - {2408392800 10800 1 EEST} - {2421694800 7200 0 EET} - {2439842400 10800 1 EEST} - {2453144400 7200 0 EET} - {2471292000 10800 1 EEST} - {2484594000 7200 0 EET} - {2503346400 10800 1 EEST} - {2516648400 7200 0 EET} - {2534796000 10800 1 EEST} - {2548098000 7200 0 EET} - {2566245600 10800 1 EEST} - {2579547600 7200 0 EET} - {2597695200 10800 1 EEST} - {2610997200 7200 0 EET} - {2629144800 10800 1 EEST} - {2642446800 7200 0 EET} - {2660594400 10800 1 EEST} - {2673896400 7200 0 EET} - {2692648800 10800 1 EEST} - {2705950800 7200 0 EET} - {2724098400 10800 1 EEST} - {2737400400 7200 0 EET} - {2755548000 10800 1 EEST} - {2768850000 7200 0 EET} - {2786997600 10800 1 EEST} - {2800299600 7200 0 EET} - {2818447200 10800 1 EEST} - {2831749200 7200 0 EET} - {2850501600 10800 1 EEST} - {2863803600 7200 0 EET} - {2881951200 10800 1 EEST} - {2895253200 7200 0 EET} - {2913400800 10800 1 EEST} - {2926702800 7200 0 EET} - {2944850400 10800 1 EEST} - {2958152400 7200 0 EET} - {2976300000 10800 1 EEST} - {2989602000 7200 0 EET} - {3007749600 10800 1 EEST} - {3021051600 7200 0 EET} - {3039804000 10800 1 EEST} - {3053106000 7200 0 EET} - {3071253600 10800 1 EEST} - {3084555600 7200 0 EET} - {3102703200 10800 1 EEST} - {3116005200 7200 0 EET} - {3134152800 10800 1 EEST} - {3147454800 7200 0 EET} - {3165602400 10800 1 EEST} - {3178904400 7200 0 EET} - {3197052000 10800 1 EEST} - {3210354000 7200 0 EET} - {3229106400 10800 1 EEST} - {3242408400 7200 0 EET} - {3260556000 10800 1 EEST} - {3273858000 7200 0 EET} - {3292005600 10800 1 EEST} - {3305307600 7200 0 EET} - {3323455200 10800 1 EEST} - {3336757200 7200 0 EET} - {3354904800 10800 1 EEST} - {3368206800 7200 0 EET} - {3386959200 10800 1 EEST} - {3400261200 7200 0 EET} - {3418408800 10800 1 EEST} - {3431710800 7200 0 EET} - {3449858400 10800 1 EEST} - {3463160400 7200 0 EET} - {3481308000 10800 1 EEST} - {3494610000 7200 0 EET} - {3512757600 10800 1 EEST} - {3526059600 7200 0 EET} - {3544207200 10800 1 EEST} - {3557509200 7200 0 EET} - {3576261600 10800 1 EEST} - {3589563600 7200 0 EET} - {3607711200 10800 1 EEST} - {3621013200 7200 0 EET} - {3639160800 10800 1 EEST} - {3652462800 7200 0 EET} - {3670610400 10800 1 EEST} - {3683912400 7200 0 EET} - {3702060000 10800 1 EEST} - {3715362000 7200 0 EET} - {3734114400 10800 1 EEST} - {3747416400 7200 0 EET} - {3765564000 10800 1 EEST} - {3778866000 7200 0 EET} - {3797013600 10800 1 EEST} - {3810315600 7200 0 EET} - {3828463200 10800 1 EEST} - {3841765200 7200 0 EET} - {3859912800 10800 1 EEST} - {3873214800 7200 0 EET} - {3891362400 10800 1 EEST} - {3904664400 7200 0 EET} - {3923416800 10800 1 EEST} - {3936718800 7200 0 EET} - {3954866400 10800 1 EEST} - {3968168400 7200 0 EET} - {3986316000 10800 1 EEST} - {3999618000 7200 0 EET} - {4017765600 10800 1 EEST} - {4031067600 7200 0 EET} - {4049215200 10800 1 EEST} - {4062517200 7200 0 EET} - {4080664800 10800 1 EEST} - {4093966800 7200 0 EET} } -- cgit v0.12 From ba5939ea3bf47fc00db9172391b3d68e24539921 Mon Sep 17 00:00:00 2001 From: max Date: Fri, 27 May 2011 17:50:38 +0000 Subject: fix a timing issue in socket-12.3 --- tests/socket.test | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/tests/socket.test b/tests/socket.test index f1acedc..83bad09 100644 --- a/tests/socket.test +++ b/tests/socket.test @@ -1610,7 +1610,7 @@ test socket_$af-12.3 {testing inheritance of accepted sockets} -setup { # If the socket is still open after 5 seconds, the script1 process must # have inherited the accepted socket. set failed 0 - after 5000 set failed 1 + set after [after 5000 [list set failed 1]] proc getdata { file } { # Read handler on the client socket. global x @@ -1637,6 +1637,7 @@ test socket_$af-12.3 {testing inheritance of accepted sockets} -setup { vwait x return $x } -cleanup { + after cancel $after catch {close $p} } -result {accepted socket was not inherited} -- cgit v0.12