easyxs_debug.h

#ifndef EASYXS_DEBUG_H
#define EASYXS_DEBUG_H 1

#include "init.h"

/* The following is courtesy of Paul Evans: */

#define exs_debug_sv_summary(sv)  S_debug_sv_summary(aTHX_ sv)

/* ------------------------------------------------------------ */

static inline void S_debug_sv_summary(pTHX_ const SV *sv)
{
  const char *type;

  if(!sv) {
    PerlIO_printf(Perl_debug_log, "NULL");
    return;
  }

  if(sv == &PL_sv_undef) {
    PerlIO_printf(Perl_debug_log, "SV=undef");
    return;
  }
  if(sv == &PL_sv_no) {
    PerlIO_printf(Perl_debug_log, "SV=false");
    return;
  }
  if(sv == &PL_sv_yes) {
    PerlIO_printf(Perl_debug_log, "SV=true");
    return;
  }

  switch(SvTYPE(sv)) {
    case SVt_NULL: type = "NULL"; break;
    case SVt_IV:   type = "IV";   break;
    case SVt_NV:   type = "NV";   break;
    case SVt_PV:   type = "PV";   break;
    case SVt_PVIV: type = "PVIV"; break;
    case SVt_PVNV: type = "PVNV"; break;
    case SVt_PVGV: type = "PVGV"; break;
    case SVt_PVAV: type = "PVAV"; break;
    case SVt_PVHV: type = "PVHV"; break;
    case SVt_PVCV: type = "PVCV"; break;
    default: {
      char buf[16];
      snprintf(buf, sizeof(buf), "(%d)", SvTYPE(sv));
      type = buf;
      break;
    }
  }

  if(SvROK(sv))
    type = "RV";

  PerlIO_printf(Perl_debug_log, "SV{type=%s,refcnt=%" IVdf, type, (IV) SvREFCNT(sv));

  if(SvTEMP(sv))
    PerlIO_printf(Perl_debug_log, ",TEMP");
  if(SvOBJECT(sv))
    PerlIO_printf(Perl_debug_log, ",blessed=%s", HvNAME(SvSTASH(sv)));

  switch(SvTYPE(sv)) {
    case SVt_PVAV:
      PerlIO_printf(Perl_debug_log, ",FILL=%d", (int) AvFILL((AV *)sv));
      break;

    default:
      /* regular scalars */
      if(SvROK(sv))
        PerlIO_printf(Perl_debug_log, ",ROK");
      else {
        if(SvIOK(sv))
          PerlIO_printf(Perl_debug_log, ",IV=%" IVdf, SvIVX(sv));
        if(SvUOK(sv))
          PerlIO_printf(Perl_debug_log, ",UV=%" UVuf, SvUVX(sv));
        if(SvPOK(sv)) {
          PerlIO_printf(Perl_debug_log, ",PVX=\"%.10s\"", SvPVX((SV *)sv));
          if(SvCUR(sv) > 10)
            PerlIO_printf(Perl_debug_log, "...");
        }
      }
      break;
  }

  PerlIO_printf(Perl_debug_log, "}");
}

#ifdef CX_CUR

#define exs_debug_showstack(pattern, ...)  S_debug_showstack(aTHX_ pattern, ##__VA_ARGS__)

static inline void S_debug_showstack(pTHX_ const char *pattern, ...)
{
  SV **sp;

  va_list ap;
  va_start(ap, pattern);

  if (!pattern) pattern = "Stack";

  PerlIO_vprintf(Perl_debug_log, pattern, ap);
  PerlIO_printf(Perl_debug_log, "\n");
  va_end(ap);

  PERL_CONTEXT *cx = CX_CUR();

  I32 floor = cx->blk_oldsp;
  I32 *mark = PL_markstack + cx->blk_oldmarksp + 1;

  PerlIO_printf(Perl_debug_log, "  TOPMARK=%d, floor = %d\n", (int) TOPMARK, (int) floor);
  PerlIO_printf(Perl_debug_log, "  marks (TOPMARK=@%" IVdf "):\n", (IV) (TOPMARK - floor));
  for(; mark <= PL_markstack_ptr; mark++)
    PerlIO_printf(Perl_debug_log,  "    @%" IVdf "\n", (IV) (*mark - floor));

  mark = PL_markstack + cx->blk_oldmarksp + 1;
  for(sp = PL_stack_base + floor + 1; sp <= PL_stack_sp; sp++) {
    PerlIO_printf(Perl_debug_log, sp == PL_stack_sp ? "-> " : "   ");
    PerlIO_printf(Perl_debug_log, "%p = ", *sp);
    S_debug_sv_summary(aTHX_ *sp);
    while(mark <= PL_markstack_ptr && PL_stack_base + *mark == sp)
      PerlIO_printf(Perl_debug_log, " [*M]"), mark++;
    PerlIO_printf(Perl_debug_log, "\n");
  }
}
#endif

/*
void static inline exs_debug_showmark_stack(pTHX) {
    PerlIO_printf(Perl_debug_log, "MARK STACK (start=%p; cur=%p, offset=%d):\n", PL_markstack, PL_markstack_ptr, (int) (PL_markstack_ptr - PL_markstack));
    I32 *mp = PL_markstack;
    while (mp != PL_markstack_max) {
        const char* pattern = (mp == PL_markstack_ptr ? "[%d]" : "%d");
        PerlIO_printf(Perl_debug_log, pattern, *mp++);
        PerlIO_printf(Perl_debug_log, (mp == PL_markstack_max) ? "\n" : ",");
    }
}
*/

#endif