SQLite

**    May you find forgiveness for yourself and forgive others.
**    May you share freely, never taking more than you give.
**
*************************************************************************
** This file contains the C functions that implement a memory
** allocation subsystem for use by SQLite.  
**
** $Id: mem2.c,v 1.23 2008/03/21 14:22:44 danielk1977 Exp $
*/
#include "sqliteInt.h"

/*
** This version of the memory allocator is used only if the
** SQLITE_MEMDEBUG macro is defined
*/

  struct MemBlockHdr *pFirst;
  struct MemBlockHdr *pLast;
  
  /*
  ** The number of levels of backtrace to save in new allocations.
  */
  int nBacktrace;
  void (*xBacktrace)(int, int, void **);

  /*
  ** Title text to insert in front of each block
  */
  int nTitle;        /* Bytes of zTitle to save.  Includes '\0' and padding */
  char zTitle[100];  /* The title text */

      pHdr->iForeGuard = FOREGUARD;
      pHdr->nBacktraceSlots = mem.nBacktrace;
      pHdr->nTitle = mem.nTitle;
      if( mem.nBacktrace ){
        void *aAddr[40];
        pHdr->nBacktrace = backtrace(aAddr, mem.nBacktrace+1)-1;
        memcpy(pBt, &aAddr[1], pHdr->nBacktrace*sizeof(void*));
	if( mem.xBacktrace ){
          mem.xBacktrace(nByte, pHdr->nBacktrace-1, &aAddr[1]);
	}
      }else{
        pHdr->nBacktrace = 0;
      }
      if( mem.nTitle ){
        memcpy(z, mem.zTitle, mem.nTitle);
      }
      pHdr->iSize = nByte;

*/
void sqlite3MemdebugBacktrace(int depth){
  if( depth<0 ){ depth = 0; }
  if( depth>20 ){ depth = 20; }
  depth = (depth+1)&0xfe;
  mem.nBacktrace = depth;
}

void sqlite3MemdebugBacktraceCallback(void (*xBacktrace)(int, int, void **)){
  mem.xBacktrace = xBacktrace;
}

/*
** Set the title string for subsequent allocations.
*/
void sqlite3MemdebugSettitle(const char *zTitle){
  int n = strlen(zTitle) + 1;
  enterMem();

**    May you share freely, never taking more than you give.
**
*************************************************************************
**
** This file contains code used to implement test interfaces to the
** memory allocation subsystem.
**
** $Id: test_malloc.c,v 1.18 2008/03/21 14:22:44 danielk1977 Exp $
*/
#include "sqliteInt.h"
#include "tcl.h"
#include <stdlib.h>
#include <string.h>
#include <assert.h>

    extern int sqlite3MemdebugSettitle(const char*);
    sqlite3MemdebugSettitle(zTitle);
  }
#endif
  return TCL_OK;
}

#define MALLOC_LOG_FRAMES 5
static Tcl_HashTable aMallocLog;
static int mallocLogEnabled = 0;

typedef struct MallocLog MallocLog;
struct MallocLog {
  int nCall;
  int nByte;
};

static void test_memdebug_callback(int nByte, int nFrame, void **aFrame){
  if( mallocLogEnabled ){
    MallocLog *pLog;
    Tcl_HashEntry *pEntry;
    int isNew;

    int aKey[MALLOC_LOG_FRAMES];
    int nKey = sizeof(int)*MALLOC_LOG_FRAMES;

    memset(aKey, 0, nKey);
    if( (sizeof(void*)*nFrame)<nKey ){
      nKey = nFrame*sizeof(void*);
    }
    memcpy(aKey, aFrame, nKey);

    pEntry = Tcl_CreateHashEntry(&aMallocLog, (const char *)aKey, &isNew);
    if( isNew ){
      pLog = (MallocLog *)Tcl_Alloc(sizeof(MallocLog));
      memset(pLog, 0, sizeof(MallocLog));
      Tcl_SetHashValue(pEntry, (ClientData)pLog);
    }else{
      pLog = (MallocLog *)Tcl_GetHashValue(pEntry);
    }

    pLog->nCall++;
    pLog->nByte += nByte;
  }
}

static int test_memdebug_log(
  void * clientData,
  Tcl_Interp *interp,
  int objc,
  Tcl_Obj *CONST objv[]
){
  static int isInit = 0;
  int iSub;

  enum MB_enum { MB_LOG_START, MB_LOG_STOP, MB_LOG_DUMP, MB_LOG_CLEAR };
  static const char *MB_strs[] = { "start", "stop", "dump", "clear" };

  if( !isInit ){
#ifdef SQLITE_MEMDEBUG
    extern void sqlite3MemdebugBacktraceCallback(
        void (*xBacktrace)(int, int, void **));
    sqlite3MemdebugBacktraceCallback(test_memdebug_callback);
#endif
    Tcl_InitHashTable(&aMallocLog, MALLOC_LOG_FRAMES);
    isInit = 1;
  }

  if( objc<2 ){
    Tcl_WrongNumArgs(interp, 1, objv, "SUB-COMMAND ...");
  }
  if( Tcl_GetIndexFromObj(interp, objv[1], MB_strs, "sub-command", 0, &iSub) ){
    return TCL_ERROR;
  }

  switch( (enum MB_enum)iSub ){
    case MB_LOG_START:
      mallocLogEnabled = 1;
      break;
    case MB_LOG_STOP:
      mallocLogEnabled = 0;
      break;
    case MB_LOG_DUMP: {
      Tcl_HashSearch search;
      Tcl_HashEntry *pEntry;
      Tcl_Obj *pRet = Tcl_NewObj();

      assert(sizeof(int)==sizeof(void*));

      for(
        pEntry=Tcl_FirstHashEntry(&aMallocLog, &search);
        pEntry;
        pEntry=Tcl_NextHashEntry(&search)
      ){
        Tcl_Obj *apElem[MALLOC_LOG_FRAMES+2];
        MallocLog *pLog = (MallocLog *)Tcl_GetHashValue(pEntry);
        int *aKey = (int *)Tcl_GetHashKey(&aMallocLog, pEntry);
        int ii;
  
        apElem[0] = Tcl_NewIntObj(pLog->nCall);
        apElem[1] = Tcl_NewIntObj(pLog->nByte);
        for(ii=0; ii<MALLOC_LOG_FRAMES; ii++){
          apElem[ii+2] = Tcl_NewIntObj(aKey[ii]);
        }

        Tcl_ListObjAppendElement(interp, pRet,
            Tcl_NewListObj(MALLOC_LOG_FRAMES+2, apElem)
        );
      }

      Tcl_SetObjResult(interp, pRet);
      break;
    }
    case MB_LOG_CLEAR: {
      Tcl_HashSearch search;
      Tcl_HashEntry *pEntry;
      for(
        pEntry=Tcl_FirstHashEntry(&aMallocLog, &search);
        pEntry;
        pEntry=Tcl_NextHashEntry(&search)
      ){
        MallocLog *pLog = (MallocLog *)Tcl_GetHashValue(pEntry);
        Tcl_Free((char *)pLog);
      }
      Tcl_DeleteHashTable(&aMallocLog);
      Tcl_InitHashTable(&aMallocLog, MALLOC_LOG_FRAMES);
    }
  }

  return TCL_OK;
}

/*
** Register commands with the TCL interpreter.
*/
int Sqlitetest_malloc_Init(Tcl_Interp *interp){
  static struct {
     char *zName;

     { "sqlite3_memory_highwater",   test_memory_highwater         },
     { "sqlite3_memdebug_backtrace", test_memdebug_backtrace       },
     { "sqlite3_memdebug_dump",      test_memdebug_dump            },
     { "sqlite3_memdebug_fail",      test_memdebug_fail            },
     { "sqlite3_memdebug_pending",   test_memdebug_pending         },
     { "sqlite3_memdebug_settitle",  test_memdebug_settitle        },
     { "sqlite3_memdebug_malloc_count", test_memdebug_malloc_count },
     { "sqlite3_memdebug_log",       test_memdebug_log },
  };
  int i;
  for(i=0; i<sizeof(aObjCmd)/sizeof(aObjCmd[0]); i++){
    Tcl_CreateObjCommand(interp, aObjCmd[i].zName, aObjCmd[i].xProc, 0, 0);
  }
  return TCL_OK;
}

# 2001 September 15
#
# The author disclaims copyright to this source code.  In place of
# a legal notice, here is a blessing:
#
#    May you do good and not evil.
#    May you find forgiveness for yourself and forgive others.
#    May you share freely, never taking more than you give.
#
#***********************************************************************
# This file implements some common TCL routines used for regression
# testing the SQLite library
#
# $Id: tester.tcl,v 1.108 2008/03/21 14:22:44 danielk1977 Exp $


set tcl_precision 15
set sqlite_pending_byte 0x0010000

# 
# Check the command-line arguments for a default soft-heap-limit.

  foreach prag {default_cache_size} {
    append txt $prag-[$db eval "PRAGMA $prag"]\n
  }
  # puts txt=$txt
  return [md5 $txt]
}

proc memdebug_log_sql {database} {
  set data [sqlite3_memdebug_log dump]
  set nFrame [expr [llength [lindex $data 0]]-2]

  if {$nFrame < 0} { return "" }

  set tbl "CREATE TABLE ${database}.malloc(nCall, nByte"
  for {set ii 1} {$ii <= $nFrame} {incr ii} {
    append tbl ", f${ii}"
  }
  append tbl ");\n"

  set sql ""
  foreach e $data {
    append sql "INSERT INTO ${database}.malloc VALUES([join $e ,]);\n"
    foreach f [lrange $e 2 end] {
      set frames($f) 1
    }
  }

  set tbl2 "CREATE TABLE ${database}.frame(frame INTEGER PRIMARY KEY, line);\n"

  foreach f [array names frames] {
    set addr [format %x $f]
    set cmd "addr2line -e [info nameofexec] $addr"
    set line [eval exec $cmd]
    append sql "INSERT INTO ${database}.frame VALUES($f, '$line');\n"
  }

  return "BEGIN; ${tbl}${tbl2}${sql} ; COMMIT;"
}
proc memdebug_log_pp2 {db iLevel iParentFrame iDepth} {
  set extra 1
  if {$iParentFrame != 0} {
    set extra "f[expr $iLevel-1] = $iParentFrame"
  }
  set leader [string repeat "         " [expr $iLevel -1]]
  $db eval "
    select 
      sum(ncall) calls, 
      sum(nbyte) as bytes, 
      frame,
      line FROM malloc, 
      frame WHERE f${iLevel}=frame AND $extra
      GROUP BY f${iLevel} ORDER BY calls DESC
  " {
    puts [format "%s%-10s %10s %s" $leader $calls $bytes $line]
    if {$iLevel < $iDepth} {
      memdebug_log_pp2 $db [expr $iLevel + 1] $frame $iDepth
    }
  }
}
proc memdebug_log_strip {db} {
  set nFrame [expr [llength [$db eval "SELECT * FROM malloc LIMIT 1"]] - 2]

  set update "UPDATE malloc SET "
  for {set ii 1} {$ii <= $nFrame} {incr ii} {
    if {$ii == $nFrame} {
      append update "f${ii} = 0"
    } else {
      append update "f${ii} = f[expr $ii+1], "
    }
  }
  append update "
    WHERE 
      (SELECT line FROM frame WHERE frame = f1) LIKE '%malloc.c:%' OR
      (SELECT line FROM frame WHERE frame = f1) LIKE '%mem2.c:%'
  "

  $db eval $update
  $db eval $update
  $db eval $update
}
proc memdebug_log_pp {{iDepth 1}} {
  set sql [memdebug_log_sql main]
  if {$sql eq ""} return

  sqlite3 mddb :memory:
  mddb eval $sql
  memdebug_log_strip mddb

  memdebug_log_pp2 mddb 1 0 $iDepth
  mddb close
}

# Copy file $from into $to. This is used because some versions of
# TCL for windows (notably the 8.4.1 binary package shipped with the
# current mingw release) have a broken "file copy" command.
#
proc copy_file {from to} {
  if {$::tcl_platform(platform)=="unix"} {