X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?p=p5sagit%2FDevel-Declare.git;a=blobdiff_plain;f=Declare.xs;h=9b840453a117478c2d40594b7373664e2016c09e;hp=1fa8897709332246572516846891fbc141c9ac1e;hb=892e0cc9aa9309bad92d4288819f0fff3b33a23a;hpb=d8e65fc873a8213746345ad11d613f5d1ee54f91 diff --git a/Declare.xs b/Declare.xs index 1fa8897..9b84045 100644 --- a/Declare.xs +++ b/Declare.xs @@ -1,134 +1,194 @@ -#define PERL_CORE -#define PERL_NO_GET_CONTEXT +#define PERL_NO_GET_CONTEXT 1 #include "EXTERN.h" #include "perl.h" #include "XSUB.h" +#include "hook_op_check.h" #undef printf #include "stolen_chunk_of_toke.c" #include #include -#define DD_HAS_TRAITS -#if 0 -#define DD_DEBUG -#endif +#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)) -#define DD_HANDLE_NAME 1 -#define DD_HANDLE_PROTO 2 -#define DD_HANDLE_PACKAGE 8 +#ifndef Newx +# define Newx(v,n,t) New(0,v,n,t) +#endif /* !Newx */ -#ifdef DD_DEBUG -#define DD_DEBUG_S printf("Buffer: %s\n", s); -#else -#define DD_DEBUG_S -#endif +#define DD_DEBUGf_UPDATED_LINESTR 1 +#define DD_DEBUGf_TRACE 2 + +#define DD_DEBUG_UPDATED_LINESTR (dd_debug & DD_DEBUGf_UPDATED_LINESTR) +#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 -/* placeholders for PL_check entries we wrap */ +/* please try not to have a line longer than this :) */ -STATIC OP *(*dd_old_ck_rv2cv)(pTHX_ OP *op); -STATIC OP *(*dd_old_ck_entereval)(pTHX_ OP *op); +#define DD_PREFERRED_LINESTR_SIZE 16384 /* flag to trigger removal of temporary declaree sub */ static int in_declare = 0; -/* replacement PL_check rv2cv entry */ +/* in 5.10, PL_parser will be NULL if we aren't parsing, and PL_lex_stuff + is a lookup into it - so if anything else we can use to tell, so we + need to be a bit more careful if PL_parser exists */ -STATIC OP *dd_ck_rv2cv(pTHX_ OP *o) { - OP* kid; - char* s; - char* save_s; - char tmpbuf[sizeof PL_tokenbuf]; - char found_name[sizeof PL_tokenbuf]; - char* found_proto = NULL, *found_traits = NULL; - STRLEN len = 0; - HV *stash; +#define DD_AM_LEXING_CHECK (PL_lex_state == LEX_NORMAL || PL_lex_state == LEX_INTERPNORMAL) + +#if defined(PL_parser) || defined(PERL_5_9_PLUS) +#define DD_HAVE_PARSER PL_parser +#define DD_HAVE_LEX_STUFF (PL_parser && PL_lex_stuff) +#define DD_AM_LEXING (PL_parser && DD_AM_LEXING_CHECK) +#else +#define DD_HAVE_PARSER 1 +#define DD_HAVE_LEX_STUFF PL_lex_stuff +#define DD_AM_LEXING DD_AM_LEXING_CHECK +#endif + +/* thing that decides whether we're dealing with a declarator */ + +int dd_is_declarator(pTHX_ char* name) { HV* is_declarator; SV** is_declarator_pack_ref; HV* is_declarator_pack_hash; SV** is_declarator_flag_ref; int dd_flags; - char* cb_args[6]; - dSP; /* define stack pointer for later call stuff */ - char* retstr; - STRLEN n_a; /* for POPpx */ - - o = dd_old_ck_rv2cv(aTHX_ o); /* let the original do its job */ - - if (in_declare) { - cb_args[0] = NULL; -#ifdef DD_DEBUG - 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)); -#endif - call_argv("Devel::Declare::done_declare", G_VOID|G_DISCARD, cb_args); - in_declare--; -#ifdef DD_DEBUG - 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)); -#endif - return o; - } - - kid = cUNOPo->op_first; - - if (kid->op_type != OP_GV) /* not a GV so ignore */ - return o; - - if (PL_lex_state != LEX_NORMAL && PL_lex_state != LEX_INTERPNORMAL) - return o; /* not lexing? */ - - stash = GvSTASH(kGVOP_gv); - -#ifdef DD_DEBUG - printf("Checking GV %s -> %s\n", HvNAME(stash), GvNAME(kGVOP_gv)); -#endif + char* curstash_name; is_declarator = get_hv("Devel::Declare::declarators", FALSE); if (!is_declarator) - return o; + return -1; + + /* $declarators{$current_package_name} */ + + curstash_name = HvNAME(PL_curstash); + if (!curstash_name) + return -1; - is_declarator_pack_ref = hv_fetch(is_declarator, HvNAME(stash), - strlen(HvNAME(stash)), 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 o; /* not a hashref */ + return -1; /* not a hashref */ is_declarator_pack_hash = (HV*) SvRV(*is_declarator_pack_ref); - is_declarator_flag_ref = hv_fetch(is_declarator_pack_hash, GvNAME(kGVOP_gv), - strlen(GvNAME(kGVOP_gv)), FALSE); + /* $declarators{$current_package_name}{$name} */ + + is_declarator_flag_ref = hv_fetch( + is_declarator_pack_hash, name, + strlen(name), FALSE + ); /* requires SvIOK as well as TRUE since flags not being an int is useless */ if (!is_declarator_flag_ref - || !SvIOK(*is_declarator_flag_ref) + || !SvIOK(*is_declarator_flag_ref) || !SvTRUE(*is_declarator_flag_ref)) - return o; + return -1; dd_flags = SvIVX(*is_declarator_flag_ref); -#ifdef DD_DEBUG - printf("dd_flags are: %i\n", dd_flags); -#endif + return dd_flags; +} - s = PL_bufptr; /* copy the current buffer pointer */ +/* callback thingy */ - DD_DEBUG_S +void dd_linestr_callback (pTHX_ char* type, char* name) { -#ifdef DD_DEBUG - printf("PL_tokenbuf: %s\n", PL_tokenbuf); -#endif + char* linestr = SvPVX(PL_linestr); + int offset = PL_bufptr - linestr; + + dSP; + + ENTER; + SAVETMPS; + + PUSHMARK(SP); + XPUSHs(sv_2mortal(newSVpv(type, 0))); + XPUSHs(sv_2mortal(newSVpv(name, 0))); + XPUSHs(sv_2mortal(newSViv(offset))); + PUTBACK; + + call_pv("Devel::Declare::linestr_callback", G_VOID|G_DISCARD); + + FREETMPS; + LEAVE; +} + +char* dd_get_linestr(pTHX) { + if (!DD_HAVE_PARSER) { + return NULL; + } + return SvPVX(PL_linestr); +} + +void dd_set_linestr(pTHX_ char* new_value) { + unsigned int new_len = strlen(new_value); + + if (SvLEN(PL_linestr) < new_len) { + croak("PL_linestr not long enough, was Devel::Declare loaded soon enough in %s", + CopFILE(&PL_compiling) + ); + } + + + memcpy(SvPVX(PL_linestr), new_value, new_len+1); + + SvCUR_set(PL_linestr, new_len); + + PL_bufend = SvPVX(PL_linestr) + new_len; + + if ( DD_DEBUG_UPDATED_LINESTR && PERLDB_LINE && PL_curstash != PL_debstash) { + /* 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); + } + } +} + +char* dd_get_lex_stuff(pTHX) { + return (DD_HAVE_LEX_STUFF ? SvPVX(PL_lex_stuff) : ""); +} + +void dd_clear_lex_stuff(pTHX) { + if (DD_HAVE_PARSER) + PL_lex_stuff = (SV*)NULL; +} + +char* dd_get_curstash_name(pTHX) { + return HvNAME(PL_curstash); +} + +int dd_get_linestr_offset(pTHX) { + char* linestr; + if (!DD_HAVE_PARSER) { + return -1; + } + linestr = SvPVX(PL_linestr); + return PL_bufptr - linestr; +} + +char* dd_move_past_token (pTHX_ char* s) { /* * buffer will be at the beginning of the declarator, -unless- the @@ -139,146 +199,196 @@ STATIC OP *dd_ck_rv2cv(pTHX_ OP *o) { while (s < PL_bufend && isSPACE(*s)) s++; if (memEQ(s, PL_tokenbuf, strlen(PL_tokenbuf))) s += strlen(PL_tokenbuf); + return s; +} + +int dd_toke_move_past_token (pTHX_ int offset) { + char* base_s = SvPVX(PL_linestr) + offset; + char* s = dd_move_past_token(aTHX_ base_s); + return s - base_s; +} + +int dd_toke_scan_word(pTHX_ int offset, int handle_package) { + char tmpbuf[sizeof PL_tokenbuf]; + char* base_s = SvPVX(PL_linestr) + offset; + STRLEN len; + char* s = scan_word(base_s, tmpbuf, sizeof tmpbuf, handle_package, &len); + return s - base_s; +} + +int dd_toke_scan_ident(pTHX_ int offset) { + char tmpbuf[sizeof PL_tokenbuf]; + char* base_s = SvPVX(PL_linestr) + offset; + char* s = scan_ident(base_s, PL_bufend, tmpbuf, sizeof tmpbuf, 0); + return s - base_s; +} - DD_DEBUG_S +int dd_toke_scan_str(pTHX_ int offset) { + 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(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)); + } + return s - base_s; +} - if (dd_flags & DD_HANDLE_NAME) { +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; +} - /* find next word */ +static void call_done_declare(pTHX) { + dSP; - s = skipspace(s); + if (DD_DEBUG_TRACE) { + printf("Deconstructing declare\n"); + printf("PL_bufptr: %s\n", PL_bufptr); + printf("bufend at: %i\n", (int)(PL_bufend - PL_bufptr)); + printf("linestr: %s\n", SvPVX(PL_linestr)); + printf("linestr len: %i\n", (int)(PL_bufend - SvPVX(PL_linestr))); + } - DD_DEBUG_S + ENTER; + SAVETMPS; - /* arg 4 is allow_package */ + PUSHMARK(SP); - s = scan_word(s, tmpbuf, sizeof tmpbuf, dd_flags & DD_HANDLE_PACKAGE, &len); + call_pv("Devel::Declare::done_declare", G_VOID|G_DISCARD); - DD_DEBUG_S + FREETMPS; + LEAVE; - if (len) { - strcpy(found_name, tmpbuf); -#ifdef DD_DEBUG - printf("Found %s\n", found_name); -#endif - } + if (DD_DEBUG_TRACE) { + printf("PL_bufptr: %s\n", PL_bufptr); + printf("bufend at: %i\n", (int)(PL_bufend - PL_bufptr)); + printf("linestr: %s\n", SvPVX(PL_linestr)); + printf("linestr len: %i\n", (int)(PL_bufend - SvPVX(PL_linestr))); + printf("actual len: %i\n", (int)strlen(PL_bufptr)); } +} - if (dd_flags & DD_HANDLE_PROTO) { - - s = skipspace(s); - - if (*s == '(') { /* found a prototype-ish thing */ - save_s = s; - s = scan_str(s, FALSE, FALSE); /* no keep_quoted, no keep_delims */ -#ifdef DD_HAS_TRAITS - { - char *traitstart = s = skipspace(s); - - while (*s && *s != '{') ++s; - if (*s) { - int tlen = s - traitstart; - New(0, found_traits, tlen+1, char); - Copy(traitstart, found_traits, tlen, char); - found_traits[tlen] = 0; -#ifdef DD_DEBUG - printf("found traits..... (%s)\n", found_traits); -#endif - } - } -#endif - - if (SvPOK(PL_lex_stuff)) { -#ifdef DD_DEBUG - printf("Found proto %s\n", SvPVX(PL_lex_stuff)); -#endif - found_proto = SvPVX(PL_lex_stuff); - if (len) /* foo name () => foo name X, only foo parsed so works */ - *save_s++ = ' '; - else /* foo () => foo =X, TOKEN('&') won't handle foo X */ - *save_s++ = '='; - *save_s++ = 'X'; - while (save_s < s) { - *save_s++ = ' '; - } -#ifdef DD_DEBUG - printf("Curbuf %s\n", 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; } - if (!len) - found_name[0] = 0; + kid = cUNOPo->op_first; -#ifdef DD_DEBUG - printf("Calling init_declare\n"); -#endif - cb_args[0] = HvNAME(stash); - cb_args[1] = GvNAME(kGVOP_gv); - cb_args[2] = HvNAME(PL_curstash); - cb_args[3] = found_name; - cb_args[4] = found_proto; - cb_args[5] = found_traits; - cb_args[6] = NULL; - - if (len && found_proto) - in_declare = 2; - else if (len || found_proto) - in_declare = 1; - if (found_proto) - PL_lex_stuff = Nullsv; - s = skipspace(s); -#ifdef DD_DEBUG - printf("cur buf: %s\n", s); - printf("bufend at: %i\n", PL_bufend - s); - printf("linestr: %s\n", SvPVX(PL_linestr)); - printf("linestr len: %i\n", PL_bufend - SvPVX(PL_linestr)); -#endif - if (*s++ == '{') { - call_argv("Devel::Declare::init_declare", G_SCALAR, cb_args); - SPAGAIN; - retstr = POPpx; - PUTBACK; - if (retstr && strlen(retstr)) { - const char* old_start = SvPVX(PL_linestr); - int start_diff; - const int old_len = SvCUR(PL_linestr); -#ifdef DD_DEBUG - printf("Got string %s\n", retstr); -#endif - SvGROW(PL_linestr, (STRLEN)(old_len + strlen(retstr))); - if (start_diff = SvPVX(PL_linestr) - old_start) { - Perl_croak(aTHX_ "forced to realloc PL_linestr for line %s, bailing out before we crash harder", SvPVX(PL_linestr)); + if (kid->op_type != OP_GV) /* not a GV so ignore */ + return o; + + 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); + } + + dd_flags = dd_is_declarator(aTHX_ gvname); + + if (dd_flags == -1) + return o; + + if (DD_DEBUG_TRACE) { + printf("dd_flags are: %i\n", dd_flags); + printf("PL_tokenbuf: %s\n", PL_tokenbuf); + } + +#if DD_CONST_VIA_RV2CV + if (PL_expect != XOPERATOR) { + 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)) != '(') { + if (in_declare) { + call_done_declare(aTHX); + } else { + dd_linestr_callback(aTHX_ "rv2cv", gvname); } - memmove(s+strlen(retstr), s, (PL_bufend - s)+1); - memmove(s, retstr, strlen(retstr)); - SvCUR_set(PL_linestr, old_len + strlen(retstr)); - PL_bufend += strlen(retstr); -#ifdef DD_DEBUG - printf("cur buf: %s\n", s); - printf("PL_bufptr: %s\n", PL_bufptr); - printf("bufend at: %i\n", PL_bufend - s); - printf("linestr: %s\n", SvPVX(PL_linestr)); - printf("linestr len: %i\n", PL_bufend - SvPVX(PL_linestr)); - printf("tokenbuf now: %s\n", PL_tokenbuf); -#endif } - } else { - call_argv("Devel::Declare::init_declare", G_VOID|G_DISCARD, cb_args); + return o; } +#endif /* DD_CONST_VIA_RV2CV */ + + 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; - dPOPss; STRLEN len; const char* s; - if (SvPOK(sv)) { -#ifdef DD_DEBUG - printf("mangling eval sv\n"); + SV *sv; +#ifdef PERL_5_9_PLUS + SV *saved_hh = NULL; + if (PL_op->op_private & OPpEVAL_HAS_HH) { + saved_hh = POPs; + } #endif + sv = POPs; + if (SvPOK(sv)) { + if (DD_DEBUG_TRACE) { + printf("mangling eval sv\n"); + } if (SvREADONLY(sv)) sv = sv_2mortal(newSVsv(sv)); s = SvPVX(sv); @@ -288,40 +398,269 @@ 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 + if (PL_op->op_private & OPpEVAL_HAS_HH) { + PUSHs(saved_hh); + } +#endif return PL_ppaddr[OP_ENTEREVAL](aTHX); } -STATIC OP *dd_ck_entereval(pTHX_ OP *o) { - o = dd_old_ck_entereval(aTHX_ o); /* let the original do its job */ +STATIC OP *dd_ck_entereval(pTHX_ OP *o, void *user_data) { + PERL_UNUSED_VAR(user_data); + if (o->op_ppaddr == PL_ppaddr[OP_ENTEREVAL]) o->op_ppaddr = dd_pp_entereval; 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; } -static int initialized = 0; +static int dd_handle_const(pTHX_ char *name) { + switch (PL_lex_inwhat) { + case OP_QR: + case OP_MATCH: + case OP_SUBST: + case OP_TRANS: + case OP_BACKTICK: + case OP_STRINGIFY: + return 0; + break; + default: + break; + } + + if (strnEQ(PL_bufptr, "->", 2)) { + return 0; + } + + { + char buf[256]; + STRLEN len; + char *s = PL_bufptr; + STRLEN old_offset = PL_bufptr - SvPVX(PL_linestr); + + s = scan_word(s, buf, sizeof buf, FALSE, &len); + if (strnEQ(buf, name, len)) { + char *d; + 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 0; + } + + sv_catpv(inject, d); + dd_set_linestr(aTHX_ SvPV_nolen(inject)); + PL_bufptr = SvPVX(PL_linestr) + old_offset; + SvREFCNT_dec (inject); + } + } + + 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 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++) { - dd_old_ck_rv2cv = PL_check[OP_RV2CV]; - PL_check[OP_RV2CV] = dd_ck_rv2cv; - dd_old_ck_entereval = PL_check[OP_ENTEREVAL]; - PL_check[OP_ENTEREVAL] = dd_ck_entereval; + dd_initialize(aTHX); + filter_add(dd_filter_realloc, NULL); + +char* +get_linestr() + CODE: + RETVAL = dd_get_linestr(aTHX); + OUTPUT: + RETVAL + +void +set_linestr(char* new_value) + CODE: + dd_set_linestr(aTHX_ new_value); + +char* +get_lex_stuff() + CODE: + RETVAL = dd_get_lex_stuff(aTHX); + OUTPUT: + RETVAL + +void +clear_lex_stuff() + CODE: + dd_clear_lex_stuff(aTHX); + +char* +get_curstash_name() + CODE: + RETVAL = dd_get_curstash_name(aTHX); + OUTPUT: + RETVAL + +int +get_linestr_offset() + CODE: + RETVAL = dd_get_linestr_offset(aTHX); + OUTPUT: + RETVAL + +int +toke_scan_word(int offset, int handle_package) + CODE: + RETVAL = dd_toke_scan_word(aTHX_ offset, handle_package); + OUTPUT: + RETVAL + +int +toke_move_past_token(int offset); + CODE: + RETVAL = dd_toke_move_past_token(aTHX_ offset); + OUTPUT: + RETVAL + +SV* +toke_scan_str(int offset); + PREINIT: + int len; + CODE: + len = dd_toke_scan_str(aTHX_ offset); + RETVAL = len ? newSViv(len) : &PL_sv_undef; + OUTPUT: + RETVAL + +int +toke_scan_ident(int offset) + CODE: + RETVAL = dd_toke_scan_ident(aTHX_ offset); + OUTPUT: + RETVAL + +int +toke_skipspace(int offset) + CODE: + RETVAL = dd_toke_skipspace(aTHX_ offset); + OUTPUT: + RETVAL + +int +get_in_declare() + CODE: + RETVAL = in_declare; + OUTPUT: + RETVAL + +void +set_in_declare(int value) + CODE: + in_declare = value; + +BOOT: +{ + char *endptr; + char *debug_str = getenv ("DD_DEBUG"); + if (debug_str) { + dd_debug = strtol (debug_str, &endptr, 10); + if (*endptr != '\0') { + dd_debug = 0; + } } - filter_add(dd_filter_realloc, NULL); +}