X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=Declare.xs;h=934f8f65f28b3aa54d5be676a796e33172ca667e;hb=6ed8c948bd71150fd1e1bb81a4d0959350924e16;hp=0474261ab56215931cb60cd2a60650fefe0d178a;hpb=a25db2dc4d4e0058d124775087b1b83453531007;p=p5sagit%2FDevel-Declare.git diff --git a/Declare.xs b/Declare.xs index 0474261..934f8f6 100644 --- a/Declare.xs +++ b/Declare.xs @@ -7,6 +7,12 @@ #include #include +#define PERL_VERSION_DECIMAL(r,v,s) (r*1000000 + v*1000 + s) +#define PERL_DECIMAL_VERSION \ + PERL_VERSION_DECIMAL(PERL_REVISION,PERL_VERSION,PERL_SUBVERSION) +#define PERL_VERSION_GE(r,v,s) \ + (PERL_DECIMAL_VERSION >= PERL_VERSION_DECIMAL(r,v,s)) + #ifndef Newx # define Newx(v,n,t) New(0,v,n,t) #endif /* !Newx */ @@ -18,6 +24,10 @@ #define DD_DEBUG_TRACE (dd_debug & DD_DEBUGf_TRACE) 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 @@ -224,41 +234,48 @@ int dd_toke_skipspace(pTHX_ int offset) { return s - base_s; } +static void call_done_declare(pTHX) { + dSP; + + 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("linestr: %s\n", SvPVX(PL_linestr)); + printf("linestr len: %i\n", PL_bufend - SvPVX(PL_linestr)); + } + + ENTER; + SAVETMPS; + + PUSHMARK(SP); + + call_pv("Devel::Declare::done_declare", G_VOID|G_DISCARD); + + FREETMPS; + LEAVE; + + if (DD_DEBUG_TRACE) { + printf("PL_bufptr: %s\n", PL_bufptr); + printf("bufend at: %i\n", 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)); + } +} + +static int dd_handle_const(pTHX_ char *name); + /* replacement PL_check rv2cv entry */ STATIC OP *dd_ck_rv2cv(pTHX_ OP *o, void *user_data) { - dSP; OP* kid; int dd_flags; PERL_UNUSED_VAR(user_data); if (in_declare) { - 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("linestr: %s\n", SvPVX(PL_linestr)); - printf("linestr len: %i\n", PL_bufend - SvPVX(PL_linestr)); - } - - ENTER; - SAVETMPS; - - PUSHMARK(SP); - - call_pv("Devel::Declare::done_declare", G_VOID|G_DISCARD); - - FREETMPS; - LEAVE; - - if (DD_DEBUG_TRACE) { - printf("PL_bufptr: %s\n", PL_bufptr); - printf("bufend at: %i\n", 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)); - } + call_done_declare(aTHX); return o; } @@ -284,11 +301,40 @@ STATIC OP *dd_ck_rv2cv(pTHX_ OP *o, void *user_data) { printf("PL_tokenbuf: %s\n", PL_tokenbuf); } +#if DD_CONST_VIA_RV2CV + if (PL_expect != XOPERATOR) { + if (!dd_handle_const(aTHX_ GvNAME(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 (in_declare) { + call_done_declare(aTHX); + } else { + dd_linestr_callback(aTHX_ "rv2cv", GvNAME(kGVOP_gv)); + } + } + return o; + } +#endif /* DD_CONST_VIA_RV2CV */ + dd_linestr_callback(aTHX_ "rv2cv", GvNAME(kGVOP_gv)); return o; } +#if DD_GROW_VIA_BLOCKHOOK + +static void dd_block_start(pTHX_ int full) +{ + PERL_UNUSED_VAR(full); + if (SvLEN(PL_linestr) < 8192) + (void) lex_grow_linestr(8192); +} + +#else /* !DD_GROW_VIA_BLOCKHOOK */ + OP* dd_pp_entereval(pTHX) { dSP; STRLEN len; @@ -341,33 +387,9 @@ static I32 dd_filter_realloc(pTHX_ int idx, SV *sv, int maxlen) return count; } -STATIC OP *dd_ck_const(pTHX_ OP *o, void *user_data) { - int dd_flags; - char* name; - - PERL_UNUSED_VAR(user_data); - - if (DD_HAVE_PARSER && PL_expect == XOPERATOR) { - return o; - } - - /* if this is set, we just grabbed a delimited string or something, - not a bareword, so NO TOUCHY */ - - if (DD_HAVE_LEX_STUFF) - return o; - - /* don't try and look this up if it's not a string const */ - if (!SvPOK(cSVOPo->op_sv)) - return o; - - name = SvPVX(cSVOPo->op_sv); - - dd_flags = dd_is_declarator(aTHX_ name); - - if (dd_flags == -1) - return o; +#endif /* !DD_GROW_VIA_BLOCKHOOK */ +static int dd_handle_const(pTHX_ char *name) { switch (PL_lex_inwhat) { case OP_QR: case OP_MATCH: @@ -375,14 +397,14 @@ STATIC OP *dd_ck_const(pTHX_ OP *o, void *user_data) { case OP_TRANS: case OP_BACKTICK: case OP_STRINGIFY: - return o; + return 0; break; default: break; } if (strnEQ(PL_bufptr, "->", 2)) { - return o; + return 0; } { @@ -394,15 +416,14 @@ STATIC OP *dd_ck_const(pTHX_ OP *o, void *user_data) { s = scan_word(s, buf, sizeof buf, FALSE, &len); if (strnEQ(buf, name, len)) { char *d; - SV *inject = newSVpv("", 0); - sv_catpvn(inject, SvPV_nolen(PL_linestr), PL_bufptr - SvPVX(PL_linestr)); + SV *inject = newSVpvn(SvPVX(PL_linestr), PL_bufptr - SvPVX(PL_linestr)); sv_catpvn(inject, buf, len); d = peekspace(s); sv_catpvn(inject, s, d - s); if ((PL_bufend - d) >= 2 && strnEQ(d, "=>", 2)) { - return o; + return 0; } sv_catpv(inject, d); @@ -414,9 +435,45 @@ STATIC OP *dd_ck_const(pTHX_ OP *o, void *user_data) { dd_linestr_callback(aTHX_ "const", name); + return 1; +} + +#if !DD_CONST_VIA_RV2CV + +STATIC OP *dd_ck_const(pTHX_ OP *o, void *user_data) { + int dd_flags; + char* name; + + PERL_UNUSED_VAR(user_data); + + if (DD_HAVE_PARSER && PL_expect == XOPERATOR) { + return o; + } + + /* if this is set, we just grabbed a delimited string or something, + not a bareword, so NO TOUCHY */ + + if (DD_HAVE_LEX_STUFF) + return o; + + /* don't try and look this up if it's not a string const */ + if (!SvPOK(cSVOPo->op_sv)) + return o; + + name = SvPVX(cSVOPo->op_sv); + + dd_flags = dd_is_declarator(aTHX_ name); + + if (dd_flags == -1) + return o; + + dd_handle_const(aTHX_ name); + return o; } +#endif /* !DD_CONST_VIA_RV2CV */ + static int initialized = 0; MODULE = Devel::Declare PACKAGE = Devel::Declare @@ -427,11 +484,25 @@ void setup() CODE: if (!initialized++) { - hook_op_check(OP_RV2CV, dd_ck_rv2cv, NULL); +#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 */ } +#if !DD_GROW_VIA_BLOCKHOOK filter_add(dd_filter_realloc, NULL); +#endif /* !DD_GROW_VIA_BLOCKHOOK */ char* get_linestr()