/* This code uses several internal APIs. I'm declaring PERL_CORE
 * purely so this is visible to anyone grepping CPAN for code that
 * does this sort of thing.
 *
 *   Copied and pasted structure of S_visit from sv.c
 *   Used PL_sv_arenaroot
 *   Used do_sv_dump (instead of sv_dump)
 *   Used pv_display
 */
#define PERL_CORE

#include "EXTERN.h"
#include "perl.h"
#include "XSUB.h"
#include "ppport.h"

void DumpPointer( pTHX_ PerlIO *f, SV *sv ) {
  if ( &PL_sv_undef == sv ) {
    PerlIO_puts(f, "PL_sv_undef");
  }
  else if (&PL_sv_yes == sv) {
    PerlIO_puts(f, "PL_sv_yes");
  }
  else if (&PL_sv_no == sv) {
    PerlIO_puts(f, "PL_sv_no");
  }
  else if (&PL_sv_placeholder) {
    PerlIO_printf(f, "%#x", (int)sv);
  }
}

void
DumpAvARRAY( pTHX_ PerlIO *f, SV *sv) {
  I32 key = 0;

  PerlIO_printf(f,"AvARRAY(%#x) = {",(int)AvARRAY(sv));
  if ( AvMAX(sv) != AvFILL(sv) ) {
    PerlIO_puts(f,"{");
  }
  
  for ( key = 0; key <= AvMAX(sv); ++key ) {
    DumpPointer(aTHX_ f, AvARRAY(sv)[key]);
    
    /* Join with something */
    if ( AvMAX(sv) == AvFILL(sv) ) {
      if (key != AvMAX(sv)) {
        PerlIO_puts(f, ",");
      }
    }
    else {
      PerlIO_puts(
        f,
        AvFILL(sv) == key ? "}{" :
        AvMAX(sv) == key  ? "}" :
        ","
      );
    }
  }
  PerlIO_puts(f,"}\n\n");
}

void
DumpHvARRAY( pTHX_ PerlIO *f, SV *sv) {
  I32 key = 0;
  HE *entry;
  SV *tmp = newSVpv("",0);

  PerlIO_printf(f,"HvARRAY(%#x)\n",(int)HvARRAY(sv));

  for ( key = 0; key <= HvMAX(sv); ++key ) {
    for ( entry = HvARRAY(sv)[key]; entry; entry = HeNEXT(entry) ) {
      if ( HEf_SVKEY == HeKLEN(entry) ) {
        PerlIO_printf(
          f, "  [SV %#x] => ",
          (int)HeKEY(entry));
      }
      else {
        PerlIO_printf(
          f, "  [%#x %s] => ",
          (int)HeKEY(entry),
          pv_display(
            tmp,
            HeKEY(entry), HeKLEN(entry), HeKLEN(entry),
            0 ));
      }
      DumpPointer(aTHX_ f, HeVAL(entry));
      PerlIO_puts(f, "\n");
    }
  }
  PerlIO_puts(f,"\n");

  SvREFCNT_dec(tmp);
}

/*
void
DumpHashKeys( aTHX_ PerlIO *f, SV *sv) {
  I32 key = 0;
  HE *entry;
  SV *tmp = newSVpv("",0);

  PerlIO_printf(f,"HASH KEYS at %#x\n",sv);
  
  for ( key = 0; key <= HvMAX(sv); ++key ) {
    for ( entry = HvARRAY(sv)[key]; entry; entry = HeNEXT(entry) ) {
      if ( HEf_SVKEY == HeKLEN(entry) ) {
        PerlIO_printf(f, "    SV %#x\n", HeKEY(entry) );
      }
      else {
        PerlIO_printf(f, "    %#x %s\n", HeKEY(entry), pv_display( (SV*)tmp, (const char*)HeKEY(entry), HeKLEN(entry), HeKLEN(entry), 0 ) );
      } 
    }
  }
  PerlIO_puts(f,"\n\n");

  SvREFCNT_dec(tmp);
}
*/

void
DumpArenasPerlIO( pTHX_ PerlIO *f) {
  SV *arena;
  
  for (arena = PL_sv_arenaroot; arena; arena = (SV*)SvANY(arena)) {
    const SV *const arena_end = &arena[SvREFCNT(arena)];
    SV *sv;

    /* See also the static function S_visit in perl's sv.c
     * This is a copied and pasted implementation of that function.
     */
    PerlIO_printf(f,"START ARENA = (%#x-%#x)\n\n",(int)arena,(int)arena_end);
    for (sv = arena + 1; sv < arena_end; ++sv) {
      if (SvTYPE(sv) != SVTYPEMASK
          && SvREFCNT(sv)) {

        /* Dump the plain SV */
        do_sv_dump(0,f,sv,0,0,0,0);
        PerlIO_puts(f,"\n");
        
        /* Dump AvARRAY(0x...) = {{0x...,0x...}{0x...}} */
        switch (SvTYPE(sv)) {
        case SVt_PVAV:
          if ( AvARRAY(sv)
               && AvMAX(sv) != -1 ) {
            DumpAvARRAY( aTHX_ f,sv);
          }
          break;
        case SVt_PVHV:
          if ( HvARRAY(sv)
               && HvMAX(sv) != -1 ) {
            DumpHvARRAY( aTHX_ f,sv);
          }
          
          if ( ! HvSHAREKEYS(sv) ) {
            /* DumpHashKeys( aTHX_ f,sv); */
          }
          
          break;
        }
      }
      else {
        PerlIO_printf(f,"AVAILABLE(%#x)\n\n",(int)sv);
      }
    }
    PerlIO_printf(f,"END ARENA = (%#x-%#x)\n\n",(int)arena,(int)arena_end);
  }
}

void
DumpArenas( pTHX ) {
  DumpArenasPerlIO( aTHX_ Perl_error_log );
}

void
DumpArenasFd( pTHX_ int fd ) {
  PerlIO *f = (PerlIO*)PerlIO_fdopen( fd, "w" );
  DumpArenasPerlIO( aTHX_ f );
}

MODULE = Internals::DumpArenas  PACKAGE = Internals::DumpArenas
  
PROTOTYPES: DISABLE

void
DumpArenas()
    CODE:
        DumpArenas( aTHX );

void
DumpArenasFd( int fn )
    CODE:
        DumpArenasFd( aTHX_ fn );