You are viewing a plain text version of this content. The canonical link for it is here.
Posted to dev@perl.apache.org by Stas Bekman <st...@stason.org> on 2004/01/07 06:35:00 UTC
[mp2] some leakage tracing code for archival
some code that I used to trace leakings in response handlers. It's a bit
messed up (with chunks copied from Devel::Peek) and I'm not sure if we want to
polish it and made available via modperl_util, but at the moment I just post
it for the archival reasons if anybody needs to do the same.
Index: src/modules/perl/mod_perl.c
===================================================================
RCS file: /home/cvs/modperl-2.0/src/modules/perl/mod_perl.c,v
retrieving revision 1.205
diff -u -r1.205 mod_perl.c
--- src/modules/perl/mod_perl.c 15 Dec 2003 08:24:57 -0000 1.205
+++ src/modules/perl/mod_perl.c 7 Jan 2004 05:16:24 -0000
@@ -838,19 +838,192 @@
int modperl_response_handler(request_rec *r)
{
+ int status;
+#ifdef MP_USE_GTOP
+ MP_dSCFG(r->server);
+#endif
+
if (!strEQ(r->handler, "modperl")) {
return DECLINED;
}
+#ifdef MP_USE_GTOP
+ MP_TRACE_m_do(
+ modperl_gtop_do_proc_mem_before(MP_FUNC, "response");
+ );
+#endif
+ status = modperl_response_handler_run(r, TRUE);
+#ifdef MP_USE_GTOP
+ MP_TRACE_m_do(
+ modperl_gtop_do_proc_mem_after(MP_FUNC, "response");
+ );
+#endif
+
+ return status;
+}
+typedef long used_proc _((void *,SV *,long));
+typedef struct hash_s *hash_ptr;
- return modperl_response_handler_run(r, TRUE);
+#ifndef DEBUGGING
+#define sv_dump(sv) PerlIO_printf(PerlIO_stderr(), "\n")
+#endif
+
+#define MAX_HASH 1009
+
+static hash_ptr pile = NULL;
+
+static void
+LangDumpVec(char *who, int count, SV **data)
+{
+ dTHX;
+ 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)
+{
+ dTHX;
+ unsigned hash = ((unsigned long) sv) % MAX_HASH;
+ hash_ptr p = ht[hash];
+ while (p)
+ {
+ if (p->sv == sv)
+ {char *old = p->tag;
+ p->tag = 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 = tag;
+ ht[hash] = p;
+ return NULL;
+}
+
+static long int
+sv_apply_to_used(void *p, used_proc *proc, long int n)
+{
+ dTHX;
+ 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 old[] = "old";
+static char new[] = "new";
+
+static long
+note_sv(void *p, SV *sv, long int n)
+{
+ lookup(p, sv, old);
+ return n+1;
+}
+
+
+long note_used(hash_ptr **x);
+
+long note_used(hash_ptr **x)
+{
+ dTHX;
+ 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)
+{
+ dTHX;
+ char *state = lookup(p,sv,new);
+ if (state != old)
+ {
+ fprintf(stderr,"%s %p : ", state ? state : new, sv);
+ sv_dump(sv);
+ }
+ return hwm+1;
+}
+
+/* static long */
+/* find_object(void *p, SV *sv, long count) */
+/* { */
+/* dTHX; */
+/* if (sv_isobject(sv)) */
+/* { */
+/* sv_dump(sv); */
+/* count++; */
+/* } */
+/* return count; */
+/* } */
+
+long check_used(hash_ptr **x);
+long check_used(hash_ptr **x)
+{
+ dTHX;
+ 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 != new)
+ {
+ LangDumpVec(t->tag ? t->tag : "NUL",1,&t->sv);
+ }
+ t->link = pile;
+ pile = t;
+ }
+ }
+ free(ht);
+ *x = NULL;
+ return count;
+}
+
+
int modperl_response_handler_cgi(request_rec *r)
{
MP_dDCFG;
GV *h_stdin, *h_stdout;
apr_status_t retval, rc;
MP_dRCFG;
+ MP_dSCFG(r->server);
+ //hash_ptr *leak_handle;
#ifdef USE_ITHREADS
pTHX;
modperl_interp_t *interp;
@@ -860,6 +1033,8 @@
return DECLINED;
}
+ MP_TRACE_m_do(modperl_gtop_do_proc_mem_before(MP_FUNC, "response"););
+
#ifdef USE_ITHREADS
interp = modperl_interp_select(r, r->connection, r->server);
aTHX = interp->perl;
@@ -867,6 +1042,11 @@
rcfg->interp = interp;
}
#endif
+
+ //MP_TRACE_m_do(modperl_gtop_do_proc_mem_after(MP_FUNC, "response interp"););
+
+
+ //MP_TRACE_m_do(modperl_gtop_do_proc_mem_before(MP_FUNC, "response setup"););
modperl_perl_global_request_save(aTHX_ r);
@@ -879,17 +1059,24 @@
if (MpDirGLOBAL_REQUEST(dcfg) || !MpDirSeenGLOBAL_REQUEST(dcfg)) {
modperl_global_request_set(r);
}
+// MP_TRACE_m_do(modperl_gtop_do_proc_mem_after(MP_FUNC, "response setup"););
+/* MP_TRACE_m_do(modperl_gtop_do_proc_mem_before(MP_FUNC, "response
io");); */
+ //note_used(&leak_handle);
/* need to create a block around the IO setup so the temp vars
* will be automatically cleaned up when we are done with IO */
ENTER;SAVETMPS;
h_stdin = modperl_io_override_stdin(aTHX_ r);
h_stdout = modperl_io_override_stdout(aTHX_ r);
+/* MP_TRACE_m_do(modperl_gtop_do_proc_mem_after(MP_FUNC, "response io");); */
+/* MP_TRACE_m_do(modperl_gtop_do_proc_mem_before(MP_FUNC, "response
env");); */
modperl_env_request_tie(aTHX_ r);
+/* MP_TRACE_m_do(modperl_gtop_do_proc_mem_after(MP_FUNC, "response
env");); */
retval = modperl_response_handler_run(r, FALSE);
+
modperl_env_request_untie(aTHX_ r);
modperl_perl_global_request_restore(aTHX_ r);
@@ -912,12 +1099,16 @@
retval = rc;
}
+ //check_used(&leak_handle);
+
switch (rcfg->status) {
case HTTP_MOVED_TEMPORARILY:
/* set by modperl_cgi_header_parse */
retval = HTTP_MOVED_TEMPORARILY;
break;
}
+
+ MP_TRACE_m_do(modperl_gtop_do_proc_mem_after(MP_FUNC, "response"););
return retval;
}
Index: src/modules/perl/modperl_gtop.c
===================================================================
RCS file: /home/cvs/modperl-2.0/src/modules/perl/modperl_gtop.c,v
retrieving revision 1.8
diff -u -r1.8 modperl_gtop.c
--- src/modules/perl/modperl_gtop.c 20 May 2003 06:53:47 -0000 1.8
+++ src/modules/perl/modperl_gtop.c 7 Jan 2004 05:16:24 -0000
@@ -99,8 +99,8 @@
{
#define ss_item(item) gtop->proc_mem_ss.item
- fprintf(stderr, "%s : %s %s: " ss_fmt "\n",
- func, (msg ? msg : ""), when,
+ fprintf(stderr, "%30s : %20s: " ss_fmt "\n",
+ func, (msg ? msg : ""),
ss_item(size),
ss_item(vsize),
ss_item(resident),
@@ -119,13 +119,13 @@
void modperl_gtop_report_proc_mem_before(modperl_gtop_t *gtop, const char
*func, char *msg)
{
modperl_gtop_proc_mem_size_string(gtop, SS_TYPE_BEFORE);
- modperl_gtop_report_proc_mem(gtop, "before", func, msg);
+ //modperl_gtop_report_proc_mem(gtop, "before", func, msg);
}
void modperl_gtop_report_proc_mem_after(modperl_gtop_t *gtop, const char
*func, char *msg)
{
modperl_gtop_proc_mem_size_string(gtop, SS_TYPE_AFTER);
- modperl_gtop_report_proc_mem(gtop, "after", func, msg);
+ //modperl_gtop_report_proc_mem(gtop, "after", func, msg);
}
#endif /* MP_USE_GTOP */
__________________________________________________________________
Stas Bekman JAm_pH ------> Just Another mod_perl Hacker
http://stason.org/ mod_perl Guide ---> http://perl.apache.org
mailto:stas@stason.org http://use.perl.org http://apacheweek.com
http://modperlbook.org http://apache.org http://ticketmaster.com
---------------------------------------------------------------------
To unsubscribe, e-mail: dev-unsubscribe@perl.apache.org
For additional commands, e-mail: dev-help@perl.apache.org