X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=Declare.xs;h=9b840453a117478c2d40594b7373664e2016c09e;hb=9bbd73fb5569e01b90f48513765712a63d34ea1b;hp=b11d65db929214231d84af179c79038c9a4907ea;hpb=023db2fba97b8b676d5ab45c99328b66409151b4;p=p5sagit%2FDevel-Declare.git diff --git a/Declare.xs b/Declare.xs index b11d65d..9b84045 100644 --- a/Declare.xs +++ b/Declare.xs @@ -1,3 +1,4 @@ +#define PERL_NO_GET_CONTEXT 1 #include "EXTERN.h" #include "perl.h" #include "XSUB.h" @@ -26,9 +27,15 @@ static int dd_debug = 0; #define DD_CONST_VIA_RV2CV PERL_VERSION_GE(5,11,2) +#define DD_GROW_VIA_BLOCKHOOK PERL_VERSION_GE(5,13,3) + #define LEX_NORMAL 10 #define LEX_INTERPNORMAL 9 +/* please try not to have a line longer than this :) */ + +#define DD_PREFERRED_LINESTR_SIZE 16384 + /* flag to trigger removal of temporary declaree sub */ static int in_declare = 0; @@ -57,6 +64,7 @@ int dd_is_declarator(pTHX_ char* name) { HV* is_declarator_pack_hash; SV** is_declarator_flag_ref; int dd_flags; + char* curstash_name; is_declarator = get_hv("Devel::Declare::declarators", FALSE); @@ -65,11 +73,12 @@ int dd_is_declarator(pTHX_ char* name) { /* $declarators{$current_package_name} */ - if (!HvNAME(PL_curstash)) + curstash_name = HvNAME(PL_curstash); + if (!curstash_name) return -1; - is_declarator_pack_ref = hv_fetch(is_declarator, HvNAME(PL_curstash), - strlen(HvNAME(PL_curstash)), FALSE); + is_declarator_pack_ref = hv_fetch(is_declarator, curstash_name, + strlen(curstash_name), FALSE); if (!is_declarator_pack_ref || !SvROK(*is_declarator_pack_ref)) return -1; /* not a hashref */ @@ -143,14 +152,17 @@ void dd_set_linestr(pTHX_ char* new_value) { PL_bufend = SvPVX(PL_linestr) + new_len; if ( DD_DEBUG_UPDATED_LINESTR && PERLDB_LINE && PL_curstash != PL_debstash) { - // Cribbed from toke.c - SV * const sv = NEWSV(85,0); - - sv_upgrade(sv, SVt_PVMG); - sv_setpvn(sv,PL_bufptr,PL_bufend-PL_bufptr); - (void)SvIOK_on(sv); - SvIV_set(sv, 0); - av_store(CopFILEAV(&PL_compiling),(I32)CopLINE(&PL_compiling),sv); + /* Cribbed from toke.c */ + AV *fileav = CopFILEAV(&PL_compiling); + if (fileav) { + SV * const sv = NEWSV(85,0); + + sv_upgrade(sv, SVt_PVMG); + sv_setpvn(sv,PL_bufptr,PL_bufend-PL_bufptr); + (void)SvIOK_on(sv); + SvIV_set(sv, 0); + av_store(fileav,(I32)CopLINE(&PL_compiling),sv); + } } } @@ -212,23 +224,30 @@ int dd_toke_scan_ident(pTHX_ int offset) { } int dd_toke_scan_str(pTHX_ int offset) { - STRLEN remaining = sv_len(PL_linestr) - offset; - SV* line_copy = newSVsv(PL_linestr); + char* old_pvx = SvPVX(PL_linestr); + SV* line_copy = sv_2mortal(newSVsv(PL_linestr)); char* base_s = SvPVX(PL_linestr) + offset; char* s = scan_str(base_s, FALSE, FALSE); - if (s != base_s && sv_len(PL_lex_stuff) > remaining) { - int ret = (s - SvPVX(PL_linestr)) + remaining; + if(SvPVX(PL_linestr) != old_pvx) + croak("PL_linestr reallocated during scan_str, " + "Devel::Declare can't continue"); + if (!s) + return 0; + if (s <= base_s || memcmp(SvPVX(line_copy), SvPVX(PL_linestr), offset)) { + s += SvCUR(line_copy); sv_catsv(line_copy, PL_linestr); dd_set_linestr(aTHX_ SvPV_nolen(line_copy)); - SvREFCNT_dec(line_copy); - return ret; } return s - base_s; } int dd_toke_skipspace(pTHX_ int offset) { + char* old_pvx = SvPVX(PL_linestr); char* base_s = SvPVX(PL_linestr) + offset; char* s = skipspace_force(base_s); + if(SvPVX(PL_linestr) != old_pvx) + croak("PL_linestr reallocated during skipspace, " + "Devel::Declare can't continue"); return s - base_s; } @@ -238,9 +257,9 @@ static void call_done_declare(pTHX) { if (DD_DEBUG_TRACE) { printf("Deconstructing declare\n"); printf("PL_bufptr: %s\n", PL_bufptr); - printf("bufend at: %i\n", PL_bufend - PL_bufptr); + printf("bufend at: %i\n", (int)(PL_bufend - PL_bufptr)); printf("linestr: %s\n", SvPVX(PL_linestr)); - printf("linestr len: %i\n", PL_bufend - SvPVX(PL_linestr)); + printf("linestr len: %i\n", (int)(PL_bufend - SvPVX(PL_linestr))); } ENTER; @@ -255,23 +274,41 @@ static void call_done_declare(pTHX) { if (DD_DEBUG_TRACE) { printf("PL_bufptr: %s\n", PL_bufptr); - printf("bufend at: %i\n", PL_bufend - PL_bufptr); + printf("bufend at: %i\n", (int)(PL_bufend - PL_bufptr)); printf("linestr: %s\n", SvPVX(PL_linestr)); - printf("linestr len: %i\n", PL_bufend - SvPVX(PL_linestr)); - printf("actual len: %i\n", strlen(PL_bufptr)); + printf("linestr len: %i\n", (int)(PL_bufend - SvPVX(PL_linestr))); + printf("actual len: %i\n", (int)strlen(PL_bufptr)); } } static int dd_handle_const(pTHX_ char *name); +#ifdef CV_NAME_NOTQUAL /* 5.21.5 */ +# define Gv_or_CvNAME(g) (isGV(g) \ + ? GvNAME(g) \ + : SvPV_nolen(cv_name((CV *)SvRV(g), NULL, CV_NAME_NOTQUAL))) +#elif defined(CvNAMED) /* 5.21.4 */ +# define Gv_or_CvNAME(g) (isGV(g) \ + ? GvNAME(g) \ + : CvNAMED(SvRV(g)) \ + ? HEK_KEY(CvNAME_HEK((CV *)SvRV(g))) \ + : GvNAME(CvGV(SvRV(g)))) +#else +# define Gv_or_CvNAME(g) GvNAME(g) +#endif + /* replacement PL_check rv2cv entry */ STATIC OP *dd_ck_rv2cv(pTHX_ OP *o, void *user_data) { OP* kid; int dd_flags; + char *gvname; PERL_UNUSED_VAR(user_data); + if (!DD_AM_LEXING) + return o; /* not lexing? */ + if (in_declare) { call_done_declare(aTHX); return o; @@ -282,14 +319,17 @@ STATIC OP *dd_ck_rv2cv(pTHX_ OP *o, void *user_data) { if (kid->op_type != OP_GV) /* not a GV so ignore */ return o; - if (!DD_AM_LEXING) - return o; /* not lexing? */ + if (!isGV(kGVOP_gv) + && (!SvROK(kGVOP_gv) || SvTYPE(SvRV(kGVOP_gv)) != SVt_PVCV)) + return o; + + gvname = Gv_or_CvNAME(kGVOP_gv); if (DD_DEBUG_TRACE) { - printf("Checking GV %s -> %s\n", HvNAME(GvSTASH(kGVOP_gv)), GvNAME(kGVOP_gv)); + printf("Checking GV %s -> %s\n", HvNAME(GvSTASH(kGVOP_gv)), gvname); } - dd_flags = dd_is_declarator(aTHX_ GvNAME(kGVOP_gv)); + dd_flags = dd_is_declarator(aTHX_ gvname); if (dd_flags == -1) return o; @@ -301,34 +341,45 @@ STATIC OP *dd_ck_rv2cv(pTHX_ OP *o, void *user_data) { #if DD_CONST_VIA_RV2CV if (PL_expect != XOPERATOR) { - if (!dd_handle_const(aTHX_ GvNAME(kGVOP_gv))) + if (!dd_handle_const(aTHX_ Gv_or_CvNAME(kGVOP_gv))) return o; CopLINE(PL_curcop) = PL_copline; /* The parser behaviour that we're simulating depends on what comes after the declarator. */ - if (*skipspace(PL_bufptr + strlen(GvNAME(kGVOP_gv))) != '(') { + if (*skipspace(PL_bufptr + strlen(gvname)) != '(') { if (in_declare) { call_done_declare(aTHX); } else { - dd_linestr_callback(aTHX_ "rv2cv", GvNAME(kGVOP_gv)); + dd_linestr_callback(aTHX_ "rv2cv", gvname); } } return o; } #endif /* DD_CONST_VIA_RV2CV */ - dd_linestr_callback(aTHX_ "rv2cv", GvNAME(kGVOP_gv)); + dd_linestr_callback(aTHX_ "rv2cv", gvname); return o; } +#if DD_GROW_VIA_BLOCKHOOK + +static void dd_block_start(pTHX_ int full) +{ + PERL_UNUSED_VAR(full); + if (SvLEN(PL_linestr) < DD_PREFERRED_LINESTR_SIZE) + (void) lex_grow_linestr(DD_PREFERRED_LINESTR_SIZE); +} + +#else /* !DD_GROW_VIA_BLOCKHOOK */ + OP* dd_pp_entereval(pTHX) { dSP; STRLEN len; const char* s; SV *sv; #ifdef PERL_5_9_PLUS - SV *saved_hh; + SV *saved_hh = NULL; if (PL_op->op_private & OPpEVAL_HAS_HH) { saved_hh = POPs; } @@ -347,7 +398,7 @@ OP* dd_pp_entereval(pTHX) { sv = sv_2mortal(newSVsv(sv)); sv_catpvn(sv, "\n;", 2); } - SvGROW(sv, 8192); + SvGROW(sv, DD_PREFERRED_LINESTR_SIZE); } PUSHs(sv); #ifdef PERL_5_9_PLUS @@ -366,11 +417,27 @@ STATIC OP *dd_ck_entereval(pTHX_ OP *o, void *user_data) { return o; } +#endif /* !DD_GROW_VIA_BLOCKHOOK */ + static I32 dd_filter_realloc(pTHX_ int idx, SV *sv, int maxlen) { + SV *filter_datasv; const I32 count = FILTER_READ(idx+1, sv, maxlen); - SvGROW(sv, 8192); /* please try not to have a line longer than this :) */ - /* filter_del(dd_filter_realloc); */ + SvGROW(sv, DD_PREFERRED_LINESTR_SIZE); + /* Filters can only be deleted in the correct order (reverse of the + order in which they were added). Insisting on deleting the filter + here would break if another filter were added after ours and is + still around. Not deleting the filter at all would break if another + filter were added earlier and attempts to delete itself later. + We can play nicely to the maximum possible extent by deleting our + filter iff it is currently deletable (i.e., it is on the top of + the filter stack). Can still run into trouble in more complex + situations, but can't avoid that. */ + if (PL_rsfp_filters && AvFILLp(PL_rsfp_filters) >= 0 && + (filter_datasv = FILTER_DATA(AvFILLp(PL_rsfp_filters))) && + IoANY(filter_datasv) == FPTR2DPTR(void *, dd_filter_realloc)) { + filter_del(dd_filter_realloc); + } return count; } @@ -459,23 +526,44 @@ STATIC OP *dd_ck_const(pTHX_ OP *o, void *user_data) { #endif /* !DD_CONST_VIA_RV2CV */ -static int initialized = 0; +STATIC void dd_initialize(pTHX) { + static int initialized = 0; + if (!initialized) { + initialized = 1; +#if DD_GROW_VIA_BLOCKHOOK + { + static BHK bhk; +#if PERL_VERSION_GE(5,13,6) + BhkENTRY_set(&bhk, bhk_start, dd_block_start); +#else /* <5.13.6 */ + BhkENTRY_set(&bhk, start, dd_block_start); +#endif /* <5.13.6 */ + Perl_blockhook_register(aTHX_ &bhk); + } +#else /* !DD_GROW_VIA_BLOCKHOOK */ + hook_op_check(OP_ENTEREVAL, dd_ck_entereval, NULL); +#endif /* !DD_GROW_VIA_BLOCKHOOK */ + hook_op_check(OP_RV2CV, dd_ck_rv2cv, NULL); +#if !DD_CONST_VIA_RV2CV + hook_op_check(OP_CONST, dd_ck_const, NULL); +#endif /* !DD_CONST_VIA_RV2CV */ + } +} MODULE = Devel::Declare PACKAGE = Devel::Declare PROTOTYPES: DISABLE void +initialize() + CODE: + dd_initialize(aTHX); + +void setup() CODE: - if (!initialized++) { - hook_op_check(OP_RV2CV, dd_ck_rv2cv, NULL); - hook_op_check(OP_ENTEREVAL, dd_ck_entereval, NULL); -#if !DD_CONST_VIA_RV2CV - hook_op_check(OP_CONST, dd_ck_const, NULL); -#endif /* !DD_CONST_VIA_RV2CV */ - } - filter_add(dd_filter_realloc, NULL); + dd_initialize(aTHX); + filter_add(dd_filter_realloc, NULL); char* get_linestr() @@ -529,10 +617,13 @@ toke_move_past_token(int offset); OUTPUT: RETVAL -int +SV* toke_scan_str(int offset); + PREINIT: + int len; CODE: - RETVAL = dd_toke_scan_str(aTHX_ offset); + len = dd_toke_scan_str(aTHX_ offset); + RETVAL = len ? newSViv(len) : &PL_sv_undef; OUTPUT: RETVAL