4 #include "hook_op_check.h"
6 #include "stolen_chunk_of_toke.c"
10 #define PERL_VERSION_DECIMAL(r,v,s) (r*1000000 + v*1000 + s)
11 #define PERL_DECIMAL_VERSION \
12 PERL_VERSION_DECIMAL(PERL_REVISION,PERL_VERSION,PERL_SUBVERSION)
13 #define PERL_VERSION_GE(r,v,s) \
14 (PERL_DECIMAL_VERSION >= PERL_VERSION_DECIMAL(r,v,s))
17 # define Newx(v,n,t) New(0,v,n,t)
20 #define DD_DEBUGf_UPDATED_LINESTR 1
21 #define DD_DEBUGf_TRACE 2
23 #define DD_DEBUG_UPDATED_LINESTR (dd_debug & DD_DEBUGf_UPDATED_LINESTR)
24 #define DD_DEBUG_TRACE (dd_debug & DD_DEBUGf_TRACE)
25 static int dd_debug = 0;
27 #define DD_CONST_VIA_RV2CV PERL_VERSION_GE(5,11,2)
29 #define DD_GROW_VIA_BLOCKHOOK PERL_VERSION_GE(5,13,3)
32 #define LEX_INTERPNORMAL 9
34 /* please try not to have a line longer than this :) */
36 #define DD_PREFERRED_LINESTR_SIZE 16384
38 /* flag to trigger removal of temporary declaree sub */
40 static int in_declare = 0;
42 /* in 5.10, PL_parser will be NULL if we aren't parsing, and PL_lex_stuff
43 is a lookup into it - so if anything else we can use to tell, so we
44 need to be a bit more careful if PL_parser exists */
46 #define DD_AM_LEXING_CHECK (PL_lex_state == LEX_NORMAL || PL_lex_state == LEX_INTERPNORMAL)
48 #if defined(PL_parser) || defined(PERL_5_9_PLUS)
49 #define DD_HAVE_PARSER PL_parser
50 #define DD_HAVE_LEX_STUFF (PL_parser && PL_lex_stuff)
51 #define DD_AM_LEXING (PL_parser && DD_AM_LEXING_CHECK)
53 #define DD_HAVE_PARSER 1
54 #define DD_HAVE_LEX_STUFF PL_lex_stuff
55 #define DD_AM_LEXING DD_AM_LEXING_CHECK
58 /* thing that decides whether we're dealing with a declarator */
60 int dd_is_declarator(pTHX_ char* name) {
62 SV** is_declarator_pack_ref;
63 HV* is_declarator_pack_hash;
64 SV** is_declarator_flag_ref;
68 is_declarator = get_hv("Devel::Declare::declarators", FALSE);
73 /* $declarators{$current_package_name} */
75 curstash_name = HvNAME(PL_curstash);
79 is_declarator_pack_ref = hv_fetch(is_declarator, curstash_name,
80 strlen(curstash_name), FALSE);
82 if (!is_declarator_pack_ref || !SvROK(*is_declarator_pack_ref))
83 return -1; /* not a hashref */
85 is_declarator_pack_hash = (HV*) SvRV(*is_declarator_pack_ref);
87 /* $declarators{$current_package_name}{$name} */
89 is_declarator_flag_ref = hv_fetch(
90 is_declarator_pack_hash, name,
94 /* requires SvIOK as well as TRUE since flags not being an int is useless */
96 if (!is_declarator_flag_ref
97 || !SvIOK(*is_declarator_flag_ref)
98 || !SvTRUE(*is_declarator_flag_ref))
101 dd_flags = SvIVX(*is_declarator_flag_ref);
106 /* callback thingy */
108 void dd_linestr_callback (pTHX_ char* type, char* name) {
110 char* linestr = SvPVX(PL_linestr);
111 int offset = PL_bufptr - linestr;
119 XPUSHs(sv_2mortal(newSVpv(type, 0)));
120 XPUSHs(sv_2mortal(newSVpv(name, 0)));
121 XPUSHs(sv_2mortal(newSViv(offset)));
124 call_pv("Devel::Declare::linestr_callback", G_VOID|G_DISCARD);
130 char* dd_get_linestr(pTHX) {
131 if (!DD_HAVE_PARSER) {
134 return SvPVX(PL_linestr);
137 void dd_set_linestr(pTHX_ char* new_value) {
138 unsigned int new_len = strlen(new_value);
140 if (SvLEN(PL_linestr) < new_len) {
141 croak("PL_linestr not long enough, was Devel::Declare loaded soon enough in %s",
142 CopFILE(&PL_compiling)
147 memcpy(SvPVX(PL_linestr), new_value, new_len+1);
149 SvCUR_set(PL_linestr, new_len);
151 PL_bufend = SvPVX(PL_linestr) + new_len;
153 if ( DD_DEBUG_UPDATED_LINESTR && PERLDB_LINE && PL_curstash != PL_debstash) {
154 /* Cribbed from toke.c */
155 AV *fileav = CopFILEAV(&PL_compiling);
157 SV * const sv = NEWSV(85,0);
159 sv_upgrade(sv, SVt_PVMG);
160 sv_setpvn(sv,PL_bufptr,PL_bufend-PL_bufptr);
163 av_store(fileav,(I32)CopLINE(&PL_compiling),sv);
168 char* dd_get_lex_stuff(pTHX) {
169 return (DD_HAVE_LEX_STUFF ? SvPVX(PL_lex_stuff) : "");
172 void dd_clear_lex_stuff(pTHX) {
174 PL_lex_stuff = (SV*)NULL;
177 char* dd_get_curstash_name(pTHX) {
178 return HvNAME(PL_curstash);
181 int dd_get_linestr_offset(pTHX) {
183 if (!DD_HAVE_PARSER) {
186 linestr = SvPVX(PL_linestr);
187 return PL_bufptr - linestr;
190 char* dd_move_past_token (pTHX_ char* s) {
193 * buffer will be at the beginning of the declarator, -unless- the
194 * declarator is at EOL in which case it'll be the next useful line
195 * so we don't short-circuit out if we don't find the declarator
198 while (s < PL_bufend && isSPACE(*s)) s++;
199 if (memEQ(s, PL_tokenbuf, strlen(PL_tokenbuf)))
200 s += strlen(PL_tokenbuf);
204 int dd_toke_move_past_token (pTHX_ int offset) {
205 char* base_s = SvPVX(PL_linestr) + offset;
206 char* s = dd_move_past_token(aTHX_ base_s);
210 int dd_toke_scan_word(pTHX_ int offset, int handle_package) {
211 char tmpbuf[sizeof PL_tokenbuf];
212 char* base_s = SvPVX(PL_linestr) + offset;
214 char* s = scan_word(base_s, tmpbuf, sizeof tmpbuf, handle_package, &len);
218 int dd_toke_scan_ident(pTHX_ int offset) {
219 char tmpbuf[sizeof PL_tokenbuf];
220 char* base_s = SvPVX(PL_linestr) + offset;
221 char* s = scan_ident(base_s, PL_bufend, tmpbuf, sizeof tmpbuf, 0);
225 int dd_toke_scan_str(pTHX_ int offset) {
226 char* old_pvx = SvPVX(PL_linestr);
227 SV* line_copy = sv_2mortal(newSVsv(PL_linestr));
228 char* base_s = SvPVX(PL_linestr) + offset;
229 char* s = scan_str(base_s, FALSE, FALSE);
230 if(SvPVX(PL_linestr) != old_pvx)
231 croak("PL_linestr reallocated during scan_str, "
232 "Devel::Declare can't continue");
235 if (s <= base_s || memcmp(SvPVX(line_copy), SvPVX(PL_linestr), offset)) {
236 s += SvCUR(line_copy);
237 sv_catsv(line_copy, PL_linestr);
238 dd_set_linestr(aTHX_ SvPV_nolen(line_copy));
243 int dd_toke_skipspace(pTHX_ int offset) {
244 char* old_pvx = SvPVX(PL_linestr);
245 char* base_s = SvPVX(PL_linestr) + offset;
246 char* s = skipspace_force(base_s);
247 if(SvPVX(PL_linestr) != old_pvx)
248 croak("PL_linestr reallocated during skipspace, "
249 "Devel::Declare can't continue");
253 static void call_done_declare(pTHX) {
256 if (DD_DEBUG_TRACE) {
257 printf("Deconstructing declare\n");
258 printf("PL_bufptr: %s\n", PL_bufptr);
259 printf("bufend at: %i\n", PL_bufend - PL_bufptr);
260 printf("linestr: %s\n", SvPVX(PL_linestr));
261 printf("linestr len: %i\n", PL_bufend - SvPVX(PL_linestr));
269 call_pv("Devel::Declare::done_declare", G_VOID|G_DISCARD);
274 if (DD_DEBUG_TRACE) {
275 printf("PL_bufptr: %s\n", PL_bufptr);
276 printf("bufend at: %i\n", PL_bufend - PL_bufptr);
277 printf("linestr: %s\n", SvPVX(PL_linestr));
278 printf("linestr len: %i\n", PL_bufend - SvPVX(PL_linestr));
279 printf("actual len: %i\n", strlen(PL_bufptr));
283 static int dd_handle_const(pTHX_ char *name);
285 /* replacement PL_check rv2cv entry */
287 STATIC OP *dd_ck_rv2cv(pTHX_ OP *o, void *user_data) {
291 PERL_UNUSED_VAR(user_data);
294 return o; /* not lexing? */
297 call_done_declare(aTHX);
301 kid = cUNOPo->op_first;
303 if (kid->op_type != OP_GV) /* not a GV so ignore */
306 if (DD_DEBUG_TRACE) {
307 printf("Checking GV %s -> %s\n", HvNAME(GvSTASH(kGVOP_gv)), GvNAME(kGVOP_gv));
310 dd_flags = dd_is_declarator(aTHX_ GvNAME(kGVOP_gv));
315 if (DD_DEBUG_TRACE) {
316 printf("dd_flags are: %i\n", dd_flags);
317 printf("PL_tokenbuf: %s\n", PL_tokenbuf);
320 #if DD_CONST_VIA_RV2CV
321 if (PL_expect != XOPERATOR) {
322 if (!dd_handle_const(aTHX_ GvNAME(kGVOP_gv)))
324 CopLINE(PL_curcop) = PL_copline;
325 /* The parser behaviour that we're simulating depends on what comes
326 after the declarator. */
327 if (*skipspace(PL_bufptr + strlen(GvNAME(kGVOP_gv))) != '(') {
329 call_done_declare(aTHX);
331 dd_linestr_callback(aTHX_ "rv2cv", GvNAME(kGVOP_gv));
336 #endif /* DD_CONST_VIA_RV2CV */
338 dd_linestr_callback(aTHX_ "rv2cv", GvNAME(kGVOP_gv));
343 #if DD_GROW_VIA_BLOCKHOOK
345 static void dd_block_start(pTHX_ int full)
347 PERL_UNUSED_VAR(full);
348 if (SvLEN(PL_linestr) < DD_PREFERRED_LINESTR_SIZE)
349 (void) lex_grow_linestr(DD_PREFERRED_LINESTR_SIZE);
352 #else /* !DD_GROW_VIA_BLOCKHOOK */
354 OP* dd_pp_entereval(pTHX) {
361 if (PL_op->op_private & OPpEVAL_HAS_HH) {
367 if (DD_DEBUG_TRACE) {
368 printf("mangling eval sv\n");
371 sv = sv_2mortal(newSVsv(sv));
374 if (!len || s[len-1] != ';') {
375 if (!(SvFLAGS(sv) & SVs_TEMP))
376 sv = sv_2mortal(newSVsv(sv));
377 sv_catpvn(sv, "\n;", 2);
379 SvGROW(sv, DD_PREFERRED_LINESTR_SIZE);
383 if (PL_op->op_private & OPpEVAL_HAS_HH) {
387 return PL_ppaddr[OP_ENTEREVAL](aTHX);
390 STATIC OP *dd_ck_entereval(pTHX_ OP *o, void *user_data) {
391 PERL_UNUSED_VAR(user_data);
393 if (o->op_ppaddr == PL_ppaddr[OP_ENTEREVAL])
394 o->op_ppaddr = dd_pp_entereval;
398 #endif /* !DD_GROW_VIA_BLOCKHOOK */
400 static I32 dd_filter_realloc(pTHX_ int idx, SV *sv, int maxlen)
403 const I32 count = FILTER_READ(idx+1, sv, maxlen);
404 SvGROW(sv, DD_PREFERRED_LINESTR_SIZE);
405 /* Filters can only be deleted in the correct order (reverse of the
406 order in which they were added). Insisting on deleting the filter
407 here would break if another filter were added after ours and is
408 still around. Not deleting the filter at all would break if another
409 filter were added earlier and attempts to delete itself later.
410 We can play nicely to the maximum possible extent by deleting our
411 filter iff it is currently deletable (i.e., it is on the top of
412 the filter stack). Can still run into trouble in more complex
413 situations, but can't avoid that. */
414 if (PL_rsfp_filters && AvFILLp(PL_rsfp_filters) >= 0 &&
415 (filter_datasv = FILTER_DATA(AvFILLp(PL_rsfp_filters))) &&
416 IoANY(filter_datasv) == FPTR2DPTR(void *, dd_filter_realloc)) {
417 filter_del(dd_filter_realloc);
422 static int dd_handle_const(pTHX_ char *name) {
423 switch (PL_lex_inwhat) {
436 if (strnEQ(PL_bufptr, "->", 2)) {
444 STRLEN old_offset = PL_bufptr - SvPVX(PL_linestr);
446 s = scan_word(s, buf, sizeof buf, FALSE, &len);
447 if (strnEQ(buf, name, len)) {
449 SV *inject = newSVpvn(SvPVX(PL_linestr), PL_bufptr - SvPVX(PL_linestr));
450 sv_catpvn(inject, buf, len);
453 sv_catpvn(inject, s, d - s);
455 if ((PL_bufend - d) >= 2 && strnEQ(d, "=>", 2)) {
460 dd_set_linestr(aTHX_ SvPV_nolen(inject));
461 PL_bufptr = SvPVX(PL_linestr) + old_offset;
462 SvREFCNT_dec (inject);
466 dd_linestr_callback(aTHX_ "const", name);
471 #if !DD_CONST_VIA_RV2CV
473 STATIC OP *dd_ck_const(pTHX_ OP *o, void *user_data) {
477 PERL_UNUSED_VAR(user_data);
479 if (DD_HAVE_PARSER && PL_expect == XOPERATOR) {
483 /* if this is set, we just grabbed a delimited string or something,
484 not a bareword, so NO TOUCHY */
486 if (DD_HAVE_LEX_STUFF)
489 /* don't try and look this up if it's not a string const */
490 if (!SvPOK(cSVOPo->op_sv))
493 name = SvPVX(cSVOPo->op_sv);
495 dd_flags = dd_is_declarator(aTHX_ name);
500 dd_handle_const(aTHX_ name);
505 #endif /* !DD_CONST_VIA_RV2CV */
507 STATIC void dd_initialize(pTHX) {
508 static int initialized = 0;
511 #if DD_GROW_VIA_BLOCKHOOK
514 #if PERL_VERSION_GE(5,13,6)
515 BhkENTRY_set(&bhk, bhk_start, dd_block_start);
517 BhkENTRY_set(&bhk, start, dd_block_start);
519 Perl_blockhook_register(aTHX_ &bhk);
521 #else /* !DD_GROW_VIA_BLOCKHOOK */
522 hook_op_check(OP_ENTEREVAL, dd_ck_entereval, NULL);
523 #endif /* !DD_GROW_VIA_BLOCKHOOK */
524 hook_op_check(OP_RV2CV, dd_ck_rv2cv, NULL);
525 #if !DD_CONST_VIA_RV2CV
526 hook_op_check(OP_CONST, dd_ck_const, NULL);
527 #endif /* !DD_CONST_VIA_RV2CV */
531 MODULE = Devel::Declare PACKAGE = Devel::Declare
544 filter_add(dd_filter_realloc, NULL);
549 RETVAL = dd_get_linestr(aTHX);
554 set_linestr(char* new_value)
556 dd_set_linestr(aTHX_ new_value);
561 RETVAL = dd_get_lex_stuff(aTHX);
568 dd_clear_lex_stuff(aTHX);
573 RETVAL = dd_get_curstash_name(aTHX);
580 RETVAL = dd_get_linestr_offset(aTHX);
585 toke_scan_word(int offset, int handle_package)
587 RETVAL = dd_toke_scan_word(aTHX_ offset, handle_package);
592 toke_move_past_token(int offset);
594 RETVAL = dd_toke_move_past_token(aTHX_ offset);
599 toke_scan_str(int offset);
603 len = dd_toke_scan_str(aTHX_ offset);
604 RETVAL = len ? newSViv(len) : &PL_sv_undef;
609 toke_scan_ident(int offset)
611 RETVAL = dd_toke_scan_ident(aTHX_ offset);
616 toke_skipspace(int offset)
618 RETVAL = dd_toke_skipspace(aTHX_ offset);
630 set_in_declare(int value)
637 char *debug_str = getenv ("DD_DEBUG");
639 dd_debug = strtol (debug_str, &endptr, 10);
640 if (*endptr != '\0') {