tags/v1_29/Leak/Leak.xs

/*
  Copyright (c) 1995,1996-1998 Nick Ing-Simmons. All rights reserved.
  This program is free software; you can redistribute it and/or
  modify it under the same terms as Perl itself.
*/
/*
 modified by dougm for use with 5.004_04    
 future versions may be made special for the mod_perl environment
*/

#include <EXTERN.h>
#include <perl.h>
#include <XSUB.h>

#include "patchlevel.h"
#if ((PATCHLEVEL == 4) && (SUBVERSION <= 76))
#define PL_sv_arenaroot sv_arenaroot
#endif

typedef long used_proc _((void *, SV *, long));
typedef struct hash_s *hash_ptr;

#define MAX_HASH 1009

static hash_ptr pile = NULL;

static void
LangDumpVec(char *who, int count, SV **data)
{
    int i;
    PerlIO_printf(PerlIO_stderr(), "%s (%d):\n", who, count);
    for (i = 0; i < count; i++)
    {
	SV *sv = data[i];
	if (sv) {
	    PerlIO_printf(PerlIO_stderr(), "%2d ", i);
	    sv_dump(sv);
	}
    }
}

struct hash_s {
    struct hash_s *link;
    SV *sv;
    char *tag;
};

static char *lookup(hash_ptr *ht, SV *sv, void *tag)
{
    unsigned hash = ((unsigned long) sv) % MAX_HASH;
    hash_ptr p = ht[hash];
    while (p) {
	if (p->sv == sv) {
	    char *old = p->tag;
	    p->tag = (char *) tag;
	    return old;
	}
	p = p->link;
    }
    if ((p = pile))
	pile = p->link;
    else
	p = (hash_ptr) malloc(sizeof(struct hash_s));
    p->link  = ht[hash];
    p->sv    = sv;
    p->tag   = (char *)tag;
    ht[hash] = p;
    return NULL;
}

static void check_arenas()
{
    SV *sva;
    for (sva = PL_sv_arenaroot; sva; sva = (SV *) SvANY(sva)) {
	SV *sv = sva + 1;
	SV *svend = &sva[SvREFCNT(sva)];
	while (sv < svend) {
	    if (SvROK(sv) && ((IV) SvANY(sv)) & 1) {
		warn("Odd SvANY for %p @ %p[%d]",sv,sva,(sv-sva));
		abort();
	    }
	    ++sv;
	}
    }
}

static long int sv_apply_to_used(void *p, used_proc *proc, long int n)
{
    SV *sva;
    for (sva = PL_sv_arenaroot; sva; sva = (SV *) SvANY(sva)) {
	SV *sv = sva + 1;
	SV *svend = &sva[SvREFCNT(sva)];

	while (sv < svend) {
	    if (SvTYPE(sv) != SVTYPEMASK) {
		n = (*proc) (p, sv, n);
	    }
	    ++sv;
	}
    }
    return n;
}

static char * t_old = "old";
static char * t_new = "new";

static long note_sv(void *p, SV *sv, long int n) {
    lookup((struct hash_s **)p, sv, t_old);
    return n+1;
}

static long note_used(hash_ptr **x)
{
    hash_ptr *ht;
    Newz(603, ht, MAX_HASH, hash_ptr);
    *x = ht;
    return sv_apply_to_used(ht, note_sv, 0);
}

static long check_sv(void *p, SV *sv, long hwm)
{
    char *state = lookup((struct hash_s **)p, sv, t_new); 
    if (state != t_old) { 
	PerlIO_printf(PerlIO_stderr(), "%s %p : ", state ? state : t_new, sv); 
	sv_dump(sv);
    }
    return hwm+1;
}

static long check_used(hash_ptr **x) {
    hash_ptr *ht = *x;
    long count = sv_apply_to_used(ht, check_sv, 0);
    long i;
    for (i = 0; i < MAX_HASH; i++) {
	hash_ptr p = ht[i];
	while (p) {
	    hash_ptr t = p;
	    p = t->link;
	    if (t->tag != t_new) {
		LangDumpVec(t->tag ? t->tag : "NUL", 1, &t->sv);
	    }
	    t->link = pile;
	    pile = t;
	}
    }
    free(ht);
    *x = NULL;
    return count;
}

MODULE = Apache::Leak	PACKAGE = Apache::Leak

PROTOTYPES: Enable

IV
NoteSV(obj)
    hash_ptr *	obj = NO_INIT

    CODE:
    RETVAL = note_used(&obj);

    OUTPUT:
    obj
    RETVAL

IV
CheckSV(obj)
    hash_ptr *	obj

    CODE:
    RETVAL = check_used(&obj);

    OUTPUT:
    RETVAL

void
check_arenas()