assloads of changes, apparently my previous commits failed
[p5sagit/Devel-Declare.git] / Declare.xs
CommitLineData
94caac6e 1#define PERL_CORE
2#define PERL_NO_GET_CONTEXT
94caac6e 3#include "EXTERN.h"
4#include "perl.h"
5#include "XSUB.h"
6#undef printf
e807ee50 7#include "stolen_chunk_of_toke.c"
94caac6e 8#include <stdio.h>
9#include <string.h>
10
9673d7ca 11#ifndef Newx
12# define Newx(v,n,t) New(0,v,n,t)
13#endif /* !Newx */
14
15#if 1
0f070758 16#define DD_HAS_TRAITS
9673d7ca 17#endif
18
53e3ab32 19#if 0
20#define DD_DEBUG
21#endif
c630715a 22
0ba8c7aa 23#define DD_HANDLE_NAME 1
24#define DD_HANDLE_PROTO 2
15d0d014 25#define DD_HANDLE_PACKAGE 8
0ba8c7aa 26
c630715a 27#ifdef DD_DEBUG
28#define DD_DEBUG_S printf("Buffer: %s\n", s);
29#else
30#define DD_DEBUG_S
31#endif
32
94caac6e 33#define LEX_NORMAL 10
34#define LEX_INTERPNORMAL 9
35
36/* placeholders for PL_check entries we wrap */
37
38STATIC OP *(*dd_old_ck_rv2cv)(pTHX_ OP *op);
b7505981 39STATIC OP *(*dd_old_ck_entereval)(pTHX_ OP *op);
94caac6e 40
41/* flag to trigger removal of temporary declaree sub */
42
43static int in_declare = 0;
44
45/* replacement PL_check rv2cv entry */
46
47STATIC OP *dd_ck_rv2cv(pTHX_ OP *o) {
48 OP* kid;
49 char* s;
0ba8c7aa 50 char* save_s;
94caac6e 51 char tmpbuf[sizeof PL_tokenbuf];
0ba8c7aa 52 char found_name[sizeof PL_tokenbuf];
0f070758 53 char* found_proto = NULL, *found_traits = NULL;
0ba8c7aa 54 STRLEN len = 0;
94caac6e 55 HV *stash;
56 HV* is_declarator;
57 SV** is_declarator_pack_ref;
58 HV* is_declarator_pack_hash;
59 SV** is_declarator_flag_ref;
0ba8c7aa 60 int dd_flags;
9026391e 61 char* cb_args[6];
53e3ab32 62 dSP; /* define stack pointer for later call stuff */
63 char* retstr;
64 STRLEN n_a; /* for POPpx */
94caac6e 65
66 o = dd_old_ck_rv2cv(aTHX_ o); /* let the original do its job */
67
68 if (in_declare) {
69 cb_args[0] = NULL;
dcca2c59 70#ifdef DD_DEBUG
71 printf("Deconstructing declare\n");
72 printf("PL_bufptr: %s\n", PL_bufptr);
73 printf("bufend at: %i\n", PL_bufend - PL_bufptr);
74 printf("linestr: %s\n", SvPVX(PL_linestr));
75 printf("linestr len: %i\n", PL_bufend - SvPVX(PL_linestr));
76#endif
94caac6e 77 call_argv("Devel::Declare::done_declare", G_VOID|G_DISCARD, cb_args);
0ba8c7aa 78 in_declare--;
dcca2c59 79#ifdef DD_DEBUG
80 printf("PL_bufptr: %s\n", PL_bufptr);
81 printf("bufend at: %i\n", PL_bufend - PL_bufptr);
82 printf("linestr: %s\n", SvPVX(PL_linestr));
83 printf("linestr len: %i\n", PL_bufend - SvPVX(PL_linestr));
84 printf("actual len: %i\n", strlen(PL_bufptr));
85#endif
94caac6e 86 return o;
87 }
88
89 kid = cUNOPo->op_first;
90
91 if (kid->op_type != OP_GV) /* not a GV so ignore */
92 return o;
93
94 if (PL_lex_state != LEX_NORMAL && PL_lex_state != LEX_INTERPNORMAL)
95 return o; /* not lexing? */
96
97 stash = GvSTASH(kGVOP_gv);
98
c630715a 99#ifdef DD_DEBUG
100 printf("Checking GV %s -> %s\n", HvNAME(stash), GvNAME(kGVOP_gv));
101#endif
94caac6e 102
103 is_declarator = get_hv("Devel::Declare::declarators", FALSE);
104
105 if (!is_declarator)
106 return o;
107
108 is_declarator_pack_ref = hv_fetch(is_declarator, HvNAME(stash),
109 strlen(HvNAME(stash)), FALSE);
110
111 if (!is_declarator_pack_ref || !SvROK(*is_declarator_pack_ref))
112 return o; /* not a hashref */
113
114 is_declarator_pack_hash = (HV*) SvRV(*is_declarator_pack_ref);
115
116 is_declarator_flag_ref = hv_fetch(is_declarator_pack_hash, GvNAME(kGVOP_gv),
117 strlen(GvNAME(kGVOP_gv)), FALSE);
118
0ba8c7aa 119 /* requires SvIOK as well as TRUE since flags not being an int is useless */
120
121 if (!is_declarator_flag_ref
122 || !SvIOK(*is_declarator_flag_ref)
123 || !SvTRUE(*is_declarator_flag_ref))
94caac6e 124 return o;
125
0ba8c7aa 126 dd_flags = SvIVX(*is_declarator_flag_ref);
127
128#ifdef DD_DEBUG
129 printf("dd_flags are: %i\n", dd_flags);
130#endif
131
94caac6e 132 s = PL_bufptr; /* copy the current buffer pointer */
133
c630715a 134 DD_DEBUG_S
135
136#ifdef DD_DEBUG
0ba8c7aa 137 printf("PL_tokenbuf: %s\n", PL_tokenbuf);
c630715a 138#endif
139
140 /*
141 * buffer will be at the beginning of the declarator, -unless- the
142 * declarator is at EOL in which case it'll be the next useful line
143 * so we don't short-circuit out if we don't find the declarator
144 */
145
94caac6e 146 while (s < PL_bufend && isSPACE(*s)) s++;
147 if (memEQ(s, PL_tokenbuf, strlen(PL_tokenbuf)))
148 s += strlen(PL_tokenbuf);
c630715a 149
150 DD_DEBUG_S
94caac6e 151
0ba8c7aa 152 if (dd_flags & DD_HANDLE_NAME) {
94caac6e 153
0ba8c7aa 154 /* find next word */
94caac6e 155
0ba8c7aa 156 s = skipspace(s);
c630715a 157
0ba8c7aa 158 DD_DEBUG_S
94caac6e 159
15d0d014 160 /* arg 4 is allow_package */
94caac6e 161
15d0d014 162 s = scan_word(s, tmpbuf, sizeof tmpbuf, dd_flags & DD_HANDLE_PACKAGE, &len);
0ba8c7aa 163
164 DD_DEBUG_S
c630715a 165
0ba8c7aa 166 if (len) {
167 strcpy(found_name, tmpbuf);
168#ifdef DD_DEBUG
169 printf("Found %s\n", found_name);
170#endif
171 }
172 }
173
174 if (dd_flags & DD_HANDLE_PROTO) {
175
176 s = skipspace(s);
177
178 if (*s == '(') { /* found a prototype-ish thing */
179 save_s = s;
180 s = scan_str(s, FALSE, FALSE); /* no keep_quoted, no keep_delims */
0f070758 181#ifdef DD_HAS_TRAITS
182 {
183 char *traitstart = s = skipspace(s);
184
185 while (*s && *s != '{') ++s;
186 if (*s) {
187 int tlen = s - traitstart;
9673d7ca 188 Newx(found_traits, tlen+1, char);
0f070758 189 Copy(traitstart, found_traits, tlen, char);
190 found_traits[tlen] = 0;
191#ifdef DD_DEBUG
192 printf("found traits..... (%s)\n", found_traits);
193#endif
194 }
195 }
196#endif
197
0ba8c7aa 198 if (SvPOK(PL_lex_stuff)) {
199#ifdef DD_DEBUG
200 printf("Found proto %s\n", SvPVX(PL_lex_stuff));
201#endif
202 found_proto = SvPVX(PL_lex_stuff);
53e3ab32 203 if (len) /* foo name () => foo name X, only foo parsed so works */
204 *save_s++ = ' ';
205 else /* foo () => foo =X, TOKEN('&') won't handle foo X */
206 *save_s++ = '=';
0ba8c7aa 207 *save_s++ = 'X';
208 while (save_s < s) {
209 *save_s++ = ' ';
210 }
211#ifdef DD_DEBUG
212 printf("Curbuf %s\n", PL_bufptr);
213#endif
214 }
215 }
216 }
217
53e3ab32 218 if (!len)
219 found_name[0] = 0;
220
221#ifdef DD_DEBUG
222 printf("Calling init_declare\n");
223#endif
224 cb_args[0] = HvNAME(stash);
225 cb_args[1] = GvNAME(kGVOP_gv);
9026391e 226 cb_args[2] = HvNAME(PL_curstash);
227 cb_args[3] = found_name;
228 cb_args[4] = found_proto;
0f070758 229 cb_args[5] = found_traits;
230 cb_args[6] = NULL;
53e3ab32 231
232 if (len && found_proto)
233 in_declare = 2;
234 else if (len || found_proto)
235 in_declare = 1;
236 if (found_proto)
237 PL_lex_stuff = Nullsv;
238 s = skipspace(s);
239#ifdef DD_DEBUG
240 printf("cur buf: %s\n", s);
241 printf("bufend at: %i\n", PL_bufend - s);
242 printf("linestr: %s\n", SvPVX(PL_linestr));
243 printf("linestr len: %i\n", PL_bufend - SvPVX(PL_linestr));
244#endif
245 if (*s++ == '{') {
246 call_argv("Devel::Declare::init_declare", G_SCALAR, cb_args);
247 SPAGAIN;
248 retstr = POPpx;
249 PUTBACK;
250 if (retstr && strlen(retstr)) {
dcca2c59 251 const char* old_start = SvPVX(PL_linestr);
252 int start_diff;
c5912dc7 253 const int old_len = SvCUR(PL_linestr);
0ba8c7aa 254#ifdef DD_DEBUG
53e3ab32 255 printf("Got string %s\n", retstr);
0ba8c7aa 256#endif
c5912dc7 257 SvGROW(PL_linestr, (STRLEN)(old_len + strlen(retstr)));
dcca2c59 258 if (start_diff = SvPVX(PL_linestr) - old_start) {
8314c6b3 259 Perl_croak(aTHX_ "forced to realloc PL_linestr for line %s, bailing out before we crash harder", SvPVX(PL_linestr));
dcca2c59 260 }
53e3ab32 261 memmove(s+strlen(retstr), s, (PL_bufend - s)+1);
262 memmove(s, retstr, strlen(retstr));
c5912dc7 263 SvCUR_set(PL_linestr, old_len + strlen(retstr));
53e3ab32 264 PL_bufend += strlen(retstr);
265#ifdef DD_DEBUG
266 printf("cur buf: %s\n", s);
dcca2c59 267 printf("PL_bufptr: %s\n", PL_bufptr);
53e3ab32 268 printf("bufend at: %i\n", PL_bufend - s);
269 printf("linestr: %s\n", SvPVX(PL_linestr));
270 printf("linestr len: %i\n", PL_bufend - SvPVX(PL_linestr));
dcca2c59 271 printf("tokenbuf now: %s\n", PL_tokenbuf);
53e3ab32 272#endif
273 }
274 } else {
94caac6e 275 call_argv("Devel::Declare::init_declare", G_VOID|G_DISCARD, cb_args);
94caac6e 276 }
53e3ab32 277 return o;
278}
279
b7505981 280OP* dd_pp_entereval(pTHX) {
281 dSP;
282 dPOPss;
283 STRLEN len;
284 const char* s;
285 if (SvPOK(sv)) {
53e3ab32 286#ifdef DD_DEBUG
b7505981 287 printf("mangling eval sv\n");
53e3ab32 288#endif
b7505981 289 if (SvREADONLY(sv))
290 sv = sv_2mortal(newSVsv(sv));
291 s = SvPVX(sv);
292 len = SvCUR(sv);
293 if (!len || s[len-1] != ';') {
294 if (!(SvFLAGS(sv) & SVs_TEMP))
295 sv = sv_2mortal(newSVsv(sv));
296 sv_catpvn(sv, "\n;", 2);
53e3ab32 297 }
b7505981 298 SvGROW(sv, 8192);
53e3ab32 299 }
b7505981 300 PUSHs(sv);
301 return PL_ppaddr[OP_ENTEREVAL](aTHX);
302}
53e3ab32 303
b7505981 304STATIC OP *dd_ck_entereval(pTHX_ OP *o) {
305 o = dd_old_ck_entereval(aTHX_ o); /* let the original do its job */
d8e65fc8 306 if (o->op_ppaddr == PL_ppaddr[OP_ENTEREVAL])
307 o->op_ppaddr = dd_pp_entereval;
94caac6e 308 return o;
309}
310
6a0bcf35 311static I32 dd_filter_realloc(pTHX_ int idx, SV *sv, int maxlen)
312{
313 const I32 count = FILTER_READ(idx+1, sv, maxlen);
314 SvGROW(sv, 8192); /* please try not to have a line longer than this :) */
315 /* filter_del(dd_filter_realloc); */
316 return count;
317}
318
94caac6e 319static int initialized = 0;
320
321MODULE = Devel::Declare PACKAGE = Devel::Declare
322
323PROTOTYPES: DISABLE
324
325void
326setup()
327 CODE:
328 if (!initialized++) {
329 dd_old_ck_rv2cv = PL_check[OP_RV2CV];
330 PL_check[OP_RV2CV] = dd_ck_rv2cv;
b7505981 331 dd_old_ck_entereval = PL_check[OP_ENTEREVAL];
332 PL_check[OP_ENTEREVAL] = dd_ck_entereval;
94caac6e 333 }
6a0bcf35 334 filter_add(dd_filter_realloc, NULL);