/*
 * This file was generated automatically by ExtUtils::ParseXS version 2.18 from the
 * contents of Leak.xs. Do not edit this file, edit Leak.xs instead.
 *
 *	ANY CHANGES MADE HERE WILL BE LOST! 
 *
 */

#line 1 "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;
}

#ifndef PERL_UNUSED_VAR
#  define PERL_UNUSED_VAR(var) if (0) var = var
#endif

#line 165 "Leak.c"

XS(XS_Apache__Leak_NoteSV); /* prototype to pass -Wmissing-prototypes */
XS(XS_Apache__Leak_NoteSV)
{
#ifdef dVAR
    dVAR; dXSARGS;
#else
    dXSARGS;
#endif
    if (items != 1)
       Perl_croak(aTHX_ "Usage: %s(%s)", "Apache::Leak::NoteSV", "obj");
    PERL_UNUSED_VAR(cv); /* -W */
    {
	hash_ptr *	obj;
	IV	RETVAL;
	dXSTARG;
#line 160 "Leak.xs"
    RETVAL = note_used(&obj);

#line 185 "Leak.c"
	sv_setiv(ST(0), PTR2IV(obj));
	SvSETMAGIC(ST(0));
	XSprePUSH; PUSHi((IV)RETVAL);
    }
    XSRETURN(1);
}


XS(XS_Apache__Leak_CheckSV); /* prototype to pass -Wmissing-prototypes */
XS(XS_Apache__Leak_CheckSV)
{
#ifdef dVAR
    dVAR; dXSARGS;
#else
    dXSARGS;
#endif
    if (items != 1)
       Perl_croak(aTHX_ "Usage: %s(%s)", "Apache::Leak::CheckSV", "obj");
    PERL_UNUSED_VAR(cv); /* -W */
    {
	hash_ptr *	obj = INT2PTR(hash_ptr *,SvIV(ST(0)));
	IV	RETVAL;
	dXSTARG;
#line 171 "Leak.xs"
    RETVAL = check_used(&obj);

#line 212 "Leak.c"
	XSprePUSH; PUSHi((IV)RETVAL);
    }
    XSRETURN(1);
}


XS(XS_Apache__Leak_check_arenas); /* prototype to pass -Wmissing-prototypes */
XS(XS_Apache__Leak_check_arenas)
{
#ifdef dVAR
    dVAR; dXSARGS;
#else
    dXSARGS;
#endif
    if (items != 0)
       Perl_croak(aTHX_ "Usage: %s(%s)", "Apache::Leak::check_arenas", "");
    PERL_UNUSED_VAR(cv); /* -W */
    {

	check_arenas();
    }
    XSRETURN_EMPTY;
}

#ifdef __cplusplus
extern "C"
#endif
XS(boot_Apache__Leak); /* prototype to pass -Wmissing-prototypes */
XS(boot_Apache__Leak)
{
#ifdef dVAR
    dVAR; dXSARGS;
#else
    dXSARGS;
#endif
    char* file = __FILE__;

    PERL_UNUSED_VAR(cv); /* -W */
    PERL_UNUSED_VAR(items); /* -W */
    XS_VERSION_BOOTCHECK ;

        newXS("Apache::Leak::NoteSV", XS_Apache__Leak_NoteSV, file);
        newXS("Apache::Leak::CheckSV", XS_Apache__Leak_CheckSV, file);
        newXS("Apache::Leak::check_arenas", XS_Apache__Leak_check_arenas, file);
    XSRETURN_YES;
}