diff options
Diffstat (limited to 'generic/tclCkalloc.c')
| -rw-r--r-- | generic/tclCkalloc.c | 43 |
1 files changed, 32 insertions, 11 deletions
diff --git a/generic/tclCkalloc.c b/generic/tclCkalloc.c index dac67d4..98c351b 100644 --- a/generic/tclCkalloc.c +++ b/generic/tclCkalloc.c @@ -13,7 +13,7 @@ * * This code contributed by Karl Lehenbauer and Mark Diekhans * - * RCS: @(#) $Id: tclCkalloc.c,v 1.13 2001/12/18 15:21:20 dkf Exp $ + * RCS: @(#) $Id: tclCkalloc.c,v 1.14 2001/12/28 23:36:31 dgp Exp $ */ #include "tclInt.h" @@ -111,6 +111,7 @@ static int init_malloced_bodies = TRUE; char *tclMemDumpFileName = NULL; +static char *onExitMemDumpFileName = NULL; static char dumpFile[100]; /* Records where to dump memory allocation * information. */ @@ -304,7 +305,7 @@ Tcl_ValidateAllMemory (file, line) * information will be written to stderr. * * Results: - * Return TCL_ERROR if an error accessing the file occures, `errno' + * Return TCL_ERROR if an error accessing the file occurs, `errno' * will have the file error number left in it. *---------------------------------------------------------------------- */ @@ -759,11 +760,14 @@ Tcl_AttemptRealloc(ptr, size) * MemoryCmd -- * Implements the Tcl "memory" command, which provides Tcl-level * control of Tcl memory debugging information. + * memory active $file + * memory break_on_malloc $count * memory info - * memory display - * memory break_on_malloc count - * memory trace_on_at_malloc count + * memory init on|off + * memory onexit $file + * memory tag $string * memory trace on|off + * memory trace_on_at_malloc $count * memory validate on|off * * Results: @@ -789,10 +793,10 @@ MemoryCmd (clientData, interp, argc, argv) return TCL_ERROR; } - if (strcmp(argv[1],"active") == 0) { + if ((strcmp(argv[1],"active") == 0) || (strcmp(argv[1],"display") == 0)) { if (argc != 3) { Tcl_AppendResult(interp, "wrong # args: should be \"", - argv[0], " active file\"", (char *) NULL); + argv[0], " ", argv[1], " file\"", (char *) NULL); return TCL_ERROR; } fileName = Tcl_TranslateFileName(interp, argv[2], &buffer); @@ -818,14 +822,14 @@ MemoryCmd (clientData, interp, argc, argv) return TCL_OK; } if (strcmp(argv[1],"info") == 0) { - char buffer[400]; - sprintf(buffer, "%-25s %10d\n%-25s %10d\n%-25s %10d\n%-25s %10d\n%-25s %10d\n%-25s %10d\n", + char buf[400]; + sprintf(buf, "%-25s %10d\n%-25s %10d\n%-25s %10d\n%-25s %10d\n%-25s %10d\n%-25s %10d\n", "total mallocs", total_mallocs, "total frees", total_frees, "current packets allocated", current_malloc_packets, "current bytes allocated", current_bytes_malloced, "maximum packets allocated", maximum_malloc_packets, "maximum bytes allocated", maximum_bytes_malloced); - Tcl_SetResult(interp, buffer, TCL_VOLATILE); + Tcl_SetResult(interp, buf, TCL_VOLATILE); return TCL_OK; } if (strcmp(argv[1],"init") == 0) { @@ -835,6 +839,21 @@ MemoryCmd (clientData, interp, argc, argv) init_malloced_bodies = (strcmp(argv[2],"on") == 0); return TCL_OK; } + if (strcmp(argv[1],"onexit") == 0) { + if (argc != 3) { + Tcl_AppendResult(interp, "wrong # args: should be \"", + argv[0], " onexit file\"", (char *) NULL); + return TCL_ERROR; + } + fileName = Tcl_TranslateFileName(interp, argv[2], &buffer); + if (fileName == NULL) { + return TCL_ERROR; + } + onExitMemDumpFileName = dumpFile; + strcpy(onExitMemDumpFileName,fileName); + Tcl_DStringFree(&buffer); + return TCL_OK; + } if (strcmp(argv[1],"tag") == 0) { if (argc != 3) { Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], @@ -875,7 +894,7 @@ MemoryCmd (clientData, interp, argc, argv) } Tcl_AppendResult(interp, "bad option \"", argv[1], - "\": should be active, break_on_malloc, info, init, ", + "\": should be active, break_on_malloc, info, init, onexit, ", "tag, trace, trace_on_at_malloc, or validate", (char *) NULL); return TCL_ERROR; @@ -1216,6 +1235,8 @@ TclFinalizeMemorySubsystem() Tcl_MutexLock(ckallocMutexPtr); if (tclMemDumpFileName != NULL) { Tcl_DumpActiveMemory(tclMemDumpFileName); + } else if (onExitMemDumpFileName != NULL) { + Tcl_DumpActiveMemory(onExitMemDumpFileName); } if (curTagPtr != NULL) { TclpFree((char *) curTagPtr); |