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", PL_bufend - PL_bufptr);
261 printf("linestr: %s\n", SvPVX(PL_linestr));
262 printf("linestr len: %i\n", 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", PL_bufend - PL_bufptr);
278 printf("linestr: %s\n", SvPVX(PL_linestr));
279 printf("linestr len: %i\n", PL_bufend - SvPVX(PL_linestr));
280 printf("actual len: %i\n", strlen(PL_bufptr));
284 static int dd_handle_const(pTHX_ char *name);
286 /* replacement PL_check rv2cv entry */
288 STATIC OP *dd_ck_rv2cv(pTHX_ OP *o, void *user_data) {
292 PERL_UNUSED_VAR(user_data);
295 return o; /* not lexing? */
298 call_done_declare(aTHX);
302 kid = cUNOPo->op_first;
304 if (kid->op_type != OP_GV) /* not a GV so ignore */
307 if (DD_DEBUG_TRACE) {
308 printf("Checking GV %s -> %s\n", HvNAME(GvSTASH(kGVOP_gv)), GvNAME(kGVOP_gv));
311 dd_flags = dd_is_declarator(aTHX_ GvNAME(kGVOP_gv));
316 if (DD_DEBUG_TRACE) {
317 printf("dd_flags are: %i\n", dd_flags);
318 printf("PL_tokenbuf: %s\n", PL_tokenbuf);
321 #if DD_CONST_VIA_RV2CV
322 if (PL_expect != XOPERATOR) {
323 if (!dd_handle_const(aTHX_ GvNAME(kGVOP_gv)))
325 CopLINE(PL_curcop) = PL_copline;
326 /* The parser behaviour that we're simulating depends on what comes
327 after the declarator. */
328 if (*skipspace(PL_bufptr + strlen(GvNAME(kGVOP_gv))) != '(') {
330 call_done_declare(aTHX);
332 dd_linestr_callback(aTHX_ "rv2cv", GvNAME(kGVOP_gv));
337 #endif /* DD_CONST_VIA_RV2CV */
339 dd_linestr_callback(aTHX_ "rv2cv", GvNAME(kGVOP_gv));
344 #if DD_GROW_VIA_BLOCKHOOK
346 static void dd_block_start(pTHX_ int full)
348 PERL_UNUSED_VAR(full);
349 if (SvLEN(PL_linestr) < DD_PREFERRED_LINESTR_SIZE)
350 (void) lex_grow_linestr(DD_PREFERRED_LINESTR_SIZE);
353 #else /* !DD_GROW_VIA_BLOCKHOOK */
355 OP* dd_pp_entereval(pTHX) {
362 if (PL_op->op_private & OPpEVAL_HAS_HH) {
368 if (DD_DEBUG_TRACE) {
369 printf("mangling eval sv\n");
372 sv = sv_2mortal(newSVsv(sv));
375 if (!len || s[len-1] != ';') {
376 if (!(SvFLAGS(sv) & SVs_TEMP))
377 sv = sv_2mortal(newSVsv(sv));
378 sv_catpvn(sv, "\n;", 2);
380 SvGROW(sv, DD_PREFERRED_LINESTR_SIZE);
384 if (PL_op->op_private & OPpEVAL_HAS_HH) {
388 return PL_ppaddr[OP_ENTEREVAL](aTHX);
391 STATIC OP *dd_ck_entereval(pTHX_ OP *o, void *user_data) {
392 PERL_UNUSED_VAR(user_data);
394 if (o->op_ppaddr == PL_ppaddr[OP_ENTEREVAL])
395 o->op_ppaddr = dd_pp_entereval;
399 #endif /* !DD_GROW_VIA_BLOCKHOOK */
401 static I32 dd_filter_realloc(pTHX_ int idx, SV *sv, int maxlen)
404 const I32 count = FILTER_READ(idx+1, sv, maxlen);
405 SvGROW(sv, DD_PREFERRED_LINESTR_SIZE);
406 /* Filters can only be deleted in the correct order (reverse of the
407 order in which they were added). Insisting on deleting the filter
408 here would break if another filter were added after ours and is
409 still around. Not deleting the filter at all would break if another
410 filter were added earlier and attempts to delete itself later.
411 We can play nicely to the maximum possible extent by deleting our
412 filter iff it is currently deletable (i.e., it is on the top of
413 the filter stack). Can still run into trouble in more complex
414 situations, but can't avoid that. */
415 if (PL_rsfp_filters && AvFILLp(PL_rsfp_filters) >= 0 &&
416 (filter_datasv = FILTER_DATA(AvFILLp(PL_rsfp_filters))) &&
417 IoANY(filter_datasv) == FPTR2DPTR(void *, dd_filter_realloc)) {
418 filter_del(dd_filter_realloc);
423 static int dd_handle_const(pTHX_ char *name) {
424 switch (PL_lex_inwhat) {
437 if (strnEQ(PL_bufptr, "->", 2)) {
445 STRLEN old_offset = PL_bufptr - SvPVX(PL_linestr);
447 s = scan_word(s, buf, sizeof buf, FALSE, &len);
448 if (strnEQ(buf, name, len)) {
450 SV *inject = newSVpvn(SvPVX(PL_linestr), PL_bufptr - SvPVX(PL_linestr));
451 sv_catpvn(inject, buf, len);
454 sv_catpvn(inject, s, d - s);
456 if ((PL_bufend - d) >= 2 && strnEQ(d, "=>", 2)) {
461 dd_set_linestr(aTHX_ SvPV_nolen(inject));
462 PL_bufptr = SvPVX(PL_linestr) + old_offset;
463 SvREFCNT_dec (inject);
467 dd_linestr_callback(aTHX_ "const", name);
472 #if !DD_CONST_VIA_RV2CV
474 STATIC OP *dd_ck_const(pTHX_ OP *o, void *user_data) {
478 PERL_UNUSED_VAR(user_data);
480 if (DD_HAVE_PARSER && PL_expect == XOPERATOR) {
484 /* if this is set, we just grabbed a delimited string or something,
485 not a bareword, so NO TOUCHY */
487 if (DD_HAVE_LEX_STUFF)
490 /* don't try and look this up if it's not a string const */
491 if (!SvPOK(cSVOPo->op_sv))
494 name = SvPVX(cSVOPo->op_sv);
496 dd_flags = dd_is_declarator(aTHX_ name);
501 dd_handle_const(aTHX_ name);
506 #endif /* !DD_CONST_VIA_RV2CV */
508 STATIC void dd_initialize(pTHX) {
509 static int initialized = 0;
512 #if DD_GROW_VIA_BLOCKHOOK
515 #if PERL_VERSION_GE(5,13,6)
516 BhkENTRY_set(&bhk, bhk_start, dd_block_start);
518 BhkENTRY_set(&bhk, start, dd_block_start);
520 Perl_blockhook_register(aTHX_ &bhk);
522 #else /* !DD_GROW_VIA_BLOCKHOOK */
523 hook_op_check(OP_ENTEREVAL, dd_ck_entereval, NULL);
524 #endif /* !DD_GROW_VIA_BLOCKHOOK */
525 hook_op_check(OP_RV2CV, dd_ck_rv2cv, NULL);
526 #if !DD_CONST_VIA_RV2CV
527 hook_op_check(OP_CONST, dd_ck_const, NULL);
528 #endif /* !DD_CONST_VIA_RV2CV */
532 MODULE = Devel::Declare PACKAGE = Devel::Declare
545 filter_add(dd_filter_realloc, NULL);
550 RETVAL = dd_get_linestr(aTHX);
555 set_linestr(char* new_value)
557 dd_set_linestr(aTHX_ new_value);
562 RETVAL = dd_get_lex_stuff(aTHX);
569 dd_clear_lex_stuff(aTHX);
574 RETVAL = dd_get_curstash_name(aTHX);
581 RETVAL = dd_get_linestr_offset(aTHX);
586 toke_scan_word(int offset, int handle_package)
588 RETVAL = dd_toke_scan_word(aTHX_ offset, handle_package);
593 toke_move_past_token(int offset);
595 RETVAL = dd_toke_move_past_token(aTHX_ offset);
600 toke_scan_str(int offset);
604 len = dd_toke_scan_str(aTHX_ offset);
605 RETVAL = len ? newSViv(len) : &PL_sv_undef;
610 toke_scan_ident(int offset)
612 RETVAL = dd_toke_scan_ident(aTHX_ offset);
617 toke_skipspace(int offset)
619 RETVAL = dd_toke_skipspace(aTHX_ offset);
631 set_in_declare(int value)
638 char *debug_str = getenv ("DD_DEBUG");
640 dd_debug = strtol (debug_str, &endptr, 10);
641 if (*endptr != '\0') {