This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
https://perl5.git.perl.org / perl5.git / blame
? search:
summary | shortlog | log | commit | commitdiff | tree
blob | blame (incremental) | history | HEAD
[asperl] Created new branch from win32@396, added AS patch#1
[perl5.git] / op.c
CommitLineData
a0d0e21e 1/* op.c
79072805 2 *
9607fc9c 3 * Copyright (c) 1991-1997, Larry Wall
79072805
LW		 4 *
5 * You may distribute under the terms of either the GNU General Public
6 * License or the Artistic License, as specified in the README file.
7 *
a0d0e21e
LW		 8 */
9
10/*
11 * "You see: Mr. Drogo, he married poor Miss Primula Brandybuck. She was
12 * our Mr. Bilbo's first cousin on the mother's side (her mother being the
13 * youngest of the Old Took's daughters); and Mr. Drogo was his second
14 * cousin. So Mr. Frodo is his first *and* second cousin, once removed
15 * either way, as the saying is, if you follow me." --the Gaffer
79072805
LW		 16 */
17
18#include "EXTERN.h"
19#include "perl.h"
20
e50aee73 21/*
5dc0d613 22 * In the following definition, the ", Nullop" is just to make the compiler
a5f75d66 23 * think the expression is of the right type: croak actually does a Siglongjmp.
e50aee73 24 */
11343788 25#define CHECKOP(type,o) \
28757baa 26 ((op_mask && op_mask[type]) \
5dc0d613 27 ? ( op_free((OP*)o), \
28757baa 28 croak("%s trapped by operation mask", op_desc[type]), \
29 Nullop ) \
11343788 30 : (*check[type])((OP*)o))
e50aee73 31
11343788 32static I32 list_assignment _((OP *o));
3bc5dc61 33static void bad_type _((I32 n, char *t, char *name, OP *kid));
11343788
MB		 34static OP *modkids _((OP *o, I32 type));
35static OP *no_fh_allowed _((OP *o));
5dc0d613 36static bool scalar_mod_type _((OP *o, I32 type));
11343788
MB		 37static OP *scalarboolean _((OP *o));
38static OP *too_few_arguments _((OP *o, char* name));
39static OP *too_many_arguments _((OP *o, char* name));
40static void null _((OP* o));
bbce6d69 41static PADOFFSET pad_findlex _((char* name, PADOFFSET newoff, U32 seq,
748a9306 42 CV* startcv, I32 cx_ix));
54b9620d 43static OP *newDEFSVOP _((void));
79072805 44
4633a7c4 45static char*
8ac85365 46gv_ename(GV *gv)
4633a7c4
LW		 47{
48 SV* tmpsv = sv_newmortal();
46fc3d4c 49 gv_efullname3(tmpsv, gv, Nullch);
4633a7c4
LW		 50 return SvPV(tmpsv,na);
51}
52
8990e307 53static OP *
8ac85365 54no_fh_allowed(OP *o)
79072805 55{
46fc3d4c 56 yyerror(form("Missing comma after first argument to %s function",
5196be3e 57 op_desc[o->op_type]));
11343788 58 return o;
79072805
LW		 59}
60
8990e307 61static OP *
8ac85365 62too_few_arguments(OP *o, char *name)
79072805 63{
46fc3d4c 64 yyerror(form("Not enough arguments for %s", name));
11343788 65 return o;
79072805
LW		 66}
67
8990e307 68static OP *
8ac85365 69too_many_arguments(OP *o, char *name)
79072805 70{
46fc3d4c 71 yyerror(form("Too many arguments for %s", name));
11343788 72 return o;
79072805
LW		 73}
74
3bc5dc61 75static void
8ac85365 76bad_type(I32 n, char *t, char *name, OP *kid)
8990e307 77{
46fc3d4c 78 yyerror(form("Type of arg %d to %s must be %s (not %s)",
79 (int)n, name, t, op_desc[kid->op_type]));
8990e307
LW		 80}
81
a0d0e21e 82void
8ac85365 83assertref(OP *o)
a0d0e21e 84{
11343788 85 int type = o->op_type;
a0d0e21e 86 if (type != OP_AELEM && type != OP_HELEM) {
46fc3d4c 87 yyerror(form("Can't use subscript on %s", op_desc[type]));
8ebc5c01 88 if (type == OP_ENTERSUB || type == OP_RV2HV || type == OP_PADHV)
748a9306 89 warn("(Did you mean $ or @ instead of %c?)\n",
8ebc5c01 90 type == OP_ENTERSUB ? '&' : '%');
a0d0e21e
LW		 91 }
92}
93
79072805
LW		 94/* "register" allocation */
95
96PADOFFSET
8ac85365 97pad_allocmy(char *name)
93a17b20 98{
11343788 99 dTHR;
a0d0e21e
LW		 100 PADOFFSET off;
101 SV *sv;
102
103 if (!(isALPHA(name[1]) || name[1] == '_' && (int)strlen(name) > 2)) {
46fc3d4c 104 if (!isPRINT(name[1])) {
105 name[3] = '\0';
106 name[2] = toCTRL(name[1]);
107 name[1] = '^';
108 }
a0d0e21e
LW		 109 croak("Can't use global %s in \"my\"",name);
110 }
fb73857a 111 if (dowarn && AvFILL(comppad_name) >= 0) {
b1cb66bf 112 SV **svp = AvARRAY(comppad_name);
113 for (off = AvFILL(comppad_name); off > comppad_name_floor; off--) {
114 if ((sv = svp[off])
115 && sv != &sv_undef
116 && SvIVX(sv) == 999999999 /* var is in open scope */
117 && strEQ(name, SvPVX(sv)))
118 {
119 warn("\"my\" variable %s masks earlier declaration in same scope", name);
120 break;
121 }
122 }
123 }
a0d0e21e
LW		 124 off = pad_alloc(OP_PADSV, SVs_PADMY);
125 sv = NEWSV(1102,0);
93a17b20
LW		 126 sv_upgrade(sv, SVt_PVNV);
127 sv_setpv(sv, name);
c750a3ec
MB		 128 if (in_my_stash) {
129 if (*name != '$')
130 croak("Can't declare class for non-scalar %s in \"my\"",name);
131 SvOBJECT_on(sv);
132 (void)SvUPGRADE(sv, SVt_PVMG);
133 SvSTASH(sv) = (HV*)SvREFCNT_inc(in_my_stash);
134 sv_objcount++;
135 }
8990e307 136 av_store(comppad_name, off, sv);
748a9306 137 SvNVX(sv) = (double)999999999;
8990e307
LW		 138 SvIVX(sv) = 0; /* Not yet introduced--see newSTATEOP */
139 if (!min_intro_pending)
140 min_intro_pending = off;
141 max_intro_pending = off;
93a17b20 142 if (*name == '@')
463ee0b2 143 av_store(comppad, off, (SV*)newAV());
93a17b20 144 else if (*name == '%')
463ee0b2 145 av_store(comppad, off, (SV*)newHV());
ed6116ce 146 SvPADMY_on(curpad[off]);
93a17b20
LW		 147 return off;
148}
149
748a9306 150static PADOFFSET
e9a444f0 151#ifndef CAN_PROTOTYPE
748a9306 152pad_findlex(name, newoff, seq, startcv, cx_ix)
93a17b20 153char *name;
748a9306 154PADOFFSET newoff;
bbce6d69 155U32 seq;
748a9306
LW		 156CV* startcv;
157I32 cx_ix;
e9a444f0 158#else
bbce6d69 159pad_findlex(char *name, PADOFFSET newoff, U32 seq, CV* startcv, I32 cx_ix)
e9a444f0 160#endif
93a17b20 161{
11343788 162 dTHR;
748a9306 163 CV *cv;
93a17b20
LW		 164 I32 off;
165 SV *sv;
93a17b20 166 register I32 i;
c09156bb 167 register PERL_CONTEXT *cx;
a0d0e21e 168 int saweval;
93a17b20 169
748a9306 170 for (cv = startcv; cv; cv = CvOUTSIDE(cv)) {
4fdae800 171 AV *curlist = CvPADLIST(cv);
172 SV **svp = av_fetch(curlist, 0, FALSE);
748a9306 173 AV *curname;
4fdae800 174
748a9306 175 if (!svp || *svp == &sv_undef)
4633a7c4 176 continue;
748a9306
LW		 177 curname = (AV*)*svp;
178 svp = AvARRAY(curname);
179 for (off = AvFILL(curname); off > 0; off--) {
180 if ((sv = svp[off]) &&
181 sv != &sv_undef &&
182 seq <= SvIVX(sv) &&
13826f2c 183 seq > I_32(SvNVX(sv)) &&
748a9306
LW		 184 strEQ(SvPVX(sv), name))
185 {
5f05dabc 186 I32 depth;
187 AV *oldpad;
188 SV *oldsv;
189
190 depth = CvDEPTH(cv);
191 if (!depth) {
9607fc9c 192 if (newoff) {
193 if (SvFAKE(sv))
194 continue;
4fdae800 195 return 0; /* don't clone from inactive stack frame */
9607fc9c 196 }
5f05dabc 197 depth = 1;
198 }
199 oldpad = (AV*)*av_fetch(curlist, depth, FALSE);
200 oldsv = *av_fetch(oldpad, off, TRUE);
748a9306 201 if (!newoff) { /* Not a mere clone operation. */
9607fc9c 202 SV *namesv = NEWSV(1103,0);
748a9306 203 newoff = pad_alloc(OP_PADSV, SVs_PADMY);
9607fc9c 204 sv_upgrade(namesv, SVt_PVNV);
205 sv_setpv(namesv, name);
206 av_store(comppad_name, newoff, namesv);
207 SvNVX(namesv) = (double)curcop->cop_seq;
208 SvIVX(namesv) = 999999999; /* A ref, intro immediately */
209 SvFAKE_on(namesv); /* A ref, not a real var */
774d564b 210 if (CvANON(compcv) || SvTYPE(compcv) == SVt_PVFM) {
28757baa 211 /* "It's closures all the way down." */
212 CvCLONE_on(compcv);
54310121 213 if (cv == startcv) {
214 if (CvANON(compcv))
215 oldsv = Nullsv; /* no need to keep ref */
216 }
217 else {
28757baa 218 CV *bcv;
219 for (bcv = startcv;
220 bcv && bcv != cv && !CvCLONE(bcv);
221 bcv = CvOUTSIDE(bcv)) {
222 if (CvANON(bcv))
223 CvCLONE_on(bcv);
224 else {
774d564b 225 if (dowarn && !CvUNIQUE(cv))
44a8e56a 226 warn(
227 "Variable \"%s\" may be unavailable",
28757baa 228 name);
229 break;
230 }
231 }
232 }
233 }
44a8e56a 234 else if (!CvUNIQUE(compcv)) {
9607fc9c 235 if (dowarn && !SvFAKE(sv) && !CvUNIQUE(cv))
44a8e56a 236 warn("Variable \"%s\" will not stay shared", name);
5f05dabc 237 }
748a9306 238 }
199100c8 239 av_store(comppad, newoff, SvREFCNT_inc(oldsv));
748a9306
LW		 240 return newoff;
241 }
93a17b20
LW		 242 }
243 }
244
245 /* Nothing in current lexical context--try eval's context, if any.
246 * This is necessary to let the perldb get at lexically scoped variables.
247 * XXX This will also probably interact badly with eval tree caching.
248 */
249
a0d0e21e 250 saweval = 0;
748a9306 251 for (i = cx_ix; i >= 0; i--) {
93a17b20
LW		 252 cx = &cxstack[i];
253 switch (cx->cx_type) {
254 default:
748a9306
LW		 255 if (i == 0 && saweval) {
256 seq = cxstack[saweval].blk_oldcop->cop_seq;
257 return pad_findlex(name, newoff, seq, main_cv, 0);
258 }
93a17b20
LW		 259 break;
260 case CXt_EVAL:
44a8e56a 261 switch (cx->blk_eval.old_op_type) {
262 case OP_ENTEREVAL:
263 saweval = i;
264 break;
265 case OP_REQUIRE:
266 /* require must have its own scope */
267 return 0;
268 }
93a17b20
LW		 269 break;
270 case CXt_SUB:
271 if (!saweval)
272 return 0;
273 cv = cx->blk_sub.cv;
748a9306
LW		 274 if (debstash && CvSTASH(cv) == debstash) { /* ignore DB'* scope */
275 saweval = i; /* so we know where we were called from */
93a17b20 276 continue;
93a17b20 277 }
748a9306
LW		 278 seq = cxstack[saweval].blk_oldcop->cop_seq;
279 return pad_findlex(name, newoff, seq, cv, i-1);
93a17b20
LW		 280 }
281 }
282
748a9306
LW		 283 return 0;
284}
a0d0e21e 285
748a9306 286PADOFFSET
8ac85365 287pad_findmy(char *name)
748a9306 288{
11343788 289 dTHR;
748a9306 290 I32 off;
54310121 291 I32 pendoff = 0;
748a9306
LW		 292 SV *sv;
293 SV **svp = AvARRAY(comppad_name);
bbce6d69 294 U32 seq = cop_seqmax;
748a9306 295
11343788
MB		 296#ifdef USE_THREADS
297 /*
298 * Special case to get lexical (and hence per-thread) @_.
299 * XXX I need to find out how to tell at parse-time whether use
300 * of @_ should refer to a lexical (from a sub) or defgv (global
301 * scope and maybe weird sub-ish things like formats). See
302 * startsub in perly.y. It's possible that @_ could be lexical
303 * (at least from subs) even in non-threaded perl.
304 */
305 if (strEQ(name, "@_"))
306 return 0; /* success. (NOT_IN_PAD indicates failure) */
307#endif /* USE_THREADS */
308
748a9306 309 /* The one we're looking for is probably just before comppad_name_fill. */
4633a7c4 310 for (off = AvFILL(comppad_name); off > 0; off--) {
a0d0e21e
LW		 311 if ((sv = svp[off]) &&
312 sv != &sv_undef &&
54310121 313 (!SvIVX(sv) ||
314 (seq <= SvIVX(sv) &&
315 seq > I_32(SvNVX(sv)))) &&
a0d0e21e
LW		 316 strEQ(SvPVX(sv), name))
317 {
54310121 318 if (SvIVX(sv))
319 return (PADOFFSET)off;
320 pendoff = off; /* this pending def. will override import */
a0d0e21e
LW		 321 }
322 }
748a9306
LW		 323
324 /* See if it's in a nested scope */
325 off = pad_findlex(name, 0, seq, CvOUTSIDE(compcv), cxstack_ix);
54310121 326 if (off) {
327 /* If there is a pending local definition, this new alias must die */
328 if (pendoff)
329 SvIVX(AvARRAY(comppad_name)[off]) = seq;
11343788 330 return off; /* pad_findlex returns 0 for failure...*/
54310121 331 }
11343788 332 return NOT_IN_PAD; /* ...but we return NOT_IN_PAD for failure */
93a17b20
LW		 333}
334
335void
8ac85365 336pad_leavemy(I32 fill)
93a17b20
LW		 337{
338 I32 off;
8990e307 339 SV **svp = AvARRAY(comppad_name);
93a17b20 340 SV *sv;
8990e307
LW		 341 if (min_intro_pending && fill < min_intro_pending) {
342 for (off = max_intro_pending; off >= min_intro_pending; off--) {
a0d0e21e 343 if ((sv = svp[off]) && sv != &sv_undef)
8990e307
LW		 344 warn("%s never introduced", SvPVX(sv));
345 }
346 }
347 /* "Deintroduce" my variables that are leaving with this scope. */
348 for (off = AvFILL(comppad_name); off > fill; off--) {
748a9306 349 if ((sv = svp[off]) && sv != &sv_undef && SvIVX(sv) == 999999999)
463ee0b2 350 SvIVX(sv) = cop_seqmax;
93a17b20
LW		 351 }
352}
353
354PADOFFSET
8ac85365 355pad_alloc(I32 optype, U32 tmptype)
79072805 356{
11343788 357 dTHR;
79072805
LW		 358 SV *sv;
359 I32 retval;
360
361 if (AvARRAY(comppad) != curpad)
463ee0b2 362 croak("panic: pad_alloc");
a0d0e21e
LW		 363 if (pad_reset_pending)
364 pad_reset();
ed6116ce 365 if (tmptype & SVs_PADMY) {
79072805
LW		 366 do {
367 sv = *av_fetch(comppad, AvFILL(comppad) + 1, TRUE);
ed6116ce 368 } while (SvPADBUSY(sv)); /* need a fresh one */
79072805
LW		 369 retval = AvFILL(comppad);
370 }
371 else {
bbce6d69 372 SV **names = AvARRAY(comppad_name);
373 SSize_t names_fill = AvFILL(comppad_name);
374 for (;;) {
375 /*
376 * "foreach" index vars temporarily become aliases to non-"my"
377 * values. Thus we must skip, not just pad values that are
378 * marked as current pad values, but also those with names.
379 */
380 if (++padix <= names_fill &&
381 (sv = names[padix]) && sv != &sv_undef)
382 continue;
383 sv = *av_fetch(comppad, padix, TRUE);
384 if (!(SvFLAGS(sv) & (SVs_PADTMP|SVs_PADMY)))
385 break;
386 }
79072805
LW		 387 retval = padix;
388 }
8990e307 389 SvFLAGS(sv) |= tmptype;
79072805 390 curpad = AvARRAY(comppad);
11343788 391#ifdef USE_THREADS
5dc0d613
MB		 392 DEBUG_X(PerlIO_printf(Perl_debug_log, "0x%lx Pad 0x%lx alloc %ld for %s\n",
393 (unsigned long) thr, (unsigned long) curpad,
394 (long) retval, op_name[optype]));
11343788 395#else
5dc0d613
MB		 396 DEBUG_X(PerlIO_printf(Perl_debug_log, "Pad alloc %ld for %s\n",
397 (long) retval, op_name[optype]));
11343788 398#endif /* USE_THREADS */
79072805
LW		 399 return (PADOFFSET)retval;
400}
401
402SV *
a0d0e21e 403#ifndef CAN_PROTOTYPE
79072805
LW		 404pad_sv(po)
405PADOFFSET po;
8990e307
LW		 406#else
407pad_sv(PADOFFSET po)
a0d0e21e 408#endif /* CAN_PROTOTYPE */
79072805 409{
11343788
MB		 410 dTHR;
411#ifdef USE_THREADS
5dc0d613
MB		 412 DEBUG_X(PerlIO_printf(Perl_debug_log, "0x%lx Pad 0x%lx sv %d\n",
413 (unsigned long) thr, (unsigned long) curpad, po));
11343788 414#else
79072805 415 if (!po)
463ee0b2 416 croak("panic: pad_sv po");
5dc0d613 417 DEBUG_X(PerlIO_printf(Perl_debug_log, "Pad sv %d\n", po));
11343788 418#endif /* USE_THREADS */
79072805
LW		 419 return curpad[po]; /* eventually we'll turn this into a macro */
420}
421
422void
a0d0e21e 423#ifndef CAN_PROTOTYPE
79072805
LW		 424pad_free(po)
425PADOFFSET po;
8990e307
LW		 426#else
427pad_free(PADOFFSET po)
a0d0e21e 428#endif /* CAN_PROTOTYPE */
79072805 429{
11343788 430 dTHR;
a0d0e21e
LW		 431 if (!curpad)
432 return;
79072805 433 if (AvARRAY(comppad) != curpad)
463ee0b2 434 croak("panic: pad_free curpad");
79072805 435 if (!po)
463ee0b2 436 croak("panic: pad_free po");
11343788 437#ifdef USE_THREADS
5dc0d613
MB		 438 DEBUG_X(PerlIO_printf(Perl_debug_log, "0x%lx Pad 0x%lx free %d\n",
439 (unsigned long) thr, (unsigned long) curpad, po));
11343788 440#else
5dc0d613 441 DEBUG_X(PerlIO_printf(Perl_debug_log, "Pad free %d\n", po));
11343788 442#endif /* USE_THREADS */
a0d0e21e 443 if (curpad[po] && curpad[po] != &sv_undef)
ed6116ce 444 SvPADTMP_off(curpad[po]);
a0d0e21e 445 if ((I32)po < padix)
79072805
LW		 446 padix = po - 1;
447}
448
449void
a0d0e21e 450#ifndef CAN_PROTOTYPE
79072805
LW		 451pad_swipe(po)
452PADOFFSET po;
8990e307
LW		 453#else
454pad_swipe(PADOFFSET po)
a0d0e21e 455#endif /* CAN_PROTOTYPE */
79072805 456{
11343788 457 dTHR;
79072805 458 if (AvARRAY(comppad) != curpad)
463ee0b2 459 croak("panic: pad_swipe curpad");
79072805 460 if (!po)
463ee0b2 461 croak("panic: pad_swipe po");
11343788 462#ifdef USE_THREADS
5dc0d613
MB		 463 DEBUG_X(PerlIO_printf(Perl_debug_log, "0x%lx Pad 0x%lx swipe %d\n",
464 (unsigned long) thr, (unsigned long) curpad, po));
11343788 465#else
5dc0d613 466 DEBUG_X(PerlIO_printf(Perl_debug_log, "Pad swipe %d\n", po));
11343788 467#endif /* USE_THREADS */
ed6116ce 468 SvPADTMP_off(curpad[po]);
a0d0e21e
LW		 469 curpad[po] = NEWSV(1107,0);
470 SvPADTMP_on(curpad[po]);
471 if ((I32)po < padix)
79072805
LW		 472 padix = po - 1;
473}
474
475void
8ac85365 476pad_reset(void)
79072805 477{
11343788 478 dTHR;
79072805
LW		 479 register I32 po;
480
481 if (AvARRAY(comppad) != curpad)
463ee0b2 482 croak("panic: pad_reset curpad");
11343788 483#ifdef USE_THREADS
5dc0d613
MB		 484 DEBUG_X(PerlIO_printf(Perl_debug_log, "0x%lx Pad 0x%lx reset\n",
485 (unsigned long) thr, (unsigned long) curpad));
11343788 486#else
760ac839 487 DEBUG_X(PerlIO_printf(Perl_debug_log, "Pad reset\n"));
11343788 488#endif /* USE_THREADS */
748a9306
LW		 489 if (!tainting) { /* Can't mix tainted and non-tainted temporaries. */
490 for (po = AvMAX(comppad); po > padix_floor; po--) {
ff0cee69 491 if (curpad[po] && !SvIMMORTAL(curpad[po]))
748a9306
LW		 492 SvPADTMP_off(curpad[po]);
493 }
494 padix = padix_floor;
79072805 495 }
a0d0e21e 496 pad_reset_pending = FALSE;
79072805
LW		 497}
498
a863c7d1 499#ifdef USE_THREADS
54b9620d 500/* find_threadsv is not reentrant */
a863c7d1 501PADOFFSET
54b9620d 502find_threadsv(char *name)
a863c7d1
MB		 503{
504 dTHR;
505 char *p;
506 PADOFFSET key;
554b3eca 507 SV **svp;
54b9620d
MB		 508 /* We currently only handle names of a single character */
509 p = strchr(threadsv_names, *name);
a863c7d1
MB		 510 if (!p)
511 return NOT_IN_PAD;
54b9620d
MB		 512 key = p - threadsv_names;
513 svp = av_fetch(thr->threadsv, key, FALSE);
554b3eca
MB		 514 if (!svp) {
515 SV *sv = NEWSV(0, 0);
54b9620d 516 av_store(thr->threadsv, key, sv);
554b3eca
MB		 517 /*
518 * Some magic variables used to be automagically initialised
519 * in gv_fetchpv. Those which are now per-thread magicals get
520 * initialised here instead.
521 */
522 switch (*name) {
54b9620d
MB		 523 case '_':
524 break;
554b3eca
MB		 525 case ';':
526 sv_setpv(sv, "\034");
54b9620d 527 sv_magic(sv, 0, 0, name, 1);
554b3eca 528 break;
c277df42
IZ		 529 case '&':
530 case '`':
531 case '\'':
532 sawampersand = TRUE;
533 SvREADONLY_on(sv);
d8b5173a 534 /* FALL THROUGH */
54b9620d
MB		 535 default:
536 sv_magic(sv, 0, 0, name, 1);
554b3eca 537 }
a863c7d1 538 DEBUG_L(PerlIO_printf(PerlIO_stderr(),
54b9620d 539 "find_threadsv: new SV %p for $%s%c\n",
554b3eca
MB		 540 sv, (*name < 32) ? "^" : "",
541 (*name < 32) ? toCTRL(*name) : *name));
a863c7d1
MB		 542 }
543 return key;
544}
545#endif /* USE_THREADS */
546
79072805
LW		 547/* Destructor */
548
549void
8ac85365 550op_free(OP *o)
79072805 551{
85e6fe83 552 register OP *kid, *nextkid;
79072805 553
5dc0d613 554 if (!o || o->op_seq == (U16)-1)
79072805
LW		 555 return;
556
11343788
MB		 557 if (o->op_flags & OPf_KIDS) {
558 for (kid = cUNOPo->op_first; kid; kid = nextkid) {
85e6fe83 559 nextkid = kid->op_sibling; /* Get before next freeing kid */
79072805 560 op_free(kid);
85e6fe83 561 }
79072805
LW		 562 }
563
11343788 564 switch (o->op_type) {
8990e307 565 case OP_NULL:
11343788 566 o->op_targ = 0; /* Was holding old type, if any. */
8990e307 567 break;
a0d0e21e 568 case OP_ENTEREVAL:
11343788 569 o->op_targ = 0; /* Was holding hints. */
a0d0e21e 570 break;
554b3eca 571#ifdef USE_THREADS
2faa37cc 572 case OP_THREADSV:
54b9620d 573 o->op_targ = 0; /* Was holding index into thr->threadsv AV. */
554b3eca
MB		 574 break;
575#endif /* USE_THREADS */
a6006777 576 default:
5196be3e 577 if (!(o->op_flags & OPf_REF) || (check[o->op_type] != ck_ftst))
a6006777 578 break;
579 /* FALL THROUGH */
463ee0b2 580 case OP_GVSV:
79072805 581 case OP_GV:
a6006777 582 case OP_AELEMFAST:
11343788 583 SvREFCNT_dec(cGVOPo->op_gv);
8990e307
LW		 584 break;
585 case OP_NEXTSTATE:
586 case OP_DBSTATE:
5196be3e 587 Safefree(cCOPo->cop_label);
11343788 588 SvREFCNT_dec(cCOPo->cop_filegv);
79072805
LW		 589 break;
590 case OP_CONST:
11343788 591 SvREFCNT_dec(cSVOPo->op_sv);
79072805 592 break;
748a9306
LW		 593 case OP_GOTO:
594 case OP_NEXT:
595 case OP_LAST:
596 case OP_REDO:
11343788 597 if (o->op_flags & (OPf_SPECIAL|OPf_STACKED|OPf_KIDS))
748a9306
LW		 598 break;
599 /* FALL THROUGH */
a0d0e21e 600 case OP_TRANS:
11343788 601 Safefree(cPVOPo->op_pv);
a0d0e21e
LW		 602 break;
603 case OP_SUBST:
11343788 604 op_free(cPMOPo->op_pmreplroot);
a0d0e21e 605 /* FALL THROUGH */
748a9306 606 case OP_PUSHRE:
a0d0e21e 607 case OP_MATCH:
c277df42 608 ReREFCNT_dec(cPMOPo->op_pmregexp);
a0d0e21e 609 break;
79072805
LW		 610 }
611
11343788
MB		 612 if (o->op_targ > 0)
613 pad_free(o->op_targ);
8990e307 614
11343788 615 Safefree(o);
79072805
LW		 616}
617
8990e307 618static void
8ac85365 619null(OP *o)
8990e307 620{
54b9620d 621 if (o->op_type != OP_NULL && o->op_type != OP_THREADSV && o->op_targ > 0)
11343788
MB		 622 pad_free(o->op_targ);
623 o->op_targ = o->op_type;
624 o->op_type = OP_NULL;
625 o->op_ppaddr = ppaddr[OP_NULL];
8990e307
LW		 626}
627
79072805
LW		 628/* Contextualizers */
629
463ee0b2 630#define LINKLIST(o) ((o)->op_next ? (o)->op_next : linklist((OP*)o))
79072805
LW		 631
632OP *
8ac85365 633linklist(OP *o)
79072805
LW		 634{
635 register OP *kid;
636
11343788
MB		 637 if (o->op_next)
638 return o->op_next;
79072805
LW		 639
640 /* establish postfix order */
11343788
MB		 641 if (cUNOPo->op_first) {
642 o->op_next = LINKLIST(cUNOPo->op_first);
643 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
79072805
LW		 644 if (kid->op_sibling)
645 kid->op_next = LINKLIST(kid->op_sibling);
646 else
11343788 647 kid->op_next = o;
79072805
LW		 648 }
649 }
650 else
11343788 651 o->op_next = o;
79072805 652
11343788 653 return o->op_next;
79072805
LW		 654}
655
656OP *
8ac85365 657scalarkids(OP *o)
79072805
LW		 658{
659 OP *kid;
11343788
MB		 660 if (o && o->op_flags & OPf_KIDS) {
661 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
79072805
LW		 662 scalar(kid);
663 }
11343788 664 return o;
79072805
LW		 665}
666
a0d0e21e 667static OP *
8ac85365 668scalarboolean(OP *o)
8990e307
LW		 669{
670 if (dowarn &&
11343788 671 o->op_type == OP_SASSIGN && cBINOPo->op_first->op_type == OP_CONST) {
0f15f207 672 dTHR;
a0d0e21e
LW		 673 line_t oldline = curcop->cop_line;
674
675 if (copline != NOLINE)
676 curcop->cop_line = copline;
677 warn("Found = in conditional, should be ==");
678 curcop->cop_line = oldline;
679 }
11343788 680 return scalar(o);
8990e307
LW		 681}
682
683OP *
8ac85365 684scalar(OP *o)
79072805
LW		 685{
686 OP *kid;
687
a0d0e21e 688 /* assumes no premature commitment */
5dc0d613
MB		 689 if (!o || (o->op_flags & OPf_WANT) || error_count
690 || o->op_type == OP_RETURN)
11343788 691 return o;
79072805 692
5dc0d613 693 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_SCALAR;
79072805 694
11343788 695 switch (o->op_type) {
79072805 696 case OP_REPEAT:
11343788
MB		 697 if (o->op_private & OPpREPEAT_DOLIST)
698 null(((LISTOP*)cBINOPo->op_first)->op_first);
699 scalar(cBINOPo->op_first);
8990e307 700 break;
79072805
LW		 701 case OP_OR:
702 case OP_AND:
703 case OP_COND_EXPR:
11343788 704 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
8990e307 705 scalar(kid);
79072805 706 break;
a0d0e21e 707 case OP_SPLIT:
11343788 708 if ((kid = cLISTOPo->op_first) && kid->op_type == OP_PUSHRE) {
a0d0e21e
LW		 709 if (!kPMOP->op_pmreplroot)
710 deprecate("implicit split to @_");
711 }
712 /* FALL THROUGH */
79072805
LW		 713 case OP_MATCH:
714 case OP_SUBST:
715 case OP_NULL:
8990e307 716 default:
11343788
MB		 717 if (o->op_flags & OPf_KIDS) {
718 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling)
8990e307
LW		 719 scalar(kid);
720 }
79072805
LW		 721 break;
722 case OP_LEAVE:
723 case OP_LEAVETRY:
5dc0d613 724 kid = cLISTOPo->op_first;
54310121 725 scalar(kid);
726 while (kid = kid->op_sibling) {
727 if (kid->op_sibling)
728 scalarvoid(kid);
729 else
730 scalar(kid);
731 }
0f15f207 732 WITH_THR(curcop = &compiling);
54310121 733 break;
748a9306 734 case OP_SCOPE:
79072805 735 case OP_LINESEQ:
8990e307 736 case OP_LIST:
11343788 737 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
79072805
LW		 738 if (kid->op_sibling)
739 scalarvoid(kid);
740 else
741 scalar(kid);
742 }
0f15f207 743 WITH_THR(curcop = &compiling);
79072805
LW		 744 break;
745 }
11343788 746 return o;
79072805
LW		 747}
748
749OP *
8ac85365 750scalarvoid(OP *o)
79072805
LW		 751{
752 OP *kid;
8990e307
LW		 753 char* useless = 0;
754 SV* sv;
79072805 755
54310121 756 /* assumes no premature commitment */
5dc0d613
MB		 757 if (!o || (o->op_flags & OPf_WANT) == OPf_WANT_LIST || error_count
758 || o->op_type == OP_RETURN)
11343788 759 return o;
79072805 760
5dc0d613 761 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
79072805 762
11343788 763 switch (o->op_type) {
79072805 764 default:
11343788 765 if (!(opargs[o->op_type] & OA_FOLDCONST))
8990e307 766 break;
36477c24 767 /* FALL THROUGH */
768 case OP_REPEAT:
11343788 769 if (o->op_flags & OPf_STACKED)
8990e307
LW		 770 break;
771 /* FALL THROUGH */
772 case OP_GVSV:
773 case OP_WANTARRAY:
774 case OP_GV:
775 case OP_PADSV:
776 case OP_PADAV:
777 case OP_PADHV:
778 case OP_PADANY:
779 case OP_AV2ARYLEN:
8990e307 780 case OP_REF:
a0d0e21e
LW		 781 case OP_REFGEN:
782 case OP_SREFGEN:
8990e307
LW		 783 case OP_DEFINED:
784 case OP_HEX:
785 case OP_OCT:
786 case OP_LENGTH:
787 case OP_SUBSTR:
788 case OP_VEC:
789 case OP_INDEX:
790 case OP_RINDEX:
791 case OP_SPRINTF:
792 case OP_AELEM:
793 case OP_AELEMFAST:
794 case OP_ASLICE:
8990e307
LW		 795 case OP_HELEM:
796 case OP_HSLICE:
797 case OP_UNPACK:
798 case OP_PACK:
8990e307
LW		 799 case OP_JOIN:
800 case OP_LSLICE:
801 case OP_ANONLIST:
802 case OP_ANONHASH:
803 case OP_SORT:
804 case OP_REVERSE:
805 case OP_RANGE:
806 case OP_FLIP:
807 case OP_FLOP:
808 case OP_CALLER:
809 case OP_FILENO:
810 case OP_EOF:
811 case OP_TELL:
812 case OP_GETSOCKNAME:
813 case OP_GETPEERNAME:
814 case OP_READLINK:
815 case OP_TELLDIR:
816 case OP_GETPPID:
817 case OP_GETPGRP:
818 case OP_GETPRIORITY:
819 case OP_TIME:
820 case OP_TMS:
821 case OP_LOCALTIME:
822 case OP_GMTIME:
823 case OP_GHBYNAME:
824 case OP_GHBYADDR:
825 case OP_GHOSTENT:
826 case OP_GNBYNAME:
827 case OP_GNBYADDR:
828 case OP_GNETENT:
829 case OP_GPBYNAME:
830 case OP_GPBYNUMBER:
831 case OP_GPROTOENT:
832 case OP_GSBYNAME:
833 case OP_GSBYPORT:
834 case OP_GSERVENT:
835 case OP_GPWNAM:
836 case OP_GPWUID:
837 case OP_GGRNAM:
838 case OP_GGRGID:
839 case OP_GETLOGIN:
11343788
MB		 840 if (!(o->op_private & OPpLVAL_INTRO))
841 useless = op_desc[o->op_type];
8990e307
LW		 842 break;
843
844 case OP_RV2GV:
845 case OP_RV2SV:
846 case OP_RV2AV:
847 case OP_RV2HV:
11343788
MB		 848 if (!(o->op_private & OPpLVAL_INTRO) &&
849 (!o->op_sibling || o->op_sibling->op_type != OP_READLINE))
8990e307
LW		 850 useless = "a variable";
851 break;
79072805 852
93a17b20 853 case OP_NEXTSTATE:
8990e307 854 case OP_DBSTATE:
0f15f207 855 WITH_THR(curcop = ((COP*)o)); /* for warning below */
93a17b20
LW		 856 break;
857
79072805 858 case OP_CONST:
11343788 859 sv = cSVOPo->op_sv;
8990e307
LW		 860 if (dowarn) {
861 useless = "a constant";
862 if (SvNIOK(sv) && (SvNV(sv) == 0.0 || SvNV(sv) == 1.0))
863 useless = 0;
864 else if (SvPOK(sv)) {
865 if (strnEQ(SvPVX(sv), "di", 2) ||
a0d0e21e 866 strnEQ(SvPVX(sv), "ds", 2) ||
8990e307
LW		 867 strnEQ(SvPVX(sv), "ig", 2))
868 useless = 0;
869 }
870 }
11343788 871 null(o); /* don't execute a constant */
8990e307 872 SvREFCNT_dec(sv); /* don't even remember it */
79072805
LW		 873 break;
874
875 case OP_POSTINC:
11343788
MB		 876 o->op_type = OP_PREINC; /* pre-increment is faster */
877 o->op_ppaddr = ppaddr[OP_PREINC];
79072805
LW		 878 break;
879
880 case OP_POSTDEC:
11343788
MB		 881 o->op_type = OP_PREDEC; /* pre-decrement is faster */
882 o->op_ppaddr = ppaddr[OP_PREDEC];
79072805
LW		 883 break;
884
79072805
LW		 885 case OP_OR:
886 case OP_AND:
887 case OP_COND_EXPR:
11343788 888 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
79072805
LW		 889 scalarvoid(kid);
890 break;
5aabfad6 891
a0d0e21e 892 case OP_NULL:
11343788 893 if (o->op_targ == OP_NEXTSTATE || o->op_targ == OP_DBSTATE)
0f15f207 894 WITH_THR(curcop = ((COP*)o)); /* for warning below */
11343788 895 if (o->op_flags & OPf_STACKED)
a0d0e21e 896 break;
5aabfad6 897 /* FALL THROUGH */
79072805
LW		 898 case OP_ENTERTRY:
899 case OP_ENTER:
900 case OP_SCALAR:
11343788 901 if (!(o->op_flags & OPf_KIDS))
79072805 902 break;
54310121 903 /* FALL THROUGH */
463ee0b2 904 case OP_SCOPE:
79072805
LW		 905 case OP_LEAVE:
906 case OP_LEAVETRY:
a0d0e21e 907 case OP_LEAVELOOP:
79072805 908 case OP_LINESEQ:
79072805 909 case OP_LIST:
11343788 910 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
79072805
LW		 911 scalarvoid(kid);
912 break;
c90c0ff4 913 case OP_ENTEREVAL:
5196be3e 914 scalarkids(o);
c90c0ff4 915 break;
5aabfad6 916 case OP_REQUIRE:
c90c0ff4 917 /* all requires must return a boolean value */
5196be3e
MB		 918 o->op_flags &= ~OPf_WANT;
919 return scalar(o);
a0d0e21e 920 case OP_SPLIT:
11343788 921 if ((kid = cLISTOPo->op_first) && kid->op_type == OP_PUSHRE) {
a0d0e21e
LW		 922 if (!kPMOP->op_pmreplroot)
923 deprecate("implicit split to @_");
924 }
925 break;
79072805 926 }
8990e307
LW		 927 if (useless && dowarn)
928 warn("Useless use of %s in void context", useless);
11343788 929 return o;
79072805
LW		 930}
931
932OP *
8ac85365 933listkids(OP *o)
79072805
LW		 934{
935 OP *kid;
11343788
MB		 936 if (o && o->op_flags & OPf_KIDS) {
937 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
79072805
LW		 938 list(kid);
939 }
11343788 940 return o;
79072805
LW		 941}
942
943OP *
8ac85365 944list(OP *o)
79072805
LW		 945{
946 OP *kid;
947
a0d0e21e 948 /* assumes no premature commitment */
5dc0d613
MB		 949 if (!o || (o->op_flags & OPf_WANT) || error_count
950 || o->op_type == OP_RETURN)
11343788 951 return o;
79072805 952
5dc0d613 953 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_LIST;
79072805 954
11343788 955 switch (o->op_type) {
79072805
LW		 956 case OP_FLOP:
957 case OP_REPEAT:
11343788 958 list(cBINOPo->op_first);
79072805
LW		 959 break;
960 case OP_OR:
961 case OP_AND:
962 case OP_COND_EXPR:
11343788 963 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
79072805
LW		 964 list(kid);
965 break;
966 default:
967 case OP_MATCH:
968 case OP_SUBST:
969 case OP_NULL:
11343788 970 if (!(o->op_flags & OPf_KIDS))
79072805 971 break;
11343788
MB		 972 if (!o->op_next && cUNOPo->op_first->op_type == OP_FLOP) {
973 list(cBINOPo->op_first);
974 return gen_constant_list(o);
79072805
LW		 975 }
976 case OP_LIST:
11343788 977 listkids(o);
79072805
LW		 978 break;
979 case OP_LEAVE:
980 case OP_LEAVETRY:
5dc0d613 981 kid = cLISTOPo->op_first;
54310121 982 list(kid);
983 while (kid = kid->op_sibling) {
984 if (kid->op_sibling)
985 scalarvoid(kid);
986 else
987 list(kid);
988 }
0f15f207 989 WITH_THR(curcop = &compiling);
54310121 990 break;
748a9306 991 case OP_SCOPE:
79072805 992 case OP_LINESEQ:
11343788 993 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
79072805
LW		 994 if (kid->op_sibling)
995 scalarvoid(kid);
996 else
997 list(kid);
998 }
0f15f207 999 WITH_THR(curcop = &compiling);
79072805 1000 break;
c90c0ff4 1001 case OP_REQUIRE:
1002 /* all requires must return a boolean value */
5196be3e
MB		 1003 o->op_flags &= ~OPf_WANT;
1004 return scalar(o);
79072805 1005 }
11343788 1006 return o;
79072805
LW		 1007}
1008
1009OP *
8ac85365 1010scalarseq(OP *o)
79072805
LW		 1011{
1012 OP *kid;
1013
11343788
MB		 1014 if (o) {
1015 if (o->op_type == OP_LINESEQ ||
1016 o->op_type == OP_SCOPE ||
1017 o->op_type == OP_LEAVE ||
1018 o->op_type == OP_LEAVETRY)
463ee0b2 1019 {
0f15f207 1020 dTHR;
11343788 1021 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
ed6116ce 1022 if (kid->op_sibling) {
463ee0b2 1023 scalarvoid(kid);
ed6116ce 1024 }
463ee0b2
LW		 1025 }
1026 curcop = &compiling;
79072805 1027 }
11343788 1028 o->op_flags &= ~OPf_PARENS;
85e6fe83 1029 if (hints & HINT_BLOCK_SCOPE)
11343788 1030 o->op_flags |= OPf_PARENS;
79072805 1031 }
8990e307 1032 else
11343788
MB		 1033 o = newOP(OP_STUB, 0);
1034 return o;
79072805
LW		 1035}
1036
a0d0e21e 1037static OP *
8ac85365 1038modkids(OP *o, I32 type)
79072805
LW		 1039{
1040 OP *kid;
11343788
MB		 1041 if (o && o->op_flags & OPf_KIDS) {
1042 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
463ee0b2 1043 mod(kid, type);
79072805 1044 }
11343788 1045 return o;
79072805
LW		 1046}
1047
463ee0b2 1048static I32 modcount;
79072805
LW		 1049
1050OP *
8ac85365 1051mod(OP *o, I32 type)
79072805 1052{
11343788 1053 dTHR;
79072805
LW		 1054 OP *kid;
1055 SV *sv;
1056
11343788
MB		 1057 if (!o || error_count)
1058 return o;
79072805 1059
11343788 1060 switch (o->op_type) {
68dc0745 1061 case OP_UNDEF:
3e3baf6d 1062 modcount++;
5dc0d613 1063 return o;
a0d0e21e 1064 case OP_CONST:
11343788 1065 if (!(o->op_private & (OPpCONST_ARYBASE)))
a0d0e21e
LW		 1066 goto nomod;
1067 if (eval_start && eval_start->op_type == OP_CONST) {
1068 compiling.cop_arybase = (I32)SvIV(((SVOP*)eval_start)->op_sv);
1069 eval_start = 0;
1070 }
1071 else if (!type) {
1072 SAVEI32(compiling.cop_arybase);
748a9306 1073 compiling.cop_arybase = 0;
a0d0e21e
LW		 1074 }
1075 else if (type == OP_REFGEN)
1076 goto nomod;
1077 else
1078 croak("That use of $[ is unsupported");
1079 break;
5f05dabc 1080 case OP_STUB:
5196be3e 1081 if (o->op_flags & OPf_PARENS)
5f05dabc 1082 break;
1083 goto nomod;
a0d0e21e
LW		 1084 case OP_ENTERSUB:
1085 if ((type == OP_UNDEF || type == OP_REFGEN) &&
11343788
MB		 1086 !(o->op_flags & OPf_STACKED)) {
1087 o->op_type = OP_RV2CV; /* entersub => rv2cv */
1088 o->op_ppaddr = ppaddr[OP_RV2CV];
1089 assert(cUNOPo->op_first->op_type == OP_NULL);
1090 null(((LISTOP*)cUNOPo->op_first)->op_first);/* disable pushmark */
79072805
LW		 1091 break;
1092 }
1093 /* FALL THROUGH */
1094 default:
a0d0e21e
LW		 1095 nomod:
1096 /* grep, foreach, subcalls, refgen */
1097 if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN)
1098 break;
46fc3d4c 1099 yyerror(form("Can't modify %s in %s",
5dc0d613 1100 op_desc[o->op_type],
46fc3d4c 1101 type ? op_desc[type] : "local"));
11343788 1102 return o;
79072805 1103
a0d0e21e
LW		 1104 case OP_PREINC:
1105 case OP_PREDEC:
1106 case OP_POW:
1107 case OP_MULTIPLY:
1108 case OP_DIVIDE:
1109 case OP_MODULO:
1110 case OP_REPEAT:
1111 case OP_ADD:
1112 case OP_SUBTRACT:
1113 case OP_CONCAT:
1114 case OP_LEFT_SHIFT:
1115 case OP_RIGHT_SHIFT:
1116 case OP_BIT_AND:
1117 case OP_BIT_XOR:
1118 case OP_BIT_OR:
1119 case OP_I_MULTIPLY:
1120 case OP_I_DIVIDE:
1121 case OP_I_MODULO:
1122 case OP_I_ADD:
1123 case OP_I_SUBTRACT:
11343788 1124 if (!(o->op_flags & OPf_STACKED))
a0d0e21e
LW		 1125 goto nomod;
1126 modcount++;
1127 break;
1128
79072805 1129 case OP_COND_EXPR:
11343788 1130 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
463ee0b2 1131 mod(kid, type);
79072805
LW		 1132 break;
1133
1134 case OP_RV2AV:
1135 case OP_RV2HV:
93af7a87 1136 if (!type && cUNOPo->op_first->op_type != OP_GV)
706a304b 1137 croak("Can't localize through a reference");
11343788 1138 if (type == OP_REFGEN && o->op_flags & OPf_PARENS) {
748a9306 1139 modcount = 10000;
11343788 1140 return o; /* Treat \(@foo) like ordinary list. */
748a9306
LW		 1141 }
1142 /* FALL THROUGH */
79072805 1143 case OP_RV2GV:
5dc0d613 1144 if (scalar_mod_type(o, type))
3fe9a6f1 1145 goto nomod;
11343788 1146 ref(cUNOPo->op_first, o->op_type);
79072805
LW		 1147 /* FALL THROUGH */
1148 case OP_AASSIGN:
1149 case OP_ASLICE:
1150 case OP_HSLICE:
93a17b20
LW		 1151 case OP_NEXTSTATE:
1152 case OP_DBSTATE:
a0d0e21e
LW		 1153 case OP_REFGEN:
1154 case OP_CHOMP:
463ee0b2 1155 modcount = 10000;
79072805 1156 break;
463ee0b2 1157 case OP_RV2SV:
11343788 1158 if (!type && cUNOPo->op_first->op_type != OP_GV)
706a304b 1159 croak("Can't localize through a reference");
aeea060c 1160 ref(cUNOPo->op_first, o->op_type);
463ee0b2 1161 /* FALL THROUGH */
79072805 1162 case OP_GV:
463ee0b2
LW		 1163 case OP_AV2ARYLEN:
1164 case OP_SASSIGN:
8990e307
LW		 1165 case OP_AELEMFAST:
1166 modcount++;
1167 break;
1168
748a9306
LW		 1169 case OP_PADAV:
1170 case OP_PADHV:
1171 modcount = 10000;
5196be3e
MB		 1172 if (type == OP_REFGEN && o->op_flags & OPf_PARENS)
1173 return o; /* Treat \(@foo) like ordinary list. */
1174 if (scalar_mod_type(o, type))
3fe9a6f1 1175 goto nomod;
748a9306
LW		 1176 /* FALL THROUGH */
1177 case OP_PADSV:
1178 modcount++;
1179 if (!type)
1180 croak("Can't localize lexical variable %s",
11343788 1181 SvPV(*av_fetch(comppad_name, o->op_targ, 4), na));
463ee0b2
LW		 1182 break;
1183
554b3eca 1184#ifdef USE_THREADS
2faa37cc 1185 case OP_THREADSV:
554b3eca 1186 modcount++; /* XXX ??? */
554b3eca
MB		 1187 break;
1188#endif /* USE_THREADS */
1189
748a9306
LW		 1190 case OP_PUSHMARK:
1191 break;
a0d0e21e 1192
69969c6f
SB		 1193 case OP_KEYS:
1194 if (type != OP_SASSIGN)
1195 goto nomod;
5f05dabc 1196 /* FALL THROUGH */
a0d0e21e 1197 case OP_POS:
463ee0b2 1198 case OP_VEC:
a0d0e21e 1199 case OP_SUBSTR:
11343788
MB		 1200 pad_free(o->op_targ);
1201 o->op_targ = pad_alloc(o->op_type, SVs_PADMY);
5dc0d613 1202 assert(SvTYPE(PAD_SV(o->op_targ)) == SVt_NULL);
11343788
MB		 1203 if (o->op_flags & OPf_KIDS)
1204 mod(cBINOPo->op_first->op_sibling, type);
463ee0b2 1205 break;
a0d0e21e 1206
463ee0b2
LW		 1207 case OP_AELEM:
1208 case OP_HELEM:
11343788 1209 ref(cBINOPo->op_first, o->op_type);
68dc0745 1210 if (type == OP_ENTERSUB &&
5dc0d613
MB		 1211 !(o->op_private & (OPpLVAL_INTRO | OPpDEREF)))
1212 o->op_private |= OPpLVAL_DEFER;
a0d0e21e 1213 modcount++;
463ee0b2
LW		 1214 break;
1215
1216 case OP_SCOPE:
1217 case OP_LEAVE:
1218 case OP_ENTER:
11343788
MB		 1219 if (o->op_flags & OPf_KIDS)
1220 mod(cLISTOPo->op_last, type);
a0d0e21e
LW		 1221 break;
1222
1223 case OP_NULL:
11343788 1224 if (!(o->op_flags & OPf_KIDS))
463ee0b2 1225 break;
11343788
MB		 1226 if (o->op_targ != OP_LIST) {
1227 mod(cBINOPo->op_first, type);
a0d0e21e
LW		 1228 break;
1229 }
1230 /* FALL THROUGH */
463ee0b2 1231 case OP_LIST:
11343788 1232 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
463ee0b2
LW		 1233 mod(kid, type);
1234 break;
1235 }
11343788 1236 o->op_flags |= OPf_MOD;
a0d0e21e
LW		 1237
1238 if (type == OP_AASSIGN || type == OP_SASSIGN)
11343788 1239 o->op_flags |= OPf_SPECIAL|OPf_REF;
a0d0e21e 1240 else if (!type) {
11343788
MB		 1241 o->op_private |= OPpLVAL_INTRO;
1242 o->op_flags &= ~OPf_SPECIAL;
463ee0b2 1243 }
a0d0e21e 1244 else if (type != OP_GREPSTART && type != OP_ENTERSUB)
11343788
MB		 1245 o->op_flags |= OPf_REF;
1246 return o;
463ee0b2
LW		 1247}
1248
3fe9a6f1 1249static bool
8ac85365 1250scalar_mod_type(OP *o, I32 type)
3fe9a6f1 1251{
1252 switch (type) {
1253 case OP_SASSIGN:
5196be3e 1254 if (o->op_type == OP_RV2GV)
3fe9a6f1 1255 return FALSE;
1256 /* FALL THROUGH */
1257 case OP_PREINC:
1258 case OP_PREDEC:
1259 case OP_POSTINC:
1260 case OP_POSTDEC:
1261 case OP_I_PREINC:
1262 case OP_I_PREDEC:
1263 case OP_I_POSTINC:
1264 case OP_I_POSTDEC:
1265 case OP_POW:
1266 case OP_MULTIPLY:
1267 case OP_DIVIDE:
1268 case OP_MODULO:
1269 case OP_REPEAT:
1270 case OP_ADD:
1271 case OP_SUBTRACT:
1272 case OP_I_MULTIPLY:
1273 case OP_I_DIVIDE:
1274 case OP_I_MODULO:
1275 case OP_I_ADD:
1276 case OP_I_SUBTRACT:
1277 case OP_LEFT_SHIFT:
1278 case OP_RIGHT_SHIFT:
1279 case OP_BIT_AND:
1280 case OP_BIT_XOR:
1281 case OP_BIT_OR:
1282 case OP_CONCAT:
1283 case OP_SUBST:
1284 case OP_TRANS:
1285 case OP_ANDASSIGN: /* may work later */
1286 case OP_ORASSIGN: /* may work later */
1287 return TRUE;
1288 default:
1289 return FALSE;
1290 }
1291}
1292
463ee0b2 1293OP *
8ac85365 1294refkids(OP *o, I32 type)
463ee0b2
LW		 1295{
1296 OP *kid;
11343788
MB		 1297 if (o && o->op_flags & OPf_KIDS) {
1298 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
463ee0b2
LW		 1299 ref(kid, type);
1300 }
11343788 1301 return o;
463ee0b2
LW		 1302}
1303
1304OP *
8ac85365 1305ref(OP *o, I32 type)
463ee0b2
LW		 1306{
1307 OP *kid;
463ee0b2 1308
11343788
MB		 1309 if (!o || error_count)
1310 return o;
463ee0b2 1311
11343788 1312 switch (o->op_type) {
a0d0e21e 1313 case OP_ENTERSUB:
e55aaa0e 1314 if ((type == OP_DEFINED || type == OP_LOCK) &&
11343788
MB		 1315 !(o->op_flags & OPf_STACKED)) {
1316 o->op_type = OP_RV2CV; /* entersub => rv2cv */
1317 o->op_ppaddr = ppaddr[OP_RV2CV];
1318 assert(cUNOPo->op_first->op_type == OP_NULL);
1319 null(((LISTOP*)cUNOPo->op_first)->op_first); /* disable pushmark */
1320 o->op_flags |= OPf_SPECIAL;
8990e307
LW		 1321 }
1322 break;
aeea060c 1323
463ee0b2 1324 case OP_COND_EXPR:
11343788 1325 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
463ee0b2
LW		 1326 ref(kid, type);
1327 break;
8990e307 1328 case OP_RV2SV:
11343788 1329 ref(cUNOPo->op_first, o->op_type);
4633a7c4
LW		 1330 /* FALL THROUGH */
1331 case OP_PADSV:
5f05dabc 1332 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
5dc0d613
MB		 1333 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
1334 : type == OP_RV2HV ? OPpDEREF_HV
1335 : OPpDEREF_SV);
11343788 1336 o->op_flags |= OPf_MOD;
a0d0e21e 1337 }
8990e307
LW		 1338 break;
1339
2faa37cc 1340 case OP_THREADSV:
a863c7d1
MB		 1341 o->op_flags |= OPf_MOD; /* XXX ??? */
1342 break;
1343
463ee0b2
LW		 1344 case OP_RV2AV:
1345 case OP_RV2HV:
aeea060c 1346 o->op_flags |= OPf_REF;
8990e307 1347 /* FALL THROUGH */
463ee0b2 1348 case OP_RV2GV:
11343788 1349 ref(cUNOPo->op_first, o->op_type);
463ee0b2 1350 break;
8990e307 1351
463ee0b2
LW		 1352 case OP_PADAV:
1353 case OP_PADHV:
aeea060c 1354 o->op_flags |= OPf_REF;
79072805 1355 break;
aeea060c 1356
8990e307 1357 case OP_SCALAR:
79072805 1358 case OP_NULL:
11343788 1359 if (!(o->op_flags & OPf_KIDS))
463ee0b2 1360 break;
11343788 1361 ref(cBINOPo->op_first, type);
79072805
LW		 1362 break;
1363 case OP_AELEM:
1364 case OP_HELEM:
11343788 1365 ref(cBINOPo->op_first, o->op_type);
5f05dabc 1366 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
5dc0d613
MB		 1367 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
1368 : type == OP_RV2HV ? OPpDEREF_HV
1369 : OPpDEREF_SV);
11343788 1370 o->op_flags |= OPf_MOD;
8990e307 1371 }
79072805
LW		 1372 break;
1373
463ee0b2 1374 case OP_SCOPE:
79072805
LW		 1375 case OP_LEAVE:
1376 case OP_ENTER:
8990e307 1377 case OP_LIST:
11343788 1378 if (!(o->op_flags & OPf_KIDS))
79072805 1379 break;
11343788 1380 ref(cLISTOPo->op_last, type);
79072805 1381 break;
a0d0e21e
LW		 1382 default:
1383 break;
79072805 1384 }
11343788 1385 return scalar(o);
8990e307 1386
79072805
LW		 1387}
1388
1389OP *
8ac85365 1390my(OP *o)
93a17b20
LW		 1391{
1392 OP *kid;
93a17b20
LW		 1393 I32 type;
1394
11343788
MB		 1395 if (!o || error_count)
1396 return o;
93a17b20 1397
11343788 1398 type = o->op_type;
93a17b20 1399 if (type == OP_LIST) {
11343788 1400 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
93a17b20
LW		 1401 my(kid);
1402 }
1403 else if (type != OP_PADSV &&
1404 type != OP_PADAV &&
1405 type != OP_PADHV &&
1406 type != OP_PUSHMARK)
1407 {
5dc0d613 1408 yyerror(form("Can't declare %s in my", op_desc[o->op_type]));
11343788 1409 return o;
93a17b20 1410 }
11343788
MB		 1411 o->op_flags |= OPf_MOD;
1412 o->op_private |= OPpLVAL_INTRO;
1413 return o;
93a17b20
LW		 1414}
1415
1416OP *
8ac85365 1417sawparens(OP *o)
79072805
LW		 1418{
1419 if (o)
1420 o->op_flags |= OPf_PARENS;
1421 return o;
1422}
1423
1424OP *
8ac85365 1425bind_match(I32 type, OP *left, OP *right)
79072805 1426{
11343788 1427 OP *o;
79072805 1428
2ae324a7 1429 if (dowarn &&
1430 (left->op_type == OP_RV2AV ||
1431 left->op_type == OP_RV2HV ||
1432 left->op_type == OP_PADAV ||
1433 left->op_type == OP_PADHV)) {
1434 char *desc = op_desc[(right->op_type == OP_SUBST ||
1435 right->op_type == OP_TRANS)
1436 ? right->op_type : OP_MATCH];
1437 char *sample = ((left->op_type == OP_RV2AV ||
1438 left->op_type == OP_PADAV)
1439 ? "@array" : "%hash");
1440 warn("Applying %s to %s will act on scalar(%s)", desc, sample, sample);
1441 }
1442
79072805
LW		 1443 if (right->op_type == OP_MATCH ||
1444 right->op_type == OP_SUBST ||
1445 right->op_type == OP_TRANS) {
1446 right->op_flags |= OPf_STACKED;
1447 if (right->op_type != OP_MATCH)
463ee0b2 1448 left = mod(left, right->op_type);
79072805 1449 if (right->op_type == OP_TRANS)
11343788 1450 o = newBINOP(OP_NULL, OPf_STACKED, scalar(left), right);
79072805 1451 else
11343788 1452 o = prepend_elem(right->op_type, scalar(left), right);
79072805 1453 if (type == OP_NOT)
11343788
MB		 1454 return newUNOP(OP_NOT, 0, scalar(o));
1455 return o;
79072805
LW		 1456 }
1457 else
1458 return bind_match(type, left,
1459 pmruntime(newPMOP(OP_MATCH, 0), right, Nullop));
1460}
1461
1462OP *
8ac85365 1463invert(OP *o)
79072805 1464{
11343788
MB		 1465 if (!o)
1466 return o;
79072805 1467 /* XXX need to optimize away NOT NOT here? Or do we let optimizer do it? */
11343788 1468 return newUNOP(OP_NOT, OPf_SPECIAL, scalar(o));
79072805
LW		 1469}
1470
1471OP *
8ac85365 1472scope(OP *o)
79072805
LW		 1473{
1474 if (o) {
84902520 1475 if (o->op_flags & OPf_PARENS || PERLDB_NOOPT || tainting) {
463ee0b2
LW		 1476 o = prepend_elem(OP_LINESEQ, newOP(OP_ENTER, 0), o);
1477 o->op_type = OP_LEAVE;
1478 o->op_ppaddr = ppaddr[OP_LEAVE];
1479 }
1480 else {
1481 if (o->op_type == OP_LINESEQ) {
1482 OP *kid;
1483 o->op_type = OP_SCOPE;
1484 o->op_ppaddr = ppaddr[OP_SCOPE];
1485 kid = ((LISTOP*)o)->op_first;
748a9306
LW		 1486 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE){
1487 SvREFCNT_dec(((COP*)kid)->cop_filegv);
8990e307 1488 null(kid);
748a9306 1489 }
463ee0b2
LW		 1490 }
1491 else
748a9306 1492 o = newLISTOP(OP_SCOPE, 0, o, Nullop);
463ee0b2 1493 }
79072805
LW		 1494 }
1495 return o;
1496}
1497
a0d0e21e 1498int
8ac85365 1499block_start(int full)
79072805 1500{
11343788 1501 dTHR;
a0d0e21e 1502 int retval = savestack_ix;
55497cff 1503 SAVEI32(comppad_name_floor);
1504 if (full) {
1505 if ((comppad_name_fill = AvFILL(comppad_name)) > 0)
1506 comppad_name_floor = comppad_name_fill;
1507 else
1508 comppad_name_floor = 0;
1509 }
1510 SAVEI32(min_intro_pending);
1511 SAVEI32(max_intro_pending);
a0d0e21e 1512 min_intro_pending = 0;
55497cff 1513 SAVEI32(comppad_name_fill);
1514 SAVEI32(padix_floor);
a0d0e21e
LW		 1515 padix_floor = padix;
1516 pad_reset_pending = FALSE;
55497cff 1517 SAVEI32(hints);
a0d0e21e
LW		 1518 hints &= ~HINT_BLOCK_SCOPE;
1519 return retval;
1520}
1521
1522OP*
8ac85365 1523block_end(I32 floor, OP *seq)
a0d0e21e 1524{
11343788 1525 dTHR;
a0d0e21e
LW		 1526 int needblockscope = hints & HINT_BLOCK_SCOPE;
1527 OP* retval = scalarseq(seq);
a0d0e21e
LW		 1528 LEAVE_SCOPE(floor);
1529 pad_reset_pending = FALSE;
1530 if (needblockscope)
1531 hints |= HINT_BLOCK_SCOPE; /* propagate out */
1532 pad_leavemy(comppad_name_fill);
bbce6d69 1533 cop_seqmax++;
a0d0e21e
LW		 1534 return retval;
1535}
1536
54b9620d
MB		 1537static OP *
1538newDEFSVOP(void)
1539{
1540#ifdef USE_THREADS
1541 OP *o = newOP(OP_THREADSV, 0);
1542 o->op_targ = find_threadsv("_");
1543 return o;
1544#else
1545 return newSVREF(newGVOP(OP_GV, 0, defgv));
1546#endif /* USE_THREADS */
1547}
1548
a0d0e21e 1549void
8ac85365 1550newPROG(OP *o)
a0d0e21e 1551{
11343788 1552 dTHR;
a0d0e21e 1553 if (in_eval) {
5dc0d613 1554 eval_root = newUNOP(OP_LEAVEEVAL, ((in_eval & 4) ? OPf_SPECIAL : 0), o);
a0d0e21e
LW		 1555 eval_start = linklist(eval_root);
1556 eval_root->op_next = 0;
1557 peep(eval_start);
1558 }
1559 else {
5dc0d613 1560 if (!o)
a0d0e21e 1561 return;
11343788 1562 main_root = scope(sawparens(scalarvoid(o)));
a0d0e21e
LW		 1563 curcop = &compiling;
1564 main_start = LINKLIST(main_root);
1565 main_root->op_next = 0;
1566 peep(main_start);
748a9306 1567 compcv = 0;
3841441e 1568
4fdae800 1569 /* Register with debugger */
84902520 1570 if (PERLDB_INTER) {
3841441e 1571 CV *cv = perl_get_cv("DB::postponed", FALSE);
3841441e
CS		 1572 if (cv) {
1573 dSP;
1574 PUSHMARK(sp);
1575 XPUSHs((SV*)compiling.cop_filegv);
1576 PUTBACK;
1577 perl_call_sv((SV*)cv, G_DISCARD);
1578 }
1579 }
79072805 1580 }
79072805
LW		 1581}
1582
1583OP *
8ac85365 1584localize(OP *o, I32 lex)
79072805
LW		 1585{
1586 if (o->op_flags & OPf_PARENS)
1587 list(o);
8990e307 1588 else {
79072805 1589 scalar(o);
8990e307
LW		 1590 if (dowarn && bufptr > oldbufptr && bufptr[-1] == ',') {
1591 char *s;
1592 for (s = bufptr; *s && (isALNUM(*s) || strchr("@$%, ",*s)); s++) ;
a0d0e21e 1593 if (*s == ';' || *s == '=')
8990e307
LW		 1594 warn("Parens missing around \"%s\" list", lex ? "my" : "local");
1595 }
1596 }
93a17b20 1597 in_my = FALSE;
c750a3ec 1598 in_my_stash = Nullhv;
93a17b20
LW		 1599 if (lex)
1600 return my(o);
1601 else
463ee0b2 1602 return mod(o, OP_NULL); /* a bit kludgey */
79072805
LW		 1603}
1604
1605OP *
8ac85365 1606jmaybe(OP *o)
79072805
LW		 1607{
1608 if (o->op_type == OP_LIST) {
554b3eca
MB		 1609 OP *o2;
1610#ifdef USE_THREADS
2faa37cc 1611 o2 = newOP(OP_THREADSV, 0);
54b9620d 1612 o2->op_targ = find_threadsv(";");
554b3eca
MB		 1613#else
1614 o2 = newSVREF(newGVOP(OP_GV, 0, gv_fetchpv(";", TRUE, SVt_PV))),
1615#endif /* USE_THREADS */
1616 o = convert(OP_JOIN, 0, prepend_elem(OP_LIST, o2, o));
79072805
LW		 1617 }
1618 return o;
1619}
1620
1621OP *
8ac85365 1622fold_constants(register OP *o)
79072805 1623{
11343788 1624 dTHR;
79072805
LW		 1625 register OP *curop;
1626 I32 type = o->op_type;
748a9306 1627 SV *sv;
79072805
LW		 1628
1629 if (opargs[type] & OA_RETSCALAR)
1630 scalar(o);
1631 if (opargs[type] & OA_TARGET)
ed6116ce 1632 o->op_targ = pad_alloc(type, SVs_PADTMP);
79072805 1633
85e6fe83 1634 if ((opargs[type] & OA_OTHERINT) && (hints & HINT_INTEGER))
a0d0e21e 1635 o->op_ppaddr = ppaddr[type = ++(o->op_type)];
85e6fe83 1636
79072805
LW		 1637 if (!(opargs[type] & OA_FOLDCONST))
1638 goto nope;
1639
de939608
CS		 1640 switch (type) {
1641 case OP_SPRINTF:
1642 case OP_UCFIRST:
1643 case OP_LCFIRST:
1644 case OP_UC:
1645 case OP_LC:
1646 if (o->op_private & OPpLOCALE)
1647 goto nope;
1648 }
1649
a0d0e21e
LW		 1650 if (error_count)
1651 goto nope; /* Don't try to run w/ errors */
1652
79072805 1653 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
93a17b20
LW		 1654 if (curop->op_type != OP_CONST &&
1655 curop->op_type != OP_LIST &&
1656 curop->op_type != OP_SCALAR &&
a0d0e21e 1657 curop->op_type != OP_NULL &&
93a17b20 1658 curop->op_type != OP_PUSHMARK) {
79072805
LW		 1659 goto nope;
1660 }
1661 }
1662
1663 curop = LINKLIST(o);
1664 o->op_next = 0;
1665 op = curop;
8da795c6 1666 runops();
748a9306
LW		 1667 sv = *(stack_sp--);
1668 if (o->op_targ && sv == PAD_SV(o->op_targ)) /* grab pad temp? */
79072805 1669 pad_swipe(o->op_targ);
748a9306
LW		 1670 else if (SvTEMP(sv)) { /* grab mortal temp? */
1671 (void)SvREFCNT_inc(sv);
1672 SvTEMP_off(sv);
85e6fe83 1673 }
79072805
LW		 1674 op_free(o);
1675 if (type == OP_RV2GV)
b1cb66bf 1676 return newGVOP(OP_GV, 0, (GV*)sv);
748a9306
LW		 1677 else {
1678 if ((SvFLAGS(sv) & (SVf_IOK|SVf_NOK|SVf_POK)) == SVf_NOK) {
1679 IV iv = SvIV(sv);
1680 if ((double)iv == SvNV(sv)) { /* can we smush double to int */
1681 SvREFCNT_dec(sv);
1682 sv = newSViv(iv);
1683 }
b1cb66bf 1684 else
1685 SvIOK_off(sv); /* undo SvIV() damage */
748a9306
LW		 1686 }
1687 return newSVOP(OP_CONST, 0, sv);
1688 }
aeea060c 1689
79072805
LW		 1690 nope:
1691 if (!(opargs[type] & OA_OTHERINT))
1692 return o;
79072805 1693
85e6fe83 1694 if (!(hints & HINT_INTEGER)) {
a0d0e21e 1695 if (type == OP_DIVIDE || !(o->op_flags & OPf_KIDS))
85e6fe83
LW		 1696 return o;
1697
1698 for (curop = ((UNOP*)o)->op_first; curop; curop = curop->op_sibling) {
1699 if (curop->op_type == OP_CONST) {
b1cb66bf 1700 if (SvIOK(((SVOP*)curop)->op_sv))
85e6fe83
LW		 1701 continue;
1702 return o;
1703 }
1704 if (opargs[curop->op_type] & OA_RETINTEGER)
79072805
LW		 1705 continue;
1706 return o;
1707 }
a0d0e21e 1708 o->op_ppaddr = ppaddr[++(o->op_type)];
79072805
LW		 1709 }
1710
79072805
LW		 1711 return o;
1712}
1713
1714OP *
8ac85365 1715gen_constant_list(register OP *o)
79072805 1716{
11343788 1717 dTHR;
79072805 1718 register OP *curop;
79072805 1719 I32 oldtmps_floor = tmps_floor;
79072805 1720
a0d0e21e
LW		 1721 list(o);
1722 if (error_count)
1723 return o; /* Don't attempt to run with errors */
1724
1725 op = curop = LINKLIST(o);
1726 o->op_next = 0;
11343788 1727 pp_pushmark(ARGS);
8da795c6 1728 runops();
a0d0e21e 1729 op = curop;
11343788 1730 pp_anonlist(ARGS);
79072805 1731 tmps_floor = oldtmps_floor;
79072805
LW		 1732
1733 o->op_type = OP_RV2AV;
1734 o->op_ppaddr = ppaddr[OP_RV2AV];
79072805 1735 curop = ((UNOP*)o)->op_first;
a0d0e21e 1736 ((UNOP*)o)->op_first = newSVOP(OP_CONST, 0, SvREFCNT_inc(*stack_sp--));
79072805 1737 op_free(curop);
79072805
LW		 1738 linklist(o);
1739 return list(o);
1740}
1741
1742OP *
8ac85365 1743convert(I32 type, I32 flags, OP *o)
79072805
LW		 1744{
1745 OP *kid;
a0d0e21e 1746 OP *last = 0;
79072805 1747
11343788
MB		 1748 if (!o || o->op_type != OP_LIST)
1749 o = newLISTOP(OP_LIST, 0, o, Nullop);
748a9306 1750 else
5dc0d613 1751 o->op_flags &= ~OPf_WANT;
79072805 1752
8990e307 1753 if (!(opargs[type] & OA_MARK))
11343788 1754 null(cLISTOPo->op_first);
8990e307 1755
11343788
MB		 1756 o->op_type = type;
1757 o->op_ppaddr = ppaddr[type];
1758 o->op_flags |= flags;
79072805 1759
11343788
MB		 1760 o = CHECKOP(type, o);
1761 if (o->op_type != type)
1762 return o;
79072805 1763
11343788 1764 if (cLISTOPo->op_children < 7) {
79072805 1765 /* XXX do we really need to do this if we're done appending?? */
11343788 1766 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
79072805 1767 last = kid;
11343788 1768 cLISTOPo->op_last = last; /* in case check substituted last arg */
79072805
LW		 1769 }
1770
11343788 1771 return fold_constants(o);
79072805
LW		 1772}
1773
1774/* List constructors */
1775
1776OP *
8ac85365 1777append_elem(I32 type, OP *first, OP *last)
79072805
LW		 1778{
1779 if (!first)
1780 return last;
8990e307
LW		 1781
1782 if (!last)
79072805 1783 return first;
8990e307 1784
a0d0e21e
LW		 1785 if (first->op_type != type || type==OP_LIST && first->op_flags & OPf_PARENS)
1786 return newLISTOP(type, 0, first, last);
79072805 1787
a0d0e21e
LW		 1788 if (first->op_flags & OPf_KIDS)
1789 ((LISTOP*)first)->op_last->op_sibling = last;
1790 else {
1791 first->op_flags |= OPf_KIDS;
1792 ((LISTOP*)first)->op_first = last;
1793 }
1794 ((LISTOP*)first)->op_last = last;
1795 ((LISTOP*)first)->op_children++;
1796 return first;
79072805
LW		 1797}
1798
1799OP *
8ac85365 1800append_list(I32 type, LISTOP *first, LISTOP *last)
79072805
LW		 1801{
1802 if (!first)
1803 return (OP*)last;
8990e307
LW		 1804
1805 if (!last)
79072805 1806 return (OP*)first;
8990e307
LW		 1807
1808 if (first->op_type != type)
79072805 1809 return prepend_elem(type, (OP*)first, (OP*)last);
8990e307
LW		 1810
1811 if (last->op_type != type)
79072805
LW		 1812 return append_elem(type, (OP*)first, (OP*)last);
1813
1814 first->op_last->op_sibling = last->op_first;
1815 first->op_last = last->op_last;
1816 first->op_children += last->op_children;
1817 if (first->op_children)
1818 last->op_flags |= OPf_KIDS;
1819
1820 Safefree(last);
1821 return (OP*)first;
1822}
1823
1824OP *
8ac85365 1825prepend_elem(I32 type, OP *first, OP *last)
79072805
LW		 1826{
1827 if (!first)
1828 return last;
8990e307
LW		 1829
1830 if (!last)
79072805 1831 return first;
8990e307
LW		 1832
1833 if (last->op_type == type) {
1834 if (type == OP_LIST) { /* already a PUSHMARK there */
1835 first->op_sibling = ((LISTOP*)last)->op_first->op_sibling;
1836 ((LISTOP*)last)->op_first->op_sibling = first;
1837 }
1838 else {
1839 if (!(last->op_flags & OPf_KIDS)) {
1840 ((LISTOP*)last)->op_last = first;
1841 last->op_flags |= OPf_KIDS;
1842 }
1843 first->op_sibling = ((LISTOP*)last)->op_first;
1844 ((LISTOP*)last)->op_first = first;
79072805 1845 }
79072805
LW		 1846 ((LISTOP*)last)->op_children++;
1847 return last;
1848 }
1849
1850 return newLISTOP(type, 0, first, last);
1851}
1852
1853/* Constructors */
1854
1855OP *
8ac85365 1856newNULLLIST(void)
79072805 1857{
8990e307
LW		 1858 return newOP(OP_STUB, 0);
1859}
1860
1861OP *
8ac85365 1862force_list(OP *o)
8990e307 1863{
11343788
MB		 1864 if (!o || o->op_type != OP_LIST)
1865 o = newLISTOP(OP_LIST, 0, o, Nullop);
1866 null(o);
1867 return o;
79072805
LW		 1868}
1869
1870OP *
8ac85365 1871newLISTOP(I32 type, I32 flags, OP *first, OP *last)
79072805
LW		 1872{
1873 LISTOP *listop;
1874
1875 Newz(1101, listop, 1, LISTOP);
1876
1877 listop->op_type = type;
1878 listop->op_ppaddr = ppaddr[type];
1879 listop->op_children = (first != 0) + (last != 0);
1880 listop->op_flags = flags;
79072805
LW		 1881
1882 if (!last && first)
1883 last = first;
1884 else if (!first && last)
1885 first = last;
8990e307
LW		 1886 else if (first)
1887 first->op_sibling = last;
79072805
LW		 1888 listop->op_first = first;
1889 listop->op_last = last;
8990e307
LW		 1890 if (type == OP_LIST) {
1891 OP* pushop;
1892 pushop = newOP(OP_PUSHMARK, 0);
1893 pushop->op_sibling = first;
1894 listop->op_first = pushop;
1895 listop->op_flags |= OPf_KIDS;
1896 if (!last)
1897 listop->op_last = pushop;
1898 }
1899 else if (listop->op_children)
1900 listop->op_flags |= OPf_KIDS;
79072805
LW		 1901
1902 return (OP*)listop;
1903}
1904
1905OP *
8ac85365 1906newOP(I32 type, I32 flags)
79072805 1907{
11343788
MB		 1908 OP *o;
1909 Newz(1101, o, 1, OP);
1910 o->op_type = type;
1911 o->op_ppaddr = ppaddr[type];
1912 o->op_flags = flags;
79072805 1913
11343788
MB		 1914 o->op_next = o;
1915 o->op_private = 0 + (flags >> 8);
79072805 1916 if (opargs[type] & OA_RETSCALAR)
11343788 1917 scalar(o);
79072805 1918 if (opargs[type] & OA_TARGET)
11343788
MB		 1919 o->op_targ = pad_alloc(type, SVs_PADTMP);
1920 return CHECKOP(type, o);
79072805
LW		 1921}
1922
1923OP *
8ac85365 1924newUNOP(I32 type, I32 flags, OP *first)
79072805
LW		 1925{
1926 UNOP *unop;
1927
93a17b20 1928 if (!first)
aeea060c 1929 first = newOP(OP_STUB, 0);
8990e307
LW		 1930 if (opargs[type] & OA_MARK)
1931 first = force_list(first);
93a17b20 1932
79072805
LW		 1933 Newz(1101, unop, 1, UNOP);
1934 unop->op_type = type;
1935 unop->op_ppaddr = ppaddr[type];
1936 unop->op_first = first;
1937 unop->op_flags = flags | OPf_KIDS;
c07a80fd 1938 unop->op_private = 1 | (flags >> 8);
c277df42
IZ		 1939#if 1
1940 if(type == OP_STUDY && first->op_type == OP_MATCH) {
1941 first->op_type = OP_PUSHRE;
1942 first->op_ppaddr = ppaddr[OP_PUSHRE];
1943 }
1944#endif
e50aee73 1945 unop = (UNOP*) CHECKOP(type, unop);
79072805
LW		 1946 if (unop->op_next)
1947 return (OP*)unop;
1948
a0d0e21e 1949 return fold_constants((OP *) unop);
79072805
LW		 1950}
1951
1952OP *
8ac85365 1953newBINOP(I32 type, I32 flags, OP *first, OP *last)
79072805
LW		 1954{
1955 BINOP *binop;
1956 Newz(1101, binop, 1, BINOP);
1957
1958 if (!first)
1959 first = newOP(OP_NULL, 0);
1960
1961 binop->op_type = type;
1962 binop->op_ppaddr = ppaddr[type];
1963 binop->op_first = first;
1964 binop->op_flags = flags | OPf_KIDS;
1965 if (!last) {
1966 last = first;
c07a80fd 1967 binop->op_private = 1 | (flags >> 8);
79072805
LW		 1968 }
1969 else {
c07a80fd 1970 binop->op_private = 2 | (flags >> 8);
79072805
LW		 1971 first->op_sibling = last;
1972 }
1973
e50aee73 1974 binop = (BINOP*)CHECKOP(type, binop);
79072805
LW		 1975 if (binop->op_next)
1976 return (OP*)binop;
1977
1978 binop->op_last = last = binop->op_first->op_sibling;
1979
a0d0e21e 1980 return fold_constants((OP *)binop);
79072805
LW		 1981}
1982
1983OP *
8ac85365 1984pmtrans(OP *o, OP *expr, OP *repl)
79072805 1985{
79072805
LW		 1986 SV *tstr = ((SVOP*)expr)->op_sv;
1987 SV *rstr = ((SVOP*)repl)->op_sv;
463ee0b2
LW		 1988 STRLEN tlen;
1989 STRLEN rlen;
ec49126f 1990 register U8 *t = (U8*)SvPV(tstr, tlen);
1991 register U8 *r = (U8*)SvPV(rstr, rlen);
79072805
LW		 1992 register I32 i;
1993 register I32 j;
8ac85365 1994 I32 Delete;
79072805 1995 I32 complement;
5d06d08e 1996 I32 squash;
79072805
LW		 1997 register short *tbl;
1998
11343788
MB		 1999 tbl = (short*)cPVOPo->op_pv;
2000 complement = o->op_private & OPpTRANS_COMPLEMENT;
8ac85365 2001 Delete = o->op_private & OPpTRANS_DELETE;
5d06d08e 2002 squash = o->op_private & OPpTRANS_SQUASH;
79072805
LW		 2003
2004 if (complement) {
2005 Zero(tbl, 256, short);
2006 for (i = 0; i < tlen; i++)
ec49126f 2007 tbl[t[i]] = -1;
79072805
LW		 2008 for (i = 0, j = 0; i < 256; i++) {
2009 if (!tbl[i]) {
2010 if (j >= rlen) {
8ac85365 2011 if (Delete)
79072805
LW		 2012 tbl[i] = -2;
2013 else if (rlen)
ec49126f 2014 tbl[i] = r[j-1];
79072805
LW		 2015 else
2016 tbl[i] = i;
2017 }
2018 else
ec49126f 2019 tbl[i] = r[j++];
79072805
LW		 2020 }
2021 }
2022 }
2023 else {
8ac85365 2024 if (!rlen && !Delete) {
79072805 2025 r = t; rlen = tlen;
5d06d08e
MB		 2026 if (!squash)
2027 o->op_private |= OPpTRANS_COUNTONLY;
79072805
LW		 2028 }
2029 for (i = 0; i < 256; i++)
2030 tbl[i] = -1;
2031 for (i = 0, j = 0; i < tlen; i++,j++) {
2032 if (j >= rlen) {
8ac85365 2033 if (Delete) {
ec49126f 2034 if (tbl[t[i]] == -1)
2035 tbl[t[i]] = -2;
79072805
LW		 2036 continue;
2037 }
2038 --j;
2039 }
ec49126f 2040 if (tbl[t[i]] == -1)
2041 tbl[t[i]] = r[j];
79072805
LW		 2042 }
2043 }
2044 op_free(expr);
2045 op_free(repl);
2046
11343788 2047 return o;
79072805
LW		 2048}
2049
2050OP *
8ac85365 2051newPMOP(I32 type, I32 flags)
79072805 2052{
11343788 2053 dTHR;
79072805
LW		 2054 PMOP *pmop;
2055
2056 Newz(1101, pmop, 1, PMOP);
2057 pmop->op_type = type;
2058 pmop->op_ppaddr = ppaddr[type];
2059 pmop->op_flags = flags;
c07a80fd 2060 pmop->op_private = 0 | (flags >> 8);
79072805 2061
36477c24 2062 if (hints & HINT_LOCALE)
2063 pmop->op_pmpermflags = (pmop->op_pmflags |= PMf_LOCALE);
2064
79072805 2065 /* link into pm list */
a0d0e21e 2066 if (type != OP_TRANS && curstash) {
79072805
LW		 2067 pmop->op_pmnext = HvPMROOT(curstash);
2068 HvPMROOT(curstash) = pmop;
2069 }
2070
2071 return (OP*)pmop;
2072}
2073
2074OP *
8ac85365 2075pmruntime(OP *o, OP *expr, OP *repl)
79072805
LW		 2076{
2077 PMOP *pm;
2078 LOGOP *rcop;
2079
11343788
MB		 2080 if (o->op_type == OP_TRANS)
2081 return pmtrans(o, expr, repl);
79072805 2082
3e3baf6d 2083 hints |= HINT_BLOCK_SCOPE;
11343788 2084 pm = (PMOP*)o;
79072805
LW		 2085
2086 if (expr->op_type == OP_CONST) {
463ee0b2 2087 STRLEN plen;
79072805 2088 SV *pat = ((SVOP*)expr)->op_sv;
463ee0b2 2089 char *p = SvPV(pat, plen);
11343788 2090 if ((o->op_flags & OPf_SPECIAL) && strEQ(p, " ")) {
93a17b20 2091 sv_setpvn(pat, "\\s+", 3);
463ee0b2 2092 p = SvPV(pat, plen);
79072805
LW		 2093 pm->op_pmflags |= PMf_SKIPWHITE;
2094 }
e50aee73 2095 pm->op_pmregexp = pregcomp(p, p + plen, pm);
aeea060c 2096 if (strEQ("\\s+", pm->op_pmregexp->precomp))
85e6fe83 2097 pm->op_pmflags |= PMf_WHITE;
79072805
LW		 2098 op_free(expr);
2099 }
2100 else {
463ee0b2
LW		 2101 if (pm->op_pmflags & PMf_KEEP)
2102 expr = newUNOP(OP_REGCMAYBE,0,expr);
2103
79072805
LW		 2104 Newz(1101, rcop, 1, LOGOP);
2105 rcop->op_type = OP_REGCOMP;
2106 rcop->op_ppaddr = ppaddr[OP_REGCOMP];
2107 rcop->op_first = scalar(expr);
2108 rcop->op_flags |= OPf_KIDS;
2109 rcop->op_private = 1;
11343788 2110 rcop->op_other = o;
79072805
LW		 2111
2112 /* establish postfix order */
463ee0b2
LW		 2113 if (pm->op_pmflags & PMf_KEEP) {
2114 LINKLIST(expr);
2115 rcop->op_next = expr;
2116 ((UNOP*)expr)->op_first->op_next = (OP*)rcop;
2117 }
2118 else {
2119 rcop->op_next = LINKLIST(expr);
2120 expr->op_next = (OP*)rcop;
2121 }
79072805 2122
11343788 2123 prepend_elem(o->op_type, scalar((OP*)rcop), o);
79072805
LW		 2124 }
2125
2126 if (repl) {
748a9306
LW		 2127 OP *curop;
2128 if (pm->op_pmflags & PMf_EVAL)
2129 curop = 0;
554b3eca 2130#ifdef USE_THREADS
2faa37cc 2131 else if (repl->op_type == OP_THREADSV
554b3eca 2132 && strchr("&`'123456789+",
54b9620d 2133 threadsv_names[repl->op_targ]))
554b3eca
MB		 2134 {
2135 curop = 0;
2136 }
2137#endif /* USE_THREADS */
748a9306
LW		 2138 else if (repl->op_type == OP_CONST)
2139 curop = repl;
79072805 2140 else {
79072805
LW		 2141 OP *lastop = 0;
2142 for (curop = LINKLIST(repl); curop!=repl; curop = LINKLIST(curop)) {
2143 if (opargs[curop->op_type] & OA_DANGEROUS) {
554b3eca 2144#ifdef USE_THREADS
2faa37cc 2145 if (curop->op_type == OP_THREADSV
554b3eca
MB		 2146 && strchr("&`'123456789+", curop->op_private)) {
2147 break;
2148 }
2149#else
79072805
LW		 2150 if (curop->op_type == OP_GV) {
2151 GV *gv = ((GVOP*)curop)->op_gv;
93a17b20 2152 if (strchr("&`'123456789+", *GvENAME(gv)))
79072805
LW		 2153 break;
2154 }
554b3eca 2155#endif /* USE_THREADS */
79072805
LW		 2156 else if (curop->op_type == OP_RV2CV)
2157 break;
2158 else if (curop->op_type == OP_RV2SV ||
2159 curop->op_type == OP_RV2AV ||
2160 curop->op_type == OP_RV2HV ||
2161 curop->op_type == OP_RV2GV) {
2162 if (lastop && lastop->op_type != OP_GV) /*funny deref?*/
2163 break;
2164 }
748a9306
LW		 2165 else if (curop->op_type == OP_PADSV ||
2166 curop->op_type == OP_PADAV ||
2167 curop->op_type == OP_PADHV ||
554b3eca 2168 curop->op_type == OP_PADANY) {
748a9306
LW		 2169 /* is okay */
2170 }
79072805
LW		 2171 else
2172 break;
2173 }
2174 lastop = curop;
2175 }
748a9306
LW		 2176 }
2177 if (curop == repl) {
2178 pm->op_pmflags |= PMf_CONST; /* const for long enough */
4633a7c4 2179 pm->op_pmpermflags |= PMf_CONST; /* const for long enough */
11343788 2180 prepend_elem(o->op_type, scalar(repl), o);
748a9306
LW		 2181 }
2182 else {
2183 Newz(1101, rcop, 1, LOGOP);
2184 rcop->op_type = OP_SUBSTCONT;
2185 rcop->op_ppaddr = ppaddr[OP_SUBSTCONT];
2186 rcop->op_first = scalar(repl);
2187 rcop->op_flags |= OPf_KIDS;
2188 rcop->op_private = 1;
11343788 2189 rcop->op_other = o;
748a9306
LW		 2190
2191 /* establish postfix order */
2192 rcop->op_next = LINKLIST(repl);
2193 repl->op_next = (OP*)rcop;
2194
2195 pm->op_pmreplroot = scalar((OP*)rcop);
2196 pm->op_pmreplstart = LINKLIST(rcop);
2197 rcop->op_next = 0;
79072805
LW		 2198 }
2199 }
2200
2201 return (OP*)pm;
2202}
2203
2204OP *
8ac85365 2205newSVOP(I32 type, I32 flags, SV *sv)
79072805
LW		 2206{
2207 SVOP *svop;
2208 Newz(1101, svop, 1, SVOP);
2209 svop->op_type = type;
2210 svop->op_ppaddr = ppaddr[type];
2211 svop->op_sv = sv;
2212 svop->op_next = (OP*)svop;
2213 svop->op_flags = flags;
2214 if (opargs[type] & OA_RETSCALAR)
463ee0b2 2215 scalar((OP*)svop);
79072805 2216 if (opargs[type] & OA_TARGET)
ed6116ce 2217 svop->op_targ = pad_alloc(type, SVs_PADTMP);
e50aee73 2218 return CHECKOP(type, svop);
79072805
LW		 2219}
2220
2221OP *
8ac85365 2222newGVOP(I32 type, I32 flags, GV *gv)
79072805 2223{
11343788 2224 dTHR;
79072805
LW		 2225 GVOP *gvop;
2226 Newz(1101, gvop, 1, GVOP);
2227 gvop->op_type = type;
2228 gvop->op_ppaddr = ppaddr[type];
8990e307 2229 gvop->op_gv = (GV*)SvREFCNT_inc(gv);
79072805
LW		 2230 gvop->op_next = (OP*)gvop;
2231 gvop->op_flags = flags;
2232 if (opargs[type] & OA_RETSCALAR)
463ee0b2 2233 scalar((OP*)gvop);
79072805 2234 if (opargs[type] & OA_TARGET)
ed6116ce 2235 gvop->op_targ = pad_alloc(type, SVs_PADTMP);
e50aee73 2236 return CHECKOP(type, gvop);
79072805
LW		 2237}
2238
2239OP *
8ac85365 2240newPVOP(I32 type, I32 flags, char *pv)
79072805
LW		 2241{
2242 PVOP *pvop;
2243 Newz(1101, pvop, 1, PVOP);
2244 pvop->op_type = type;
2245 pvop->op_ppaddr = ppaddr[type];
2246 pvop->op_pv = pv;
2247 pvop->op_next = (OP*)pvop;
2248 pvop->op_flags = flags;
2249 if (opargs[type] & OA_RETSCALAR)
463ee0b2 2250 scalar((OP*)pvop);
79072805 2251 if (opargs[type] & OA_TARGET)
ed6116ce 2252 pvop->op_targ = pad_alloc(type, SVs_PADTMP);
e50aee73 2253 return CHECKOP(type, pvop);
79072805
LW		 2254}
2255
79072805 2256void
8ac85365 2257package(OP *o)
79072805 2258{
11343788 2259 dTHR;
93a17b20 2260 SV *sv;
79072805
LW		 2261
2262 save_hptr(&curstash);
2263 save_item(curstname);
11343788 2264 if (o) {
463ee0b2
LW		 2265 STRLEN len;
2266 char *name;
11343788 2267 sv = cSVOPo->op_sv;
463ee0b2 2268 name = SvPV(sv, len);
b1cb66bf 2269 curstash = gv_stashpvn(name,len,TRUE);
463ee0b2 2270 sv_setpvn(curstname, name, len);
11343788 2271 op_free(o);
93a17b20
LW		 2272 }
2273 else {
2274 sv_setpv(curstname,"<none>");
2275 curstash = Nullhv;
2276 }
79072805 2277 copline = NOLINE;
8990e307 2278 expect = XSTATE;
79072805
LW		 2279}
2280
85e6fe83 2281void
8ac85365 2282utilize(int aver, I32 floor, OP *version, OP *id, OP *arg)
85e6fe83 2283{
a0d0e21e
LW		 2284 OP *pack;
2285 OP *meth;
2286 OP *rqop;
2287 OP *imop;
b1cb66bf 2288 OP *veop;
85e6fe83 2289
a0d0e21e
LW		 2290 if (id->op_type != OP_CONST)
2291 croak("Module name must be constant");
85e6fe83 2292
b1cb66bf 2293 veop = Nullop;
2294
2295 if(version != Nullop) {
2296 SV *vesv = ((SVOP*)version)->op_sv;
2297
2298 if (arg == Nullop && !SvNIOK(vesv)) {
2299 arg = version;
2300 }
2301 else {
2302 OP *pack;
2303 OP *meth;
2304
2305 if (version->op_type != OP_CONST || !SvNIOK(vesv))
2306 croak("Version number must be constant number");
2307
2308 /* Make copy of id so we don't free it twice */
2309 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)id)->op_sv));
2310
2311 /* Fake up a method call to VERSION */
2312 meth = newSVOP(OP_CONST, 0, newSVpv("VERSION", 7));
2313 veop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
2314 append_elem(OP_LIST,
2315 prepend_elem(OP_LIST, pack, list(version)),
2316 newUNOP(OP_METHOD, 0, meth)));
2317 }
2318 }
aeea060c 2319
a0d0e21e 2320 /* Fake up an import/unimport */
4633a7c4
LW		 2321 if (arg && arg->op_type == OP_STUB)
2322 imop = arg; /* no import on explicit () */
b1cb66bf 2323 else if(SvNIOK(((SVOP*)id)->op_sv)) {
2324 imop = Nullop; /* use 5.0; */
2325 }
4633a7c4
LW		 2326 else {
2327 /* Make copy of id so we don't free it twice */
2328 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)id)->op_sv));
4633a7c4
LW		 2329 meth = newSVOP(OP_CONST, 0,
2330 aver
2331 ? newSVpv("import", 6)
2332 : newSVpv("unimport", 8)
2333 );
2334 imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
a0d0e21e
LW		 2335 append_elem(OP_LIST,
2336 prepend_elem(OP_LIST, pack, list(arg)),
2337 newUNOP(OP_METHOD, 0, meth)));
4633a7c4
LW		 2338 }
2339
2340 /* Fake up a require */
2341 rqop = newUNOP(OP_REQUIRE, 0, id);
a0d0e21e
LW		 2342
2343 /* Fake up the BEGIN {}, which does its thing immediately. */
c07a80fd 2344 newSUB(floor,
a0d0e21e 2345 newSVOP(OP_CONST, 0, newSVpv("BEGIN", 5)),
4633a7c4 2346 Nullop,
a0d0e21e 2347 append_elem(OP_LINESEQ,
b1cb66bf 2348 append_elem(OP_LINESEQ,
2349 newSTATEOP(0, Nullch, rqop),
2350 newSTATEOP(0, Nullch, veop)),
a0d0e21e 2351 newSTATEOP(0, Nullch, imop) ));
85e6fe83 2352
85e6fe83
LW		 2353 copline = NOLINE;
2354 expect = XSTATE;
2355}
2356
79072805 2357OP *
8ac85365 2358newSLICEOP(I32 flags, OP *subscript, OP *listval)
79072805
LW		 2359{
2360 return newBINOP(OP_LSLICE, flags,
8990e307
LW		 2361 list(force_list(subscript)),
2362 list(force_list(listval)) );
79072805
LW		 2363}
2364
2365static I32
8ac85365 2366list_assignment(register OP *o)
79072805 2367{
11343788 2368 if (!o)
79072805
LW		 2369 return TRUE;
2370
11343788
MB		 2371 if (o->op_type == OP_NULL && o->op_flags & OPf_KIDS)
2372 o = cUNOPo->op_first;
79072805 2373
11343788
MB		 2374 if (o->op_type == OP_COND_EXPR) {
2375 I32 t = list_assignment(cCONDOPo->op_first->op_sibling);
2376 I32 f = list_assignment(cCONDOPo->op_first->op_sibling->op_sibling);
79072805
LW		 2377
2378 if (t && f)
2379 return TRUE;
2380 if (t || f)
2381 yyerror("Assignment to both a list and a scalar");
2382 return FALSE;
2383 }
2384
11343788
MB		 2385 if (o->op_type == OP_LIST || o->op_flags & OPf_PARENS ||
2386 o->op_type == OP_RV2AV || o->op_type == OP_RV2HV ||
2387 o->op_type == OP_ASLICE || o->op_type == OP_HSLICE)
79072805
LW		 2388 return TRUE;
2389
11343788 2390 if (o->op_type == OP_PADAV || o->op_type == OP_PADHV)
93a17b20
LW		 2391 return TRUE;
2392
11343788 2393 if (o->op_type == OP_RV2SV)
79072805
LW		 2394 return FALSE;
2395
2396 return FALSE;
2397}
2398
2399OP *
8ac85365 2400newASSIGNOP(I32 flags, OP *left, I32 optype, OP *right)
79072805 2401{
11343788 2402 OP *o;
79072805 2403
a0d0e21e
LW		 2404 if (optype) {
2405 if (optype == OP_ANDASSIGN || optype == OP_ORASSIGN) {
2406 return newLOGOP(optype, 0,
2407 mod(scalar(left), optype),
2408 newUNOP(OP_SASSIGN, 0, scalar(right)));
2409 }
2410 else {
2411 return newBINOP(optype, OPf_STACKED,
2412 mod(scalar(left), optype), scalar(right));
2413 }
2414 }
2415
79072805 2416 if (list_assignment(left)) {
463ee0b2 2417 modcount = 0;
748a9306 2418 eval_start = right; /* Grandfathering $[ assignment here. Bletch.*/
463ee0b2 2419 left = mod(left, OP_AASSIGN);
748a9306
LW		 2420 if (eval_start)
2421 eval_start = 0;
2422 else {
a0d0e21e
LW		 2423 op_free(left);
2424 op_free(right);
2425 return Nullop;
2426 }
11343788 2427 o = newBINOP(OP_AASSIGN, flags,
8990e307
LW		 2428 list(force_list(right)),
2429 list(force_list(left)) );
11343788 2430 o->op_private = 0 | (flags >> 8);
a0d0e21e 2431 if (!(left->op_private & OPpLVAL_INTRO)) {
748a9306 2432 static int generation = 100;
79072805 2433 OP *curop;
11343788 2434 OP *lastop = o;
79072805 2435 generation++;
11343788 2436 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
79072805
LW		 2437 if (opargs[curop->op_type] & OA_DANGEROUS) {
2438 if (curop->op_type == OP_GV) {
2439 GV *gv = ((GVOP*)curop)->op_gv;
2440 if (gv == defgv || SvCUR(gv) == generation)
2441 break;
2442 SvCUR(gv) = generation;
2443 }
748a9306
LW		 2444 else if (curop->op_type == OP_PADSV ||
2445 curop->op_type == OP_PADAV ||
2446 curop->op_type == OP_PADHV ||
2447 curop->op_type == OP_PADANY) {
2448 SV **svp = AvARRAY(comppad_name);
8e07c86e 2449 SV *sv = svp[curop->op_targ];
748a9306
LW		 2450 if (SvCUR(sv) == generation)
2451 break;
2452 SvCUR(sv) = generation; /* (SvCUR not used any more) */
2453 }
79072805
LW		 2454 else if (curop->op_type == OP_RV2CV)
2455 break;
2456 else if (curop->op_type == OP_RV2SV ||
2457 curop->op_type == OP_RV2AV ||
2458 curop->op_type == OP_RV2HV ||
2459 curop->op_type == OP_RV2GV) {
2460 if (lastop->op_type != OP_GV) /* funny deref? */
2461 break;
2462 }
2463 else
2464 break;
2465 }
2466 lastop = curop;
2467 }
11343788
MB		 2468 if (curop != o)
2469 o->op_private = OPpASSIGN_COMMON;
79072805 2470 }
c07a80fd 2471 if (right && right->op_type == OP_SPLIT) {
2472 OP* tmpop;
2473 if ((tmpop = ((LISTOP*)right)->op_first) &&
2474 tmpop->op_type == OP_PUSHRE)
2475 {
2476 PMOP *pm = (PMOP*)tmpop;
2477 if (left->op_type == OP_RV2AV &&
2478 !(left->op_private & OPpLVAL_INTRO) &&
11343788 2479 !(o->op_private & OPpASSIGN_COMMON) )
c07a80fd 2480 {
2481 tmpop = ((UNOP*)left)->op_first;
2482 if (tmpop->op_type == OP_GV && !pm->op_pmreplroot) {
2483 pm->op_pmreplroot = (OP*)((GVOP*)tmpop)->op_gv;
2484 pm->op_pmflags |= PMf_ONCE;
11343788 2485 tmpop = cUNOPo->op_first; /* to list (nulled) */
c07a80fd 2486 tmpop = ((UNOP*)tmpop)->op_first; /* to pushmark */
2487 tmpop->op_sibling = Nullop; /* don't free split */
2488 right->op_next = tmpop->op_next; /* fix starting loc */
11343788 2489 op_free(o); /* blow off assign */
54310121 2490 right->op_flags &= ~OPf_WANT;
a5f75d66 2491 /* "I don't know and I don't care." */
c07a80fd 2492 return right;
2493 }
2494 }
2495 else {
2496 if (modcount < 10000 &&
2497 ((LISTOP*)right)->op_last->op_type == OP_CONST)
2498 {
2499 SV *sv = ((SVOP*)((LISTOP*)right)->op_last)->op_sv;
2500 if (SvIVX(sv) == 0)
2501 sv_setiv(sv, modcount+1);
2502 }
2503 }
2504 }
2505 }
11343788 2506 return o;
79072805
LW		 2507 }
2508 if (!right)
2509 right = newOP(OP_UNDEF, 0);
2510 if (right->op_type == OP_READLINE) {
2511 right->op_flags |= OPf_STACKED;
463ee0b2 2512 return newBINOP(OP_NULL, flags, mod(scalar(left), OP_SASSIGN), scalar(right));
79072805 2513 }
a0d0e21e 2514 else {
748a9306 2515 eval_start = right; /* Grandfathering $[ assignment here. Bletch.*/
11343788 2516 o = newBINOP(OP_SASSIGN, flags,
463ee0b2 2517 scalar(right), mod(scalar(left), OP_SASSIGN) );
748a9306
LW		 2518 if (eval_start)
2519 eval_start = 0;
2520 else {
11343788 2521 op_free(o);
a0d0e21e
LW		 2522 return Nullop;
2523 }
2524 }
11343788 2525 return o;
79072805
LW		 2526}
2527
2528OP *
8ac85365 2529newSTATEOP(I32 flags, char *label, OP *o)
79072805 2530{
11343788 2531 dTHR;
bbce6d69 2532 U32 seq = intro_my();
79072805
LW		 2533 register COP *cop;
2534
2535 Newz(1101, cop, 1, COP);
84902520 2536 if (PERLDB_LINE && curcop->cop_line && curstash != debstash) {
8990e307
LW		 2537 cop->op_type = OP_DBSTATE;
2538 cop->op_ppaddr = ppaddr[ OP_DBSTATE ];
2539 }
2540 else {
2541 cop->op_type = OP_NEXTSTATE;
2542 cop->op_ppaddr = ppaddr[ OP_NEXTSTATE ];
2543 }
79072805 2544 cop->op_flags = flags;
c07a80fd 2545 cop->op_private = 0 | (flags >> 8);
ff0cee69 2546#ifdef NATIVE_HINTS
2547 cop->op_private |= NATIVE_HINTS;
2548#endif
79072805
LW		 2549 cop->op_next = (OP*)cop;
2550
463ee0b2
LW		 2551 if (label) {
2552 cop->cop_label = label;
85e6fe83 2553 hints |= HINT_BLOCK_SCOPE;
463ee0b2 2554 }
bbce6d69 2555 cop->cop_seq = seq;
a0d0e21e 2556 cop->cop_arybase = curcop->cop_arybase;
79072805
LW		 2557
2558 if (copline == NOLINE)
2559 cop->cop_line = curcop->cop_line;
2560 else {
2561 cop->cop_line = copline;
2562 copline = NOLINE;
2563 }
44a8e56a 2564 cop->cop_filegv = (GV*)SvREFCNT_inc(curcop->cop_filegv);
79072805
LW		 2565 cop->cop_stash = curstash;
2566
84902520 2567 if (PERLDB_LINE && curstash != debstash) {
93a17b20
LW		 2568 SV **svp = av_fetch(GvAV(curcop->cop_filegv),(I32)cop->cop_line, FALSE);
2569 if (svp && *svp != &sv_undef && !SvIOK(*svp)) {
a0d0e21e 2570 (void)SvIOK_on(*svp);
a5f75d66 2571 SvIVX(*svp) = 1;
93a17b20
LW		 2572 SvSTASH(*svp) = (HV*)cop;
2573 }
2574 }
2575
11343788 2576 return prepend_elem(OP_LINESEQ, (OP*)cop, o);
79072805
LW		 2577}
2578
bbce6d69 2579/* "Introduce" my variables to visible status. */
2580U32
8ac85365 2581intro_my(void)
bbce6d69 2582{
2583 SV **svp;
2584 SV *sv;
2585 I32 i;
2586
2587 if (! min_intro_pending)
2588 return cop_seqmax;
2589
2590 svp = AvARRAY(comppad_name);
2591 for (i = min_intro_pending; i <= max_intro_pending; i++) {
2592 if ((sv = svp[i]) && sv != &sv_undef && !SvIVX(sv)) {
2593 SvIVX(sv) = 999999999; /* Don't know scope end yet. */
2594 SvNVX(sv) = (double)cop_seqmax;
2595 }
2596 }
2597 min_intro_pending = 0;
2598 comppad_name_fill = max_intro_pending; /* Needn't search higher */
2599 return cop_seqmax++;
2600}
2601
79072805 2602OP *
8ac85365 2603newLOGOP(I32 type, I32 flags, OP *first, OP *other)
79072805 2604{
11343788 2605 dTHR;
79072805 2606 LOGOP *logop;
11343788 2607 OP *o;
79072805 2608
a0d0e21e
LW		 2609 if (type == OP_XOR) /* Not short circuit, but here by precedence. */
2610 return newBINOP(type, flags, scalar(first), scalar(other));
2611
8990e307 2612 scalarboolean(first);
79072805
LW		 2613 /* optimize "!a && b" to "a || b", and "!a || b" to "a && b" */
2614 if (first->op_type == OP_NOT && (first->op_flags & OPf_SPECIAL)) {
2615 if (type == OP_AND || type == OP_OR) {
2616 if (type == OP_AND)
2617 type = OP_OR;
2618 else
2619 type = OP_AND;
11343788
MB		 2620 o = first;
2621 first = cUNOPo->op_first;
2622 if (o->op_next)
2623 first->op_next = o->op_next;
2624 cUNOPo->op_first = Nullop;
2625 op_free(o);
79072805
LW		 2626 }
2627 }
2628 if (first->op_type == OP_CONST) {
93a17b20 2629 if (dowarn && (first->op_private & OPpCONST_BARE))
c07a80fd 2630 warn("Probable precedence problem on %s", op_desc[type]);
79072805
LW		 2631 if ((type == OP_AND) == (SvTRUE(((SVOP*)first)->op_sv))) {
2632 op_free(first);
2633 return other;
2634 }
2635 else {
2636 op_free(other);
2637 return first;
2638 }
2639 }
2640 else if (first->op_type == OP_WANTARRAY) {
2641 if (type == OP_AND)
2642 list(other);
2643 else
2644 scalar(other);
2645 }
a6006777 2646 else if (dowarn && (first->op_flags & OPf_KIDS)) {
2647 OP *k1 = ((UNOP*)first)->op_first;
2648 OP *k2 = k1->op_sibling;
2649 OPCODE warnop = 0;
2650 switch (first->op_type)
2651 {
2652 case OP_NULL:
2653 if (k2 && k2->op_type == OP_READLINE
2654 && (k2->op_flags & OPf_STACKED)
2655 && (k1->op_type == OP_RV2SV || k1->op_type == OP_PADSV))
2656 warnop = k2->op_type;
2657 break;
2658
2659 case OP_SASSIGN:
68dc0745 2660 if (k1->op_type == OP_READDIR
2661 || k1->op_type == OP_GLOB
2662 || k1->op_type == OP_EACH)
a6006777 2663 warnop = k1->op_type;
2664 break;
2665 }
8ebc5c01 2666 if (warnop) {
2667 line_t oldline = curcop->cop_line;
2668 curcop->cop_line = copline;
68dc0745 2669 warn("Value of %s%s can be \"0\"; test with defined()",
2670 op_desc[warnop],
2671 ((warnop == OP_READLINE || warnop == OP_GLOB)
2672 ? " construct" : "() operator"));
2673 curcop->cop_line = oldline;
8ebc5c01 2674 }
a6006777 2675 }
79072805
LW		 2676
2677 if (!other)
2678 return first;
2679
a0d0e21e
LW		 2680 if (type == OP_ANDASSIGN || type == OP_ORASSIGN)
2681 other->op_private |= OPpASSIGN_BACKWARDS; /* other is an OP_SASSIGN */
2682
79072805
LW		 2683 Newz(1101, logop, 1, LOGOP);
2684
2685 logop->op_type = type;
2686 logop->op_ppaddr = ppaddr[type];
2687 logop->op_first = first;
2688 logop->op_flags = flags | OPf_KIDS;
2689 logop->op_other = LINKLIST(other);
c07a80fd 2690 logop->op_private = 1 | (flags >> 8);
79072805
LW		 2691
2692 /* establish postfix order */
2693 logop->op_next = LINKLIST(first);
2694 first->op_next = (OP*)logop;
2695 first->op_sibling = other;
2696
11343788
MB		 2697 o = newUNOP(OP_NULL, 0, (OP*)logop);
2698 other->op_next = o;
79072805 2699
11343788 2700 return o;
79072805
LW		 2701}
2702
2703OP *
8ac85365 2704newCONDOP(I32 flags, OP *first, OP *trueop, OP *falseop)
79072805 2705{
11343788 2706 dTHR;
79072805 2707 CONDOP *condop;
11343788 2708 OP *o;
79072805 2709
b1cb66bf 2710 if (!falseop)
2711 return newLOGOP(OP_AND, 0, first, trueop);
2712 if (!trueop)
2713 return newLOGOP(OP_OR, 0, first, falseop);
79072805 2714
8990e307 2715 scalarboolean(first);
79072805
LW		 2716 if (first->op_type == OP_CONST) {
2717 if (SvTRUE(((SVOP*)first)->op_sv)) {
2718 op_free(first);
b1cb66bf 2719 op_free(falseop);
2720 return trueop;
79072805
LW		 2721 }
2722 else {
2723 op_free(first);
b1cb66bf 2724 op_free(trueop);
2725 return falseop;
79072805
LW		 2726 }
2727 }
2728 else if (first->op_type == OP_WANTARRAY) {
b1cb66bf 2729 list(trueop);
2730 scalar(falseop);
79072805
LW		 2731 }
2732 Newz(1101, condop, 1, CONDOP);
2733
2734 condop->op_type = OP_COND_EXPR;
2735 condop->op_ppaddr = ppaddr[OP_COND_EXPR];
2736 condop->op_first = first;
2737 condop->op_flags = flags | OPf_KIDS;
b1cb66bf 2738 condop->op_true = LINKLIST(trueop);
2739 condop->op_false = LINKLIST(falseop);
c07a80fd 2740 condop->op_private = 1 | (flags >> 8);
79072805
LW		 2741
2742 /* establish postfix order */
2743 condop->op_next = LINKLIST(first);
2744 first->op_next = (OP*)condop;
2745
b1cb66bf 2746 first->op_sibling = trueop;
2747 trueop->op_sibling = falseop;
11343788 2748 o = newUNOP(OP_NULL, 0, (OP*)condop);
79072805 2749
5dc0d613
MB		 2750 trueop->op_next = o;
2751 falseop->op_next = o;
79072805 2752
11343788 2753 return o;
79072805
LW		 2754}
2755
2756OP *
8ac85365 2757newRANGE(I32 flags, OP *left, OP *right)
79072805 2758{
b35b2403 2759 dTHR;
79072805
LW		 2760 CONDOP *condop;
2761 OP *flip;
2762 OP *flop;
11343788 2763 OP *o;
79072805
LW		 2764
2765 Newz(1101, condop, 1, CONDOP);
2766
2767 condop->op_type = OP_RANGE;
2768 condop->op_ppaddr = ppaddr[OP_RANGE];
2769 condop->op_first = left;
2770 condop->op_flags = OPf_KIDS;
2771 condop->op_true = LINKLIST(left);
2772 condop->op_false = LINKLIST(right);
c07a80fd 2773 condop->op_private = 1 | (flags >> 8);
79072805
LW		 2774
2775 left->op_sibling = right;
2776
2777 condop->op_next = (OP*)condop;
2778 flip = newUNOP(OP_FLIP, flags, (OP*)condop);
2779 flop = newUNOP(OP_FLOP, 0, flip);
11343788 2780 o = newUNOP(OP_NULL, 0, flop);
79072805
LW		 2781 linklist(flop);
2782
2783 left->op_next = flip;
2784 right->op_next = flop;
2785
ed6116ce 2786 condop->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
79072805 2787 sv_upgrade(PAD_SV(condop->op_targ), SVt_PVNV);
ed6116ce 2788 flip->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
79072805
LW		 2789 sv_upgrade(PAD_SV(flip->op_targ), SVt_PVNV);
2790
2791 flip->op_private = left->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
2792 flop->op_private = right->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
2793
11343788 2794 flip->op_next = o;
79072805 2795 if (!flip->op_private || !flop->op_private)
11343788 2796 linklist(o); /* blow off optimizer unless constant */
79072805 2797
11343788 2798 return o;
79072805
LW		 2799}
2800
2801OP *
8ac85365 2802newLOOPOP(I32 flags, I32 debuggable, OP *expr, OP *block)
79072805 2803{
11343788 2804 dTHR;
463ee0b2 2805 OP* listop;
11343788 2806 OP* o;
463ee0b2 2807 int once = block && block->op_flags & OPf_SPECIAL &&
a0d0e21e 2808 (block->op_type == OP_ENTERSUB || block->op_type == OP_NULL);
93a17b20 2809
463ee0b2
LW		 2810 if (expr) {
2811 if (once && expr->op_type == OP_CONST && !SvTRUE(((SVOP*)expr)->op_sv))
2812 return block; /* do {} while 0 does once */
fb73857a 2813 if (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
2814 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
774d564b 2815 expr = newUNOP(OP_DEFINED, 0,
54b9620d 2816 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
774d564b 2817 }
463ee0b2 2818 }
93a17b20 2819
8990e307 2820 listop = append_elem(OP_LINESEQ, block, newOP(OP_UNSTACK, 0));
11343788 2821 o = newLOGOP(OP_AND, 0, expr, listop);
463ee0b2 2822
11343788 2823 ((LISTOP*)listop)->op_last->op_next = LINKLIST(o);
79072805 2824
11343788
MB		 2825 if (once && o != listop)
2826 o->op_next = ((LOGOP*)cUNOPo->op_first)->op_other;
79072805 2827
11343788
MB		 2828 if (o == listop)
2829 o = newUNOP(OP_NULL, 0, o); /* or do {} while 1 loses outer block */
748a9306 2830
11343788
MB		 2831 o->op_flags |= flags;
2832 o = scope(o);
2833 o->op_flags |= OPf_SPECIAL; /* suppress POPBLOCK curpm restoration*/
2834 return o;
79072805
LW		 2835}
2836
2837OP *
8ac85365 2838newWHILEOP(I32 flags, I32 debuggable, LOOP *loop, I32 whileline, OP *expr, OP *block, OP *cont)
79072805 2839{
11343788 2840 dTHR;
79072805
LW		 2841 OP *redo;
2842 OP *next = 0;
2843 OP *listop;
11343788 2844 OP *o;
79072805
LW		 2845 OP *condop;
2846
fb73857a 2847 if (expr && (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
2848 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB))) {
748a9306 2849 expr = newUNOP(OP_DEFINED, 0,
54b9620d 2850 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
748a9306 2851 }
79072805
LW		 2852
2853 if (!block)
2854 block = newOP(OP_NULL, 0);
2855
2856 if (cont)
2857 next = LINKLIST(cont);
fb73857a 2858 if (expr) {
79072805 2859 cont = append_elem(OP_LINESEQ, cont, newOP(OP_UNSTACK, 0));
fb73857a 2860 if ((line_t)whileline != NOLINE) {
2861 copline = whileline;
2862 cont = append_elem(OP_LINESEQ, cont,
2863 newSTATEOP(0, Nullch, Nullop));
2864 }
2865 }
79072805 2866
463ee0b2 2867 listop = append_list(OP_LINESEQ, (LISTOP*)block, (LISTOP*)cont);
79072805
LW		 2868 redo = LINKLIST(listop);
2869
2870 if (expr) {
11343788
MB		 2871 o = newLOGOP(OP_AND, 0, expr, scalar(listop));
2872 if (o == expr && o->op_type == OP_CONST && !SvTRUE(cSVOPo->op_sv)) {
85e6fe83 2873 op_free(expr); /* oops, it's a while (0) */
463ee0b2
LW		 2874 op_free((OP*)loop);
2875 return Nullop; /* (listop already freed by newLOGOP) */
2876 }
aeea060c 2877 ((LISTOP*)listop)->op_last->op_next = condop =
11343788 2878 (o == listop ? redo : LINKLIST(o));
79072805
LW		 2879 if (!next)
2880 next = condop;
2881 }
2882 else
11343788 2883 o = listop;
79072805
LW		 2884
2885 if (!loop) {
2886 Newz(1101,loop,1,LOOP);
2887 loop->op_type = OP_ENTERLOOP;
2888 loop->op_ppaddr = ppaddr[OP_ENTERLOOP];
2889 loop->op_private = 0;
2890 loop->op_next = (OP*)loop;
2891 }
2892
11343788 2893 o = newBINOP(OP_LEAVELOOP, 0, (OP*)loop, o);
79072805
LW		 2894
2895 loop->op_redoop = redo;
11343788 2896 loop->op_lastop = o;
79072805
LW		 2897
2898 if (next)
2899 loop->op_nextop = next;
2900 else
11343788 2901 loop->op_nextop = o;
79072805 2902
11343788
MB		 2903 o->op_flags |= flags;
2904 o->op_private |= (flags >> 8);
2905 return o;
79072805
LW		 2906}
2907
2908OP *
a0d0e21e 2909#ifndef CAN_PROTOTYPE
79072805
LW		 2910newFOROP(flags,label,forline,sv,expr,block,cont)
2911I32 flags;
2912char *label;
2913line_t forline;
2914OP* sv;
2915OP* expr;
2916OP*block;
2917OP*cont;
8990e307
LW		 2918#else
2919newFOROP(I32 flags,char *label,line_t forline,OP *sv,OP *expr,OP *block,OP *cont)
a0d0e21e 2920#endif /* CAN_PROTOTYPE */
79072805
LW		 2921{
2922 LOOP *loop;
fb73857a 2923 OP *wop;
85e6fe83 2924 int padoff = 0;
4633a7c4 2925 I32 iterflags = 0;
79072805 2926
79072805 2927 if (sv) {
85e6fe83 2928 if (sv->op_type == OP_RV2SV) { /* symbol table variable */
748a9306
LW		 2929 sv->op_type = OP_RV2GV;
2930 sv->op_ppaddr = ppaddr[OP_RV2GV];
79072805 2931 }
85e6fe83
LW		 2932 else if (sv->op_type == OP_PADSV) { /* private variable */
2933 padoff = sv->op_targ;
2934 op_free(sv);
2935 sv = Nullop;
2936 }
54b9620d
MB		 2937 else if (sv->op_type == OP_THREADSV) { /* per-thread variable */
2938 padoff = sv->op_targ;
2939 iterflags |= OPf_SPECIAL;
2940 op_free(sv);
2941 sv = Nullop;
2942 }
79072805 2943 else
c07a80fd 2944 croak("Can't use %s for loop variable", op_desc[sv->op_type]);
79072805
LW		 2945 }
2946 else {
54b9620d
MB		 2947#ifdef USE_THREADS
2948 padoff = find_threadsv("_");
2949 iterflags |= OPf_SPECIAL;
2950#else
79072805 2951 sv = newGVOP(OP_GV, 0, defgv);
54b9620d 2952#endif
79072805 2953 }
5f05dabc 2954 if (expr->op_type == OP_RV2AV || expr->op_type == OP_PADAV) {
4633a7c4
LW		 2955 expr = scalar(ref(expr, OP_ITER));
2956 iterflags |= OPf_STACKED;
2957 }
2958 loop = (LOOP*)list(convert(OP_ENTERITER, iterflags,
a0d0e21e
LW		 2959 append_elem(OP_LIST, mod(force_list(expr), OP_GREPSTART),
2960 scalar(sv))));
85e6fe83
LW		 2961 assert(!loop->op_next);
2962 Renew(loop, 1, LOOP);
2963 loop->op_targ = padoff;
fb73857a 2964 wop = newWHILEOP(flags, 1, loop, forline, newOP(OP_ITER, 0), block, cont);
2965 copline = forline;
2966 return newSTATEOP(0, label, wop);
79072805
LW		 2967}
2968
8990e307 2969OP*
8ac85365 2970newLOOPEX(I32 type, OP *label)
8990e307 2971{
11343788
MB		 2972 dTHR;
2973 OP *o;
8990e307 2974 if (type != OP_GOTO || label->op_type == OP_CONST) {
11343788 2975 o = newPVOP(type, 0, savepv(
a0d0e21e
LW		 2976 label->op_type == OP_CONST
2977 ? SvPVx(((SVOP*)label)->op_sv, na)
2978 : "" ));
8990e307
LW		 2979 op_free(label);
2980 }
2981 else {
a0d0e21e
LW		 2982 if (label->op_type == OP_ENTERSUB)
2983 label = newUNOP(OP_REFGEN, 0, mod(label, OP_REFGEN));
11343788 2984 o = newUNOP(type, OPf_STACKED, label);
8990e307 2985 }
85e6fe83 2986 hints |= HINT_BLOCK_SCOPE;
11343788 2987 return o;
8990e307
LW		 2988}
2989
79072805 2990void
8ac85365 2991cv_undef(CV *cv)
79072805 2992{
11343788
MB		 2993 dTHR;
2994#ifdef USE_THREADS
e858de61
MB		 2995 if (CvMUTEXP(cv)) {
2996 MUTEX_DESTROY(CvMUTEXP(cv));
2997 Safefree(CvMUTEXP(cv));
2998 CvMUTEXP(cv) = 0;
2999 }
11343788
MB		 3000#endif /* USE_THREADS */
3001
a0d0e21e 3002 if (!CvXSUB(cv) && CvROOT(cv)) {
11343788
MB		 3003#ifdef USE_THREADS
3004 if (CvDEPTH(cv) || (CvOWNER(cv) && CvOWNER(cv) != thr))
3005 croak("Can't undef active subroutine");
3006#else
a0d0e21e
LW		 3007 if (CvDEPTH(cv))
3008 croak("Can't undef active subroutine");
11343788 3009#endif /* USE_THREADS */
8990e307 3010 ENTER;
a0d0e21e
LW		 3011
3012 SAVESPTR(curpad);
3013 curpad = 0;
3014
a5f75d66 3015 if (!CvCLONED(cv))
748a9306 3016 op_free(CvROOT(cv));
79072805 3017 CvROOT(cv) = Nullop;
8990e307 3018 LEAVE;
79072805 3019 }
1d5db326 3020 SvPOK_off((SV*)cv); /* forget prototype */
44a8e56a 3021 CvFLAGS(cv) = 0;
8e07c86e
AD		 3022 SvREFCNT_dec(CvGV(cv));
3023 CvGV(cv) = Nullgv;
3024 SvREFCNT_dec(CvOUTSIDE(cv));
3025 CvOUTSIDE(cv) = Nullcv;
3026 if (CvPADLIST(cv)) {
8ebc5c01 3027 /* may be during global destruction */
3028 if (SvREFCNT(CvPADLIST(cv))) {
3029 I32 i = AvFILL(CvPADLIST(cv));
3030 while (i >= 0) {
3031 SV** svp = av_fetch(CvPADLIST(cv), i--, FALSE);
46fc3d4c 3032 SV* sv = svp ? *svp : Nullsv;
3033 if (!sv)
3034 continue;
3035 if (sv == (SV*)comppad_name)
3036 comppad_name = Nullav;
3037 else if (sv == (SV*)comppad) {
3038 comppad = Nullav;
3039 curpad = Null(SV**);
3040 }
3041 SvREFCNT_dec(sv);
8ebc5c01 3042 }
3043 SvREFCNT_dec((SV*)CvPADLIST(cv));
8e07c86e 3044 }
8e07c86e
AD		 3045 CvPADLIST(cv) = Nullav;
3046 }
79072805
LW		 3047}
3048
5f05dabc 3049#ifdef DEBUG_CLOSURES
3050static void
3051cv_dump(cv)
3052CV* cv;
3053{
3054 CV *outside = CvOUTSIDE(cv);
3055 AV* padlist = CvPADLIST(cv);
4fdae800 3056 AV* pad_name;
3057 AV* pad;
3058 SV** pname;
3059 SV** ppad;
5f05dabc 3060 I32 ix;
3061
fb73857a 3062 PerlIO_printf(Perl_debug_log, "\tCV=0x%lx (%s), OUTSIDE=0x%lx (%s)\n",
ab50184a
CS		 3063 cv,
3064 (CvANON(cv) ? "ANON"
3065 : (cv == main_cv) ? "MAIN"
07055b4c 3066 : CvUNIQUE(outside) ? "UNIQUE"
44a8e56a 3067 : CvGV(cv) ? GvNAME(CvGV(cv)) : "UNDEFINED"),
ab50184a
CS		 3068 outside,
3069 (!outside ? "null"
3070 : CvANON(outside) ? "ANON"
3071 : (outside == main_cv) ? "MAIN"
07055b4c 3072 : CvUNIQUE(outside) ? "UNIQUE"
44a8e56a 3073 : CvGV(outside) ? GvNAME(CvGV(outside)) : "UNDEFINED"));
5f05dabc 3074
4fdae800 3075 if (!padlist)
3076 return;
3077
3078 pad_name = (AV*)*av_fetch(padlist, 0, FALSE);
3079 pad = (AV*)*av_fetch(padlist, 1, FALSE);
3080 pname = AvARRAY(pad_name);
3081 ppad = AvARRAY(pad);
3082
9607fc9c 3083 for (ix = 1; ix <= AvFILL(pad_name); ix++) {
5f05dabc 3084 if (SvPOK(pname[ix]))
fb73857a 3085 PerlIO_printf(Perl_debug_log, "\t%4d. 0x%lx (%s\"%s\" %ld-%ld)\n",
4fdae800 3086 ix, ppad[ix],
3087 SvFAKE(pname[ix]) ? "FAKE " : "",
3088 SvPVX(pname[ix]),
ab50184a
CS		 3089 (long)I_32(SvNVX(pname[ix])),
3090 (long)SvIVX(pname[ix]));
5f05dabc 3091 }
3092}
3093#endif /* DEBUG_CLOSURES */
3094
3095static CV *
8ac85365 3096cv_clone2(CV *proto, CV *outside)
748a9306 3097{
11343788 3098 dTHR;
748a9306
LW		 3099 AV* av;
3100 I32 ix;
3101 AV* protopadlist = CvPADLIST(proto);
3102 AV* protopad_name = (AV*)*av_fetch(protopadlist, 0, FALSE);
3103 AV* protopad = (AV*)*av_fetch(protopadlist, 1, FALSE);
5f05dabc 3104 SV** pname = AvARRAY(protopad_name);
3105 SV** ppad = AvARRAY(protopad);
9607fc9c 3106 I32 fname = AvFILL(protopad_name);
3107 I32 fpad = AvFILL(protopad);
748a9306
LW		 3108 AV* comppadlist;
3109 CV* cv;
3110
07055b4c
CS		 3111 assert(!CvUNIQUE(proto));
3112
748a9306
LW		 3113 ENTER;
3114 SAVESPTR(curpad);
3115 SAVESPTR(comppad);
46fc3d4c 3116 SAVESPTR(comppad_name);
748a9306
LW		 3117 SAVESPTR(compcv);
3118
3119 cv = compcv = (CV*)NEWSV(1104,0);
fa83b5b6 3120 sv_upgrade((SV *)cv, SvTYPE(proto));
a5f75d66 3121 CvCLONED_on(cv);
5f05dabc 3122 if (CvANON(proto))
3123 CvANON_on(cv);
748a9306 3124
11343788 3125#ifdef USE_THREADS
12ca11f6 3126 New(666, CvMUTEXP(cv), 1, perl_mutex);
11343788 3127 MUTEX_INIT(CvMUTEXP(cv));
11343788
MB		 3128 CvOWNER(cv) = 0;
3129#endif /* USE_THREADS */
748a9306 3130 CvFILEGV(cv) = CvFILEGV(proto);
44a8e56a 3131 CvGV(cv) = (GV*)SvREFCNT_inc(CvGV(proto));
748a9306
LW		 3132 CvSTASH(cv) = CvSTASH(proto);
3133 CvROOT(cv) = CvROOT(proto);
3134 CvSTART(cv) = CvSTART(proto);
5f05dabc 3135 if (outside)
3136 CvOUTSIDE(cv) = (CV*)SvREFCNT_inc(outside);
748a9306 3137
68dc0745 3138 if (SvPOK(proto))
3139 sv_setpvn((SV*)cv, SvPVX(proto), SvCUR(proto));
3140
46fc3d4c 3141 comppad_name = newAV();
3142 for (ix = fname; ix >= 0; ix--)
3143 av_store(comppad_name, ix, SvREFCNT_inc(pname[ix]));
748a9306
LW		 3144
3145 comppad = newAV();
3146
3147 comppadlist = newAV();
3148 AvREAL_off(comppadlist);
46fc3d4c 3149 av_store(comppadlist, 0, (SV*)comppad_name);
b355b4e0 3150 av_store(comppadlist, 1, (SV*)comppad);
748a9306 3151 CvPADLIST(cv) = comppadlist;
5f05dabc 3152 av_fill(comppad, AvFILL(protopad));
748a9306
LW		 3153 curpad = AvARRAY(comppad);
3154
3155 av = newAV(); /* will be @_ */
3156 av_extend(av, 0);
3157 av_store(comppad, 0, (SV*)av);
3158 AvFLAGS(av) = AVf_REIFY;
3159
9607fc9c 3160 for (ix = fpad; ix > 0; ix--) {
3161 SV* namesv = (ix <= fname) ? pname[ix] : Nullsv;
aa689395 3162 if (namesv && namesv != &sv_undef) {
3163 char *name = SvPVX(namesv); /* XXX */
3164 if (SvFLAGS(namesv) & SVf_FAKE) { /* lexical from outside? */
3165 I32 off = pad_findlex(name, ix, SvIVX(namesv),
5f05dabc 3166 CvOUTSIDE(cv), cxstack_ix);
3167 if (!off)
3168 curpad[ix] = SvREFCNT_inc(ppad[ix]);
3169 else if (off != ix)
748a9306
LW		 3170 croak("panic: cv_clone: %s", name);
3171 }
3172 else { /* our own lexical */
aa689395 3173 SV* sv;
5f05dabc 3174 if (*name == '&') {
3175 /* anon code -- we'll come back for it */
3176 sv = SvREFCNT_inc(ppad[ix]);
3177 }
3178 else if (*name == '@')
3179 sv = (SV*)newAV();
748a9306 3180 else if (*name == '%')
5f05dabc 3181 sv = (SV*)newHV();
748a9306 3182 else
5f05dabc 3183 sv = NEWSV(0,0);
3184 if (!SvPADBUSY(sv))
3185 SvPADMY_on(sv);
3186 curpad[ix] = sv;
748a9306
LW		 3187 }
3188 }
3189 else {
aa689395 3190 SV* sv = NEWSV(0,0);
748a9306 3191 SvPADTMP_on(sv);
5f05dabc 3192 curpad[ix] = sv;
748a9306
LW		 3193 }
3194 }
3195
5f05dabc 3196 /* Now that vars are all in place, clone nested closures. */
3197
9607fc9c 3198 for (ix = fpad; ix > 0; ix--) {
3199 SV* namesv = (ix <= fname) ? pname[ix] : Nullsv;
aa689395 3200 if (namesv
3201 && namesv != &sv_undef
3202 && !(SvFLAGS(namesv) & SVf_FAKE)
3203 && *SvPVX(namesv) == '&'
5f05dabc 3204 && CvCLONE(ppad[ix]))
3205 {
3206 CV *kid = cv_clone2((CV*)ppad[ix], cv);
3207 SvREFCNT_dec(ppad[ix]);
3208 CvCLONE_on(kid);
3209 SvPADMY_on(kid);
3210 curpad[ix] = (SV*)kid;
748a9306
LW		 3211 }
3212 }
3213
5f05dabc 3214#ifdef DEBUG_CLOSURES
ab50184a
CS		 3215 PerlIO_printf(Perl_debug_log, "Cloned inside:\n");
3216 cv_dump(outside);
3217 PerlIO_printf(Perl_debug_log, " from:\n");
5f05dabc 3218 cv_dump(proto);
ab50184a 3219 PerlIO_printf(Perl_debug_log, " to:\n");
5f05dabc 3220 cv_dump(cv);
3221#endif
3222
748a9306
LW		 3223 LEAVE;
3224 return cv;
3225}
3226
3227CV *
8ac85365 3228cv_clone(CV *proto)
5f05dabc 3229{
3230 return cv_clone2(proto, CvOUTSIDE(proto));
3231}
3232
3fe9a6f1 3233void
8ac85365 3234cv_ckproto(CV *cv, GV *gv, char *p)
3fe9a6f1 3235{
3236 if ((!p != !SvPOK(cv)) || (p && strNE(p, SvPVX(cv)))) {
46fc3d4c 3237 SV* msg = sv_newmortal();
3fe9a6f1 3238 SV* name = Nullsv;
3239
3240 if (gv)
46fc3d4c 3241 gv_efullname3(name = sv_newmortal(), gv, Nullch);
3242 sv_setpv(msg, "Prototype mismatch:");
3243 if (name)
fc36a67e 3244 sv_catpvf(msg, " sub %_", name);
3fe9a6f1 3245 if (SvPOK(cv))
46fc3d4c 3246 sv_catpvf(msg, " (%s)", SvPVX(cv));
3247 sv_catpv(msg, " vs ");
3248 if (p)
3249 sv_catpvf(msg, "(%s)", p);
3250 else
3251 sv_catpv(msg, "none");
fc36a67e 3252 warn("%_", msg);
3fe9a6f1 3253 }
3254}
3255
760ac839 3256SV *
8ac85365 3257cv_const_sv(CV *cv)
760ac839
LW		 3258{
3259 OP *o;
54310121 3260 SV *sv;
aeea060c 3261
54310121 3262 if (!cv || !SvPOK(cv) || SvCUR(cv))
3263 return Nullsv;
760ac839 3264
54310121 3265 sv = Nullsv;
3266 for (o = CvSTART(cv); o; o = o->op_next) {
3267 OPCODE type = o->op_type;
3268
3269 if (type == OP_NEXTSTATE || type == OP_NULL || type == OP_PUSHMARK)
3270 continue;
3271 if (type == OP_LEAVESUB || type == OP_RETURN)
3272 break;
3273 if (sv)
3274 return Nullsv;
3275 if (type == OP_CONST)
5dc0d613 3276 sv = cSVOPo->op_sv;
54310121 3277 else if (type == OP_PADSV) {
e858de61
MB		 3278 AV* padav = (AV*)(AvARRAY(CvPADLIST(cv))[1]);
3279 sv = padav ? AvARRAY(padav)[o->op_targ] : Nullsv;
5aabfad6 3280 if (!sv || (!SvREADONLY(sv) && SvREFCNT(sv) > 1))
54310121 3281 return Nullsv;
760ac839 3282 }
54310121 3283 else
3284 return Nullsv;
760ac839 3285 }
5aabfad6 3286 if (sv)
3287 SvREADONLY_on(sv);
760ac839
LW		 3288 return sv;
3289}
3290
748a9306 3291CV *
8ac85365 3292newSUB(I32 floor, OP *o, OP *proto, OP *block)
79072805 3293{
11343788 3294 dTHR;
5dc0d613 3295 char *name = o ? SvPVx(cSVOPo->op_sv, na) : Nullch;
44a8e56a 3296 GV *gv = gv_fetchpv(name ? name : "__ANON__", GV_ADDMULTI, SVt_PVCV);
3fe9a6f1 3297 char *ps = proto ? SvPVx(((SVOP*)proto)->op_sv, na) : Nullch;
79072805 3298 register CV *cv;
a0d0e21e 3299 I32 ix;
79072805 3300
11343788 3301 if (o)
5dc0d613 3302 SAVEFREEOP(o);
3fe9a6f1 3303 if (proto)
3304 SAVEFREEOP(proto);
3305
68dc0745 3306 if (!name || GvCVGEN(gv))
3307 cv = Nullcv;
3308 else if (cv = GvCV(gv)) {
3fe9a6f1 3309 cv_ckproto(cv, gv, ps);
68dc0745 3310 /* already defined (or promised)? */
3311 if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) {
3312 SV* const_sv;
aa689395 3313 if (!block) {
3314 /* just a "sub foo;" when &foo is already defined */
3315 SAVEFREESV(compcv);
3316 goto done;
3317 }
7bac28a0 3318 /* ahem, death to those who redefine active sort subs */
3319 if (curstack == sortstack && sortcop == CvSTART(cv))
3320 croak("Can't redefine active sort subroutine %s", name);
68dc0745 3321 const_sv = cv_const_sv(cv);
44a8e56a 3322 if (const_sv || dowarn) {
79072805 3323 line_t oldline = curcop->cop_line;
79072805 3324 curcop->cop_line = copline;
760ac839 3325 warn(const_sv ? "Constant subroutine %s redefined"
68dc0745 3326 : "Subroutine %s redefined", name);
79072805
LW		 3327 curcop->cop_line = oldline;
3328 }
8990e307 3329 SvREFCNT_dec(cv);
68dc0745 3330 cv = Nullcv;
79072805
LW		 3331 }
3332 }
a0d0e21e 3333 if (cv) { /* must reuse cv if autoloaded */
4633a7c4 3334 cv_undef(cv);
44a8e56a 3335 CvFLAGS(cv) = CvFLAGS(compcv);
748a9306 3336 CvOUTSIDE(cv) = CvOUTSIDE(compcv);
e9a444f0 3337 CvOUTSIDE(compcv) = 0;
748a9306 3338 CvPADLIST(cv) = CvPADLIST(compcv);
4aa0a1f7 3339 CvPADLIST(compcv) = 0;
4633a7c4
LW		 3340 if (SvREFCNT(compcv) > 1) /* XXX Make closures transit through stub. */
3341 CvOUTSIDE(compcv) = (CV*)SvREFCNT_inc((SV*)cv);
748a9306 3342 SvREFCNT_dec(compcv);
a0d0e21e
LW		 3343 }
3344 else {
748a9306 3345 cv = compcv;
44a8e56a 3346 if (name) {
3347 GvCV(gv) = cv;
3348 GvCVGEN(gv) = 0;
3349 sub_generation++;
3350 }
a0d0e21e 3351 }
44a8e56a 3352 CvGV(cv) = (GV*)SvREFCNT_inc(gv);
79072805 3353 CvFILEGV(cv) = curcop->cop_filegv;
8990e307 3354 CvSTASH(cv) = curstash;
11343788
MB		 3355#ifdef USE_THREADS
3356 CvOWNER(cv) = 0;
12ca11f6 3357 New(666, CvMUTEXP(cv), 1, perl_mutex);
11343788 3358 MUTEX_INIT(CvMUTEXP(cv));
11343788 3359#endif /* USE_THREADS */
8990e307 3360
3fe9a6f1 3361 if (ps)
3362 sv_setpv((SV*)cv, ps);
4633a7c4 3363
c07a80fd 3364 if (error_count) {
3365 op_free(block);
3366 block = Nullop;
68dc0745 3367 if (name) {
3368 char *s = strrchr(name, ':');
3369 s = s ? s+1 : name;
6d4c2119
CS		 3370 if (strEQ(s, "BEGIN")) {
3371 char *not_safe =
3372 "BEGIN not safe after errors--compilation aborted";
3373 if (in_eval & 4)
3374 croak(not_safe);
3375 else {
3376 /* force display of errors found but not reported */
38a03e6e
MB		 3377 sv_catpv(ERRSV, not_safe);
3378 croak("%s", SvPVx(ERRSV, na));
6d4c2119
CS		 3379 }
3380 }
68dc0745 3381 }
c07a80fd 3382 }
a0d0e21e 3383 if (!block) {
a0d0e21e
LW		 3384 copline = NOLINE;
3385 LEAVE_SCOPE(floor);
3386 return cv;
3387 }
3388
54310121 3389 if (AvFILL(comppad_name) < AvFILL(comppad))
3390 av_store(comppad_name, AvFILL(comppad), Nullsv);
a0d0e21e 3391
54310121 3392 if (CvCLONE(cv)) {
3393 SV **namep = AvARRAY(comppad_name);
3394 for (ix = AvFILL(comppad); ix > 0; ix--) {
3395 SV *namesv;
3396
3397 if (SvIMMORTAL(curpad[ix]))
3398 continue;
3399 /*
3400 * The only things that a clonable function needs in its
3401 * pad are references to outer lexicals and anonymous subs.
3402 * The rest are created anew during cloning.
3403 */
3404 if (!((namesv = namep[ix]) != Nullsv &&
3405 namesv != &sv_undef &&
3406 (SvFAKE(namesv) ||
3407 *SvPVX(namesv) == '&')))
3408 {
3409 SvREFCNT_dec(curpad[ix]);
3410 curpad[ix] = Nullsv;
3411 }
3412 }
a0d0e21e 3413 }
54310121 3414 else {
3415 AV *av = newAV(); /* Will be @_ */
3416 av_extend(av, 0);
3417 av_store(comppad, 0, (SV*)av);
3418 AvFLAGS(av) = AVf_REIFY;
79072805 3419
54310121 3420 for (ix = AvFILL(comppad); ix > 0; ix--) {
3421 if (SvIMMORTAL(curpad[ix]))
3422 continue;
3423 if (!SvPADMY(curpad[ix]))
3424 SvPADTMP_on(curpad[ix]);
3425 }
3426 }
79072805 3427
a0d0e21e 3428 CvROOT(cv) = newUNOP(OP_LEAVESUB, 0, scalarseq(block));
79072805
LW		 3429 CvSTART(cv) = LINKLIST(CvROOT(cv));
3430 CvROOT(cv)->op_next = 0;
3431 peep(CvSTART(cv));
93a17b20 3432
44a8e56a 3433 if (name) {
3434 char *s;
3435
84902520 3436 if (PERLDB_SUBLINE && curstash != debstash) {
46fc3d4c 3437 SV *sv = NEWSV(0,0);
44a8e56a 3438 SV *tmpstr = sv_newmortal();
549bb64a 3439 GV *db_postponed = gv_fetchpv("DB::postponed", GV_ADDMULTI, SVt_PVHV);
44a8e56a 3440 CV *cv;
3441 HV *hv;
3442
51790459
MB		 3443 sv_setpvf(sv, "%_:%ld-%ld",
3444 GvSV(curcop->cop_filegv),
3445 (long)subline, (long)curcop->cop_line);
44a8e56a 3446 gv_efullname3(tmpstr, gv, Nullch);
3447 hv_store(GvHV(DBsub), SvPVX(tmpstr), SvCUR(tmpstr), sv, 0);
44a8e56a 3448 hv = GvHVn(db_postponed);
9607fc9c 3449 if (HvFILL(hv) > 0 && hv_exists(hv, SvPVX(tmpstr), SvCUR(tmpstr))
3450 && (cv = GvCV(db_postponed))) {
44a8e56a 3451 dSP;
3452 PUSHMARK(sp);
3453 XPUSHs(tmpstr);
3454 PUTBACK;
3455 perl_call_sv((SV*)cv, G_DISCARD);
3456 }
3457 }
79072805 3458
44a8e56a 3459 if ((s = strrchr(name,':')))
28757baa 3460 s++;
3461 else
3462 s = name;
68dc0745 3463 if (strEQ(s, "BEGIN")) {
2ae324a7 3464 I32 oldscope = scopestack_ix;
28757baa 3465 ENTER;
3466 SAVESPTR(compiling.cop_filegv);
3467 SAVEI16(compiling.cop_line);
3468 SAVEI32(perldb);
3469 save_svref(&rs);
3470 sv_setsv(rs, nrs);
3471
3472 if (!beginav)
3473 beginav = newAV();
3474 DEBUG_x( dump_sub(gv) );
3475 av_push(beginav, (SV *)cv);
3476 GvCV(gv) = 0;
68dc0745 3477 call_list(oldscope, beginav);
a6006777 3478
28757baa 3479 curcop = &compiling;
3480 LEAVE;
3481 }
3482 else if (strEQ(s, "END") && !error_count) {
3483 if (!endav)
3484 endav = newAV();
3485 av_unshift(endav, 1);
3486 av_store(endav, 0, (SV *)cv);
3487 GvCV(gv) = 0;
3488 }
7d07dbc2
MB		 3489 else if (strEQ(s, "INIT") && !error_count) {
3490 if (!initav)
3491 initav = newAV();
3492 av_push(initav, SvREFCNT_inc(cv));
ae77835f 3493 }
79072805 3494 }
a6006777 3495
aa689395 3496 done:
79072805 3497 copline = NOLINE;
8990e307 3498 LEAVE_SCOPE(floor);
a0d0e21e 3499 return cv;
79072805
LW		 3500}
3501
57d3b86d 3502CV *
aeea060c 3503newXS(char *name, void (*subaddr) (CV *), char *filename)
a0d0e21e 3504{
11343788 3505 dTHR;
44a8e56a 3506 GV *gv = gv_fetchpv(name ? name : "__ANON__", GV_ADDMULTI, SVt_PVCV);
79072805 3507 register CV *cv;
44a8e56a 3508
3509 if (cv = (name ? GvCV(gv) : Nullcv)) {
3510 if (GvCVGEN(gv)) {
3511 /* just a cached method */
3512 SvREFCNT_dec(cv);
3513 cv = 0;
3514 }
3515 else if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) {
3516 /* already defined (or promised) */
a0d0e21e
LW		 3517 if (dowarn) {
3518 line_t oldline = curcop->cop_line;
a0d0e21e
LW		 3519 curcop->cop_line = copline;
3520 warn("Subroutine %s redefined",name);
3521 curcop->cop_line = oldline;
3522 }
3523 SvREFCNT_dec(cv);
3524 cv = 0;
79072805 3525 }
79072805 3526 }
44a8e56a 3527
3528 if (cv) /* must reuse cv if autoloaded */
3529 cv_undef(cv);
a0d0e21e
LW		 3530 else {
3531 cv = (CV*)NEWSV(1105,0);
3532 sv_upgrade((SV *)cv, SVt_PVCV);
44a8e56a 3533 if (name) {
3534 GvCV(gv) = cv;
3535 GvCVGEN(gv) = 0;
3536 sub_generation++;
3537 }
a0d0e21e 3538 }
5196be3e 3539 CvGV(cv) = (GV*)SvREFCNT_inc(gv);
11343788 3540#ifdef USE_THREADS
12ca11f6 3541 New(666, CvMUTEXP(cv), 1, perl_mutex);
11343788 3542 MUTEX_INIT(CvMUTEXP(cv));
11343788
MB		 3543 CvOWNER(cv) = 0;
3544#endif /* USE_THREADS */
79072805 3545 CvFILEGV(cv) = gv_fetchfile(filename);
a0d0e21e 3546 CvXSUB(cv) = subaddr;
44a8e56a 3547
28757baa 3548 if (name) {
3549 char *s = strrchr(name,':');
3550 if (s)
3551 s++;
3552 else
3553 s = name;
3554 if (strEQ(s, "BEGIN")) {
3555 if (!beginav)
3556 beginav = newAV();
44a8e56a 3557 av_push(beginav, (SV *)cv);
3558 GvCV(gv) = 0;
28757baa 3559 }
3560 else if (strEQ(s, "END")) {
3561 if (!endav)
3562 endav = newAV();
3563 av_unshift(endav, 1);
44a8e56a 3564 av_store(endav, 0, (SV *)cv);
3565 GvCV(gv) = 0;
28757baa 3566 }
7d07dbc2
MB		 3567 else if (strEQ(s, "INIT")) {
3568 if (!initav)
3569 initav = newAV();
3570 av_push(initav, (SV *)cv);
ae77835f 3571 }
28757baa 3572 }
8990e307 3573 else
a5f75d66 3574 CvANON_on(cv);
44a8e56a 3575
a0d0e21e 3576 return cv;
79072805
LW		 3577}
3578
3579void
8ac85365 3580newFORM(I32 floor, OP *o, OP *block)
79072805 3581{
11343788 3582 dTHR;
79072805
LW		 3583 register CV *cv;
3584 char *name;
3585 GV *gv;
a0d0e21e 3586 I32 ix;
79072805 3587
11343788
MB		 3588 if (o)
3589 name = SvPVx(cSVOPo->op_sv, na);
79072805
LW		 3590 else
3591 name = "STDOUT";
85e6fe83 3592 gv = gv_fetchpv(name,TRUE, SVt_PVFM);
a5f75d66 3593 GvMULTI_on(gv);
79072805
LW		 3594 if (cv = GvFORM(gv)) {
3595 if (dowarn) {
3596 line_t oldline = curcop->cop_line;
3597
3598 curcop->cop_line = copline;
3599 warn("Format %s redefined",name);
3600 curcop->cop_line = oldline;
3601 }
8990e307 3602 SvREFCNT_dec(cv);
79072805 3603 }
748a9306 3604 cv = compcv;
79072805 3605 GvFORM(gv) = cv;
44a8e56a 3606 CvGV(cv) = (GV*)SvREFCNT_inc(gv);
79072805
LW		 3607 CvFILEGV(cv) = curcop->cop_filegv;
3608
a0d0e21e 3609 for (ix = AvFILL(comppad); ix > 0; ix--) {
44a8e56a 3610 if (!SvPADMY(curpad[ix]) && !SvIMMORTAL(curpad[ix]))
a0d0e21e
LW		 3611 SvPADTMP_on(curpad[ix]);
3612 }
3613
79072805
LW