Enbugger.xs

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

/*
 * COPYRIGHT AND LICENCE
 *
 * Copyright (C) 2007,2008 WhitePages.com, Inc. with primary development by
 * Joshua ben Jore.
 *
 * This program is distributed WITHOUT ANY WARRANTY, including but not
 * limited to the implied warranties of merchantability or fitness for
 * a particular purpose.
 *
 * The program is free software.  You may distribute it and/or modify
 * it under the terms of the GNU General Public License as published
 * by the Free Software Foundation (either version 2 or any later
 * version) and the Perl Artistic License as published by O’Reilly
 * Media, Inc.  Please open the files named gpl-2.0.txt and Artistic
 * for a copy of these licenses.
 */


/*
 * Debugging diagnostics.
 */
#define DEBUG (!!EnbuggerDebugMode)
I32 EnbuggerDebugMode = 0;


/*
 * The ENBUGGER_DEBUG environment variable toggles debugging. It is
 * checked once during module loading.
 */
static void
set_debug_from_environment(pTHX)
{
  HV *env_hv;
  SV **svp;

  /* Fetch %ENV. */
  env_hv = get_hv("main::ENV",0);
  if ( ! env_hv ) {
    /* Does this ever happen? */
    Perl_croak(aTHX_ "Couldn't fetch %%ENV hash");
  }

  /* Fetch $ENV{ENBUGGER_DEBUG}. */
  svp = hv_fetch(env_hv,"ENBUGGER_DEBUG",0,0);
  if ( ! ( svp && *svp )) {
    EnbuggerDebugMode = 0;
    return;
  }
  
  EnbuggerDebugMode = SvTRUE( *svp );
}


/*
 * Set a nextstate/dbstate op's op_type and op_ppaddr.
 */
static void
alter_cop( pTHX_ SV *rv, I32 op_type )
{
  SV  *sv;
  COP *cop;


  /*
   * Validate that rv is a B::COP object and it has an IV to vetch.
   */
  if (!( sv_isobject(rv)
	 && sv_isa(rv, "B::COP")
	 && SvOK( sv = SvRV(rv) )
	 && SvIOK(sv) )) {
    if ( DEBUG ) {
      PerlIO_printf(Perl_debug_log, "Enbugger: SvOK(o)=%"UVuf" SvROK(o)=%"UVuf" SvIOK(SvRV(o))=%"UVuf"\n",
          SvOK(sv), SvROK(sv), SvIOK(SvRV(sv)));
    }
    Perl_croak(aTHX_ "Expecting a B::COP object");
  }


  /*
   * Change the type of the COP and the function pointer.
   *
   * TODO: stop hardcoding the values OP_DBSTATE and Perl_pp*. This
   * could be the result of a lookup function. It is allowed 
   */
  cop = INT2PTR( COP*, SvIV(sv) );
  cop->op_type = op_type;
  cop->op_ppaddr =
    op_type == OP_DBSTATE ? Perl_pp_dbstate : Perl_pp_nextstate;

  return;
}






/*
 * All future compilation will result in code without
 * breakpoints. This is typical for code that belongs to debuggers all
 * of which is ordinarily in the DB package.
 *
 * TODO: save off the old values. If the user ever wanted to change
 * these values outside of this module, we'd never know. We should.
 */
static void
compile_with_nextstate() {
  PL_ppaddr[OP_NEXTSTATE]
    = PL_ppaddr[OP_DBSTATE]
    = Perl_pp_nextstate;
}


/*
 * All future compilation will result in code with breakpoints.
 */
static void
compile_with_dbstate() {
  PL_ppaddr[OP_NEXTSTATE]
    = PL_ppaddr[OP_DBSTATE]
    = Perl_pp_dbstate;
}






MODULE = Enbugger PACKAGE = Enbugger PREFIX = Enbugger_

PROTOTYPES: DISABLE







=pod

Enable XS debugging.

=cut

void
Enbugger_debug( state )
        I32 state
    CODE:
        EnbuggerDebugMode = state;




=pod

Hooks or unhooks a given B::COP object.

=cut

void
Enbugger__nextstate_cop( o )
    SV * o
  CODE:
    alter_cop( aTHX_ o, OP_NEXTSTATE );

void
Enbugger__dbstate_cop( o )
    SV * o
  CODE:
    alter_cop( aTHX_ o, OP_DBSTATE );





=pod

From perl, state that future compilation will have or not have breakpoint dbstate ops.

=cut

void
Enbugger__compile_with_nextstate(class)
    SV *class
  CODE:
    compile_with_nextstate();

void
Enbugger__compile_with_dbstate(class)
    SV *class
  CODE:
    compile_with_dbstate();




=pod

A perl-available way to initialize various debugger variables like
PL_DBsub.

=cut

void
Enbugger_init_debugger( SV* class )
  CODE:
    if ( DEBUG ) {
      PerlIO_printf(Perl_debug_log,"Enbugger: Initializing debugger\n");
    }

    init_debugger();
    PL_perldb = PERLDB_ALL;




=pod

Sets RMAGIC on the %_<$filename hashes.

=cut

void
Enbugger_set_magic_dbfile(rv)
    SV *rv
  INIT:
    HV *hv;
  CODE:
    assert(SvROK(rv));

    hv = (HV*) SvRV(rv);
    assert(SVt_PVHV == SvTYPE(hv));
    hv_magic(hv, NULL, PERL_MAGIC_dbfile);




=pod

Sets up some things thatE<apos>ll be needed for debugging later on. These
may need to be moved into individual "off" and "on" functions so more
of the runtime is cleaned up after loading this module.

=cut

BOOT:
    set_debug_from_environment(aTHX);

    if ( PL_DBgv ) {
      if ( DEBUG ) {
        PerlIO_printf(Perl_debug_log,"Enbugger: Debugger is already loaded\n" );
      }
    }
    else {
      if ( DEBUG ) {
        PerlIO_printf(Perl_debug_log,"Enbugger: Initializing debugger during Enbugger boot\n");
      }
      
      /*
       * Copied right out ouf perl.c. I have no idea what this is used
       * for. I've got the idea that maybe something depends on this
       * so I'm including it for now or until I find out that I'm just
       * cargo-culting something inappropriate.
       */
      sv_setpvn(PERL_DEBUG_PAD(0), "", 0);  /* For regex debugging. */
      sv_setpvn(PERL_DEBUG_PAD(1), "", 0);  /* ext/re needs these */
      sv_setpvn(PERL_DEBUG_PAD(2), "", 0);  /* even without DEBUGGING */
      

      /*
       * It is *mandatory* to initialize the debugger before changing
       * PL_ppaddr. This is to avoid ever compiling code that uses
       * Perl_pp_dbstate without having the required PL_DBsingle, etc
       * variables
       *
       * This will need to be reinitialized again later when an actual
       * debugger is present.
       */
      init_debugger();
    }

MODULE = Enbugger PACKAGE = Enbugger::NYTProf PREFIX = Enbugger_NYTProf_

PROTOTYPES: DISABLE

void
Enbugger_NYTProf_instrument_op(... )
  INIT:
    SV *sv;
    OP *op;
    void *a;
    void *b;
  CODE:
    if (!( SvOK(ST(0))
           && SvROK(ST(0))
           && SvOK( sv = SvRV(ST(0)) )
           && SvIOK(sv) )) {
      return;
    }

    op = INT2PTR(OP*, SvIV(sv));
    if ( PL_ppaddr[op->op_type] != op->op_ppaddr ) {
      op->op_ppaddr = PL_ppaddr[op->op_type];
    }

MODULE = Enbugger PACKAGE = Enbugger PREFIX = Enbugger_

## Local Variables:
## mode: c
## mode: auto-fill
## End: