1			#define PERL_NO_GET_CONTEXT
     2			#include "EXTERN.h"
     3			#include "perl.h"
     4			#include "XSUB.h"
     5			
     6			static bool
     7			_runops_debug(int flag)
     8	      ######    {
     9			    dTHX;
    10	      ######        const bool d = PL_runops == MEMBER_TO_FPTR(Perl_runops_debug);
    11			
    12	      ######        if (flag >= 0)
    13	      ######    	PL_runops 
    14				    = MEMBER_TO_FPTR(flag ? Perl_runops_debug : Perl_runops_standard);
    15	      ######        return d;
    16			}
    17			
    18			static SV *
    19			DeadCode(pTHX)
    20	      ######    {
    21			#ifdef PURIFY
    22			    return Nullsv;
    23			#else
    24	      ######        SV* sva;
    25	      ######        SV* sv;
    26	      ######        SV* ret = newRV_noinc((SV*)newAV());
    27	      ######        register SV* svend;
    28	      ######        int tm = 0, tref = 0, ts = 0, ta = 0, tas = 0;
    29			
    30	      ######        for (sva = PL_sv_arenaroot; sva; sva = (SV*)SvANY(sva)) {
    31	      ######    	svend = &sva[SvREFCNT(sva)];
    32	      ######    	for (sv = sva + 1; sv < svend; ++sv) {
    33	      ######    	    if (SvTYPE(sv) == SVt_PVCV) {
    34	      ######    		CV *cv = (CV*)sv;
    35	      ######    		AV* padlist = CvPADLIST(cv), *argav;
    36	      ######    		SV** svp;
    37	      ######    		SV** pad;
    38	      ######    		int i = 0, j, levelm, totm = 0, levelref, totref = 0;
    39	      ######    		int levels, tots = 0, levela, tota = 0, levelas, totas = 0;
    40	      ######    		int dumpit = 0;
    41			
    42	      ######    		if (CvXSUB(sv)) {
    43	      ######    		    continue;		/* XSUB */
    44					}
    45	      ######    		if (!CvGV(sv)) {
    46	      ######    		    continue;		/* file-level scope. */
    47					}
    48	      ######    		if (!CvROOT(cv)) {
    49					    /* PerlIO_printf(Perl_debug_log, "  no root?!\n"); */
    50	      ######    		    continue;		/* autoloading stub. */
    51					}
    52	      ######    		do_gvgv_dump(0, Perl_debug_log, "GVGV::GV", CvGV(sv));
    53	      ######    		if (CvDEPTH(cv)) {
    54	      ######    		    PerlIO_printf(Perl_debug_log, "  busy\n");
    55	      ######    		    continue;
    56					}
    57	      ######    		svp = AvARRAY(padlist);
    58	      ######    		while (++i <= AvFILL(padlist)) { /* Depth. */
    59	      ######    		    SV **args;
    60					    
    61	      ######    		    pad = AvARRAY((AV*)svp[i]);
    62	      ######    		    argav = (AV*)pad[0];
    63	      ######    		    if (!argav || (SV*)argav == &PL_sv_undef) {
    64	      ######    			PerlIO_printf(Perl_debug_log, "    closure-template\n");
    65	      ######    			continue;
    66					    }
    67	      ######    		    args = AvARRAY(argav);
    68	      ######    		    levelm = levels = levelref = levelas = 0;
    69	      ######    		    levela = sizeof(SV*) * (AvMAX(argav) + 1);
    70	      ######    		    if (AvREAL(argav)) {
    71	      ######    			for (j = 0; j < AvFILL(argav); j++) {
    72	      ######    			    if (SvROK(args[j])) {
    73	      ######    				PerlIO_printf(Perl_debug_log, "     ref in args!\n");
    74	      ######    				levelref++;
    75						    }
    76						    /* else if (SvPOK(args[j]) && SvPVX(args[j])) { */
    77	      ######    			    else if (SvTYPE(args[j]) >= SVt_PV && SvLEN(args[j])) {
    78	      ######    				levelas += SvLEN(args[j])/SvREFCNT(args[j]);
    79						    }
    80						}
    81					    }
    82	      ######    		    for (j = 1; j < AvFILL((AV*)svp[1]); j++) {	/* Vars. */
    83	      ######    			if (SvROK(pad[j])) {
    84	      ######    			    levelref++;
    85	      ######    			    do_sv_dump(0, Perl_debug_log, pad[j], 0, 4, 0, 0);
    86	      ######    			    dumpit = 1;
    87						}
    88						/* else if (SvPOK(pad[j]) && SvPVX(pad[j])) { */
    89	      ######    			else if (SvTYPE(pad[j]) >= SVt_PVAV) {
    90	      ######    			    if (!SvPADMY(pad[j])) {
    91	      ######    				levelref++;
    92	      ######    				do_sv_dump(0, Perl_debug_log, pad[j], 0, 4, 0, 0);
    93	      ######    				dumpit = 1;
    94						    }
    95						}
    96	      ######    			else if (SvTYPE(pad[j]) >= SVt_PV && SvLEN(pad[j])) {
    97	      ######    			    levels++;
    98	      ######    			    levelm += SvLEN(pad[j])/SvREFCNT(pad[j]);
    99							/* Dump(pad[j],4); */
   100						}
   101					    }
   102	      ######    		    PerlIO_printf(Perl_debug_log, "    level %i: refs: %i, strings: %i in %i,\targsarray: %i, argsstrings: %i\n", 
   103						    i, levelref, levelm, levels, levela, levelas);
   104	      ######    		    totm += levelm;
   105	      ######    		    tota += levela;
   106	      ######    		    totas += levelas;
   107	      ######    		    tots += levels;
   108	      ######    		    totref += levelref;
   109	      ######    		    if (dumpit)
   110	      ######    			do_sv_dump(0, Perl_debug_log, (SV*)cv, 0, 2, 0, 0);
   111					}
   112	      ######    		if (AvFILL(padlist) > 1) {
   113	      ######    		    PerlIO_printf(Perl_debug_log, "  total: refs: %i, strings: %i in %i,\targsarrays: %i, argsstrings: %i\n", 
   114						    totref, totm, tots, tota, totas);
   115					}
   116	      ######    		tref += totref;
   117	      ######    		tm += totm;
   118	      ######    		ts += tots;
   119	      ######    		ta += tota;
   120	      ######    		tas += totas;
   121				    }
   122				}
   123			    }
   124	      ######        PerlIO_printf(Perl_debug_log, "total: refs: %i, strings: %i in %i\targsarray: %i, argsstrings: %i\n", tref, tm, ts, ta, tas);
   125			
   126	      ######        return ret;
   127			#endif /* !PURIFY */
   128			}
   129			
   130			#if (defined(PERL_DEBUGGING_MSTATS) || defined(DEBUGGING_MSTATS)) \
   131				&& (defined(MYMALLOC) && !defined(PLAIN_MALLOC))
   132			#   define mstat(str) dump_mstats(str)
   133			#else
   134			#   define mstat(str) \
   135				PerlIO_printf(Perl_debug_log, "%s: perl not compiled with DEBUGGING_MSTATS\n",str);
   136			#endif
   137			
   138			#if (defined(PERL_DEBUGGING_MSTATS) || defined(DEBUGGING_MSTATS)) \
   139				&& (defined(MYMALLOC) && !defined(PLAIN_MALLOC))
   140			
   141			/* Very coarse overestimate, 2-per-power-of-2, one more to determine NBUCKETS. */
   142			#  define _NBUCKETS (2*8*IVSIZE+1)
   143			
   144			struct mstats_buffer 
   145			{
   146			    perl_mstats_t buffer;
   147			    UV buf[_NBUCKETS*4];
   148			};
   149			
   150			static void
   151			_fill_mstats(struct mstats_buffer *b, int level)
   152			{
   153			    dTHX;
   154			    b->buffer.nfree  = b->buf;
   155			    b->buffer.ntotal = b->buf + _NBUCKETS;
   156			    b->buffer.bucket_mem_size = b->buf + 2*_NBUCKETS;
   157			    b->buffer.bucket_available_size = b->buf + 3*_NBUCKETS;
   158			    Zero(b->buf, (level ? 4*_NBUCKETS: 2*_NBUCKETS), unsigned long);
   159			    get_mstats(&(b->buffer), _NBUCKETS, level);
   160			}
   161			
   162			static void
   163			fill_mstats(SV *sv, int level)
   164			{
   165			    dTHX;
   166			
   167			    if (SvREADONLY(sv))
   168				croak("Cannot modify a readonly value");
   169			    SvGROW(sv, sizeof(struct mstats_buffer)+1);
   170			    _fill_mstats((struct mstats_buffer*)SvPVX(sv),level);
   171			    SvCUR_set(sv, sizeof(struct mstats_buffer));
   172			    *SvEND(sv) = '\0';
   173			    SvPOK_only(sv);
   174			}
   175			
   176			static void
   177			_mstats_to_hv(HV *hv, const struct mstats_buffer *b, int level)
   178			{
   179			    dTHX;
   180			    SV **svp;
   181			    int type;
   182			
   183			    svp = hv_fetch(hv, "topbucket", 9, 1);
   184			    sv_setiv(*svp, b->buffer.topbucket);
   185			
   186			    svp = hv_fetch(hv, "topbucket_ev", 12, 1);
   187			    sv_setiv(*svp, b->buffer.topbucket_ev);
   188			
   189			    svp = hv_fetch(hv, "topbucket_odd", 13, 1);
   190			    sv_setiv(*svp, b->buffer.topbucket_odd);
   191			
   192			    svp = hv_fetch(hv, "totfree", 7, 1);
   193			    sv_setiv(*svp, b->buffer.totfree);
   194			
   195			    svp = hv_fetch(hv, "total", 5, 1);
   196			    sv_setiv(*svp, b->buffer.total);
   197			
   198			    svp = hv_fetch(hv, "total_chain", 11, 1);
   199			    sv_setiv(*svp, b->buffer.total_chain);
   200			
   201			    svp = hv_fetch(hv, "total_sbrk", 10, 1);
   202			    sv_setiv(*svp, b->buffer.total_sbrk);
   203			
   204			    svp = hv_fetch(hv, "sbrks", 5, 1);
   205			    sv_setiv(*svp, b->buffer.sbrks);
   206			
   207			    svp = hv_fetch(hv, "sbrk_good", 9, 1);
   208			    sv_setiv(*svp, b->buffer.sbrk_good);
   209			
   210			    svp = hv_fetch(hv, "sbrk_slack", 10, 1);
   211			    sv_setiv(*svp, b->buffer.sbrk_slack);
   212			
   213			    svp = hv_fetch(hv, "start_slack", 11, 1);
   214			    sv_setiv(*svp, b->buffer.start_slack);
   215			
   216			    svp = hv_fetch(hv, "sbrked_remains", 14, 1);
   217			    sv_setiv(*svp, b->buffer.sbrked_remains);
   218			    
   219			    svp = hv_fetch(hv, "minbucket", 9, 1);
   220			    sv_setiv(*svp, b->buffer.minbucket);
   221			    
   222			    svp = hv_fetch(hv, "nbuckets", 8, 1);
   223			    sv_setiv(*svp, b->buffer.nbuckets);
   224			
   225			    if (_NBUCKETS < b->buffer.nbuckets) 
   226				warn("FIXME: internal mstats buffer too short");
   227			    
   228			    for (type = 0; type < (level ? 4 : 2); type++) {
   229				UV *p = 0, *p1 = 0;
   230				AV *av;
   231				int i;
   232				static const char *types[4] = { 
   233				    "free", "used", "mem_size", "available_size"    
   234				};
   235			
   236				svp = hv_fetch(hv, types[type], strlen(types[type]), 1);
   237			
   238				if (SvOK(*svp) && !(SvROK(*svp) && SvTYPE(SvRV(*svp)) == SVt_PVAV))
   239				    croak("Unexpected value for the key '%s' in the mstats hash", types[type]);
   240				if (!SvOK(*svp)) {
   241				    av = newAV();
   242				    (void)SvUPGRADE(*svp, SVt_RV);
   243				    SvRV_set(*svp, (SV*)av);
   244				    SvROK_on(*svp);
   245				} else
   246				    av = (AV*)SvRV(*svp);
   247			
   248				av_extend(av, b->buffer.nbuckets - 1);
   249				/* XXXX What is the official way to reduce the size of the array? */
   250				switch (type) {
   251				case 0:
   252				    p = b->buffer.nfree;
   253				    break;
   254				case 1:
   255				    p = b->buffer.ntotal;
   256				    p1 = b->buffer.nfree;
   257				    break;
   258				case 2:
   259				    p = b->buffer.bucket_mem_size;
   260				    break;
   261				case 3:
   262				    p = b->buffer.bucket_available_size;
   263				    break;
   264				}
   265				for (i = 0; i < b->buffer.nbuckets; i++) {
   266				    svp = av_fetch(av, i, 1);
   267				    if (type == 1)
   268					sv_setiv(*svp, p[i]-p1[i]);
   269				    else
   270					sv_setuv(*svp, p[i]);
   271				}
   272			    }
   273			}
   274			
   275			static void
   276			mstats_fillhash(SV *sv, int level)
   277			{
   278			    struct mstats_buffer buf;
   279			
   280			    if (!(SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVHV))
   281				croak("Not a hash reference");
   282			    _fill_mstats(&buf, level);
   283			    _mstats_to_hv((HV *)SvRV(sv), &buf, level);
   284			}
   285			
   286			static void
   287			mstats2hash(SV *sv, SV *rv, int level)
   288			{
   289			    if (!(SvROK(rv) && SvTYPE(SvRV(rv)) == SVt_PVHV))
   290				croak("Not a hash reference");
   291			    if (!SvPOK(sv))
   292				croak("Undefined value when expecting mstats buffer");
   293			    if (SvCUR(sv) != sizeof(struct mstats_buffer))
   294				croak("Wrong size for a value with a mstats buffer");
   295			    _mstats_to_hv((HV *)SvRV(rv), (struct mstats_buffer*)SvPVX(sv), level);
   296			}
   297			#else	/* !( defined(PERL_DEBUGGING_MSTATS) || defined(DEBUGGING_MSTATS) \ ) */ 
   298			static void
   299			fill_mstats(SV *sv, int level)
   300	      ######    {
   301	      ######        croak("Cannot report mstats without Perl malloc");
   302			}
   303			
   304			static void
   305			mstats_fillhash(SV *sv, int level)
   306	      ######    {
   307	      ######        croak("Cannot report mstats without Perl malloc");
   308			}
   309			
   310			static void
   311			mstats2hash(SV *sv, SV *rv, int level)
   312	      ######    {
   313	      ######        croak("Cannot report mstats without Perl malloc");
   314			}
   315			#endif	/* defined(PERL_DEBUGGING_MSTATS) || defined(DEBUGGING_MSTATS)... */ 
   316			
   317			#define _CvGV(cv)					\
   318				(SvROK(cv) && (SvTYPE(SvRV(cv))==SVt_PVCV)	\
   319				 ? SvREFCNT_inc(CvGV((CV*)SvRV(cv))) : &PL_sv_undef)
   320			
   321			MODULE = Devel::Peek		PACKAGE = Devel::Peek
   322			
   323			void
   324			mstat(str="Devel::Peek::mstat: ")
   325			char *str
   326			
   327			void
   328			fill_mstats(SV *sv, int level = 0)
   329			
   330			void
   331			mstats_fillhash(SV *sv, int level = 0)
   332			    PROTOTYPE: \%;$
   333			
   334			void
   335			mstats2hash(SV *sv, SV *rv, int level = 0)
   336			    PROTOTYPE: $\%;$
   337			
   338			void
   339			Dump(sv,lim=4)
   340			SV *	sv
   341			I32	lim
   342			PPCODE:
   343			{
   344	          22        SV *pv_lim_sv = perl_get_sv("Devel::Peek::pv_limit", FALSE);
   345	          22        const STRLEN pv_lim = pv_lim_sv ? SvIV(pv_lim_sv) : 0;
   346	          22        SV *dumpop = perl_get_sv("Devel::Peek::dump_ops", FALSE);
   347	          22        const I32 save_dumpindent = PL_dumpindent;
   348	          22        PL_dumpindent = 2;
   349	          22        do_sv_dump(0, Perl_debug_log, sv, 0, lim,
   350	      ######    	       (bool)(dumpop && SvTRUE(dumpop)), pv_lim);
   351	          22        PL_dumpindent = save_dumpindent;
   352			}
   353			
   354			void
   355			DumpArray(lim,...)
   356			I32	lim
   357			PPCODE:
   358			{
   359	      ######        long i;
   360	      ######        SV *pv_lim_sv = perl_get_sv("Devel::Peek::pv_limit", FALSE);
   361	      ######        const STRLEN pv_lim = pv_lim_sv ? SvIV(pv_lim_sv) : 0;
   362	      ######        SV *dumpop = perl_get_sv("Devel::Peek::dump_ops", FALSE);
   363	      ######        const I32 save_dumpindent = PL_dumpindent;
   364	      ######        PL_dumpindent = 2;
   365			
   366	      ######        for (i=1; i<items; i++) {
   367	      ######    	PerlIO_printf(Perl_debug_log, "Elt No. %ld  0x%"UVxf"\n", i - 1, PTR2UV(ST(i)));
   368	      ######    	do_sv_dump(0, Perl_debug_log, ST(i), 0, lim,
   369	      ######    		   (bool)(dumpop && SvTRUE(dumpop)), pv_lim);
   370			    }
   371	      ######        PL_dumpindent = save_dumpindent;
   372			}
   373			
   374			void
   375			DumpProg()
   376			PPCODE:
   377			{
   378	      ######        warn("dumpindent is %d", (int)PL_dumpindent);
   379	      ######        if (PL_main_root)
   380	      ######    	op_dump(PL_main_root);
   381			}
   382			
   383			I32
   384			SvREFCNT(sv)
   385			SV *	sv
   386			
   387			# PPCODE needed since otherwise sv_2mortal is inserted that will kill the value.
   388			
   389			SV *
   390			SvREFCNT_inc(sv)
   391			SV *	sv
   392			PPCODE:
   393			{
   394	      ######        RETVAL = SvREFCNT_inc(sv);
   395	      ######        PUSHs(RETVAL);
   396			}
   397			
   398			# PPCODE needed since by default it is void
   399			
   400			void
   401			SvREFCNT_dec(sv)
   402			SV *	sv
   403			PPCODE:
   404			{
   405	      ######        SvREFCNT_dec(sv);
   406	      ######        PUSHs(sv);
   407			}
   408			
   409			SV *
   410			DeadCode()
   411			CODE:
   412	      ######        RETVAL = DeadCode(aTHX);
   413			OUTPUT:
   414			    RETVAL
   415			
   416			MODULE = Devel::Peek		PACKAGE = Devel::Peek	PREFIX = _
   417			
   418			SV *
   419			_CvGV(cv)
   420			    SV *cv
   421			
   422			bool
   423			_runops_debug(int flag = -1)