#include "EXTERN.h"
#include "perl.h"
#include "XSUB.h"
#define NEED_PL_parser_GLOBAL
#define NEED_newRV_noinc_GLOBAL
#define NEED_sv_2pv_flags_GLOBAL
#include "ppport.h"
#include "hook_op_check.h"
#include "hook_op_ppaddr.h"
#ifndef CvISXSUB
# define CvISXSUB(cv) CvXSUB(cv)
#endif
static int trycatch_debug = 0;
STATIC I32
dump_cxstack()
{
I32 i;
for (i = cxstack_ix; i >= 0; i--) {
register const PERL_CONTEXT * const cx = cxstack+i;
switch (CxTYPE(cx)) {
default:
continue;
case CXt_EVAL:
printf("***\n* eval stack %d: WA: %d\n", (int)i, cx->blk_gimme);
/* sv_dump((SV*)cx->blk_eval.cv); */
break;
case CXt_SUB:
printf("***\n* cx stack %d: WA: %d\n", (int)i, cx->blk_gimme);
sv_dump((SV*)cx->blk_sub.cv);
break;
}
}
return i;
}
/* Return the (array)context of the first subroutine context up the Cx stack */
int get_sub_context()
{
I32 i;
for (i = cxstack_ix; i >= 0; i--) {
register const PERL_CONTEXT * const cx = cxstack+i;
switch (CxTYPE(cx)) {
default:
continue;
case CXt_SUB:
return cx->blk_gimme;
}
}
return G_VOID;
}
/* the implementation of 'return' op inside try blocks. */
STATIC OP*
try_return (pTHX_ OP *op, void *user_data) {
dSP;
SV* ctx;
CV *unwind;
PERL_UNUSED_VAR(op);
PERL_UNUSED_VAR(user_data);
ctx = get_sv("TryCatch::CTX", 0);
if (ctx) {
XPUSHs( ctx );
PUTBACK;
if (trycatch_debug & 2) {
printf("have a $CTX of %d\n", SvIV(ctx));
}
} else {
PUSHMARK(SP);
PUTBACK;
call_pv("Scope::Upper::SUB", G_SCALAR);
if (trycatch_debug & 2) {
printf("No ctx, making it up\n");
}
SPAGAIN;
}
if (trycatch_debug & 2) {
printf("unwinding to %d\n", (int)SvIV(*sp));
}
/* Can't use call_sv et al. since it resets PL_op. */
/* call_pv("Scope::Upper::unwind", G_VOID); */
unwind = get_cv("Scope::Upper::unwind", 0);
XPUSHs( (SV*)unwind);
PUTBACK;
/* pp_entersub gets the XSUB arguments from @_ if there are any.
* Bypass this as we pushed the arguments directly on the stack. */
if (CvISXSUB(unwind))
AvFILLp(GvAV(PL_defgv)) = -1;
return CALL_FPTR(PL_ppaddr[OP_ENTERSUB])(aTHX);
}
/* The implementation of wantarray op/keyword inside try blocks. */
STATIC OP*
try_wantarray( pTHX_ OP *op, void *user_data ) {
dVAR;
dSP;
EXTEND(SP, 1);
PERL_UNUSED_VAR(op);
PERL_UNUSED_VAR(user_data);
/* We want the context from the closest subroutine, not from the closest
* block
*/
switch ( get_sub_context() ) {
case G_ARRAY:
RETPUSHYES;
case G_SCALAR:
RETPUSHNO;
default:
RETPUSHUNDEF;
}
}
/* After the scope has been created, fix up the context of the C<eval {}> block */
STATIC OP*
try_after_entertry(pTHX_ OP *op, void *user_data) {
PERL_CONTEXT * cx = cxstack+cxstack_ix;
cx->blk_gimme = get_sub_context();
return op;
}
STATIC OP*
hook_if_correct_file( pTHX_ OP *op, void* user_data ) {
SV* eval_is_try;
const char* wanted_file = SvPV_nolen( (SV*)user_data );
const char* cur_file = CopFILE( &PL_compiling );
if ( strcmp(wanted_file, cur_file) ) {
if ( trycatch_debug & 4 )
Perl_warn( aTHX_ "Not hooking OP %s since its not in '%s'", PL_op_name[op->op_type], wanted_file );
return op;
}
if (trycatch_debug & 4) {
Perl_warn(aTHX_ "hooking OP %s", PL_op_name[op->op_type]);
}
switch (op->op_type) {
case OP_WANTARRAY:
hook_op_ppaddr(op, try_wantarray, NULL);
break;
case OP_RETURN:
hook_op_ppaddr(op, try_return, NULL);
break;
#if (PERL_BCDVERSION < 0x5011000)
case OP_ENTEREVAL:
/* Do nothing if its still an entereval */
break;
#endif
case OP_LEAVETRY:
/* eval {} starts off as an OP_ENTEREVAL, and then the PL_check[OP_ENTEREVAL]
returns a newly created ENTERTRY (and LEAVETRY) ops without calling the
PL_check for these new ops into OP_ENTERTRY. How ever versions prior to perl
5.10.1 didn't call the PL_check for these new ops */
hook_if_correct_file( aTHX_ ((LISTOP*)op)->op_first, user_data );
break;
case OP_ENTERTRY:
eval_is_try = get_sv("TryCatch::NEXT_EVAL_IS_TRY", 0);
if ( eval_is_try && SvOK( eval_is_try ) && SvTRUE( eval_is_try ) ) {
/* We've hooked a try block, so reset the flag */
SvIV_set( eval_is_try, 0 );
hook_op_ppaddr_around( op, NULL, try_after_entertry, NULL );
}
break;
default:
fprintf(stderr, "Try Catch Internal Error: Unknown op %d: %s\n", op->op_type, PL_op_name[op->op_type]);
abort();
}
return op;
}
/* Hook all the *_check functions we need. Return an arrayref of:
*
* [ current_file_name, op_id, hook_id, op_id, hook_id, ... ]
*/
SV*
xs_install_op_checks() {
SV *sv_curfile = newSV( 0 );
AV* av = newAV();
/* Get the filename we install check op hooks into. Need this so that we
don't hook ops if a require Other::Module happens in a try block. */
char* file = CopFILE(&PL_compiling);
STRLEN len = strlen(file);
(void)SvUPGRADE(sv_curfile,SVt_PVNV);
sv_setpvn(sv_curfile,file,len);
av_push(av, sv_curfile);
#define do_hook(op) \
av_push(av, newSVuv( (op) ) ); \
av_push(av, newSVuv( hook_op_check( op, hook_if_correct_file, sv_curfile ) ) ); \
/* This replace return with an unwird */
do_hook( OP_RETURN );
/* This fixes 'wantarray' keyword */
do_hook( OP_WANTARRAY );
/* And this gives the right context to C<return foo()> in a try block */
do_hook( OP_ENTERTRY );
#if (PERL_BCDVERSION < 0x5011000)
/* Prior to 5.10.1(?) the ENTERTRY starts out as an ENTEREVAL and doesn't get
* PL_checked, so we need to hook ENTEREVAL (string eval) too and see if the
* type got changed. */
do_hook( OP_ENTEREVAL );
#endif
#undef do_hook
/* Get an array ref form the array, return that. This keeps the sv_curfile alive */
return newRV_noinc( (SV*) av );
}
MODULE = TryCatch PACKAGE = TryCatch::XS
PROTOTYPES: DISABLE
void
install_op_checks()
CODE:
ST(0) = xs_install_op_checks();
XSRETURN(1);
void
uninstall_op_checks( aref )
SV* aref;
PREINIT:
AV* av;
SV *op, *id;
CODE:
if ( !SvROK(aref) && SvTYPE(SvRV(aref)) != SVt_PVAV ) {
Perl_croak(aTHX_ "ArrayRef expected");
}
av = (AV*)(SvRV(aref));
/* throw away cur_file */
av_shift(av);
while (av_len(av) != -1) {
op = av_shift(av);
id = av_shift(av);
hook_op_check_remove( SvUV(op), SvUV(id) );
}
OUTPUT:
void dump_stack()
CODE:
dump_cxstack();
OUTPUT:
void set_linestr_offset(int offset)
CODE:
char* linestr = SvPVX(PL_linestr);
PL_bufptr = linestr + offset;
BOOT:
{
char *debug = getenv ("TRYCATCH_DEBUG");
/* Debug meanings:
1 - line string changes (from the .pm)
2 - Debug unwid contexts
4 - debug op hooking
*/
if (debug && (trycatch_debug = atoi(debug)) ) {
fprintf(stderr, "TryCatch XS debug enabled: %d\n", trycatch_debug);
}
}