File: /home/.cpan/build/Test-LeakTrace-0.17-0/LeakTrace.c
/*
* This file was generated automatically by ExtUtils::ParseXS version 3.40 from the
* contents of LeakTrace.xs. Do not edit this file, edit LeakTrace.xs instead.
*
* ANY CHANGES MADE HERE WILL BE LOST!
*
*/
#line 1 "LeakTrace.xs"
#define PERL_NO_GET_CONTEXT /* I want efficiency. */
#include <EXTERN.h>
#include <perl.h>
#define NO_XSLOCKS /* use exception handling macros */
#include <XSUB.h>
#define NEED_newSVpvn_flags /* newSVpvs_flags depends on */
#include "ppport.h"
#include "ptr_table.h"
#ifndef SvIS_FREED
#define SvIS_FREED(sv) (SvFLAGS(sv) == SVTYPEMASK)
#endif
#ifndef SvPADSTALE
#define SvPADSTALE(sv) (SvPADMY(sv) && SvREFCNT(sv) == 1)
#endif /* !SvPADSTALE */
#define IS_STALE(sv) (SvIS_FREED(sv) || SvPADSTALE(sv))
#define PteKey(pte) ((SV*)pte->oldval)
#define PteVal(pte) ((stateinfo*)pte->newval)
#define REPORT_DISABLED 0x00
#define REPORT_ENABLED 0x01
#define REPORT_SV_DUMP 0x02
#define REPORT_SOURCE_LINES 0x04
#define REPORT_SILENT 0x08
#define MY_CXT_KEY "Test::LeakTrace::_guts" XS_VERSION
typedef struct{
bool enabled;
bool need_stateinfo;
char* file;
I32 filelen;
I32 line;
PTR_TBL_t* usedsv_reg;
PTR_TBL_t* newsv_reg;
} my_cxt_t;
START_MY_CXT;
typedef struct stateinfo stateinfo;
struct stateinfo{
SV* sv;
char* file;
I32 filelen;
I32 line;
stateinfo* next;
};
/* START_ARENA_VISIT and END_ARENA_VISIT macros are originated from S_visit() in sv.c.
They are used to scan the sv arena.
*/
#define START_ARENA_VISIT STMT_START{ \
SV* sva; \
for (sva = PL_sv_arenaroot; sva; sva = (SV*)SvANY(sva)){ \
const SV * const svend = &sva[SvREFCNT(sva)]; \
register SV* sv; \
for (sv = sva + 1; sv < svend; ++sv){ \
if (!IS_STALE(sv))
#define END_ARENA_VISIT \
} /* end for(1) */ \
} /* end for(2) */ \
} STMT_END
/* START_PTR_TABLE_VISIT and END_PTR_TABLE_VISIT macros are originatred from ptr_table_clear() in sv.c */
#define START_PTR_TABLE_VISIT(tbl) STMT_START{ \
assert(tbl); \
if (tbl->tbl_items) { \
PTR_TBL_ENT_t * const * const array = tbl->tbl_ary; \
UV riter = tbl->tbl_max; \
do { \
register PTR_TBL_ENT_t *pte = array[riter]; \
while (pte) { \
STMT_START
#define END_PTR_TABLE_VISIT \
STMT_END; \
pte = pte->next; \
} \
} while (riter--); \
} /* end if(ptr_table->tbl_items) */ \
} STMT_END
static UV
count_sv_in_arena(pTHX) {
UV count = 0;
START_ARENA_VISIT {
count++;
} END_ARENA_VISIT;
return count;
}
#define ptr_table_free_val(tbl) my_ptr_table_free_val(aTHX_ tbl)
static void
my_ptr_table_free_val(pTHX_ PTR_TBL_t * const tbl){
START_PTR_TABLE_VISIT(tbl) {
Safefree(PteVal(pte)->file);
Safefree(pte->newval);
pte->newval = NULL;
} END_PTR_TABLE_VISIT;
}
static void
set_stateinfo(pTHX_ pMY_CXT_ COP* const cop){
const char* file;
I32 filelen;
assert(cop);
file = CopFILE(cop);
assert(file);
filelen = strlen(file);
if(filelen > MY_CXT.filelen) Renew(MY_CXT.file, filelen+1, char);
Copy(file, MY_CXT.file, filelen+1, char);
MY_CXT.filelen = filelen;
MY_CXT.line = (I32)CopLINE(cop);
}
static void
unmark_all(pTHX_ pMY_CXT){
START_PTR_TABLE_VISIT(MY_CXT.newsv_reg) {
if(IS_STALE(PteKey(pte))){
PteVal(pte)->sv = NULL; /* unmark */
}
} END_PTR_TABLE_VISIT;
}
static void
mark_all(pTHX_ pMY_CXT){
assert(MY_CXT.usedsv_reg);
assert(MY_CXT.newsv_reg);
unmark_all(aTHX_ aMY_CXT);
/* mark SVs as "new" with statement info */
START_ARENA_VISIT {
if(!ptr_table_fetch(MY_CXT.usedsv_reg, sv)){
stateinfo* si = (stateinfo*)ptr_table_fetch(MY_CXT.newsv_reg, sv);
if(si){
if(si->sv){
/* already marked */
continue;
}
/* unmarked */
}
else{
/* not marked */
Newxz(si, 1, stateinfo);
ptr_table_store(MY_CXT.newsv_reg, sv, si);
}
/* sv_dump(sv); // */
si->sv = sv; /* mark */
if(MY_CXT.need_stateinfo){
if(MY_CXT.filelen > si->filelen) Renew(si->file, MY_CXT.filelen+1, char);
Copy(MY_CXT.file, si->file, MY_CXT.filelen+1, char);
si->filelen = MY_CXT.filelen;
si->line = MY_CXT.line;
}
}
} END_ARENA_VISIT;
}
static int
leaktrace_runops(pTHX){
dVAR;
dMY_CXT;
COP* last_cop = PL_curcop;
while((PL_op = CALL_FPTR(PL_op->op_ppaddr)(aTHX))) {
PERL_ASYNC_CHECK();
if(!MY_CXT.need_stateinfo) continue;
#if 0
PerlIO_printf(Perl_debug_log, "#run [%s] %s %d\n",
OP_NAME(PL_op),
CopFILE(PL_curcop),
(int)CopLINE(PL_curcop));
#endif
if(last_cop != PL_curcop){
mark_all(aTHX_ aMY_CXT);
last_cop = PL_curcop;
set_stateinfo(aTHX_ aMY_CXT_ last_cop);
}
}
if(MY_CXT.enabled){
mark_all(aTHX_ aMY_CXT);
}
TAINT_NOT;
return 0;
}
static stateinfo*
make_leakedsv_list(pTHX_ pMY_CXT_ IV* const countp){
stateinfo* leaked = NULL;
IV count = 0;
START_ARENA_VISIT{
stateinfo* const si = (stateinfo*)ptr_table_fetch(MY_CXT.newsv_reg, sv);
if(si && si->sv){
count++;
si->next = leaked; /* make a link */
leaked = si;
}
} END_ARENA_VISIT;
*countp = count;
return leaked;
}
static void
callback_each_leaked(pTHX_ stateinfo* leaked, SV* const callback){
while(leaked){
dSP;
I32 n;
if(IS_STALE(leaked->sv)){ /* NOTE: it is possible when the callback releases some SVs. */
leaked = leaked->next;
continue;
}
ENTER;
SAVETMPS;
PUSHMARK(SP);
EXTEND(SP, 3);
mXPUSHs(newRV_inc(leaked->sv));
mPUSHp(leaked->file, leaked->filelen); /* can be empty */
mPUSHi(leaked->line); /* can be zero */
PUTBACK;
n = call_sv(callback, G_VOID);
SPAGAIN;
while(n--) (void)POPs;
PUTBACK;
FREETMPS;
LEAVE;
leaked = leaked->next;
}
}
static void
print_lines_around(pTHX_ PerlIO* const ofp, const char* const file, I32 const lineno){
PerlIO* const ifp = PerlIO_open(file, "r");
SV* const sv = DEFSV;
int i = 0;
if(ifp){
while(sv_gets(sv, ifp, FALSE)){
i++;
if( i >= (lineno-1) ){
PerlIO_printf(ofp, "%4d:%"SVf, (int)i, sv);
if( i >= (lineno+1) ){
break;
}
}
}
PerlIO_close(ifp);
}
}
static void
report_each_leaked(pTHX_ stateinfo* leaked, int const reporting_mode){
PerlIO* const logfp = Perl_error_log;
if(reporting_mode & REPORT_SOURCE_LINES){
ENTER;
SAVETMPS;
/*
local $/ = "\n"
local $_;
*/
SAVESPTR(PL_rs);
SAVE_DEFSV;
PL_rs = newSVpvs_flags("\n", SVs_TEMP);
DEFSV = sv_newmortal();
}
while(leaked){
assert(!IS_STALE(leaked->sv));
if(leaked->filelen){
PerlIO_printf(logfp, "leaked %s(0x%p) from %s line %d.\n",
sv_reftype(leaked->sv, FALSE),
leaked->sv,
leaked->file, (int)leaked->line);
if(leaked->line && (reporting_mode & REPORT_SOURCE_LINES)){
print_lines_around(aTHX_ logfp, leaked->file, leaked->line);
}
}
if(reporting_mode & REPORT_SV_DUMP){
do_sv_dump(
0, /* level */
logfp,
leaked->sv,
0, /* nest */
4, /* maxnest */
FALSE, /* dumpops */
0 /* pvlim */
);
}
leaked = leaked->next;
}
if(reporting_mode & REPORT_SOURCE_LINES){
FREETMPS;
LEAVE;
}
}
#line 355 "LeakTrace.c"
#ifndef PERL_UNUSED_VAR
# define PERL_UNUSED_VAR(var) if (0) var = var
#endif
#ifndef dVAR
# define dVAR dNOOP
#endif
/* This stuff is not part of the API! You have been warned. */
#ifndef PERL_VERSION_DECIMAL
# define PERL_VERSION_DECIMAL(r,v,s) (r*1000000 + v*1000 + s)
#endif
#ifndef PERL_DECIMAL_VERSION
# define PERL_DECIMAL_VERSION \
PERL_VERSION_DECIMAL(PERL_REVISION,PERL_VERSION,PERL_SUBVERSION)
#endif
#ifndef PERL_VERSION_GE
# define PERL_VERSION_GE(r,v,s) \
(PERL_DECIMAL_VERSION >= PERL_VERSION_DECIMAL(r,v,s))
#endif
#ifndef PERL_VERSION_LE
# define PERL_VERSION_LE(r,v,s) \
(PERL_DECIMAL_VERSION <= PERL_VERSION_DECIMAL(r,v,s))
#endif
/* XS_INTERNAL is the explicit static-linkage variant of the default
* XS macro.
*
* XS_EXTERNAL is the same as XS_INTERNAL except it does not include
* "STATIC", ie. it exports XSUB symbols. You probably don't want that
* for anything but the BOOT XSUB.
*
* See XSUB.h in core!
*/
/* TODO: This might be compatible further back than 5.10.0. */
#if PERL_VERSION_GE(5, 10, 0) && PERL_VERSION_LE(5, 15, 1)
# undef XS_EXTERNAL
# undef XS_INTERNAL
# if defined(__CYGWIN__) && defined(USE_DYNAMIC_LOADING)
# define XS_EXTERNAL(name) __declspec(dllexport) XSPROTO(name)
# define XS_INTERNAL(name) STATIC XSPROTO(name)
# endif
# if defined(__SYMBIAN32__)
# define XS_EXTERNAL(name) EXPORT_C XSPROTO(name)
# define XS_INTERNAL(name) EXPORT_C STATIC XSPROTO(name)
# endif
# ifndef XS_EXTERNAL
# if defined(HASATTRIBUTE_UNUSED) && !defined(__cplusplus)
# define XS_EXTERNAL(name) void name(pTHX_ CV* cv __attribute__unused__)
# define XS_INTERNAL(name) STATIC void name(pTHX_ CV* cv __attribute__unused__)
# else
# ifdef __cplusplus
# define XS_EXTERNAL(name) extern "C" XSPROTO(name)
# define XS_INTERNAL(name) static XSPROTO(name)
# else
# define XS_EXTERNAL(name) XSPROTO(name)
# define XS_INTERNAL(name) STATIC XSPROTO(name)
# endif
# endif
# endif
#endif
/* perl >= 5.10.0 && perl <= 5.15.1 */
/* The XS_EXTERNAL macro is used for functions that must not be static
* like the boot XSUB of a module. If perl didn't have an XS_EXTERNAL
* macro defined, the best we can do is assume XS is the same.
* Dito for XS_INTERNAL.
*/
#ifndef XS_EXTERNAL
# define XS_EXTERNAL(name) XS(name)
#endif
#ifndef XS_INTERNAL
# define XS_INTERNAL(name) XS(name)
#endif
/* Now, finally, after all this mess, we want an ExtUtils::ParseXS
* internal macro that we're free to redefine for varying linkage due
* to the EXPORT_XSUB_SYMBOLS XS keyword. This is internal, use
* XS_EXTERNAL(name) or XS_INTERNAL(name) in your code if you need to!
*/
#undef XS_EUPXS
#if defined(PERL_EUPXS_ALWAYS_EXPORT)
# define XS_EUPXS(name) XS_EXTERNAL(name)
#else
/* default to internal */
# define XS_EUPXS(name) XS_INTERNAL(name)
#endif
#ifndef PERL_ARGS_ASSERT_CROAK_XS_USAGE
#define PERL_ARGS_ASSERT_CROAK_XS_USAGE assert(cv); assert(params)
/* prototype to pass -Wmissing-prototypes */
STATIC void
S_croak_xs_usage(const CV *const cv, const char *const params);
STATIC void
S_croak_xs_usage(const CV *const cv, const char *const params)
{
const GV *const gv = CvGV(cv);
PERL_ARGS_ASSERT_CROAK_XS_USAGE;
if (gv) {
const char *const gvname = GvNAME(gv);
const HV *const stash = GvSTASH(gv);
const char *const hvname = stash ? HvNAME(stash) : NULL;
if (hvname)
Perl_croak_nocontext("Usage: %s::%s(%s)", hvname, gvname, params);
else
Perl_croak_nocontext("Usage: %s(%s)", gvname, params);
} else {
/* Pants. I don't think that it should be possible to get here. */
Perl_croak_nocontext("Usage: CODE(0x%" UVxf ")(%s)", PTR2UV(cv), params);
}
}
#undef PERL_ARGS_ASSERT_CROAK_XS_USAGE
#define croak_xs_usage S_croak_xs_usage
#endif
/* NOTE: the prototype of newXSproto() is different in versions of perls,
* so we define a portable version of newXSproto()
*/
#ifdef newXS_flags
#define newXSproto_portable(name, c_impl, file, proto) newXS_flags(name, c_impl, file, proto, 0)
#else
#define newXSproto_portable(name, c_impl, file, proto) (PL_Sv=(SV*)newXS(name, c_impl, file), sv_setpv(PL_Sv, proto), (CV*)PL_Sv)
#endif /* !defined(newXS_flags) */
#if PERL_VERSION_LE(5, 21, 5)
# define newXS_deffile(a,b) Perl_newXS(aTHX_ a,b,file)
#else
# define newXS_deffile(a,b) Perl_newXS_deffile(aTHX_ a,b)
#endif
#line 499 "LeakTrace.c"
XS_EUPXS(XS_Test__LeakTrace_CLONE); /* prototype to pass -Wmissing-prototypes */
XS_EUPXS(XS_Test__LeakTrace_CLONE)
{
dVAR; dXSARGS;
PERL_UNUSED_VAR(cv); /* -W */
PERL_UNUSED_VAR(items); /* -W */
{
#line 359 "LeakTrace.xs"
MY_CXT_CLONE;
Zero(&MY_CXT, 1, my_cxt_t);
PERL_UNUSED_VAR(items);
#line 512 "LeakTrace.c"
}
XSRETURN_EMPTY;
}
XS_EUPXS(XS_Test__LeakTrace_END); /* prototype to pass -Wmissing-prototypes */
XS_EUPXS(XS_Test__LeakTrace_END)
{
dVAR; dXSARGS;
PERL_UNUSED_VAR(cv); /* -W */
PERL_UNUSED_VAR(items); /* -W */
{
#line 366 "LeakTrace.xs"
dMY_CXT;
// release resources for valgrind
Safefree(MY_CXT.file);
MY_CXT.file = NULL;
PERL_UNUSED_VAR(items);
#line 531 "LeakTrace.c"
}
XSRETURN_EMPTY;
}
XS_EUPXS(XS_Test__LeakTrace__start); /* prototype to pass -Wmissing-prototypes */
XS_EUPXS(XS_Test__LeakTrace__start)
{
dVAR; dXSARGS;
if (items != 1)
croak_xs_usage(cv, "need_stateinfo");
{
#line 375 "LeakTrace.xs"
dMY_CXT;
#line 546 "LeakTrace.c"
bool need_stateinfo = (bool)SvTRUE(ST(0))
;
#line 377 "LeakTrace.xs"
if(MY_CXT.enabled){
Perl_croak(aTHX_ "Cannot start LeakTrace inside its scope");
}
assert(MY_CXT.usedsv_reg == NULL);
assert(MY_CXT.newsv_reg == NULL);
MY_CXT.enabled = TRUE;
MY_CXT.need_stateinfo = need_stateinfo;
MY_CXT.usedsv_reg = ptr_table_new();
MY_CXT.newsv_reg = ptr_table_new();
START_ARENA_VISIT{
/* mark as "used" */
ptr_table_store(MY_CXT.usedsv_reg, sv, sv);
} END_ARENA_VISIT;
#line 566 "LeakTrace.c"
}
XSRETURN_EMPTY;
}
XS_EUPXS(XS_Test__LeakTrace__finish); /* prototype to pass -Wmissing-prototypes */
XS_EUPXS(XS_Test__LeakTrace__finish)
{
dVAR; dXSARGS;
if (items < 0 || items > 1)
croak_xs_usage(cv, "mode= &PL_sv_undef");
PERL_UNUSED_VAR(ax); /* -Wall */
SP -= items;
{
#line 398 "LeakTrace.xs"
dMY_CXT;
I32 const gimme = GIMME_V;
int reporting_mode = REPORT_DISABLED;
IV count;
/* volatile to pass -Wuninitialized (longjmp) */
stateinfo* volatile leaked;
SV* volatile callback = NULL;
SV* volatile invalid_mode = NULL;
#line 590 "LeakTrace.c"
SV* mode;
if (items < 1)
mode = &PL_sv_undef;
else {
mode = ST(0)
;
}
#line 407 "LeakTrace.xs"
if(!MY_CXT.enabled){
Perl_warn(aTHX_ "LeakTrace not started");
XSRETURN_EMPTY;
}
if(SvOK(mode)){
if(SvROK(mode) && SvTYPE(SvRV(mode)) == SVt_PVCV){
reporting_mode = REPORT_ENABLED;
callback = mode;
}
else{
const char* const modepv = SvPV_nolen_const(mode);
if(strEQ(modepv, "-simple")){
reporting_mode = REPORT_ENABLED;
}
else if(strEQ(modepv, "-sv_dump")){
reporting_mode = REPORT_SV_DUMP;
}
else if(strEQ(modepv, "-lines")){
reporting_mode = REPORT_SOURCE_LINES;
}
else if(strEQ(modepv, "-verbose")){
reporting_mode = REPORT_SV_DUMP | REPORT_SOURCE_LINES;
}
else if(strEQ(modepv, "-silent")){
reporting_mode = REPORT_SILENT;
}
else{
reporting_mode = REPORT_SILENT;
invalid_mode = mode;
}
}
}
assert(MY_CXT.usedsv_reg);
assert(MY_CXT.newsv_reg);
mark_all(aTHX_ aMY_CXT);
MY_CXT.enabled = FALSE;
MY_CXT.need_stateinfo = FALSE;
leaked = make_leakedsv_list(aTHX_ aMY_CXT_ &count);
ptr_table_free(MY_CXT.usedsv_reg);
MY_CXT.usedsv_reg = NULL;
if(reporting_mode){
if(callback){
dXCPT;
XCPT_TRY_START {
callback_each_leaked(aTHX_ leaked, callback);
} XCPT_TRY_END
XCPT_CATCH {
ptr_table_free_val(MY_CXT.newsv_reg);
ptr_table_free(MY_CXT.newsv_reg);
MY_CXT.newsv_reg = NULL;
XCPT_RETHROW;
}
}
else if(!(reporting_mode & REPORT_SILENT)){
report_each_leaked(aTHX_ leaked, reporting_mode);
}
}
else if(gimme == G_SCALAR){
mXPUSHi(count);
}
else if(gimme == G_ARRAY){
EXTEND(SP, count);
while(leaked){
SV* sv = newRV_inc(leaked->sv);
if(leaked->filelen){
AV* const av = newAV();
av_push(av, sv);
av_push(av, newSVpvn(leaked->file, leaked->filelen));
av_push(av, newSViv(leaked->line));
sv = newRV_noinc((SV*)av);
}
mPUSHs(sv);
leaked = leaked->next;
}
}
ptr_table_free_val(MY_CXT.newsv_reg);
ptr_table_free(MY_CXT.newsv_reg);
MY_CXT.newsv_reg = NULL;
if(invalid_mode){
Perl_croak(aTHX_ "Invalid reporting mode: %"SVf, invalid_mode);
}
#line 695 "LeakTrace.c"
PUTBACK;
return;
}
}
XS_EUPXS(XS_Test__LeakTrace__runops_installed); /* prototype to pass -Wmissing-prototypes */
XS_EUPXS(XS_Test__LeakTrace__runops_installed)
{
dVAR; dXSARGS;
if (items != 0)
croak_xs_usage(cv, "");
{
bool RETVAL;
#line 506 "LeakTrace.xs"
RETVAL = (PL_runops == leaktrace_runops);
#line 712 "LeakTrace.c"
ST(0) = boolSV(RETVAL);
}
XSRETURN(1);
}
XS_EUPXS(XS_Test__LeakTrace_count_sv); /* prototype to pass -Wmissing-prototypes */
XS_EUPXS(XS_Test__LeakTrace_count_sv)
{
dVAR; dXSARGS;
if (items != 0)
croak_xs_usage(cv, "");
{
UV RETVAL;
dXSTARG;
#line 513 "LeakTrace.xs"
RETVAL = count_sv_in_arena(aTHX);
#line 730 "LeakTrace.c"
XSprePUSH; PUSHu((UV)RETVAL);
}
XSRETURN(1);
}
#ifdef __cplusplus
extern "C"
#endif
XS_EXTERNAL(boot_Test__LeakTrace); /* prototype to pass -Wmissing-prototypes */
XS_EXTERNAL(boot_Test__LeakTrace)
{
#if PERL_VERSION_LE(5, 21, 5)
dVAR; dXSARGS;
#else
dVAR; dXSBOOTARGSXSAPIVERCHK;
#endif
#if (PERL_REVISION == 5 && PERL_VERSION < 9)
char* file = __FILE__;
#else
const char* file = __FILE__;
#endif
PERL_UNUSED_VAR(file);
PERL_UNUSED_VAR(cv); /* -W */
PERL_UNUSED_VAR(items); /* -W */
#if PERL_VERSION_LE(5, 21, 5)
XS_VERSION_BOOTCHECK;
# ifdef XS_APIVERSION_BOOTCHECK
XS_APIVERSION_BOOTCHECK;
# endif
#endif
newXS_deffile("Test::LeakTrace::CLONE", XS_Test__LeakTrace_CLONE);
newXS_deffile("Test::LeakTrace::END", XS_Test__LeakTrace_END);
newXS_deffile("Test::LeakTrace::_start", XS_Test__LeakTrace__start);
newXS_deffile("Test::LeakTrace::_finish", XS_Test__LeakTrace__finish);
newXS_deffile("Test::LeakTrace::_runops_installed", XS_Test__LeakTrace__runops_installed);
newXS_deffile("Test::LeakTrace::count_sv", XS_Test__LeakTrace_count_sv);
/* Initialisation Section */
#line 350 "LeakTrace.xs"
{
MY_CXT_INIT;
set_stateinfo(aTHX_ aMY_CXT_ PL_curcop); /* only to prevent core dumps with Devel::Cover */
PL_runops = leaktrace_runops;
}
#line 780 "LeakTrace.c"
/* End of Initialisation Section */
#if PERL_VERSION_LE(5, 21, 5)
# if PERL_VERSION_GE(5, 9, 0)
if (PL_unitcheckav)
call_list(PL_scopestack_ix, PL_unitcheckav);
# endif
XSRETURN_YES;
#else
Perl_xs_boot_epilog(aTHX_ ax);
#endif
}