summaryrefslogtreecommitdiffstats
path: root/generic/tclCkalloc.c
diff options
context:
space:
mode:
Diffstat (limited to 'generic/tclCkalloc.c')
-rw-r--r--generic/tclCkalloc.c23
1 files changed, 22 insertions, 1 deletions
diff --git a/generic/tclCkalloc.c b/generic/tclCkalloc.c
index 2cbff69..9a3b4e3 100644
--- a/generic/tclCkalloc.c
+++ b/generic/tclCkalloc.c
@@ -14,7 +14,7 @@
*
* This code contributed by Karl Lehenbauer and Mark Diekhans
*
- * RCS: @(#) $Id: tclCkalloc.c,v 1.35 2009/02/27 23:03:41 nijtmans Exp $
+ * RCS: @(#) $Id: tclCkalloc.c,v 1.36 2009/06/18 09:41:26 dkf Exp $
*/
#include "tclInt.h"
@@ -803,6 +803,7 @@ MemoryCmd(
const char *argv[])
{
const char *fileName;
+ FILE *fileP;
Tcl_DString buffer;
int result;
@@ -856,6 +857,26 @@ MemoryCmd(
init_malloced_bodies = (strcmp(argv[2],"on") == 0);
return TCL_OK;
}
+ if (strcmp(argv[1],"objs") == 0) {
+ if (argc != 3) {
+ Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
+ " objs file\"", NULL);
+ return TCL_ERROR;
+ }
+ fileName = Tcl_TranslateFileName(interp, argv[2], &buffer);
+ if (fileName == NULL) {
+ return TCL_ERROR;
+ }
+ fileP = fopen(fileName, "w");
+ if (fileP == NULL) {
+ Tcl_AppendResult(interp, "cannot open output file", NULL);
+ return TCL_ERROR;
+ }
+ TclDbDumpActiveObjects(fileP);
+ fclose(fileP);
+ Tcl_DStringFree(&buffer);
+ return TCL_OK;
+ }
if (strcmp(argv[1],"onexit") == 0) {
if (argc != 3) {
Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],