From b93f9358c0e9106a49dd3cde6376706de4714747 Mon Sep 17 00:00:00 2001 From: Konstantin Kushnir Date: Thu, 30 May 2024 01:16:43 +0000 Subject: [PATCH] Fix multiple memory leaks --- .github/workflows/cppcheck.yml | 1 + .github/workflows/linux-build.yml | 3 +- .github/workflows/memleaks.yml | 65 ++++++++++++++++++++++ ChangeLog | 3 ++ generic/fsindex.c | 20 ++++--- generic/fsindexCmd.c | 7 +-- generic/fsindexCmd.h | 2 - generic/pages.c | 24 ++++++--- generic/pagesCmd.c | 11 ++-- generic/pagesCmd.h | 1 - generic/pagesCompr.c | 7 +++ generic/readerchannelIO.c | 5 -- generic/vfsCmd.c | 2 + generic/writer.c | 13 +++-- tests/all.tcl | 2 +- tests/memleakhunter.tcl | 89 ++++++++++++++++++++++++++++--- 16 files changed, 213 insertions(+), 42 deletions(-) create mode 100644 .github/workflows/memleaks.yml diff --git a/.github/workflows/cppcheck.yml b/.github/workflows/cppcheck.yml index 7f4649e..f9025c5 100644 --- a/.github/workflows/cppcheck.yml +++ b/.github/workflows/cppcheck.yml @@ -8,6 +8,7 @@ defaults: jobs: build: runs-on: ubuntu-24.04 + timeout-minutes: 5 steps: - name: Checkout uses: actions/checkout@v4 diff --git a/.github/workflows/linux-build.yml b/.github/workflows/linux-build.yml index 3a2f6e3..32acebe 100644 --- a/.github/workflows/linux-build.yml +++ b/.github/workflows/linux-build.yml @@ -8,6 +8,7 @@ defaults: jobs: build: runs-on: ubuntu-24.04 + timeout-minutes: 5 strategy: matrix: compiler: ["gcc", "clang"] @@ -58,7 +59,7 @@ jobs: } - name: Build run: | - make || { + make -j || { echo "::error::Failure during Build" exit 1 } diff --git a/.github/workflows/memleaks.yml b/.github/workflows/memleaks.yml new file mode 100644 index 0000000..1584e8b --- /dev/null +++ b/.github/workflows/memleaks.yml @@ -0,0 +1,65 @@ +name: Memory leak check +on: [push] +permissions: + contents: read +defaults: + run: + shell: bash +jobs: + build: + runs-on: ubuntu-24.04 + timeout-minutes: 10 + steps: + + - name: Checkout Tcl + uses: actions/checkout@v4 + with: + repository: tcltk/tcl + ref: core-8-6-14 + path: tcl + - name: Configure Tcl + working-directory: tcl/unix + run: | + ./configure --enable-symbols=all --prefix $HOME/tcl_install || { + cat config.log + echo "::error::Failure during Configure Tcl" + exit 1 + } + - name: Build Tcl + working-directory: tcl/unix + run: | + make -j || { + echo "::error::Failure during Build Tcl" + exit 1 + } + - name: Install Tcl + working-directory: tcl/unix + run: | + make install || { + echo "::error::Failure during Install Tcl" + exit 1 + } + + - name: Checkout + uses: actions/checkout@v4 + with: + submodules: recursive + - name: Configure + run: | + ./configure --with-tcl=$HOME/tcl_install --enable-symbols=all || { + cat config.log + echo "::error::Failure during Configure" + exit 1 + } + - name: Build + run: | + make -j || { + echo "::error::Failure during Build" + exit 1 + } + - name: Run Tests + run: | + MEMDEBUG=1 make test || { + echo "::error::Failure during Test" + exit 1 + } diff --git a/ChangeLog b/ChangeLog index 16348c4..5d5935b 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,6 @@ +2024-05-30 Konstantin Kushnir + * Fix multiple memory leaks + 2024-05-29 Konstantin Kushnir * Fix a regression when register volume and unregister with vfs::unmount * Add memory leak hunter to tests diff --git a/generic/fsindex.c b/generic/fsindex.c index 6e43708..2d0e1f7 100644 --- a/generic/fsindex.c +++ b/generic/fsindex.c @@ -519,7 +519,7 @@ Cookfs_FsindexEntry *Cookfs_FsindexSet(Cookfs_Fsindex *i, Tcl_Obj *pathList, int /* if finding failed (i.e. parent did not exist), return NULL */ if ((foundFileNode == NULL) || (dirNode == NULL)) { - CookfsLog(printf("Cookfs_FsindexSet - NULL")) + CookfsLog(printf("Cookfs_FsindexSet - NULL")); /* the current node is already released by CookfsFsindexFind() */ return NULL; } @@ -1088,14 +1088,14 @@ static Cookfs_FsindexEntry *CookfsFsindexFind(Cookfs_Fsindex *i, Cookfs_FsindexE char *pathTailStr; if (Tcl_ListObjLength(NULL, pathList, &listSize) != TCL_OK) { - return NULL; + goto error; } if (listSize == 0) { if (command == COOKFSFSINDEX_FIND_FIND) { return i->rootItem; } else { /* create or delete will not work with empty file list */ - return NULL; + goto error; } } @@ -1112,19 +1112,19 @@ static Cookfs_FsindexEntry *CookfsFsindexFind(Cookfs_Fsindex *i, Cookfs_FsindexE /* if parent was not found or is not a directory, return NULL */ if (currentNode == NULL) { CookfsLog(printf("CookfsFsindexCreateHashElement - node not found")) - return NULL; + goto error; } if (currentNode->fileBlocks != COOKFS_NUMBLOCKS_DIRECTORY) { CookfsLog(printf("CookfsFsindexCreateHashElement - not a directory")) - return NULL; + goto error; } /* get information about fail of the file name * and invoke CookfsFsindexFindInDirectory() */ if (Tcl_ListObjIndex(NULL, pathList, listSize - 1, &pathTail) != TCL_OK) { CookfsLog(printf("CookfsFsindexCreateHashElement - Unable to get element")) - return NULL; + goto error; } pathTailStr = Tcl_GetStringFromObj(pathTail, NULL); @@ -1135,6 +1135,14 @@ static Cookfs_FsindexEntry *CookfsFsindexFind(Cookfs_Fsindex *i, Cookfs_FsindexE Cookfs_FsindexIncrChangeCount(i, 1); } return rc; + +error: + + if (newFileNode != NULL) { + Cookfs_FsindexEntryFree(newFileNode); + } + return NULL; + } diff --git a/generic/fsindexCmd.c b/generic/fsindexCmd.c index 2ec3fe3..e5eae52 100644 --- a/generic/fsindexCmd.c +++ b/generic/fsindexCmd.c @@ -26,6 +26,8 @@ static int CookfsFsindexCmdGetBlockUsage(Cookfs_Fsindex *fsIndex, Tcl_Interp *in static int CookfsFsindexCmdChangeCount(Cookfs_Fsindex *fsIndex, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); static int CookfsFsindexCmdImport(Cookfs_Fsindex *fsIndex, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); +static void CookfsRegisterExistingFsindexObjectCmd(Tcl_Interp *interp, Cookfs_Fsindex *i); + // These functions are in header //static int CookfsFsindexCmdSetMetadata(Cookfs_Fsindex *fsIndex, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); //static int CookfsFsindexCmdGetMetadata(Cookfs_Fsindex *fsIndex, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); @@ -99,7 +101,7 @@ Tcl_Obj *CookfsGetFsindexObjectCmd(Tcl_Interp *interp, Cookfs_Fsindex *i) { *---------------------------------------------------------------------- */ -void CookfsRegisterExistingFsindexObjectCmd(Tcl_Interp *interp, Cookfs_Fsindex *i) { +static void CookfsRegisterExistingFsindexObjectCmd(Tcl_Interp *interp, Cookfs_Fsindex *i) { if (i->commandToken != NULL) { return; } @@ -109,7 +111,6 @@ void CookfsRegisterExistingFsindexObjectCmd(Tcl_Interp *interp, Cookfs_Fsindex * i->commandToken = Tcl_CreateObjCommand(interp, buf, CookfsFsindexCmd, (ClientData) i, CookfsFsindexDeleteProc); i->interp = interp; - Tcl_SetObjResult(interp, Tcl_NewStringObj(buf, -1)); } @@ -165,7 +166,7 @@ static int CookfsRegisterFsindexObjectCmd(ClientData clientData, Tcl_Interp *int /* create Tcl command and return its name and set interp result to the command name */ CookfsLog(printf("Create Tcl command for the fsindex object...")) - CookfsRegisterExistingFsindexObjectCmd(interp, i); + Tcl_SetObjResult(interp, CookfsGetFsindexObjectCmd(interp, i)); return TCL_OK; ERROR: diff --git a/generic/fsindexCmd.h b/generic/fsindexCmd.h index cd1fe33..a49527b 100644 --- a/generic/fsindexCmd.h +++ b/generic/fsindexCmd.h @@ -7,10 +7,8 @@ #ifdef COOKFS_USECFSINDEX int Cookfs_InitFsindexCmd(Tcl_Interp *interp); -void CookfsRegisterExistingFsindexObjectCmd(Tcl_Interp *interp, Cookfs_Fsindex *i); Tcl_Obj *CookfsGetFsindexObjectCmd(Tcl_Interp *interp, Cookfs_Fsindex *i); - int CookfsFsindexCmdGetMetadata(Cookfs_Fsindex *fsIndex, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); int CookfsFsindexCmdSetMetadata(Cookfs_Fsindex *fsIndex, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); diff --git a/generic/pages.c b/generic/pages.c index 785499b..4eac995 100644 --- a/generic/pages.c +++ b/generic/pages.c @@ -880,13 +880,15 @@ int Cookfs_PageAddRaw(Cookfs_Pages *p, unsigned char *bytes, int objLength) { /* use -1000 weight as it is temporary page and we don't really need it in cache */ otherPageData = Cookfs_PageGet(p, idx, -1000); + // No need to incr refcounter on otherPageData because Cookfs_PageGet() + // always returns pages with refcount=1. + /* fail in case when decompression is not available */ if (otherPageData == NULL) { CookfsLog(printf("Cookfs_PageAdd: Unable to verify page with same MD5 checksum")) return -1; } - Tcl_IncrRefCount(otherPageData); otherBytes = Tcl_GetByteArrayFromObj(otherPageData, &otherObjLength); /* if page with same checksum was found, verify its contents as we @@ -993,7 +995,7 @@ Tcl_Obj *Cookfs_PageGet(Cookfs_Pages *p, int index, int weight) { /* if cache is disabled, immediately get page */ if (p->cacheSize <= 0) { rc = CookfsPagesPageGetInt(p, index); - CookfsLog(printf("Returning directly [%s]", rc == NULL ? "NULL" : "SET")) + CookfsLog(printf("Cookfs_PageGet: Returning directly [%p]", (void *)rc)) return rc; } @@ -1007,17 +1009,21 @@ Tcl_Obj *Cookfs_PageGet(Cookfs_Pages *p, int index, int weight) { rc = Cookfs_PageCacheGet(p, index, 1, weight); if (rc != NULL) { + CookfsLog(printf("Cookfs_PageGet: Returning from cache [%p]", (void *)rc)); + // Increase refcount by 1 for pages from cache because + // CookfsPagesPageGetInt()->Cookfs_ReadPage() returns pages with + // refcount=1 + Tcl_IncrRefCount(rc); return rc; } /* get page and store it in cache */ rc = CookfsPagesPageGetInt(p, index); - CookfsLog(printf("Returning and caching [%s]", rc == NULL ? "NULL" : "SET")) - if (rc == NULL) { - return NULL; - } + CookfsLog(printf("Cookfs_PageGet: Returning and caching [%p]", (void *)rc)) - Cookfs_PageCacheSet(p, index, rc, weight); + if (rc != NULL) { + Cookfs_PageCacheSet(p, index, rc, weight); + } return rc; } @@ -1156,6 +1162,7 @@ void Cookfs_PageCacheSet(Cookfs_Pages *p, int idx, Tcl_Obj *obj, int weight) { p->cache[newIdx].pageIdx = idx; p->cache[newIdx].pageObj = obj; p->cache[newIdx].weight = weight; + Tcl_IncrRefCount(obj); CookfsLog(printf("Cookfs_PageCacheSet: replace entry [%d]", newIdx)); /* age will be set by CookfsPagesPageCacheMoveToTop */ CookfsPagesPageCacheMoveToTop(p, newIdx); @@ -1898,8 +1905,9 @@ static int CookfsReadIndex(Tcl_Interp *interp, Cookfs_Pages *p) { indexReadOk: /* read page MD5 checksums and pages */ + Tcl_DecrRefCount(p->dataIndex); p->dataIndex = buffer; - Tcl_IncrRefCount(p->dataIndex); + // Do not increase refcount for p->dataIndex because Cookfs_ReadPage returns Tcl_Obj with refcount=1 /* seek to beginning of data, depending on if foffset was specified */ Tcl_Seek(p->fileChannel, p->foffset, SEEK_SET); diff --git a/generic/pagesCmd.c b/generic/pagesCmd.c index 7c0dd98..a920664 100644 --- a/generic/pagesCmd.c +++ b/generic/pagesCmd.c @@ -14,7 +14,7 @@ static int CookfsPagesCmd(ClientData clientData, Tcl_Interp *interp, int objc, T static int CookfsPagesCmdHash(Cookfs_Pages *pages, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); static void CookfsPagesDeleteProc(ClientData clientData); static int CookfsRegisterPagesObjectCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); - +static void CookfsRegisterExistingPagesObjectCmd(Tcl_Interp *interp, Cookfs_Pages *p); /* *---------------------------------------------------------------------- @@ -65,6 +65,7 @@ Tcl_Obj *CookfsGetPagesObjectCmd(Tcl_Interp *interp, Cookfs_Pages *p) { CookfsRegisterExistingPagesObjectCmd(interp, p); Tcl_Obj *rc = Tcl_NewObj(); Tcl_GetCommandFullName(interp, p->commandToken, rc); + CookfsLog(printf("CookfsGetPagesObjectCmd: return [%p]", (void *)rc)); return rc; } @@ -85,7 +86,7 @@ Tcl_Obj *CookfsGetPagesObjectCmd(Tcl_Interp *interp, Cookfs_Pages *p) { *---------------------------------------------------------------------- */ -void CookfsRegisterExistingPagesObjectCmd(Tcl_Interp *interp, Cookfs_Pages *p) { +static void CookfsRegisterExistingPagesObjectCmd(Tcl_Interp *interp, Cookfs_Pages *p) { if (p->commandToken != NULL) { return; } @@ -95,7 +96,6 @@ void CookfsRegisterExistingPagesObjectCmd(Tcl_Interp *interp, Cookfs_Pages *p) { p->commandToken = Tcl_CreateObjCommand(interp, buf, CookfsPagesCmd, (ClientData)p, CookfsPagesDeleteProc); p->interp = interp; - Tcl_SetObjResult(interp, Tcl_NewStringObj(buf, -1)); } /* command for creating new objects that deal with pages */ @@ -299,7 +299,7 @@ static int CookfsRegisterPagesObjectCmd(ClientData clientData, Tcl_Interp *inter /* create Tcl command and return its name and set interp result to the command name */ CookfsLog(printf("Create Tcl command for the pages object...")) - CookfsRegisterExistingPagesObjectCmd(interp, pages); + Tcl_SetObjResult(interp, CookfsGetPagesObjectCmd(interp, pages)); return TCL_OK; ERROR: @@ -402,6 +402,9 @@ static int CookfsPagesCmd(ClientData clientData, Tcl_Interp *interp, int objc, T return TCL_ERROR; } else { Tcl_SetObjResult(interp, rc); + // Cookfs_PageGet always returns a page with refcount=1. We need + // to decrease refcount now. + Tcl_DecrRefCount(rc); } break; } diff --git a/generic/pagesCmd.h b/generic/pagesCmd.h index ca762c9..8ebfdbf 100644 --- a/generic/pagesCmd.h +++ b/generic/pagesCmd.h @@ -9,7 +9,6 @@ #ifdef COOKFS_USECPAGES int Cookfs_InitPagesCmd(Tcl_Interp *interp); -void CookfsRegisterExistingPagesObjectCmd(Tcl_Interp *interp, Cookfs_Pages *p); Tcl_Obj *CookfsGetPagesObjectCmd(Tcl_Interp *interp, Cookfs_Pages *p); int CookfsPagesCmdCompression(Cookfs_Pages *pages, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); diff --git a/generic/pagesCompr.c b/generic/pagesCompr.c index 9e44c2f..15d0454 100644 --- a/generic/pagesCompr.c +++ b/generic/pagesCompr.c @@ -283,6 +283,13 @@ void Cookfs_PagesFiniCompr(Cookfs_Pages *rc) { } ckfree((void *) rc->asyncCompressCommandPtr); } + if (rc->asyncDecompressCommandPtr != NULL) { + Tcl_Obj **ptr; + for (ptr = rc->asyncDecompressCommandPtr; *ptr; ptr++) { + Tcl_DecrRefCount(*ptr); + } + ckfree((void *) rc->asyncDecompressCommandPtr); + } } #ifdef COOKFS_USEXZ CookfsLog(printf("Cookfs_PagesFiniCompr: free xz resources")); diff --git a/generic/readerchannelIO.c b/generic/readerchannelIO.c index 77ea7ef..3acf4fe 100644 --- a/generic/readerchannelIO.c +++ b/generic/readerchannelIO.c @@ -95,9 +95,6 @@ int Cookfs_Readerchannel_Input(ClientData instanceData, char *buf, int bufSize, goto error; } - CookfsLog(printf("Cookfs_Readerchannel_Input: before incr")) - Tcl_IncrRefCount(pageObj); - CookfsLog(printf("Cookfs_Readerchannel_Input: after incr")) pageBuf = (char *) Tcl_GetByteArrayFromObj(pageObj, &pageBufSize); CookfsLog(printf("Cookfs_Readerchannel_Input: copying %d+%d", instData->buf[instData->currentBlock + 1], instData->currentBlockOffset)) @@ -106,9 +103,7 @@ int Cookfs_Readerchannel_Input(ClientData instanceData, char *buf, int bufSize, goto error; } memcpy(buf + bytesRead, pageBuf + instData->buf[instData->currentBlock + 1] + instData->currentBlockOffset, blockRead); - CookfsLog(printf("Cookfs_Readerchannel_Input: before decr")) Tcl_DecrRefCount(pageObj); - CookfsLog(printf("Cookfs_Readerchannel_Input: after decr")) instData->currentBlockOffset += blockRead; bytesRead += blockRead; diff --git a/generic/vfsCmd.c b/generic/vfsCmd.c index d3ec481..dd9d003 100644 --- a/generic/vfsCmd.c +++ b/generic/vfsCmd.c @@ -1090,6 +1090,8 @@ static int CookfsMountHandleCommandOptimizelist(Cookfs_Vfs *vfs, } } + //ckfree(pageFiles); + CookfsLog(printf("CookfsMountHandleCommandOptimizelist: add the large" " files to the small files")); Tcl_ListObjAppendList(interp, smallFiles, largeFiles); diff --git a/generic/writer.c b/generic/writer.c index d91a5e5..03ea075 100644 --- a/generic/writer.c +++ b/generic/writer.c @@ -580,11 +580,11 @@ int Cookfs_WriterAddFile(Cookfs_Writer *w, Tcl_Obj *pathObj, } // Try to add page - CookfsLog(printf("Cookfs_WriterPurge: add page...")); + CookfsLog(printf("Cookfs_WriterAddFile: add page...")); int block = Cookfs_PageAddRaw(w->pages, (readBuffer == NULL ? (char *)data + currentOffset : readBuffer), bytesToWrite); - CookfsLog(printf("Cookfs_WriterPurge: got block index: %d", block)); + CookfsLog(printf("Cookfs_WriterAddFile: got block index: %d", block)); if (block < 0) { Tcl_Obj *err = Cookfs_PagesGetLastError(w->pages); @@ -595,7 +595,7 @@ int Cookfs_WriterAddFile(Cookfs_Writer *w, Tcl_Obj *pathObj, goto error; } - CookfsLog(printf("Cookfs_WriterPurge: update block number %d" + CookfsLog(printf("Cookfs_WriterAddFile: update block number %d" " of fsindex entry...", currentBlockNumber)); Cookfs_FsindexUpdateEntryBlock(w->index, entry, currentBlockNumber, block, 0, bytesToWrite); @@ -609,6 +609,13 @@ int Cookfs_WriterAddFile(Cookfs_Writer *w, Tcl_Obj *pathObj, // Unset entry to avoid releasing it at the end entry = NULL; + // If we add a buffer, the caller expects that the writer now owns + // the buffer. Since we already store the file (its buffer) in pages, + // we don't need this data anymore. + if (dataType == COOKFS_WRITER_SOURCE_BUFFER) { + ckfree(data); + } + } goto done; diff --git a/tests/all.tcl b/tests/all.tcl index d3ca390..17bf0ec 100644 --- a/tests/all.tcl +++ b/tests/all.tcl @@ -82,5 +82,5 @@ foreach file [lsort [::tcltest::getMatchingFiles]] { puts stdout "\nTests ended at [eval $timeCmd]" if { $::tcltest::numTests(Total) } { set r $::tcltest::numTests(Failed) } { set r 1 } ::tcltest::cleanupTests 1 +incr r [check_memleaks] exit $r - diff --git a/tests/memleakhunter.tcl b/tests/memleakhunter.tcl index 0f78adf..81affc6 100644 --- a/tests/memleakhunter.tcl +++ b/tests/memleakhunter.tcl @@ -8,7 +8,9 @@ proc snapshot_vars { interp ns } { dict set result $var [interp eval $interp [list array get $var]] } else { if { [catch { interp eval $interp [list set $var] } data] } { - set data "@@DONT_EXISTS@@" + # This is the case where a variable is defined in the namespace + # but does not yet exist. + continue } dict set result $var $data } @@ -119,21 +121,77 @@ proc tcltest::SetupTest { code } { catch { uplevel 1 $code } res opts + # See comment in tcltest::EvalTest about this hack with 'string range'. + set opts [string range " $opts" 1 end] + set res [string range " $res" 1 end] return -options $opts $res } -#proc tcltest::EvalTest { code } { -#} +proc tcltest::EvalTest { code } { + catch { + uplevel 1 $code + } res opts + # Do not mark objects created after the test has been executed as + # related to the test. + memory tag "" + # After running the test, it is possible that the test result contains + # objects that were created in the extension. We want to identify + # all objects that were created in the extension to judge possible + # memory leaks. However, these objects in interp's result are expected + # and should not be considered as memory leaks. + # + # To avoid detecting such objects, we convert the interp's result to + # a new string object created from scratch and not associated with + # the extension. We will do this with the 'string range' command. + set opts [string range " $opts" 1 end] + set res [string range " $res" 1 end] + return -options $opts $res +} proc tcltest::CleanupTest { code } { + variable filesMade + catch { uplevel 1 $code - memory tag "" } res opts + # See comment in tcltest::EvalTest about this hack with 'string range'. + set opts [string range " $opts" 1 end] + set res [string range " $res" 1 end] + + # Commands enclosed in "catch" in cleanup code for a test can leave + # references to objects created by the extension. I am not sure where they + # are stored. Unsetting ::errorInfo and ::errorCode does not work, + # and these references still remain in the interpreter. + # It looks like the only stable option to remove all possible + # references is to throw an error in script enclosed in + # "catch" command. + catch { unset not_existing_variable_here } + # cleanup after tclvfs - catch { unset ::vfs::_unmountCmd } + if { [array exists ::vfs::_unmountCmd] } { + if { [array size ::vfs::_unmountCmd] } { + puts [outputChannel] "WARNING: ::vfs::_unmountCmd is not empty: \[[array get ::vfs::_unmountCmd]\]" + } + unset ::vfs::_unmountCmd + } + + # tcltest::makeFile stores the names of the created files in + # the filesMade variable. The filename may have been generated by + # the extension or may contain linked objects (such as a normalized path + # or internal file system representation) generated by the extension. + # To clear all references to objects created by the extension, we convert + # the filenames in this variable to normal strings. + if { [info exists filesMade] } { + set result [list] + foreach fn $filesMade { + lappend result [string range " $fn" 1 end] + } + set filesMade $result + # fn variable also contains a file name! release it now. + unset -nocomplain fn + } foreach msg [compare_snapshot $::tcltest::ss [create_snapshot]] { puts [outputChannel] $msg @@ -152,7 +210,7 @@ proc tcltest::CleanupTest { code } { if { [string match "*/generic/regcomp.c * $::tcltest::testname" $line] } continue if { [string match "*/generic/regc_*.c * $::tcltest::testname" $line] } continue if { ![info exists fo] } { - set fo [open "${::tcltest::testname}.dump" w] + set fo [open "x-${::tcltest::testname}.memdump" w] } puts $fo $line } @@ -160,8 +218,23 @@ proc tcltest::CleanupTest { code } { close $fi if { [info exists fo] } { close $fo + } elseif { [file exists "x-${::tcltest::testname}.memdump"] } { + file delete "x-${::tcltest::testname}.memdump" } - file delete -force $memdump + file delete $memdump return -options $opts $res -} \ No newline at end of file +} + +proc check_memleaks {} { + set found 0 + foreach fn [glob -nocomplain -type f *.memdump] { + set found 1 + puts "" + puts "=== Memory leaks in [file rootname [file tail $fn]] ===" + puts [string trim [read [set fp [open $fn]]]][close $fp] + puts "=================================" + puts "" + } + return $found +}