1 #define PERL_NO_GET_CONTEXT 1
5 #include "hook_op_check.h"
7 #include "stolen_chunk_of_toke.c"
11 #define PERL_VERSION_DECIMAL(r,v,s) (r*1000000 + v*1000 + s)
12 #define PERL_DECIMAL_VERSION \
13 PERL_VERSION_DECIMAL(PERL_REVISION,PERL_VERSION,PERL_SUBVERSION)
14 #define PERL_VERSION_GE(r,v,s) \
15 (PERL_DECIMAL_VERSION >= PERL_VERSION_DECIMAL(r,v,s))
18 # define Newx(v,n,t) New(0,v,n,t)
21 #define DD_DEBUGf_UPDATED_LINESTR 1
22 #define DD_DEBUGf_TRACE 2
24 #define DD_DEBUG_UPDATED_LINESTR (dd_debug & DD_DEBUGf_UPDATED_LINESTR)
25 #define DD_DEBUG_TRACE (dd_debug & DD_DEBUGf_TRACE)
26 static int dd_debug = 0;
28 #define DD_CONST_VIA_RV2CV PERL_VERSION_GE(5,11,2)
30 #define DD_GROW_VIA_BLOCKHOOK PERL_VERSION_GE(5,13,3)
33 #define LEX_INTERPNORMAL 9
35 /* please try not to have a line longer than this :) */
37 #define DD_PREFERRED_LINESTR_SIZE 16384
39 /* flag to trigger removal of temporary declaree sub */
41 static int in_declare = 0;
43 /* in 5.10, PL_parser will be NULL if we aren't parsing, and PL_lex_stuff
44 is a lookup into it - so if anything else we can use to tell, so we
45 need to be a bit more careful if PL_parser exists */
47 #define DD_AM_LEXING_CHECK (PL_lex_state == LEX_NORMAL || PL_lex_state == LEX_INTERPNORMAL)
49 #if defined(PL_parser) || defined(PERL_5_9_PLUS)
50 #define DD_HAVE_PARSER PL_parser
51 #define DD_HAVE_LEX_STUFF (PL_parser && PL_lex_stuff)
52 #define DD_AM_LEXING (PL_parser && DD_AM_LEXING_CHECK)
54 #define DD_HAVE_PARSER 1
55 #define DD_HAVE_LEX_STUFF PL_lex_stuff
56 #define DD_AM_LEXING DD_AM_LEXING_CHECK
59 /* thing that decides whether we're dealing with a declarator */
61 int dd_is_declarator(pTHX_ char* name) {
63 SV** is_declarator_pack_ref;
64 HV* is_declarator_pack_hash;
65 SV** is_declarator_flag_ref;
69 is_declarator = get_hv("Devel::Declare::declarators", FALSE);
74 /* $declarators{$current_package_name} */
76 curstash_name = HvNAME(PL_curstash);
80 is_declarator_pack_ref = hv_fetch(is_declarator, curstash_name,
81 strlen(curstash_name), FALSE);
83 if (!is_declarator_pack_ref || !SvROK(*is_declarator_pack_ref))
84 return -1; /* not a hashref */
86 is_declarator_pack_hash = (HV*) SvRV(*is_declarator_pack_ref);
88 /* $declarators{$current_package_name}{$name} */
90 is_declarator_flag_ref = hv_fetch(
91 is_declarator_pack_hash, name,
95 /* requires SvIOK as well as TRUE since flags not being an int is useless */
97 if (!is_declarator_flag_ref
98 || !SvIOK(*is_declarator_flag_ref)
99 || !SvTRUE(*is_declarator_flag_ref))
102 dd_flags = SvIVX(*is_declarator_flag_ref);
107 /* callback thingy */
109 void dd_linestr_callback (pTHX_ char* type, char* name) {
111 char* linestr = SvPVX(PL_linestr);
112 int offset = PL_bufptr - linestr;
120 XPUSHs(sv_2mortal(newSVpv(type, 0)));
121 XPUSHs(sv_2mortal(newSVpv(name, 0)));
122 XPUSHs(sv_2mortal(newSViv(offset)));
125 call_pv("Devel::Declare::linestr_callback", G_VOID|G_DISCARD);
131 char* dd_get_linestr(pTHX) {
132 if (!DD_HAVE_PARSER) {
135 return SvPVX(PL_linestr);
138 void dd_set_linestr(pTHX_ char* new_value) {
139 unsigned int new_len = strlen(new_value);
141 if (SvLEN(PL_linestr) < new_len) {
142 croak("PL_linestr not long enough, was Devel::Declare loaded soon enough in %s",
143 CopFILE(&PL_compiling)
148 memcpy(SvPVX(PL_linestr), new_value, new_len+1);
150 SvCUR_set(PL_linestr, new_len);
152 PL_bufend = SvPVX(PL_linestr) + new_len;
154 if ( DD_DEBUG_UPDATED_LINESTR && PERLDB_LINE && PL_curstash != PL_debstash) {
155 /* Cribbed from toke.c */
156 AV *fileav = CopFILEAV(&PL_compiling);
158 SV * const sv = NEWSV(85,0);
160 sv_upgrade(sv, SVt_PVMG);
161 sv_setpvn(sv,PL_bufptr,PL_bufend-PL_bufptr);
164 av_store(fileav,(I32)CopLINE(&PL_compiling),sv);
169 char* dd_get_lex_stuff(pTHX) {
170 return (DD_HAVE_LEX_STUFF ? SvPVX(PL_lex_stuff) : "");
173 void dd_clear_lex_stuff(pTHX) {
175 PL_lex_stuff = (SV*)NULL;
178 char* dd_get_curstash_name(pTHX) {
179 return HvNAME(PL_curstash);
182 int dd_get_linestr_offset(pTHX) {
184 if (!DD_HAVE_PARSER) {
187 linestr = SvPVX(PL_linestr);
188 return PL_bufptr - linestr;
191 char* dd_move_past_token (pTHX_ char* s) {
194 * buffer will be at the beginning of the declarator, -unless- the
195 * declarator is at EOL in which case it'll be the next useful line
196 * so we don't short-circuit out if we don't find the declarator
199 while (s < PL_bufend && isSPACE(*s)) s++;
200 if (memEQ(s, PL_tokenbuf, strlen(PL_tokenbuf)))
201 s += strlen(PL_tokenbuf);
205 int dd_toke_move_past_token (pTHX_ int offset) {
206 char* base_s = SvPVX(PL_linestr) + offset;
207 char* s = dd_move_past_token(aTHX_ base_s);
211 int dd_toke_scan_word(pTHX_ int offset, int handle_package) {
212 char tmpbuf[sizeof PL_tokenbuf];
213 char* base_s = SvPVX(PL_linestr) + offset;
215 char* s = scan_word(base_s, tmpbuf, sizeof tmpbuf, handle_package, &len);
219 int dd_toke_scan_ident(pTHX_ int offset) {
220 char tmpbuf[sizeof PL_tokenbuf];
221 char* base_s = SvPVX(PL_linestr) + offset;
222 char* s = scan_ident(base_s, PL_bufend, tmpbuf, sizeof tmpbuf, 0);
226 int dd_toke_scan_str(pTHX_ int offset) {
227 char* old_pvx = SvPVX(PL_linestr);
228 SV* line_copy = sv_2mortal(newSVsv(PL_linestr));
229 char* base_s = SvPVX(PL_linestr) + offset;
230 char* s = scan_str(base_s, FALSE, FALSE);
231 if(SvPVX(PL_linestr) != old_pvx)
232 croak("PL_linestr reallocated during scan_str, "
233 "Devel::Declare can't continue");
236 if (s <= base_s || memcmp(SvPVX(line_copy), SvPVX(PL_linestr), offset)) {
237 s += SvCUR(line_copy);
238 sv_catsv(line_copy, PL_linestr);
239 dd_set_linestr(aTHX_ SvPV_nolen(line_copy));
244 int dd_toke_skipspace(pTHX_ int offset) {
245 char* old_pvx = SvPVX(PL_linestr);
246 char* base_s = SvPVX(PL_linestr) + offset;
247 char* s = skipspace_force(base_s);
248 if(SvPVX(PL_linestr) != old_pvx)
249 croak("PL_linestr reallocated during skipspace, "
250 "Devel::Declare can't continue");
254 static void call_done_declare(pTHX) {
257 if (DD_DEBUG_TRACE) {
258 printf("Deconstructing declare\n");
259 printf("PL_bufptr: %s\n", PL_bufptr);
260 printf("bufend at: %i\n", (int)(PL_bufend - PL_bufptr));
261 printf("linestr: %s\n", SvPVX(PL_linestr));
262 printf("linestr len: %i\n", (int)(PL_bufend - SvPVX(PL_linestr)));
270 call_pv("Devel::Declare::done_declare", G_VOID|G_DISCARD);
275 if (DD_DEBUG_TRACE) {
276 printf("PL_bufptr: %s\n", PL_bufptr);
277 printf("bufend at: %i\n", (int)(PL_bufend - PL_bufptr));
278 printf("linestr: %s\n", SvPVX(PL_linestr));
279 printf("linestr len: %i\n", (int)(PL_bufend - SvPVX(PL_linestr)));
280 printf("actual len: %i\n", (int)strlen(PL_bufptr));
284 static int dd_handle_const(pTHX_ char *name);
286 #ifdef CV_NAME_NOTQUAL /* 5.21.5 */
287 # define Gv_or_CvNAME(g) (isGV(g) \
289 : SvPV_nolen(cv_name((CV *)SvRV(g), NULL, CV_NAME_NOTQUAL)))
290 #elif defined(CvNAMED) /* 5.21.4 */
291 # define Gv_or_CvNAME(g) (isGV(g) \
294 ? HEK_KEY(CvNAME_HEK((CV *)SvRV(g))) \
295 : GvNAME(CvGV(SvRV(g))))
297 # define Gv_or_CvNAME(g) GvNAME(g)
300 /* replacement PL_check rv2cv entry */
302 STATIC OP *dd_ck_rv2cv(pTHX_ OP *o, void *user_data) {
307 PERL_UNUSED_VAR(user_data);
310 return o; /* not lexing? */
313 call_done_declare(aTHX);
317 kid = cUNOPo->op_first;
319 if (kid->op_type != OP_GV) /* not a GV so ignore */
323 && (!SvROK(kGVOP_gv) || SvTYPE(SvRV(kGVOP_gv)) != SVt_PVCV))
326 gvname = Gv_or_CvNAME(kGVOP_gv);
328 if (DD_DEBUG_TRACE) {
329 printf("Checking GV %s -> %s\n", HvNAME(GvSTASH(kGVOP_gv)), gvname);
332 dd_flags = dd_is_declarator(aTHX_ gvname);
337 if (DD_DEBUG_TRACE) {
338 printf("dd_flags are: %i\n", dd_flags);
339 printf("PL_tokenbuf: %s\n", PL_tokenbuf);
342 #if DD_CONST_VIA_RV2CV
343 if (PL_expect != XOPERATOR) {
344 if (!dd_handle_const(aTHX_ Gv_or_CvNAME(kGVOP_gv)))
346 CopLINE(PL_curcop) = PL_copline;
347 /* The parser behaviour that we're simulating depends on what comes
348 after the declarator. */
349 if (*skipspace(PL_bufptr + strlen(gvname)) != '(') {
351 call_done_declare(aTHX);
353 dd_linestr_callback(aTHX_ "rv2cv", gvname);
358 #endif /* DD_CONST_VIA_RV2CV */
360 dd_linestr_callback(aTHX_ "rv2cv", gvname);
365 #if DD_GROW_VIA_BLOCKHOOK
367 static void dd_block_start(pTHX_ int full)
369 PERL_UNUSED_VAR(full);
370 if (SvLEN(PL_linestr) < DD_PREFERRED_LINESTR_SIZE)
371 (void) lex_grow_linestr(DD_PREFERRED_LINESTR_SIZE);
374 #else /* !DD_GROW_VIA_BLOCKHOOK */
376 OP* dd_pp_entereval(pTHX) {
383 if (PL_op->op_private & OPpEVAL_HAS_HH) {
389 if (DD_DEBUG_TRACE) {
390 printf("mangling eval sv\n");
393 sv = sv_2mortal(newSVsv(sv));
396 if (!len || s[len-1] != ';') {
397 if (!(SvFLAGS(sv) & SVs_TEMP))
398 sv = sv_2mortal(newSVsv(sv));
399 sv_catpvn(sv, "\n;", 2);
401 SvGROW(sv, DD_PREFERRED_LINESTR_SIZE);
405 if (PL_op->op_private & OPpEVAL_HAS_HH) {
409 return PL_ppaddr[OP_ENTEREVAL](aTHX);
412 STATIC OP *dd_ck_entereval(pTHX_ OP *o, void *user_data) {
413 PERL_UNUSED_VAR(user_data);
415 if (o->op_ppaddr == PL_ppaddr[OP_ENTEREVAL])
416 o->op_ppaddr = dd_pp_entereval;
420 #endif /* !DD_GROW_VIA_BLOCKHOOK */
422 static I32 dd_filter_realloc(pTHX_ int idx, SV *sv, int maxlen)
425 const I32 count = FILTER_READ(idx+1, sv, maxlen);
426 SvGROW(sv, DD_PREFERRED_LINESTR_SIZE);
427 /* Filters can only be deleted in the correct order (reverse of the
428 order in which they were added). Insisting on deleting the filter
429 here would break if another filter were added after ours and is
430 still around. Not deleting the filter at all would break if another
431 filter were added earlier and attempts to delete itself later.
432 We can play nicely to the maximum possible extent by deleting our
433 filter iff it is currently deletable (i.e., it is on the top of
434 the filter stack). Can still run into trouble in more complex
435 situations, but can't avoid that. */
436 if (PL_rsfp_filters && AvFILLp(PL_rsfp_filters) >= 0 &&
437 (filter_datasv = FILTER_DATA(AvFILLp(PL_rsfp_filters))) &&
438 IoANY(filter_datasv) == FPTR2DPTR(void *, dd_filter_realloc)) {
439 filter_del(dd_filter_realloc);
444 static int dd_handle_const(pTHX_ char *name) {
445 switch (PL_lex_inwhat) {
458 if (strnEQ(PL_bufptr, "->", 2)) {
466 STRLEN old_offset = PL_bufptr - SvPVX(PL_linestr);
468 s = scan_word(s, buf, sizeof buf, FALSE, &len);
469 if (strnEQ(buf, name, len)) {
471 SV *inject = newSVpvn(SvPVX(PL_linestr), PL_bufptr - SvPVX(PL_linestr));
472 sv_catpvn(inject, buf, len);
475 sv_catpvn(inject, s, d - s);
477 if ((PL_bufend - d) >= 2 && strnEQ(d, "=>", 2)) {
482 dd_set_linestr(aTHX_ SvPV_nolen(inject));
483 PL_bufptr = SvPVX(PL_linestr) + old_offset;
484 SvREFCNT_dec (inject);
488 dd_linestr_callback(aTHX_ "const", name);
493 #if !DD_CONST_VIA_RV2CV
495 STATIC OP *dd_ck_const(pTHX_ OP *o, void *user_data) {
499 PERL_UNUSED_VAR(user_data);
501 if (DD_HAVE_PARSER && PL_expect == XOPERATOR) {
505 /* if this is set, we just grabbed a delimited string or something,
506 not a bareword, so NO TOUCHY */
508 if (DD_HAVE_LEX_STUFF)
511 /* don't try and look this up if it's not a string const */
512 if (!SvPOK(cSVOPo->op_sv))
515 name = SvPVX(cSVOPo->op_sv);
517 dd_flags = dd_is_declarator(aTHX_ name);
522 dd_handle_const(aTHX_ name);
527 #endif /* !DD_CONST_VIA_RV2CV */
529 STATIC void dd_initialize(pTHX) {
530 static int initialized = 0;
533 #if DD_GROW_VIA_BLOCKHOOK
536 #if PERL_VERSION_GE(5,13,6)
537 BhkENTRY_set(&bhk, bhk_start, dd_block_start);
539 BhkENTRY_set(&bhk, start, dd_block_start);
541 Perl_blockhook_register(aTHX_ &bhk);
543 #else /* !DD_GROW_VIA_BLOCKHOOK */
544 hook_op_check(OP_ENTEREVAL, dd_ck_entereval, NULL);
545 #endif /* !DD_GROW_VIA_BLOCKHOOK */
546 hook_op_check(OP_RV2CV, dd_ck_rv2cv, NULL);
547 #if !DD_CONST_VIA_RV2CV
548 hook_op_check(OP_CONST, dd_ck_const, NULL);
549 #endif /* !DD_CONST_VIA_RV2CV */
553 MODULE = Devel::Declare PACKAGE = Devel::Declare
566 filter_add(dd_filter_realloc, NULL);
571 RETVAL = dd_get_linestr(aTHX);
576 set_linestr(char* new_value)
578 dd_set_linestr(aTHX_ new_value);
583 RETVAL = dd_get_lex_stuff(aTHX);
590 dd_clear_lex_stuff(aTHX);
595 RETVAL = dd_get_curstash_name(aTHX);
602 RETVAL = dd_get_linestr_offset(aTHX);
607 toke_scan_word(int offset, int handle_package)
609 RETVAL = dd_toke_scan_word(aTHX_ offset, handle_package);
614 toke_move_past_token(int offset);
616 RETVAL = dd_toke_move_past_token(aTHX_ offset);
621 toke_scan_str(int offset);
625 len = dd_toke_scan_str(aTHX_ offset);
626 RETVAL = len ? newSViv(len) : &PL_sv_undef;
631 toke_scan_ident(int offset)
633 RETVAL = dd_toke_scan_ident(aTHX_ offset);
638 toke_skipspace(int offset)
640 RETVAL = dd_toke_skipspace(aTHX_ offset);
652 set_in_declare(int value)
659 char *debug_str = getenv ("DD_DEBUG");
661 dd_debug = strtol (debug_str, &endptr, 10);
662 if (*endptr != '\0') {