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
Integrate mainline (for Arthurs thread.xs fix)
[perl5.git] / op.c
CommitLineData
a0d0e21e 1/* op.c
79072805 2 *
bc89e66f 3 * Copyright (c) 1991-2001, 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"
864dbfa3 19#define PERL_IN_OP_C
79072805 20#include "perl.h"
77ca0c92 21#include "keywords.h"
79072805 22
a07e034d 23#define CALL_PEEP(o) CALL_FPTR(PL_peepp)(aTHX_ o)
a2efc822 24
b7dc083c 25/* #define PL_OP_SLAB_ALLOC */
7934575e 26
1c846c1f 27#ifdef PL_OP_SLAB_ALLOC
b7dc083c
NIS		 28#define SLAB_SIZE 8192
29static char *PL_OpPtr = NULL;
30static int PL_OpSpace = 0;
31#define NewOp(m,var,c,type) do { if ((PL_OpSpace -= c*sizeof(type)) >= 0) \
32 var = (type *)(PL_OpPtr -= c*sizeof(type)); \
33 else \
34 var = (type *) Slab_Alloc(m,c*sizeof(type)); \
35 } while (0)
36
1c846c1f 37STATIC void *
cea2e8a9 38S_Slab_Alloc(pTHX_ int m, size_t sz)
1c846c1f 39{
b7dc083c
NIS		 40 Newz(m,PL_OpPtr,SLAB_SIZE,char);
41 PL_OpSpace = SLAB_SIZE - sz;
42 return PL_OpPtr += PL_OpSpace;
43}
76e3520e 44
1c846c1f 45#else
b7dc083c
NIS		 46#define NewOp(m, var, c, type) Newz(m, var, c, type)
47#endif
e50aee73 48/*
5dc0d613 49 * In the following definition, the ", Nullop" is just to make the compiler
a5f75d66 50 * think the expression is of the right type: croak actually does a Siglongjmp.
e50aee73 51 */
11343788 52#define CHECKOP(type,o) \
3280af22 53 ((PL_op_mask && PL_op_mask[type]) \
5dc0d613 54 ? ( op_free((OP*)o), \
cea2e8a9 55 Perl_croak(aTHX_ "%s trapped by operation mask", PL_op_desc[type]), \
28757baa 56 Nullop ) \
fc0dc3b3 57 : CALL_FPTR(PL_check[type])(aTHX_ (OP*)o))
e50aee73 58
c53d7c7d 59#define PAD_MAX 999999999
e6438c1a 60#define RETURN_UNLIMITED_NUMBER (PERL_INT_MAX / 2)
c53d7c7d 61
76e3520e 62STATIC char*
cea2e8a9 63S_gv_ename(pTHX_ GV *gv)
4633a7c4 64{
2d8e6c8d 65 STRLEN n_a;
4633a7c4 66 SV* tmpsv = sv_newmortal();
46fc3d4c 67 gv_efullname3(tmpsv, gv, Nullch);
2d8e6c8d 68 return SvPV(tmpsv,n_a);
4633a7c4
LW		 69}
70
76e3520e 71STATIC OP *
cea2e8a9 72S_no_fh_allowed(pTHX_ OP *o)
79072805 73{
cea2e8a9 74 yyerror(Perl_form(aTHX_ "Missing comma after first argument to %s function",
53e06cf0 75 OP_DESC(o)));
11343788 76 return o;
79072805
LW		 77}
78
76e3520e 79STATIC OP *
cea2e8a9 80S_too_few_arguments(pTHX_ OP *o, char *name)
79072805 81{
cea2e8a9 82 yyerror(Perl_form(aTHX_ "Not enough arguments for %s", name));
11343788 83 return o;
79072805
LW		 84}
85
76e3520e 86STATIC OP *
cea2e8a9 87S_too_many_arguments(pTHX_ OP *o, char *name)
79072805 88{
cea2e8a9 89 yyerror(Perl_form(aTHX_ "Too many arguments for %s", name));
11343788 90 return o;
79072805
LW		 91}
92
76e3520e 93STATIC void
cea2e8a9 94S_bad_type(pTHX_ I32 n, char *t, char *name, OP *kid)
8990e307 95{
cea2e8a9 96 yyerror(Perl_form(aTHX_ "Type of arg %d to %s must be %s (not %s)",
53e06cf0 97 (int)n, name, t, OP_DESC(kid)));
8990e307
LW		 98}
99
7a52d87a 100STATIC void
cea2e8a9 101S_no_bareword_allowed(pTHX_ OP *o)
7a52d87a 102{
5a844595
GS		 103 qerror(Perl_mess(aTHX_
104 "Bareword \"%s\" not allowed while \"strict subs\" in use",
7766f137 105 SvPV_nolen(cSVOPo_sv)));
7a52d87a
GS		 106}
107
79072805
LW		 108/* "register" allocation */
109
110PADOFFSET
864dbfa3 111Perl_pad_allocmy(pTHX_ char *name)
93a17b20 112{
a0d0e21e
LW		 113 PADOFFSET off;
114 SV *sv;
115
155aba94
GS		 116 if (!(PL_in_my == KEY_our ||
117 isALPHA(name[1]) ||
39e02b42 118 (USE_UTF8_IN_NAMES && UTF8_IS_START(name[1])) ||
155aba94 119 (name[1] == '_' && (int)strlen(name) > 2)))
834a4ddd 120 {
c4d0567e 121 if (!isPRINT(name[1]) || strchr("\t\n\r\f", name[1])) {
2b92dfce
GS		 122 /* 1999-02-27 mjd@plover.com */
123 char *p;
124 p = strchr(name, '\0');
125 /* The next block assumes the buffer is at least 205 chars
126 long. At present, it's always at least 256 chars. */
127 if (p-name > 200) {
128 strcpy(name+200, "...");
129 p = name+199;
130 }
131 else {
132 p[1] = '\0';
133 }
134 /* Move everything else down one character */
135 for (; p-name > 2; p--)
136 *p = *(p-1);
46fc3d4c 137 name[2] = toCTRL(name[1]);
138 name[1] = '^';
139 }
cea2e8a9 140 yyerror(Perl_form(aTHX_ "Can't use global %s in \"my\"",name));
a0d0e21e 141 }
e476b1b5 142 if (ckWARN(WARN_MISC) && AvFILLp(PL_comppad_name) >= 0) {
3280af22 143 SV **svp = AvARRAY(PL_comppad_name);
33633739
GS		 144 HV *ourstash = (PL_curstash ? PL_curstash : PL_defstash);
145 PADOFFSET top = AvFILLp(PL_comppad_name);
146 for (off = top; off > PL_comppad_name_floor; off--) {
b1cb66bf 147 if ((sv = svp[off])
3280af22 148 && sv != &PL_sv_undef
c53d7c7d 149 && (SvIVX(sv) == PAD_MAX || SvIVX(sv) == 0)
33633739
GS		 150 && (PL_in_my != KEY_our
151 || ((SvFLAGS(sv) & SVpad_OUR) && GvSTASH(sv) == ourstash))
b1cb66bf 152 && strEQ(name, SvPVX(sv)))
153 {
e476b1b5 154 Perl_warner(aTHX_ WARN_MISC,
1c846c1f 155 "\"%s\" variable %s masks earlier declaration in same %s",
33633739
GS		 156 (PL_in_my == KEY_our ? "our" : "my"),
157 name,
158 (SvIVX(sv) == PAD_MAX ? "scope" : "statement"));
159 --off;
160 break;
161 }
162 }
163 if (PL_in_my == KEY_our) {
635bab04 164 do {
33633739
GS		 165 if ((sv = svp[off])
166 && sv != &PL_sv_undef
5ce0178e 167 && (SvIVX(sv) == PAD_MAX || SvIVX(sv) == 0)
33633739
GS		 168 && ((SvFLAGS(sv) & SVpad_OUR) && GvSTASH(sv) == ourstash)
169 && strEQ(name, SvPVX(sv)))
f472eb5c 170 {
e476b1b5 171 Perl_warner(aTHX_ WARN_MISC,
33633739 172 "\"our\" variable %s redeclared", name);
e476b1b5 173 Perl_warner(aTHX_ WARN_MISC,
cc507455 174 "\t(Did you mean \"local\" instead of \"our\"?)\n");
33633739 175 break;
f472eb5c 176 }
635bab04 177 } while ( off-- > 0 );
b1cb66bf 178 }
179 }
a0d0e21e
LW		 180 off = pad_alloc(OP_PADSV, SVs_PADMY);
181 sv = NEWSV(1102,0);
93a17b20
LW		 182 sv_upgrade(sv, SVt_PVNV);
183 sv_setpv(sv, name);
3280af22 184 if (PL_in_my_stash) {
c750a3ec 185 if (*name != '$')
eb64745e
GS		 186 yyerror(Perl_form(aTHX_ "Can't declare class for non-scalar %s in \"%s\"",
187 name, PL_in_my == KEY_our ? "our" : "my"));
524189f1 188 SvFLAGS(sv) |= SVpad_TYPED;
c750a3ec 189 (void)SvUPGRADE(sv, SVt_PVMG);
3280af22 190 SvSTASH(sv) = (HV*)SvREFCNT_inc(PL_in_my_stash);
c750a3ec 191 }
f472eb5c
GS		 192 if (PL_in_my == KEY_our) {
193 (void)SvUPGRADE(sv, SVt_PVGV);
ef75a179 194 GvSTASH(sv) = (HV*)SvREFCNT_inc(PL_curstash ? (SV*)PL_curstash : (SV*)PL_defstash);
77ca0c92 195 SvFLAGS(sv) |= SVpad_OUR;
f472eb5c 196 }
3280af22 197 av_store(PL_comppad_name, off, sv);
65202027 198 SvNVX(sv) = (NV)PAD_MAX;
8990e307 199 SvIVX(sv) = 0; /* Not yet introduced--see newSTATEOP */
3280af22
NIS		 200 if (!PL_min_intro_pending)
201 PL_min_intro_pending = off;
202 PL_max_intro_pending = off;
93a17b20 203 if (*name == '@')
3280af22 204 av_store(PL_comppad, off, (SV*)newAV());
93a17b20 205 else if (*name == '%')
3280af22
NIS		 206 av_store(PL_comppad, off, (SV*)newHV());
207 SvPADMY_on(PL_curpad[off]);
93a17b20
LW		 208 return off;
209}
210
94f23f41
GS		 211STATIC PADOFFSET
212S_pad_addlex(pTHX_ SV *proto_namesv)
213{
214 SV *namesv = NEWSV(1103,0);
215 PADOFFSET newoff = pad_alloc(OP_PADSV, SVs_PADMY);
216 sv_upgrade(namesv, SVt_PVNV);
217 sv_setpv(namesv, SvPVX(proto_namesv));
218 av_store(PL_comppad_name, newoff, namesv);
219 SvNVX(namesv) = (NV)PL_curcop->cop_seq;
220 SvIVX(namesv) = PAD_MAX; /* A ref, intro immediately */
221 SvFAKE_on(namesv); /* A ref, not a real var */
222 if (SvFLAGS(proto_namesv) & SVpad_OUR) { /* An "our" variable */
223 SvFLAGS(namesv) |= SVpad_OUR;
224 (void)SvUPGRADE(namesv, SVt_PVGV);
225 GvSTASH(namesv) = (HV*)SvREFCNT_inc((SV*)GvSTASH(proto_namesv));
226 }
524189f1
JH		 227 if (SvFLAGS(proto_namesv) & SVpad_TYPED) { /* A typed lexical */
228 SvFLAGS(namesv) |= SVpad_TYPED;
94f23f41
GS		 229 (void)SvUPGRADE(namesv, SVt_PVMG);
230 SvSTASH(namesv) = (HV*)SvREFCNT_inc((SV*)SvSTASH(proto_namesv));
94f23f41
GS		 231 }
232 return newoff;
233}
234
2680586e
GS		 235#define FINDLEX_NOSEARCH 1 /* don't search outer contexts */
236
76e3520e 237STATIC PADOFFSET
cea2e8a9 238S_pad_findlex(pTHX_ char *name, PADOFFSET newoff, U32 seq, CV* startcv,
864dbfa3 239 I32 cx_ix, I32 saweval, U32 flags)
93a17b20 240{
748a9306 241 CV *cv;
93a17b20
LW		 242 I32 off;
243 SV *sv;
93a17b20 244 register I32 i;
c09156bb 245 register PERL_CONTEXT *cx;
93a17b20 246
748a9306 247 for (cv = startcv; cv; cv = CvOUTSIDE(cv)) {
4fdae800 248 AV *curlist = CvPADLIST(cv);
249 SV **svp = av_fetch(curlist, 0, FALSE);
748a9306 250 AV *curname;
4fdae800 251
3280af22 252 if (!svp || *svp == &PL_sv_undef)
4633a7c4 253 continue;
748a9306
LW		 254 curname = (AV*)*svp;
255 svp = AvARRAY(curname);
93965878 256 for (off = AvFILLp(curname); off > 0; off--) {
748a9306 257 if ((sv = svp[off]) &&
3280af22 258 sv != &PL_sv_undef &&
748a9306 259 seq <= SvIVX(sv) &&
13826f2c 260 seq > I_32(SvNVX(sv)) &&
748a9306
LW		 261 strEQ(SvPVX(sv), name))
262 {
5f05dabc 263 I32 depth;
264 AV *oldpad;
265 SV *oldsv;
266
267 depth = CvDEPTH(cv);
268 if (!depth) {
9607fc9c 269 if (newoff) {
270 if (SvFAKE(sv))
271 continue;
4fdae800 272 return 0; /* don't clone from inactive stack frame */
9607fc9c 273 }
5f05dabc 274 depth = 1;
275 }
94f23f41 276 oldpad = (AV*)AvARRAY(curlist)[depth];
5f05dabc 277 oldsv = *av_fetch(oldpad, off, TRUE);
748a9306 278 if (!newoff) { /* Not a mere clone operation. */
94f23f41 279 newoff = pad_addlex(sv);
3280af22 280 if (CvANON(PL_compcv) || SvTYPE(PL_compcv) == SVt_PVFM) {
28757baa 281 /* "It's closures all the way down." */
3280af22 282 CvCLONE_on(PL_compcv);
54310121 283 if (cv == startcv) {
3280af22 284 if (CvANON(PL_compcv))
54310121 285 oldsv = Nullsv; /* no need to keep ref */
286 }
287 else {
28757baa 288 CV *bcv;
289 for (bcv = startcv;
290 bcv && bcv != cv && !CvCLONE(bcv);
6b35e009
GS		 291 bcv = CvOUTSIDE(bcv))
292 {
94f23f41
GS		 293 if (CvANON(bcv)) {
294 /* install the missing pad entry in intervening
295 * nested subs and mark them cloneable.
296 * XXX fix pad_foo() to not use globals */
297 AV *ocomppad_name = PL_comppad_name;
298 AV *ocomppad = PL_comppad;
299 SV **ocurpad = PL_curpad;
300 AV *padlist = CvPADLIST(bcv);
301 PL_comppad_name = (AV*)AvARRAY(padlist)[0];
302 PL_comppad = (AV*)AvARRAY(padlist)[1];
303 PL_curpad = AvARRAY(PL_comppad);
304 pad_addlex(sv);
305 PL_comppad_name = ocomppad_name;
306 PL_comppad = ocomppad;
307 PL_curpad = ocurpad;
28757baa 308 CvCLONE_on(bcv);
94f23f41 309 }
28757baa 310 else {
6b35e009
GS		 311 if (ckWARN(WARN_CLOSURE)
312 && !CvUNIQUE(bcv) && !CvUNIQUE(cv))
313 {
cea2e8a9 314 Perl_warner(aTHX_ WARN_CLOSURE,
44a8e56a 315 "Variable \"%s\" may be unavailable",
28757baa 316 name);
6b35e009 317 }
28757baa 318 break;
319 }
320 }
321 }
322 }
3280af22 323 else if (!CvUNIQUE(PL_compcv)) {
741b6338
GS		 324 if (ckWARN(WARN_CLOSURE) && !SvFAKE(sv) && !CvUNIQUE(cv)
325 && !(SvFLAGS(sv) & SVpad_OUR))
326 {
cea2e8a9 327 Perl_warner(aTHX_ WARN_CLOSURE,
599cee73 328 "Variable \"%s\" will not stay shared", name);
741b6338 329 }
5f05dabc 330 }
748a9306 331 }
3280af22 332 av_store(PL_comppad, newoff, SvREFCNT_inc(oldsv));
748a9306
LW		 333 return newoff;
334 }
93a17b20
LW		 335 }
336 }
337
2680586e
GS		 338 if (flags & FINDLEX_NOSEARCH)
339 return 0;
340
93a17b20
LW		 341 /* Nothing in current lexical context--try eval's context, if any.
342 * This is necessary to let the perldb get at lexically scoped variables.
343 * XXX This will also probably interact badly with eval tree caching.
344 */
345
748a9306 346 for (i = cx_ix; i >= 0; i--) {
93a17b20 347 cx = &cxstack[i];
6b35e009 348 switch (CxTYPE(cx)) {
93a17b20 349 default:
748a9306 350 if (i == 0 && saweval) {
2680586e 351 return pad_findlex(name, newoff, seq, PL_main_cv, -1, saweval, 0);
748a9306 352 }
93a17b20
LW		 353 break;
354 case CXt_EVAL:
44a8e56a 355 switch (cx->blk_eval.old_op_type) {
356 case OP_ENTEREVAL:
2090ab20
JH		 357 if (CxREALEVAL(cx)) {
358 PADOFFSET off;
6b35e009 359 saweval = i;
2090ab20
JH		 360 seq = cxstack[i].blk_oldcop->cop_seq;
361 startcv = cxstack[i].blk_eval.cv;
c975facc
JH		 362 if (startcv && CvOUTSIDE(startcv)) {
363 off = pad_findlex(name, newoff, seq, CvOUTSIDE(startcv),
364 i-1, saweval, 0);
365 if (off) /* continue looking if not found here */
366 return off;
367 }
2090ab20 368 }
44a8e56a 369 break;
faa7e5bb 370 case OP_DOFILE:
44a8e56a 371 case OP_REQUIRE:
faa7e5bb 372 /* require/do must have their own scope */
44a8e56a 373 return 0;
374 }
93a17b20 375 break;
7766f137 376 case CXt_FORMAT:
93a17b20
LW		 377 case CXt_SUB:
378 if (!saweval)
379 return 0;
380 cv = cx->blk_sub.cv;
3280af22 381 if (PL_debstash && CvSTASH(cv) == PL_debstash) { /* ignore DB'* scope */
748a9306 382 saweval = i; /* so we know where we were called from */
708c0d06 383 seq = cxstack[i].blk_oldcop->cop_seq;
93a17b20 384 continue;
93a17b20 385 }
2680586e 386 return pad_findlex(name, newoff, seq, cv, i-1, saweval,FINDLEX_NOSEARCH);
93a17b20
LW		 387 }
388 }
389
748a9306
LW		 390 return 0;
391}
a0d0e21e 392
748a9306 393PADOFFSET
864dbfa3 394Perl_pad_findmy(pTHX_ char *name)
748a9306
LW		 395{
396 I32 off;
54310121 397 I32 pendoff = 0;
748a9306 398 SV *sv;
3280af22
NIS		 399 SV **svp = AvARRAY(PL_comppad_name);
400 U32 seq = PL_cop_seqmax;
6b35e009 401 PERL_CONTEXT *cx;
33b8ce05 402 CV *outside;
748a9306 403
4d1ff10f 404#ifdef USE_5005THREADS
11343788
MB		 405 /*
406 * Special case to get lexical (and hence per-thread) @_.
407 * XXX I need to find out how to tell at parse-time whether use
408 * of @_ should refer to a lexical (from a sub) or defgv (global
409 * scope and maybe weird sub-ish things like formats). See
410 * startsub in perly.y. It's possible that @_ could be lexical
411 * (at least from subs) even in non-threaded perl.
412 */
413 if (strEQ(name, "@_"))
414 return 0; /* success. (NOT_IN_PAD indicates failure) */
4d1ff10f 415#endif /* USE_5005THREADS */
11343788 416
748a9306 417 /* The one we're looking for is probably just before comppad_name_fill. */
3280af22 418 for (off = AvFILLp(PL_comppad_name); off > 0; off--) {
a0d0e21e 419 if ((sv = svp[off]) &&
3280af22 420 sv != &PL_sv_undef &&
54310121 421 (!SvIVX(sv) ||
422 (seq <= SvIVX(sv) &&
423 seq > I_32(SvNVX(sv)))) &&
a0d0e21e
LW		 424 strEQ(SvPVX(sv), name))
425 {
77ca0c92 426 if (SvIVX(sv) || SvFLAGS(sv) & SVpad_OUR)
54310121 427 return (PADOFFSET)off;
428 pendoff = off; /* this pending def. will override import */
a0d0e21e
LW		 429 }
430 }
748a9306 431
33b8ce05
GS		 432 outside = CvOUTSIDE(PL_compcv);
433
434 /* Check if if we're compiling an eval'', and adjust seq to be the
435 * eval's seq number. This depends on eval'' having a non-null
436 * CvOUTSIDE() while it is being compiled. The eval'' itself is
1aff0e91
GS		 437 * identified by CvEVAL being true and CvGV being null. */
438 if (outside && CvEVAL(PL_compcv) && !CvGV(PL_compcv) && cxstack_ix >= 0) {
6b35e009
GS		 439 cx = &cxstack[cxstack_ix];
440 if (CxREALEVAL(cx))
441 seq = cx->blk_oldcop->cop_seq;
442 }
443
748a9306 444 /* See if it's in a nested scope */
2680586e 445 off = pad_findlex(name, 0, seq, outside, cxstack_ix, 0, 0);
54310121 446 if (off) {
447 /* If there is a pending local definition, this new alias must die */
448 if (pendoff)
3280af22 449 SvIVX(AvARRAY(PL_comppad_name)[off]) = seq;
11343788 450 return off; /* pad_findlex returns 0 for failure...*/
54310121 451 }
11343788 452 return NOT_IN_PAD; /* ...but we return NOT_IN_PAD for failure */
93a17b20
LW		 453}
454
455void
864dbfa3 456Perl_pad_leavemy(pTHX_ I32 fill)
93a17b20
LW		 457{
458 I32 off;
3280af22 459 SV **svp = AvARRAY(PL_comppad_name);
93a17b20 460 SV *sv;
3280af22
NIS		 461 if (PL_min_intro_pending && fill < PL_min_intro_pending) {
462 for (off = PL_max_intro_pending; off >= PL_min_intro_pending; off--) {
0453d815
PM		 463 if ((sv = svp[off]) && sv != &PL_sv_undef && ckWARN_d(WARN_INTERNAL))
464 Perl_warner(aTHX_ WARN_INTERNAL, "%s never introduced", SvPVX(sv));
8990e307
LW		 465 }
466 }
467 /* "Deintroduce" my variables that are leaving with this scope. */
3280af22 468 for (off = AvFILLp(PL_comppad_name); off > fill; off--) {
c53d7c7d 469 if ((sv = svp[off]) && sv != &PL_sv_undef && SvIVX(sv) == PAD_MAX)
3280af22 470 SvIVX(sv) = PL_cop_seqmax;
93a17b20
LW		 471 }
472}
473
474PADOFFSET
864dbfa3 475Perl_pad_alloc(pTHX_ I32 optype, U32 tmptype)
79072805
LW		 476{
477 SV *sv;
478 I32 retval;
479
3280af22 480 if (AvARRAY(PL_comppad) != PL_curpad)
cea2e8a9 481 Perl_croak(aTHX_ "panic: pad_alloc");
3280af22 482 if (PL_pad_reset_pending)
a0d0e21e 483 pad_reset();
ed6116ce 484 if (tmptype & SVs_PADMY) {
79072805 485 do {
3280af22 486 sv = *av_fetch(PL_comppad, AvFILLp(PL_comppad) + 1, TRUE);
ed6116ce 487 } while (SvPADBUSY(sv)); /* need a fresh one */
3280af22 488 retval = AvFILLp(PL_comppad);
79072805
LW		 489 }
490 else {
3280af22
NIS		 491 SV **names = AvARRAY(PL_comppad_name);
492 SSize_t names_fill = AvFILLp(PL_comppad_name);
bbce6d69 493 for (;;) {
494 /*
495 * "foreach" index vars temporarily become aliases to non-"my"
496 * values. Thus we must skip, not just pad values that are
497 * marked as current pad values, but also those with names.
498 */
3280af22
NIS		 499 if (++PL_padix <= names_fill &&
500 (sv = names[PL_padix]) && sv != &PL_sv_undef)
bbce6d69 501 continue;
3280af22 502 sv = *av_fetch(PL_comppad, PL_padix, TRUE);
3049cdab
SB		 503 if (!(SvFLAGS(sv) & (SVs_PADTMP|SVs_PADMY)) &&
504 !IS_PADGV(sv) && !IS_PADCONST(sv))
bbce6d69 505 break;
506 }
3280af22 507 retval = PL_padix;
79072805 508 }
8990e307 509 SvFLAGS(sv) |= tmptype;
3280af22 510 PL_curpad = AvARRAY(PL_comppad);
4d1ff10f 511#ifdef USE_5005THREADS
b900a521
JH		 512 DEBUG_X(PerlIO_printf(Perl_debug_log,
513 "0x%"UVxf" Pad 0x%"UVxf" alloc %ld for %s\n",
514 PTR2UV(thr), PTR2UV(PL_curpad),
22c35a8c 515 (long) retval, PL_op_name[optype]));
11343788 516#else
b900a521
JH		 517 DEBUG_X(PerlIO_printf(Perl_debug_log,
518 "Pad 0x%"UVxf" alloc %ld for %s\n",
519 PTR2UV(PL_curpad),
22c35a8c 520 (long) retval, PL_op_name[optype]));
4d1ff10f 521#endif /* USE_5005THREADS */
79072805
LW		 522 return (PADOFFSET)retval;
523}
524
525SV *
864dbfa3 526Perl_pad_sv(pTHX_ PADOFFSET po)
79072805 527{
4d1ff10f 528#ifdef USE_5005THREADS
b900a521 529 DEBUG_X(PerlIO_printf(Perl_debug_log,
f1dbda3d
JH		 530 "0x%"UVxf" Pad 0x%"UVxf" sv %"IVdf"\n",
531 PTR2UV(thr), PTR2UV(PL_curpad), (IV)po));
11343788 532#else
79072805 533 if (!po)
cea2e8a9 534 Perl_croak(aTHX_ "panic: pad_sv po");
97835f67
JH		 535 DEBUG_X(PerlIO_printf(Perl_debug_log, "Pad 0x%"UVxf" sv %"IVdf"\n",
536 PTR2UV(PL_curpad), (IV)po));
4d1ff10f 537#endif /* USE_5005THREADS */
3280af22 538 return PL_curpad[po]; /* eventually we'll turn this into a macro */
79072805
LW		 539}
540
541void
864dbfa3 542Perl_pad_free(pTHX_ PADOFFSET po)
79072805 543{
3280af22 544 if (!PL_curpad)
a0d0e21e 545 return;
3280af22 546 if (AvARRAY(PL_comppad) != PL_curpad)
cea2e8a9 547 Perl_croak(aTHX_ "panic: pad_free curpad");
79072805 548 if (!po)
cea2e8a9 549 Perl_croak(aTHX_ "panic: pad_free po");
4d1ff10f 550#ifdef USE_5005THREADS
b900a521 551 DEBUG_X(PerlIO_printf(Perl_debug_log,
7766f137 552 "0x%"UVxf" Pad 0x%"UVxf" free %"IVdf"\n",
f1dbda3d 553 PTR2UV(thr), PTR2UV(PL_curpad), (IV)po));
11343788 554#else
97835f67
JH		 555 DEBUG_X(PerlIO_printf(Perl_debug_log, "Pad 0x%"UVxf" free %"IVdf"\n",
556 PTR2UV(PL_curpad), (IV)po));
4d1ff10f 557#endif /* USE_5005THREADS */
2aa1bedc 558 if (PL_curpad[po] && PL_curpad[po] != &PL_sv_undef) {
3280af22 559 SvPADTMP_off(PL_curpad[po]);
2aa1bedc
GS		 560#ifdef USE_ITHREADS
561 SvREADONLY_off(PL_curpad[po]); /* could be a freed constant */
562#endif
563 }
3280af22
NIS		 564 if ((I32)po < PL_padix)
565 PL_padix = po - 1;
79072805
LW		 566}
567
568void
864dbfa3 569Perl_pad_swipe(pTHX_ PADOFFSET po)
79072805 570{
3280af22 571 if (AvARRAY(PL_comppad) != PL_curpad)
cea2e8a9 572 Perl_croak(aTHX_ "panic: pad_swipe curpad");
79072805 573 if (!po)
cea2e8a9 574 Perl_croak(aTHX_ "panic: pad_swipe po");
4d1ff10f 575#ifdef USE_5005THREADS
b900a521 576 DEBUG_X(PerlIO_printf(Perl_debug_log,
f1dbda3d
JH		 577 "0x%"UVxf" Pad 0x%"UVxf" swipe %"IVdf"\n",
578 PTR2UV(thr), PTR2UV(PL_curpad), (IV)po));
11343788 579#else
97835f67
JH		 580 DEBUG_X(PerlIO_printf(Perl_debug_log, "Pad 0x%"UVxf" swipe %"IVdf"\n",
581 PTR2UV(PL_curpad), (IV)po));
4d1ff10f 582#endif /* USE_5005THREADS */
3280af22
NIS		 583 SvPADTMP_off(PL_curpad[po]);
584 PL_curpad[po] = NEWSV(1107,0);
585 SvPADTMP_on(PL_curpad[po]);
586 if ((I32)po < PL_padix)
587 PL_padix = po - 1;
79072805
LW		 588}
589
d9bb4600
GS		 590/* XXX pad_reset() is currently disabled because it results in serious bugs.
591 * It causes pad temp TARGs to be shared between OPs. Since TARGs are pushed
592 * on the stack by OPs that use them, there are several ways to get an alias
593 * to a shared TARG. Such an alias will change randomly and unpredictably.
594 * We avoid doing this until we can think of a Better Way.
595 * GSAR 97-10-29 */
79072805 596void
864dbfa3 597Perl_pad_reset(pTHX)
79072805 598{
d9bb4600 599#ifdef USE_BROKEN_PAD_RESET
79072805
LW		 600 register I32 po;
601
6b88bc9c 602 if (AvARRAY(PL_comppad) != PL_curpad)
cea2e8a9 603 Perl_croak(aTHX_ "panic: pad_reset curpad");
4d1ff10f 604#ifdef USE_5005THREADS
b900a521
JH		 605 DEBUG_X(PerlIO_printf(Perl_debug_log,
606 "0x%"UVxf" Pad 0x%"UVxf" reset\n",
607 PTR2UV(thr), PTR2UV(PL_curpad)));
11343788 608#else
b900a521
JH		 609 DEBUG_X(PerlIO_printf(Perl_debug_log, "Pad 0x%"UVxf" reset\n",
610 PTR2UV(PL_curpad)));
4d1ff10f 611#endif /* USE_5005THREADS */
6b88bc9c
GS		 612 if (!PL_tainting) { /* Can't mix tainted and non-tainted temporaries. */
613 for (po = AvMAX(PL_comppad); po > PL_padix_floor; po--) {
614 if (PL_curpad[po] && !SvIMMORTAL(PL_curpad[po]))
615 SvPADTMP_off(PL_curpad[po]);
748a9306 616 }
6b88bc9c 617 PL_padix = PL_padix_floor;
79072805 618 }
d9bb4600 619#endif
3280af22 620 PL_pad_reset_pending = FALSE;
79072805
LW		 621}
622
4d1ff10f 623#ifdef USE_5005THREADS
54b9620d 624/* find_threadsv is not reentrant */
a863c7d1 625PADOFFSET
864dbfa3 626Perl_find_threadsv(pTHX_ const char *name)
a863c7d1 627{
a863c7d1
MB		 628 char *p;
629 PADOFFSET key;
554b3eca 630 SV **svp;
54b9620d 631 /* We currently only handle names of a single character */
533c011a 632 p = strchr(PL_threadsv_names, *name);
a863c7d1
MB		 633 if (!p)
634 return NOT_IN_PAD;
533c011a 635 key = p - PL_threadsv_names;
2d8e6c8d 636 MUTEX_LOCK(&thr->mutex);
54b9620d 637 svp = av_fetch(thr->threadsv, key, FALSE);
2d8e6c8d
GS		 638 if (svp)
639 MUTEX_UNLOCK(&thr->mutex);
640 else {
554b3eca 641 SV *sv = NEWSV(0, 0);
54b9620d 642 av_store(thr->threadsv, key, sv);
940cb80d 643 thr->threadsvp = AvARRAY(thr->threadsv);
2d8e6c8d 644 MUTEX_UNLOCK(&thr->mutex);
554b3eca
MB		 645 /*
646 * Some magic variables used to be automagically initialised
647 * in gv_fetchpv. Those which are now per-thread magicals get
648 * initialised here instead.
649 */
650 switch (*name) {
54b9620d
MB		 651 case '_':
652 break;
554b3eca
MB		 653 case ';':
654 sv_setpv(sv, "\034");
14befaf4 655 sv_magic(sv, 0, PERL_MAGIC_sv, name, 1);
554b3eca 656 break;
c277df42
IZ		 657 case '&':
658 case '`':
659 case '\'':
533c011a 660 PL_sawampersand = TRUE;
a3f914c5
GS		 661 /* FALL THROUGH */
662 case '1':
663 case '2':
664 case '3':
665 case '4':
666 case '5':
667 case '6':
668 case '7':
669 case '8':
670 case '9':
c277df42 671 SvREADONLY_on(sv);
d8b5173a 672 /* FALL THROUGH */
067391ea
GS		 673
674 /* XXX %! tied to Errno.pm needs to be added here.
675 * See gv_fetchpv(). */
676 /* case '!': */
677
54b9620d 678 default:
14befaf4 679 sv_magic(sv, 0, PERL_MAGIC_sv, name, 1);
554b3eca 680 }
bf49b057 681 DEBUG_S(PerlIO_printf(Perl_error_log,
54b9620d 682 "find_threadsv: new SV %p for $%s%c\n",
554b3eca
MB		 683 sv, (*name < 32) ? "^" : "",
684 (*name < 32) ? toCTRL(*name) : *name));
a863c7d1
MB		 685 }
686 return key;
687}
4d1ff10f 688#endif /* USE_5005THREADS */
a863c7d1 689
79072805
LW		 690/* Destructor */
691
692void
864dbfa3 693Perl_op_free(pTHX_ OP *o)
79072805 694{
85e6fe83 695 register OP *kid, *nextkid;
acb36ea4 696 OPCODE type;
79072805 697
5dc0d613 698 if (!o || o->op_seq == (U16)-1)
79072805
LW		 699 return;
700
7934575e
GS		 701 if (o->op_private & OPpREFCOUNTED) {
702 switch (o->op_type) {
703 case OP_LEAVESUB:
704 case OP_LEAVESUBLV:
705 case OP_LEAVEEVAL:
706 case OP_LEAVE:
707 case OP_SCOPE:
708 case OP_LEAVEWRITE:
709 OP_REFCNT_LOCK;
710 if (OpREFCNT_dec(o)) {
711 OP_REFCNT_UNLOCK;
712 return;
713 }
714 OP_REFCNT_UNLOCK;
715 break;
716 default:
717 break;
718 }
719 }
720
11343788
MB		 721 if (o->op_flags & OPf_KIDS) {
722 for (kid = cUNOPo->op_first; kid; kid = nextkid) {
85e6fe83 723 nextkid = kid->op_sibling; /* Get before next freeing kid */
79072805 724 op_free(kid);
85e6fe83 725 }
79072805 726 }
acb36ea4
GS		 727 type = o->op_type;
728 if (type == OP_NULL)
729 type = o->op_targ;
730
731 /* COP* is not cleared by op_clear() so that we may track line
732 * numbers etc even after null() */
733 if (type == OP_NEXTSTATE || type == OP_SETSTATE || type == OP_DBSTATE)
734 cop_free((COP*)o);
735
736 op_clear(o);
737
738#ifdef PL_OP_SLAB_ALLOC
739 if ((char *) o == PL_OpPtr)
740 {
741 }
742#else
743 Safefree(o);
744#endif
745}
79072805 746
93c66552
DM		 747void
748Perl_op_clear(pTHX_ OP *o)
acb36ea4 749{
13137afc 750
11343788 751 switch (o->op_type) {
acb36ea4
GS		 752 case OP_NULL: /* Was holding old type, if any. */
753 case OP_ENTEREVAL: /* Was holding hints. */
4d1ff10f 754#ifdef USE_5005THREADS
acb36ea4
GS		 755 case OP_THREADSV: /* Was holding index into thr->threadsv AV. */
756#endif
757 o->op_targ = 0;
a0d0e21e 758 break;
4d1ff10f 759#ifdef USE_5005THREADS
8dd3ba40
SM		 760 case OP_ENTERITER:
761 if (!(o->op_flags & OPf_SPECIAL))
762 break;
763 /* FALL THROUGH */
4d1ff10f 764#endif /* USE_5005THREADS */
a6006777 765 default:
ac4c12e7 766 if (!(o->op_flags & OPf_REF)
0b94c7bb 767 || (PL_check[o->op_type] != MEMBER_TO_FPTR(Perl_ck_ftst)))
a6006777 768 break;
769 /* FALL THROUGH */
463ee0b2 770 case OP_GVSV:
79072805 771 case OP_GV:
a6006777 772 case OP_AELEMFAST:
350de78d 773#ifdef USE_ITHREADS
971a9dd3
GS		 774 if (cPADOPo->op_padix > 0) {
775 if (PL_curpad) {
638eceb6 776 GV *gv = cGVOPo_gv;
971a9dd3
GS		 777 pad_swipe(cPADOPo->op_padix);
778 /* No GvIN_PAD_off(gv) here, because other references may still
779 * exist on the pad */
780 SvREFCNT_dec(gv);
781 }
782 cPADOPo->op_padix = 0;
783 }
350de78d 784#else
971a9dd3 785 SvREFCNT_dec(cSVOPo->op_sv);
7934575e 786 cSVOPo->op_sv = Nullsv;
350de78d 787#endif
79072805 788 break;
a1ae71d2 789 case OP_METHOD_NAMED:
79072805 790 case OP_CONST:
11343788 791 SvREFCNT_dec(cSVOPo->op_sv);
acb36ea4 792 cSVOPo->op_sv = Nullsv;
79072805 793 break;
748a9306
LW		 794 case OP_GOTO:
795 case OP_NEXT:
796 case OP_LAST:
797 case OP_REDO:
11343788 798 if (o->op_flags & (OPf_SPECIAL|OPf_STACKED|OPf_KIDS))
748a9306
LW		 799 break;
800 /* FALL THROUGH */
a0d0e21e 801 case OP_TRANS:
acb36ea4 802 if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
a0ed51b3 803 SvREFCNT_dec(cSVOPo->op_sv);
acb36ea4
GS		 804 cSVOPo->op_sv = Nullsv;
805 }
806 else {
a0ed51b3 807 Safefree(cPVOPo->op_pv);
acb36ea4
GS		 808 cPVOPo->op_pv = Nullch;
809 }
a0d0e21e
LW		 810 break;
811 case OP_SUBST:
11343788 812 op_free(cPMOPo->op_pmreplroot);
971a9dd3 813 goto clear_pmop;
748a9306 814 case OP_PUSHRE:
971a9dd3 815#ifdef USE_ITHREADS
ba89bb6e 816 if (INT2PTR(PADOFFSET, cPMOPo->op_pmreplroot)) {
971a9dd3 817 if (PL_curpad) {
ba89bb6e
AB		 818 GV *gv = (GV*)PL_curpad[INT2PTR(PADOFFSET, cPMOPo->op_pmreplroot)];
819 pad_swipe(INT2PTR(PADOFFSET, cPMOPo->op_pmreplroot));
971a9dd3
GS		 820 /* No GvIN_PAD_off(gv) here, because other references may still
821 * exist on the pad */
822 SvREFCNT_dec(gv);
823 }
824 }
825#else
826 SvREFCNT_dec((SV*)cPMOPo->op_pmreplroot);
827#endif
828 /* FALL THROUGH */
a0d0e21e 829 case OP_MATCH:
8782bef2 830 case OP_QR:
971a9dd3 831clear_pmop:
cb55de95
JH		 832 {
833 HV *pmstash = PmopSTASH(cPMOPo);
834 if (pmstash && SvREFCNT(pmstash)) {
835 PMOP *pmop = HvPMROOT(pmstash);
836 PMOP *lastpmop = NULL;
837 while (pmop) {
838 if (cPMOPo == pmop) {
839 if (lastpmop)
840 lastpmop->op_pmnext = pmop->op_pmnext;
841 else
842 HvPMROOT(pmstash) = pmop->op_pmnext;
843 break;
844 }
845 lastpmop = pmop;
846 pmop = pmop->op_pmnext;
847 }
83da49e6 848 }
cb55de95 849#ifdef USE_ITHREADS
83da49e6 850 Safefree(PmopSTASHPV(cPMOPo));
cb55de95 851#else
83da49e6 852 /* NOTE: PMOP.op_pmstash is not refcounted */
cb55de95 853#endif
cb55de95 854 }
971a9dd3 855 cPMOPo->op_pmreplroot = Nullop;
5f8cb046
DM		 856 /* we use the "SAFE" version of the PM_ macros here
857 * since sv_clean_all might release some PMOPs
858 * after PL_regex_padav has been cleared
859 * and the clearing of PL_regex_padav needs to
860 * happen before sv_clean_all
861 */
862 ReREFCNT_dec(PM_GETRE_SAFE(cPMOPo));
863 PM_SETRE_SAFE(cPMOPo, (REGEXP*)NULL);
13137afc
AB		 864#ifdef USE_ITHREADS
865 if(PL_regex_pad) { /* We could be in destruction */
866 av_push((AV*) PL_regex_pad[0],(SV*) PL_regex_pad[(cPMOPo)->op_pmoffset]);
1cc8b4c5 867 SvREPADTMP_on(PL_regex_pad[(cPMOPo)->op_pmoffset]);
13137afc
AB		 868 PM_SETRE(cPMOPo, (cPMOPo)->op_pmoffset);
869 }
870#endif
871
a0d0e21e 872 break;
79072805
LW		 873 }
874
743e66e6 875 if (o->op_targ > 0) {
11343788 876 pad_free(o->op_targ);
743e66e6
GS		 877 o->op_targ = 0;
878 }
79072805
LW		 879}
880
76e3520e 881STATIC void
3eb57f73
HS		 882S_cop_free(pTHX_ COP* cop)
883{
884 Safefree(cop->cop_label);
57843af0 885#ifdef USE_ITHREADS
f4dd75d9
GS		 886 Safefree(CopFILE(cop)); /* XXX share in a pvtable? */
887 Safefree(CopSTASHPV(cop)); /* XXX share in a pvtable? */
57843af0 888#else
11faa288 889 /* NOTE: COP.cop_stash is not refcounted */
cc49e20b 890 SvREFCNT_dec(CopFILEGV(cop));
57843af0 891#endif
0453d815 892 if (! specialWARN(cop->cop_warnings))
3eb57f73 893 SvREFCNT_dec(cop->cop_warnings);
ac27b0f5
NIS		 894 if (! specialCopIO(cop->cop_io))
895 SvREFCNT_dec(cop->cop_io);
3eb57f73
HS		 896}
897
93c66552
DM		 898void
899Perl_op_null(pTHX_ OP *o)
8990e307 900{
acb36ea4
GS		 901 if (o->op_type == OP_NULL)
902 return;
903 op_clear(o);
11343788
MB		 904 o->op_targ = o->op_type;
905 o->op_type = OP_NULL;
22c35a8c 906 o->op_ppaddr = PL_ppaddr[OP_NULL];
8990e307
LW		 907}
908
79072805
LW		 909/* Contextualizers */
910
463ee0b2 911#define LINKLIST(o) ((o)->op_next ? (o)->op_next : linklist((OP*)o))
79072805
LW		 912
913OP *
864dbfa3 914Perl_linklist(pTHX_ OP *o)
79072805
LW		 915{
916 register OP *kid;
917
11343788
MB		 918 if (o->op_next)
919 return o->op_next;
79072805
LW		 920
921 /* establish postfix order */
11343788
MB		 922 if (cUNOPo->op_first) {
923 o->op_next = LINKLIST(cUNOPo->op_first);
924 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
79072805
LW		 925 if (kid->op_sibling)
926 kid->op_next = LINKLIST(kid->op_sibling);
927 else
11343788 928 kid->op_next = o;
79072805
LW		 929 }
930 }
931 else
11343788 932 o->op_next = o;
79072805 933
11343788 934 return o->op_next;
79072805
LW		 935}
936
937OP *
864dbfa3 938Perl_scalarkids(pTHX_ OP *o)
79072805
LW		 939{
940 OP *kid;
11343788
MB		 941 if (o && o->op_flags & OPf_KIDS) {
942 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
79072805
LW		 943 scalar(kid);
944 }
11343788 945 return o;
79072805
LW		 946}
947
76e3520e 948STATIC OP *
cea2e8a9 949S_scalarboolean(pTHX_ OP *o)
8990e307 950{
d008e5eb 951 if (o->op_type == OP_SASSIGN && cBINOPo->op_first->op_type == OP_CONST) {
d008e5eb 952 if (ckWARN(WARN_SYNTAX)) {
57843af0 953 line_t oldline = CopLINE(PL_curcop);
a0d0e21e 954
d008e5eb 955 if (PL_copline != NOLINE)
57843af0 956 CopLINE_set(PL_curcop, PL_copline);
cea2e8a9 957 Perl_warner(aTHX_ WARN_SYNTAX, "Found = in conditional, should be ==");
57843af0 958 CopLINE_set(PL_curcop, oldline);
d008e5eb 959 }
a0d0e21e 960 }
11343788 961 return scalar(o);
8990e307
LW		 962}
963
964OP *
864dbfa3 965Perl_scalar(pTHX_ OP *o)
79072805
LW		 966{
967 OP *kid;
968
a0d0e21e 969 /* assumes no premature commitment */
3280af22 970 if (!o || (o->op_flags & OPf_WANT) || PL_error_count
5dc0d613 971 || o->op_type == OP_RETURN)
7e363e51 972 {
11343788 973 return o;
7e363e51 974 }
79072805 975
5dc0d613 976 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_SCALAR;
79072805 977
11343788 978 switch (o->op_type) {
79072805 979 case OP_REPEAT:
11343788 980 scalar(cBINOPo->op_first);
8990e307 981 break;
79072805
LW		 982 case OP_OR:
983 case OP_AND:
984 case OP_COND_EXPR:
11343788 985 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
8990e307 986 scalar(kid);
79072805 987 break;
a0d0e21e 988 case OP_SPLIT:
11343788 989 if ((kid = cLISTOPo->op_first) && kid->op_type == OP_PUSHRE) {
a0d0e21e
LW		 990 if (!kPMOP->op_pmreplroot)
991 deprecate("implicit split to @_");
992 }
993 /* FALL THROUGH */
79072805 994 case OP_MATCH:
8782bef2 995 case OP_QR:
79072805
LW		 996 case OP_SUBST:
997 case OP_NULL:
8990e307 998 default:
11343788
MB		 999 if (o->op_flags & OPf_KIDS) {
1000 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling)
8990e307
LW		 1001 scalar(kid);
1002 }
79072805
LW		 1003 break;
1004 case OP_LEAVE:
1005 case OP_LEAVETRY:
5dc0d613 1006 kid = cLISTOPo->op_first;
54310121 1007 scalar(kid);
155aba94 1008 while ((kid = kid->op_sibling)) {
54310121 1009 if (kid->op_sibling)
1010 scalarvoid(kid);
1011 else
1012 scalar(kid);
1013 }
3280af22 1014 WITH_THR(PL_curcop = &PL_compiling);
54310121 1015 break;
748a9306 1016 case OP_SCOPE:
79072805 1017 case OP_LINESEQ:
8990e307 1018 case OP_LIST:
11343788 1019 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
79072805
LW		 1020 if (kid->op_sibling)
1021 scalarvoid(kid);
1022 else
1023 scalar(kid);
1024 }
3280af22 1025 WITH_THR(PL_curcop = &PL_compiling);
79072805
LW		 1026 break;
1027 }
11343788 1028 return o;
79072805
LW		 1029}
1030
1031OP *
864dbfa3 1032Perl_scalarvoid(pTHX_ OP *o)
79072805
LW		 1033{
1034 OP *kid;
8990e307
LW		 1035 char* useless = 0;
1036 SV* sv;
2ebea0a1
GS		 1037 U8 want;
1038
acb36ea4
GS		 1039 if (o->op_type == OP_NEXTSTATE
1040 || o->op_type == OP_SETSTATE
1041 || o->op_type == OP_DBSTATE
1042 || (o->op_type == OP_NULL && (o->op_targ == OP_NEXTSTATE
1043 || o->op_targ == OP_SETSTATE
1044 || o->op_targ == OP_DBSTATE)))
2ebea0a1 1045 PL_curcop = (COP*)o; /* for warning below */
79072805 1046
54310121 1047 /* assumes no premature commitment */
2ebea0a1
GS		 1048 want = o->op_flags & OPf_WANT;
1049 if ((want && want != OPf_WANT_SCALAR) || PL_error_count
5dc0d613 1050 || o->op_type == OP_RETURN)
7e363e51 1051 {
11343788 1052 return o;
7e363e51 1053 }
79072805 1054
b162f9ea 1055 if ((o->op_private & OPpTARGET_MY)
7e363e51
GS		 1056 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1057 {
b162f9ea 1058 return scalar(o); /* As if inside SASSIGN */
7e363e51 1059 }
1c846c1f 1060
5dc0d613 1061 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
79072805 1062
11343788 1063 switch (o->op_type) {
79072805 1064 default:
22c35a8c 1065 if (!(PL_opargs[o->op_type] & OA_FOLDCONST))
8990e307 1066 break;
36477c24 1067 /* FALL THROUGH */
1068 case OP_REPEAT:
11343788 1069 if (o->op_flags & OPf_STACKED)
8990e307 1070 break;
5d82c453
GA		 1071 goto func_ops;
1072 case OP_SUBSTR:
1073 if (o->op_private == 4)
1074 break;
8990e307
LW		 1075 /* FALL THROUGH */
1076 case OP_GVSV:
1077 case OP_WANTARRAY:
1078 case OP_GV:
1079 case OP_PADSV:
1080 case OP_PADAV:
1081 case OP_PADHV:
1082 case OP_PADANY:
1083 case OP_AV2ARYLEN:
8990e307 1084 case OP_REF:
a0d0e21e
LW		 1085 case OP_REFGEN:
1086 case OP_SREFGEN:
8990e307
LW		 1087 case OP_DEFINED:
1088 case OP_HEX:
1089 case OP_OCT:
1090 case OP_LENGTH:
8990e307
LW		 1091 case OP_VEC:
1092 case OP_INDEX:
1093 case OP_RINDEX:
1094 case OP_SPRINTF:
1095 case OP_AELEM:
1096 case OP_AELEMFAST:
1097 case OP_ASLICE:
8990e307
LW		 1098 case OP_HELEM:
1099 case OP_HSLICE:
1100 case OP_UNPACK:
1101 case OP_PACK:
8990e307
LW		 1102 case OP_JOIN:
1103 case OP_LSLICE:
1104 case OP_ANONLIST:
1105 case OP_ANONHASH:
1106 case OP_SORT:
1107 case OP_REVERSE:
1108 case OP_RANGE:
1109 case OP_FLIP:
1110 case OP_FLOP:
1111 case OP_CALLER:
1112 case OP_FILENO:
1113 case OP_EOF:
1114 case OP_TELL:
1115 case OP_GETSOCKNAME:
1116 case OP_GETPEERNAME:
1117 case OP_READLINK:
1118 case OP_TELLDIR:
1119 case OP_GETPPID:
1120 case OP_GETPGRP:
1121 case OP_GETPRIORITY:
1122 case OP_TIME:
1123 case OP_TMS:
1124 case OP_LOCALTIME:
1125 case OP_GMTIME:
1126 case OP_GHBYNAME:
1127 case OP_GHBYADDR:
1128 case OP_GHOSTENT:
1129 case OP_GNBYNAME:
1130 case OP_GNBYADDR:
1131 case OP_GNETENT:
1132 case OP_GPBYNAME:
1133 case OP_GPBYNUMBER:
1134 case OP_GPROTOENT:
1135 case OP_GSBYNAME:
1136 case OP_GSBYPORT:
1137 case OP_GSERVENT:
1138 case OP_GPWNAM:
1139 case OP_GPWUID:
1140 case OP_GGRNAM:
1141 case OP_GGRGID:
1142 case OP_GETLOGIN:
5d82c453 1143 func_ops:
64aac5a9 1144 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)))
53e06cf0 1145 useless = OP_DESC(o);
8990e307
LW		 1146 break;
1147
1148 case OP_RV2GV:
1149 case OP_RV2SV:
1150 case OP_RV2AV:
1151 case OP_RV2HV:
192587c2 1152 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)) &&
11343788 1153 (!o->op_sibling || o->op_sibling->op_type != OP_READLINE))
8990e307
LW		 1154 useless = "a variable";
1155 break;
79072805
LW		 1156
1157 case OP_CONST:
7766f137 1158 sv = cSVOPo_sv;
7a52d87a
GS		 1159 if (cSVOPo->op_private & OPpCONST_STRICT)
1160 no_bareword_allowed(o);
1161 else {
d008e5eb
GS		 1162 if (ckWARN(WARN_VOID)) {
1163 useless = "a constant";
960b4253
MG		 1164 /* the constants 0 and 1 are permitted as they are
1165 conventionally used as dummies in constructs like
1166 1 while some_condition_with_side_effects; */
d008e5eb
GS		 1167 if (SvNIOK(sv) && (SvNV(sv) == 0.0 || SvNV(sv) == 1.0))
1168 useless = 0;
1169 else if (SvPOK(sv)) {
a52fe3ac
A		 1170 /* perl4's way of mixing documentation and code
1171 (before the invention of POD) was based on a
1172 trick to mix nroff and perl code. The trick was
1173 built upon these three nroff macros being used in
1174 void context. The pink camel has the details in
1175 the script wrapman near page 319. */
d008e5eb
GS		 1176 if (strnEQ(SvPVX(sv), "di", 2) ||
1177 strnEQ(SvPVX(sv), "ds", 2) ||
1178 strnEQ(SvPVX(sv), "ig", 2))
1179 useless = 0;
1180 }
8990e307
LW		 1181 }
1182 }
93c66552 1183 op_null(o); /* don't execute or even remember it */
79072805
LW		 1184 break;
1185
1186 case OP_POSTINC:
11343788 1187 o->op_type = OP_PREINC; /* pre-increment is faster */
22c35a8c 1188 o->op_ppaddr = PL_ppaddr[OP_PREINC];
79072805
LW		 1189 break;
1190
1191 case OP_POSTDEC:
11343788 1192 o->op_type = OP_PREDEC; /* pre-decrement is faster */
22c35a8c 1193 o->op_ppaddr = PL_ppaddr[OP_PREDEC];
79072805
LW		 1194 break;
1195
79072805
LW		 1196 case OP_OR:
1197 case OP_AND:
1198 case OP_COND_EXPR:
11343788 1199 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
79072805
LW		 1200 scalarvoid(kid);
1201 break;
5aabfad6 1202
a0d0e21e 1203 case OP_NULL:
11343788 1204 if (o->op_flags & OPf_STACKED)
a0d0e21e 1205 break;
5aabfad6 1206 /* FALL THROUGH */
2ebea0a1
GS		 1207 case OP_NEXTSTATE:
1208 case OP_DBSTATE:
79072805
LW		 1209 case OP_ENTERTRY:
1210 case OP_ENTER:
11343788 1211 if (!(o->op_flags & OPf_KIDS))
79072805 1212 break;
54310121 1213 /* FALL THROUGH */
463ee0b2 1214 case OP_SCOPE:
79072805
LW		 1215 case OP_LEAVE:
1216 case OP_LEAVETRY:
a0d0e21e 1217 case OP_LEAVELOOP:
79072805 1218 case OP_LINESEQ:
79072805 1219 case OP_LIST:
11343788 1220 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
79072805
LW		 1221 scalarvoid(kid);
1222 break;
c90c0ff4 1223 case OP_ENTEREVAL:
5196be3e 1224 scalarkids(o);
c90c0ff4 1225 break;
5aabfad6 1226 case OP_REQUIRE:
c90c0ff4 1227 /* all requires must return a boolean value */
5196be3e 1228 o->op_flags &= ~OPf_WANT;
d6483035
GS		 1229 /* FALL THROUGH */
1230 case OP_SCALAR:
5196be3e 1231 return scalar(o);
a0d0e21e 1232 case OP_SPLIT:
11343788 1233 if ((kid = cLISTOPo->op_first) && kid->op_type == OP_PUSHRE) {
a0d0e21e
LW		 1234 if (!kPMOP->op_pmreplroot)
1235 deprecate("implicit split to @_");
1236 }
1237 break;
79072805 1238 }
411caa50
JH		 1239 if (useless && ckWARN(WARN_VOID))
1240 Perl_warner(aTHX_ WARN_VOID, "Useless use of %s in void context", useless);
11343788 1241 return o;
79072805
LW		 1242}
1243
1244OP *
864dbfa3 1245Perl_listkids(pTHX_ OP *o)
79072805
LW		 1246{
1247 OP *kid;
11343788
MB		 1248 if (o && o->op_flags & OPf_KIDS) {
1249 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
79072805
LW		 1250 list(kid);
1251 }
11343788 1252 return o;
79072805
LW		 1253}
1254
1255OP *
864dbfa3 1256Perl_list(pTHX_ OP *o)
79072805
LW		 1257{
1258 OP *kid;
1259
a0d0e21e 1260 /* assumes no premature commitment */
3280af22 1261 if (!o || (o->op_flags & OPf_WANT) || PL_error_count
5dc0d613 1262 || o->op_type == OP_RETURN)
7e363e51 1263 {
11343788 1264 return o;
7e363e51 1265 }
79072805 1266
b162f9ea 1267 if ((o->op_private & OPpTARGET_MY)
7e363e51
GS		 1268 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1269 {
b162f9ea 1270 return o; /* As if inside SASSIGN */
7e363e51 1271 }
1c846c1f 1272
5dc0d613 1273 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_LIST;
79072805 1274
11343788 1275 switch (o->op_type) {
79072805
LW		 1276 case OP_FLOP:
1277 case OP_REPEAT:
11343788 1278 list(cBINOPo->op_first);
79072805
LW		 1279 break;
1280 case OP_OR:
1281 case OP_AND:
1282 case OP_COND_EXPR:
11343788 1283 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
79072805
LW		 1284 list(kid);
1285 break;
1286 default:
1287 case OP_MATCH:
8782bef2 1288 case OP_QR:
79072805
LW		 1289 case OP_SUBST:
1290 case OP_NULL:
11343788 1291 if (!(o->op_flags & OPf_KIDS))
79072805 1292 break;
11343788
MB		 1293 if (!o->op_next && cUNOPo->op_first->op_type == OP_FLOP) {
1294 list(cBINOPo->op_first);
1295 return gen_constant_list(o);
79072805
LW		 1296 }
1297 case OP_LIST:
11343788 1298 listkids(o);
79072805
LW		 1299 break;
1300 case OP_LEAVE:
1301 case OP_LEAVETRY:
5dc0d613 1302 kid = cLISTOPo->op_first;
54310121 1303 list(kid);
155aba94 1304 while ((kid = kid->op_sibling)) {
54310121 1305 if (kid->op_sibling)
1306 scalarvoid(kid);
1307 else
1308 list(kid);
1309 }
3280af22 1310 WITH_THR(PL_curcop = &PL_compiling);
54310121 1311 break;
748a9306 1312 case OP_SCOPE:
79072805 1313 case OP_LINESEQ:
11343788 1314 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
79072805
LW		 1315 if (kid->op_sibling)
1316 scalarvoid(kid);
1317 else
1318 list(kid);
1319 }
3280af22 1320 WITH_THR(PL_curcop = &PL_compiling);
79072805 1321 break;
c90c0ff4 1322 case OP_REQUIRE:
1323 /* all requires must return a boolean value */
5196be3e
MB		 1324 o->op_flags &= ~OPf_WANT;
1325 return scalar(o);
79072805 1326 }
11343788 1327 return o;
79072805
LW		 1328}
1329
1330OP *
864dbfa3 1331Perl_scalarseq(pTHX_ OP *o)
79072805
LW		 1332{
1333 OP *kid;
1334
11343788
MB		 1335 if (o) {
1336 if (o->op_type == OP_LINESEQ ||
1337 o->op_type == OP_SCOPE ||
1338 o->op_type == OP_LEAVE ||
1339 o->op_type == OP_LEAVETRY)
463ee0b2 1340 {
11343788 1341 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
ed6116ce 1342 if (kid->op_sibling) {
463ee0b2 1343 scalarvoid(kid);
ed6116ce 1344 }
463ee0b2 1345 }
3280af22 1346 PL_curcop = &PL_compiling;
79072805 1347 }
11343788 1348 o->op_flags &= ~OPf_PARENS;
3280af22 1349 if (PL_hints & HINT_BLOCK_SCOPE)
11343788 1350 o->op_flags |= OPf_PARENS;
79072805 1351 }
8990e307 1352 else
11343788
MB		 1353 o = newOP(OP_STUB, 0);
1354 return o;
79072805
LW		 1355}
1356
76e3520e 1357STATIC OP *
cea2e8a9 1358S_modkids(pTHX_ OP *o, I32 type)
79072805
LW		 1359{
1360 OP *kid;
11343788
MB		 1361 if (o && o->op_flags & OPf_KIDS) {
1362 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
463ee0b2 1363 mod(kid, type);
79072805 1364 }
11343788 1365 return o;
79072805
LW		 1366}
1367
79072805 1368OP *
864dbfa3 1369Perl_mod(pTHX_ OP *o, I32 type)
79072805
LW		 1370{
1371 OP *kid;
2d8e6c8d 1372 STRLEN n_a;
79072805 1373
3280af22 1374 if (!o || PL_error_count)
11343788 1375 return o;
79072805 1376
b162f9ea 1377 if ((o->op_private & OPpTARGET_MY)
7e363e51
GS		 1378 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1379 {
b162f9ea 1380 return o;
7e363e51 1381 }
1c846c1f 1382
11343788 1383 switch (o->op_type) {
68dc0745 1384 case OP_UNDEF:
3280af22 1385 PL_modcount++;
5dc0d613 1386 return o;
a0d0e21e 1387 case OP_CONST:
11343788 1388 if (!(o->op_private & (OPpCONST_ARYBASE)))
a0d0e21e 1389 goto nomod;
3280af22 1390 if (PL_eval_start && PL_eval_start->op_type == OP_CONST) {
7766f137 1391 PL_compiling.cop_arybase = (I32)SvIV(cSVOPx(PL_eval_start)->op_sv);
3280af22 1392 PL_eval_start = 0;
a0d0e21e
LW		 1393 }
1394 else if (!type) {
3280af22
NIS		 1395 SAVEI32(PL_compiling.cop_arybase);
1396 PL_compiling.cop_arybase = 0;
a0d0e21e
LW		 1397 }
1398 else if (type == OP_REFGEN)
1399 goto nomod;
1400 else
cea2e8a9 1401 Perl_croak(aTHX_ "That use of $[ is unsupported");
a0d0e21e 1402 break;
5f05dabc 1403 case OP_STUB:
5196be3e 1404 if (o->op_flags & OPf_PARENS)
5f05dabc 1405 break;
1406 goto nomod;
a0d0e21e
LW		 1407 case OP_ENTERSUB:
1408 if ((type == OP_UNDEF || type == OP_REFGEN) &&
11343788
MB		 1409 !(o->op_flags & OPf_STACKED)) {
1410 o->op_type = OP_RV2CV; /* entersub => rv2cv */
22c35a8c 1411 o->op_ppaddr = PL_ppaddr[OP_RV2CV];
11343788 1412 assert(cUNOPo->op_first->op_type == OP_NULL);
93c66552 1413 op_null(((LISTOP*)cUNOPo->op_first)->op_first);/* disable pushmark */
79072805
LW		 1414 break;
1415 }
cd06dffe
GS		 1416 else { /* lvalue subroutine call */
1417 o->op_private |= OPpLVAL_INTRO;
e6438c1a 1418 PL_modcount = RETURN_UNLIMITED_NUMBER;
4978d6d9 1419 if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN) {
cd06dffe
GS		 1420 /* Backward compatibility mode: */
1421 o->op_private |= OPpENTERSUB_INARGS;
1422 break;
1423 }
1424 else { /* Compile-time error message: */
1425 OP *kid = cUNOPo->op_first;
1426 CV *cv;
1427 OP *okid;
1428
1429 if (kid->op_type == OP_PUSHMARK)
1430 goto skip_kids;
1431 if (kid->op_type != OP_NULL || kid->op_targ != OP_LIST)
1432 Perl_croak(aTHX_
1433 "panic: unexpected lvalue entersub "
55140b79 1434 "args: type/targ %ld:%"UVuf,
3d811634 1435 (long)kid->op_type, (UV)kid->op_targ);
cd06dffe
GS		 1436 kid = kLISTOP->op_first;
1437 skip_kids:
1438 while (kid->op_sibling)
1439 kid = kid->op_sibling;
1440 if (!(kid->op_type == OP_NULL && kid->op_targ == OP_RV2CV)) {
1441 /* Indirect call */
1442 if (kid->op_type == OP_METHOD_NAMED
1443 || kid->op_type == OP_METHOD)
1444 {
87d7fd28 1445 UNOP *newop;
cd06dffe
GS		 1446
1447 if (kid->op_sibling || kid->op_next != kid) {
1448 yyerror("panic: unexpected optree near method call");
1449 break;
1450 }
1451
87d7fd28 1452 NewOp(1101, newop, 1, UNOP);
349fd7b7
GS		 1453 newop->op_type = OP_RV2CV;
1454 newop->op_ppaddr = PL_ppaddr[OP_RV2CV];
87d7fd28
GS		 1455 newop->op_first = Nullop;
1456 newop->op_next = (OP*)newop;
1457 kid->op_sibling = (OP*)newop;
349fd7b7 1458 newop->op_private |= OPpLVAL_INTRO;
cd06dffe
GS		 1459 break;
1460 }
1c846c1f 1461
cd06dffe
GS		 1462 if (kid->op_type != OP_RV2CV)
1463 Perl_croak(aTHX_
1464 "panic: unexpected lvalue entersub "
55140b79 1465 "entry via type/targ %ld:%"UVuf,
3d811634 1466 (long)kid->op_type, (UV)kid->op_targ);
cd06dffe
GS		 1467 kid->op_private |= OPpLVAL_INTRO;
1468 break; /* Postpone until runtime */
1469 }
1470
1471 okid = kid;
1472 kid = kUNOP->op_first;
1473 if (kid->op_type == OP_NULL && kid->op_targ == OP_RV2SV)
1474 kid = kUNOP->op_first;
1475 if (kid->op_type == OP_NULL)
1476 Perl_croak(aTHX_
1477 "Unexpected constant lvalue entersub "
55140b79 1478 "entry via type/targ %ld:%"UVuf,
3d811634 1479 (long)kid->op_type, (UV)kid->op_targ);
cd06dffe
GS		 1480 if (kid->op_type != OP_GV) {
1481 /* Restore RV2CV to check lvalueness */
1482 restore_2cv:
1483 if (kid->op_next && kid->op_next != kid) { /* Happens? */
1484 okid->op_next = kid->op_next;
1485 kid->op_next = okid;
1486 }
1487 else
1488 okid->op_next = Nullop;
1489 okid->op_type = OP_RV2CV;
1490 okid->op_targ = 0;
1491 okid->op_ppaddr = PL_ppaddr[OP_RV2CV];
1492 okid->op_private |= OPpLVAL_INTRO;
1493 break;
1494 }
1495
638eceb6 1496 cv = GvCV(kGVOP_gv);
1c846c1f 1497 if (!cv)
cd06dffe
GS		 1498 goto restore_2cv;
1499 if (CvLVALUE(cv))
1500 break;
1501 }
1502 }
79072805
LW		 1503 /* FALL THROUGH */
1504 default:
a0d0e21e
LW		 1505 nomod:
1506 /* grep, foreach, subcalls, refgen */
1507 if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN)
1508 break;
cea2e8a9 1509 yyerror(Perl_form(aTHX_ "Can't modify %s in %s",
638bc118 1510 (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)
cd06dffe
GS		 1511 ? "do block"
1512 : (o->op_type == OP_ENTERSUB
1513 ? "non-lvalue subroutine call"
53e06cf0 1514 : OP_DESC(o))),
22c35a8c 1515 type ? PL_op_desc[type] : "local"));
11343788 1516 return o;
79072805 1517
a0d0e21e
LW		 1518 case OP_PREINC:
1519 case OP_PREDEC:
1520 case OP_POW:
1521 case OP_MULTIPLY:
1522 case OP_DIVIDE:
1523 case OP_MODULO:
1524 case OP_REPEAT:
1525 case OP_ADD:
1526 case OP_SUBTRACT:
1527 case OP_CONCAT:
1528 case OP_LEFT_SHIFT:
1529 case OP_RIGHT_SHIFT:
1530 case OP_BIT_AND:
1531 case OP_BIT_XOR:
1532 case OP_BIT_OR:
1533 case OP_I_MULTIPLY:
1534 case OP_I_DIVIDE:
1535 case OP_I_MODULO:
1536 case OP_I_ADD:
1537 case OP_I_SUBTRACT:
11343788 1538 if (!(o->op_flags & OPf_STACKED))
a0d0e21e 1539 goto nomod;
3280af22 1540 PL_modcount++;
a0d0e21e
LW		 1541 break;
1542
79072805 1543 case OP_COND_EXPR:
11343788 1544 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
463ee0b2 1545 mod(kid, type);
79072805
LW		 1546 break;
1547
1548 case OP_RV2AV:
1549 case OP_RV2HV:
93af7a87 1550 if (!type && cUNOPo->op_first->op_type != OP_GV)
cea2e8a9 1551 Perl_croak(aTHX_ "Can't localize through a reference");
11343788 1552 if (type == OP_REFGEN && o->op_flags & OPf_PARENS) {
e6438c1a 1553 PL_modcount = RETURN_UNLIMITED_NUMBER;
11343788 1554 return o; /* Treat \(@foo) like ordinary list. */
748a9306
LW		 1555 }
1556 /* FALL THROUGH */
79072805 1557 case OP_RV2GV:
5dc0d613 1558 if (scalar_mod_type(o, type))
3fe9a6f1 1559 goto nomod;
11343788 1560 ref(cUNOPo->op_first, o->op_type);
79072805 1561 /* FALL THROUGH */
79072805
LW		 1562 case OP_ASLICE:
1563 case OP_HSLICE:
78f9721b
SM		 1564 if (type == OP_LEAVESUBLV)
1565 o->op_private |= OPpMAYBE_LVSUB;
1566 /* FALL THROUGH */
1567 case OP_AASSIGN:
93a17b20
LW		 1568 case OP_NEXTSTATE:
1569 case OP_DBSTATE:
a0d0e21e 1570 case OP_CHOMP:
e6438c1a 1571 PL_modcount = RETURN_UNLIMITED_NUMBER;
79072805 1572 break;
463ee0b2 1573 case OP_RV2SV:
11343788 1574 if (!type && cUNOPo->op_first->op_type != OP_GV)
cea2e8a9 1575 Perl_croak(aTHX_ "Can't localize through a reference");
aeea060c 1576 ref(cUNOPo->op_first, o->op_type);
463ee0b2 1577 /* FALL THROUGH */
79072805 1578 case OP_GV:
463ee0b2 1579 case OP_AV2ARYLEN:
3280af22 1580 PL_hints |= HINT_BLOCK_SCOPE;
463ee0b2 1581 case OP_SASSIGN:
bf4b1e52
GS		 1582 case OP_ANDASSIGN:
1583 case OP_ORASSIGN:
8990e307 1584 case OP_AELEMFAST:
3280af22 1585 PL_modcount++;
8990e307
LW		 1586 break;
1587
748a9306
LW		 1588 case OP_PADAV:
1589 case OP_PADHV:
e6438c1a 1590 PL_modcount = RETURN_UNLIMITED_NUMBER;
5196be3e
MB		 1591 if (type == OP_REFGEN && o->op_flags & OPf_PARENS)
1592 return o; /* Treat \(@foo) like ordinary list. */
1593 if (scalar_mod_type(o, type))
3fe9a6f1 1594 goto nomod;
78f9721b
SM		 1595 if (type == OP_LEAVESUBLV)
1596 o->op_private |= OPpMAYBE_LVSUB;
748a9306
LW		 1597 /* FALL THROUGH */
1598 case OP_PADSV:
3280af22 1599 PL_modcount++;
748a9306 1600 if (!type)
cea2e8a9 1601 Perl_croak(aTHX_ "Can't localize lexical variable %s",
2d8e6c8d 1602 SvPV(*av_fetch(PL_comppad_name, o->op_targ, 4), n_a));
463ee0b2
LW		 1603 break;
1604
4d1ff10f 1605#ifdef USE_5005THREADS
2faa37cc 1606 case OP_THREADSV:
533c011a 1607 PL_modcount++; /* XXX ??? */
554b3eca 1608 break;
4d1ff10f 1609#endif /* USE_5005THREADS */
554b3eca 1610
748a9306
LW		 1611 case OP_PUSHMARK:
1612 break;
a0d0e21e 1613
69969c6f
SB		 1614 case OP_KEYS:
1615 if (type != OP_SASSIGN)
1616 goto nomod;
5d82c453
GA		 1617 goto lvalue_func;
1618 case OP_SUBSTR:
1619 if (o->op_private == 4) /* don't allow 4 arg substr as lvalue */
1620 goto nomod;
5f05dabc 1621 /* FALL THROUGH */
a0d0e21e 1622 case OP_POS:
463ee0b2 1623 case OP_VEC:
78f9721b
SM		 1624 if (type == OP_LEAVESUBLV)
1625 o->op_private |= OPpMAYBE_LVSUB;
5d82c453 1626 lvalue_func:
11343788
MB		 1627 pad_free(o->op_targ);
1628 o->op_targ = pad_alloc(o->op_type, SVs_PADMY);
5dc0d613 1629 assert(SvTYPE(PAD_SV(o->op_targ)) == SVt_NULL);
11343788
MB		 1630 if (o->op_flags & OPf_KIDS)
1631 mod(cBINOPo->op_first->op_sibling, type);
463ee0b2 1632 break;
a0d0e21e 1633
463ee0b2
LW		 1634 case OP_AELEM:
1635 case OP_HELEM:
11343788 1636 ref(cBINOPo->op_first, o->op_type);
68dc0745 1637 if (type == OP_ENTERSUB &&
5dc0d613
MB		 1638 !(o->op_private & (OPpLVAL_INTRO | OPpDEREF)))
1639 o->op_private |= OPpLVAL_DEFER;
78f9721b
SM		 1640 if (type == OP_LEAVESUBLV)
1641 o->op_private |= OPpMAYBE_LVSUB;
3280af22 1642 PL_modcount++;
463ee0b2
LW		 1643 break;
1644
1645 case OP_SCOPE:
1646 case OP_LEAVE:
1647 case OP_ENTER:
78f9721b 1648 case OP_LINESEQ:
11343788
MB		 1649 if (o->op_flags & OPf_KIDS)
1650 mod(cLISTOPo->op_last, type);
a0d0e21e
LW		 1651 break;
1652
1653 case OP_NULL:
638bc118
GS		 1654 if (o->op_flags & OPf_SPECIAL) /* do BLOCK */
1655 goto nomod;
1656 else if (!(o->op_flags & OPf_KIDS))
463ee0b2 1657 break;
11343788
MB		 1658 if (o->op_targ != OP_LIST) {
1659 mod(cBINOPo->op_first, type);
a0d0e21e
LW		 1660 break;
1661 }
1662 /* FALL THROUGH */
463ee0b2 1663 case OP_LIST:
11343788 1664 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
463ee0b2
LW		 1665 mod(kid, type);
1666 break;
78f9721b
SM		 1667
1668 case OP_RETURN:
1669 if (type != OP_LEAVESUBLV)
1670 goto nomod;
1671 break; /* mod()ing was handled by ck_return() */
463ee0b2 1672 }
78f9721b
SM		 1673 if (type != OP_LEAVESUBLV)
1674 o->op_flags |= OPf_MOD;
a0d0e21e
LW		 1675
1676 if (type == OP_AASSIGN || type == OP_SASSIGN)
11343788 1677 o->op_flags |= OPf_SPECIAL|OPf_REF;
a0d0e21e 1678 else if (!type) {
11343788
MB		 1679 o->op_private |= OPpLVAL_INTRO;
1680 o->op_flags &= ~OPf_SPECIAL;
3280af22 1681 PL_hints |= HINT_BLOCK_SCOPE;
463ee0b2 1682 }
78f9721b
SM		 1683 else if (type != OP_GREPSTART && type != OP_ENTERSUB
1684 && type != OP_LEAVESUBLV)
11343788
MB		 1685 o->op_flags |= OPf_REF;
1686 return o;
463ee0b2
LW		 1687}
1688
864dbfa3 1689STATIC bool
cea2e8a9 1690S_scalar_mod_type(pTHX_ OP *o, I32 type)
3fe9a6f1 1691{
1692 switch (type) {
1693 case OP_SASSIGN:
5196be3e 1694 if (o->op_type == OP_RV2GV)
3fe9a6f1 1695 return FALSE;
1696 /* FALL THROUGH */
1697 case OP_PREINC:
1698 case OP_PREDEC:
1699 case OP_POSTINC:
1700 case OP_POSTDEC:
1701 case OP_I_PREINC:
1702 case OP_I_PREDEC:
1703 case OP_I_POSTINC:
1704 case OP_I_POSTDEC:
1705 case OP_POW:
1706 case OP_MULTIPLY:
1707 case OP_DIVIDE:
1708 case OP_MODULO:
1709 case OP_REPEAT:
1710 case OP_ADD:
1711 case OP_SUBTRACT:
1712 case OP_I_MULTIPLY:
1713 case OP_I_DIVIDE:
1714 case OP_I_MODULO:
1715 case OP_I_ADD:
1716 case OP_I_SUBTRACT:
1717 case OP_LEFT_SHIFT:
1718 case OP_RIGHT_SHIFT:
1719 case OP_BIT_AND:
1720 case OP_BIT_XOR:
1721 case OP_BIT_OR:
1722 case OP_CONCAT:
1723 case OP_SUBST:
1724 case OP_TRANS:
49e9fbe6
GS		 1725 case OP_READ:
1726 case OP_SYSREAD:
1727 case OP_RECV:
bf4b1e52
GS		 1728 case OP_ANDASSIGN:
1729 case OP_ORASSIGN:
3fe9a6f1 1730 return TRUE;
1731 default:
1732 return FALSE;
1733 }
1734}
1735
35cd451c 1736STATIC bool
cea2e8a9 1737S_is_handle_constructor(pTHX_ OP *o, I32 argnum)
35cd451c
GS		 1738{
1739 switch (o->op_type) {
1740 case OP_PIPE_OP:
1741 case OP_SOCKPAIR:
1742 if (argnum == 2)
1743 return TRUE;
1744 /* FALL THROUGH */
1745 case OP_SYSOPEN:
1746 case OP_OPEN:
ded8aa31 1747 case OP_SELECT: /* XXX c.f. SelectSaver.pm */
35cd451c
GS		 1748 case OP_SOCKET:
1749 case OP_OPEN_DIR:
1750 case OP_ACCEPT:
1751 if (argnum == 1)
1752 return TRUE;
1753 /* FALL THROUGH */
1754 default:
1755 return FALSE;
1756 }
1757}
1758
463ee0b2 1759OP *
864dbfa3 1760Perl_refkids(pTHX_ OP *o, I32 type)
463ee0b2
LW		 1761{
1762 OP *kid;
11343788
MB		 1763 if (o && o->op_flags & OPf_KIDS) {
1764 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
463ee0b2
LW		 1765 ref(kid, type);
1766 }
11343788 1767 return o;
463ee0b2
LW		 1768}
1769
1770OP *
864dbfa3 1771Perl_ref(pTHX_ OP *o, I32 type)
463ee0b2
LW		 1772{
1773 OP *kid;
463ee0b2 1774
3280af22 1775 if (!o || PL_error_count)
11343788 1776 return o;
463ee0b2 1777
11343788 1778 switch (o->op_type) {
a0d0e21e 1779 case OP_ENTERSUB:
afebc493 1780 if ((type == OP_EXISTS || type == OP_DEFINED || type == OP_LOCK) &&
11343788
MB		 1781 !(o->op_flags & OPf_STACKED)) {
1782 o->op_type = OP_RV2CV; /* entersub => rv2cv */
22c35a8c 1783 o->op_ppaddr = PL_ppaddr[OP_RV2CV];
11343788 1784 assert(cUNOPo->op_first->op_type == OP_NULL);
93c66552 1785 op_null(((LISTOP*)cUNOPo->op_first)->op_first); /* disable pushmark */
11343788 1786 o->op_flags |= OPf_SPECIAL;
8990e307
LW		 1787 }
1788 break;
aeea060c 1789
463ee0b2 1790 case OP_COND_EXPR:
11343788 1791 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
463ee0b2
LW		 1792 ref(kid, type);
1793 break;
8990e307 1794 case OP_RV2SV:
35cd451c
GS		 1795 if (type == OP_DEFINED)
1796 o->op_flags |= OPf_SPECIAL; /* don't create GV */
11343788 1797 ref(cUNOPo->op_first, o->op_type);
4633a7c4
LW		 1798 /* FALL THROUGH */
1799 case OP_PADSV:
5f05dabc 1800 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
5dc0d613
MB		 1801 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
1802 : type == OP_RV2HV ? OPpDEREF_HV
1803 : OPpDEREF_SV);
11343788 1804 o->op_flags |= OPf_MOD;
a0d0e21e 1805 }
8990e307 1806 break;
1c846c1f 1807
2faa37cc 1808 case OP_THREADSV:
a863c7d1
MB		 1809 o->op_flags |= OPf_MOD; /* XXX ??? */
1810 break;
1811
463ee0b2
LW		 1812 case OP_RV2AV:
1813 case OP_RV2HV:
aeea060c 1814 o->op_flags |= OPf_REF;
8990e307 1815 /* FALL THROUGH */
463ee0b2 1816 case OP_RV2GV:
35cd451c
GS		 1817 if (type == OP_DEFINED)
1818 o->op_flags |= OPf_SPECIAL; /* don't create GV */
11343788 1819 ref(cUNOPo->op_first, o->op_type);
463ee0b2 1820 break;
8990e307 1821
463ee0b2
LW		 1822 case OP_PADAV:
1823 case OP_PADHV:
aeea060c 1824 o->op_flags |= OPf_REF;
79072805 1825 break;
aeea060c 1826
8990e307 1827 case OP_SCALAR:
79072805 1828 case OP_NULL:
11343788 1829 if (!(o->op_flags & OPf_KIDS))
463ee0b2 1830 break;
11343788 1831 ref(cBINOPo->op_first, type);
79072805
LW		 1832 break;
1833 case OP_AELEM:
1834 case OP_HELEM:
11343788 1835 ref(cBINOPo->op_first, o->op_type);
5f05dabc 1836 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
5dc0d613
MB		 1837 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
1838 : type == OP_RV2HV ? OPpDEREF_HV
1839 : OPpDEREF_SV);
11343788 1840 o->op_flags |= OPf_MOD;
8990e307 1841 }
79072805
LW		 1842 break;
1843
463ee0b2 1844 case OP_SCOPE:
79072805
LW		 1845 case OP_LEAVE:
1846 case OP_ENTER:
8990e307 1847 case OP_LIST:
11343788 1848 if (!(o->op_flags & OPf_KIDS))
79072805 1849 break;
11343788 1850 ref(cLISTOPo->op_last, type);
79072805 1851 break;
a0d0e21e
LW		 1852 default:
1853 break;
79072805 1854 }
11343788 1855 return scalar(o);
8990e307 1856
79072805
LW		 1857}
1858
09bef843
SB		 1859STATIC OP *
1860S_dup_attrlist(pTHX_ OP *o)
1861{
1862 OP *rop = Nullop;
1863
1864 /* An attrlist is either a simple OP_CONST or an OP_LIST with kids,
1865 * where the first kid is OP_PUSHMARK and the remaining ones
1866 * are OP_CONST. We need to push the OP_CONST values.
1867 */
1868 if (o->op_type == OP_CONST)
1869 rop = newSVOP(OP_CONST, o->op_flags, SvREFCNT_inc(cSVOPo->op_sv));
1870 else {
1871 assert((o->op_type == OP_LIST) && (o->op_flags & OPf_KIDS));
1872 for (o = cLISTOPo->op_first; o; o=o->op_sibling) {
1873 if (o->op_type == OP_CONST)
1874 rop = append_elem(OP_LIST, rop,
1875 newSVOP(OP_CONST, o->op_flags,
1876 SvREFCNT_inc(cSVOPo->op_sv)));
1877 }
1878 }
1879 return rop;
1880}
1881
1882STATIC void
1883S_apply_attrs(pTHX_ HV *stash, SV *target, OP *attrs)
1884{
09bef843
SB		 1885 SV *stashsv;
1886
1887 /* fake up C<use attributes $pkg,$rv,@attrs> */
1888 ENTER; /* need to protect against side-effects of 'use' */
1889 SAVEINT(PL_expect);
a9164de8 1890 if (stash)
09bef843
SB		 1891 stashsv = newSVpv(HvNAME(stash), 0);
1892 else
1893 stashsv = &PL_sv_no;
e4783991 1894
09bef843 1895#define ATTRSMODULE "attributes"
e4783991
GS		 1896
1897 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
1898 newSVpvn(ATTRSMODULE, sizeof(ATTRSMODULE)-1),
1899 Nullsv,
1900 prepend_elem(OP_LIST,
1901 newSVOP(OP_CONST, 0, stashsv),
1902 prepend_elem(OP_LIST,
1903 newSVOP(OP_CONST, 0,
1904 newRV(target)),
1905 dup_attrlist(attrs))));
09bef843
SB		 1906 LEAVE;
1907}
1908
be3174d2
GS		 1909void
1910Perl_apply_attrs_string(pTHX_ char *stashpv, CV *cv,
1911 char *attrstr, STRLEN len)
1912{
1913 OP *attrs = Nullop;
1914
1915 if (!len) {
1916 len = strlen(attrstr);
1917 }
1918
1919 while (len) {
1920 for (; isSPACE(*attrstr) && len; --len, ++attrstr) ;
1921 if (len) {
1922 char *sstr = attrstr;
1923 for (; !isSPACE(*attrstr) && len; --len, ++attrstr) ;
1924 attrs = append_elem(OP_LIST, attrs,
1925 newSVOP(OP_CONST, 0,
1926 newSVpvn(sstr, attrstr-sstr)));
1927 }
1928 }
1929
1930 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
1931 newSVpvn(ATTRSMODULE, sizeof(ATTRSMODULE)-1),
1932 Nullsv, prepend_elem(OP_LIST,
1933 newSVOP(OP_CONST, 0, newSVpv(stashpv,0)),
1934 prepend_elem(OP_LIST,
1935 newSVOP(OP_CONST, 0,
1936 newRV((SV*)cv)),
1937 attrs)));
1938}
1939
09bef843
SB		 1940STATIC OP *
1941S_my_kid(pTHX_ OP *o, OP *attrs)
93a17b20
LW		 1942{
1943 OP *kid;
93a17b20
LW		 1944 I32 type;
1945
3280af22 1946 if (!o || PL_error_count)
11343788 1947 return o;
93a17b20 1948
11343788 1949 type = o->op_type;
93a17b20 1950 if (type == OP_LIST) {
11343788 1951 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
09bef843 1952 my_kid(kid, attrs);
dab48698 1953 } else if (type == OP_UNDEF) {
7766148a 1954 return o;
77ca0c92
LW		 1955 } else if (type == OP_RV2SV || /* "our" declaration */
1956 type == OP_RV2AV ||
1957 type == OP_RV2HV) { /* XXX does this let anything illegal in? */
0256094b
DM		 1958 if (attrs) {
1959 GV *gv = cGVOPx_gv(cUNOPo->op_first);
1960 PL_in_my = FALSE;
1961 PL_in_my_stash = Nullhv;
1962 apply_attrs(GvSTASH(gv),
1963 (type == OP_RV2SV ? GvSV(gv) :
1964 type == OP_RV2AV ? (SV*)GvAV(gv) :
1965 type == OP_RV2HV ? (SV*)GvHV(gv) : (SV*)gv),
1966 attrs);
1967 }
192587c2 1968 o->op_private |= OPpOUR_INTRO;
77ca0c92 1969 return o;
dab48698 1970 } else if (type != OP_PADSV &&
93a17b20
LW		 1971 type != OP_PADAV &&
1972 type != OP_PADHV &&
1973 type != OP_PUSHMARK)
1974 {
eb64745e 1975 yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"",
53e06cf0 1976 OP_DESC(o),
eb64745e 1977 PL_in_my == KEY_our ? "our" : "my"));
11343788 1978 return o;
93a17b20 1979 }
09bef843
SB		 1980 else if (attrs && type != OP_PUSHMARK) {
1981 HV *stash;
1982 SV *padsv;
1983 SV **namesvp;
1984
eb64745e
GS		 1985 PL_in_my = FALSE;
1986 PL_in_my_stash = Nullhv;
1987
09bef843
SB		 1988 /* check for C<my Dog $spot> when deciding package */
1989 namesvp = av_fetch(PL_comppad_name, o->op_targ, FALSE);
a9164de8 1990 if (namesvp && *namesvp && (SvFLAGS(*namesvp) & SVpad_TYPED))
09bef843
SB		 1991 stash = SvSTASH(*namesvp);
1992 else
1993 stash = PL_curstash;
1994 padsv = PAD_SV(o->op_targ);
1995 apply_attrs(stash, padsv, attrs);
1996 }
11343788
MB		 1997 o->op_flags |= OPf_MOD;
1998 o->op_private |= OPpLVAL_INTRO;
1999 return o;
93a17b20
LW		 2000}
2001
2002OP *
09bef843
SB		 2003Perl_my_attrs(pTHX_ OP *o, OP *attrs)
2004{
2005 if (o->op_flags & OPf_PARENS)
2006 list(o);
09bef843
SB		 2007 if (attrs)
2008 SAVEFREEOP(attrs);
eb64745e
GS		 2009 o = my_kid(o, attrs);
2010 PL_in_my = FALSE;
2011 PL_in_my_stash = Nullhv;
2012 return o;
09bef843
SB		 2013}
2014
2015OP *
2016Perl_my(pTHX_ OP *o)
2017{
2018 return my_kid(o, Nullop);
2019}
2020
2021OP *
864dbfa3 2022Perl_sawparens(pTHX_ OP *o)
79072805
LW		 2023{
2024 if (o)
2025 o->op_flags |= OPf_PARENS;
2026 return o;
2027}
2028
2029OP *
864dbfa3 2030Perl_bind_match(pTHX_ I32 type, OP *left, OP *right)
79072805 2031{
11343788 2032 OP *o;
79072805 2033
e476b1b5 2034 if (ckWARN(WARN_MISC) &&
599cee73
PM		 2035 (left->op_type == OP_RV2AV ||
2036 left->op_type == OP_RV2HV ||
2037 left->op_type == OP_PADAV ||
2038 left->op_type == OP_PADHV)) {
22c35a8c 2039 char *desc = PL_op_desc[(right->op_type == OP_SUBST ||
599cee73
PM		 2040 right->op_type == OP_TRANS)
2041 ? right->op_type : OP_MATCH];
dff6d3cd
GS		 2042 const char *sample = ((left->op_type == OP_RV2AV ||
2043 left->op_type == OP_PADAV)
2044 ? "@array" : "%hash");
e476b1b5 2045 Perl_warner(aTHX_ WARN_MISC,
1c846c1f 2046 "Applying %s to %s will act on scalar(%s)",
599cee73 2047 desc, sample, sample);
2ae324a7 2048 }
2049
de4bf5b3
MG		 2050 if (!(right->op_flags & OPf_STACKED) &&
2051 (right->op_type == OP_MATCH ||
79072805 2052 right->op_type == OP_SUBST ||
de4bf5b3 2053 right->op_type == OP_TRANS)) {
79072805 2054 right->op_flags |= OPf_STACKED;
55d27857
RG		 2055 if ((right->op_type != OP_MATCH &&
2056 ! (right->op_type == OP_TRANS &&
2057 right->op_private & OPpTRANS_IDENTICAL)) ||
2058 /* if SV has magic, then match on original SV, not on its copy.
2059 see note in pp_helem() */
2060 (right->op_type == OP_MATCH &&
2061 (left->op_type == OP_AELEM ||
2062 left->op_type == OP_HELEM ||
2063 left->op_type == OP_AELEMFAST)))
463ee0b2 2064 left = mod(left, right->op_type);
79072805 2065 if (right->op_type == OP_TRANS)
11343788 2066 o = newBINOP(OP_NULL, OPf_STACKED, scalar(left), right);
79072805 2067 else
11343788 2068 o = prepend_elem(right->op_type, scalar(left), right);
79072805 2069 if (type == OP_NOT)
11343788
MB		 2070 return newUNOP(OP_NOT, 0, scalar(o));
2071 return o;
79072805
LW		 2072 }
2073 else
2074 return bind_match(type, left,
2075 pmruntime(newPMOP(OP_MATCH, 0), right, Nullop));
2076}
2077
2078OP *
864dbfa3 2079Perl_invert(pTHX_ OP *o)
79072805 2080{
11343788
MB		 2081 if (!o)
2082 return o;
79072805 2083 /* XXX need to optimize away NOT NOT here? Or do we let optimizer do it? */
11343788 2084 return newUNOP(OP_NOT, OPf_SPECIAL, scalar(o));
79072805
LW		 2085}
2086
2087OP *
864dbfa3 2088Perl_scope(pTHX_ OP *o)
79072805
LW		 2089{
2090 if (o) {
3280af22 2091 if (o->op_flags & OPf_PARENS || PERLDB_NOOPT || PL_tainting) {
463ee0b2
LW		 2092 o = prepend_elem(OP_LINESEQ, newOP(OP_ENTER, 0), o);
2093 o->op_type = OP_LEAVE;
22c35a8c 2094 o->op_ppaddr = PL_ppaddr[OP_LEAVE];
463ee0b2
LW		 2095 }
2096 else {
2097 if (o->op_type == OP_LINESEQ) {
2098 OP *kid;
2099 o->op_type = OP_SCOPE;
22c35a8c 2100 o->op_ppaddr = PL_ppaddr[OP_SCOPE];
c3ed7a6a
GS		 2101 kid = ((LISTOP*)o)->op_first;
2102 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE)
93c66552 2103 op_null(kid);
463ee0b2
LW		 2104 }
2105 else
748a9306 2106 o = newLISTOP(OP_SCOPE, 0, o, Nullop);
463ee0b2 2107 }
79072805
LW		 2108 }
2109 return o;
2110}
2111
b3ac6de7 2112void
864dbfa3 2113Perl_save_hints(pTHX)
b3ac6de7 2114{
3280af22
NIS		 2115 SAVEI32(PL_hints);
2116 SAVESPTR(GvHV(PL_hintgv));
2117 GvHV(PL_hintgv) = newHVhv(GvHV(PL_hintgv));
2118 SAVEFREESV(GvHV(PL_hintgv));
b3ac6de7
IZ		 2119}
2120
a0d0e21e 2121int
864dbfa3 2122Perl_block_start(pTHX_ int full)
79072805 2123{
3280af22 2124 int retval = PL_savestack_ix;
b3ac6de7 2125
3280af22 2126 SAVEI32(PL_comppad_name_floor);
43d4d5c6
GS		 2127 PL_comppad_name_floor = AvFILLp(PL_comppad_name);
2128 if (full)
2129 PL_comppad_name_fill = PL_comppad_name_floor;
2130 if (PL_comppad_name_floor < 0)
2131 PL_comppad_name_floor = 0;
3280af22
NIS		 2132 SAVEI32(PL_min_intro_pending);
2133 SAVEI32(PL_max_intro_pending);
2134 PL_min_intro_pending = 0;
2135 SAVEI32(PL_comppad_name_fill);
2136 SAVEI32(PL_padix_floor);
2137 PL_padix_floor = PL_padix;
2138 PL_pad_reset_pending = FALSE;
b3ac6de7 2139 SAVEHINTS();
3280af22 2140 PL_hints &= ~HINT_BLOCK_SCOPE;
1c846c1f 2141 SAVESPTR(PL_compiling.cop_warnings);
0453d815 2142 if (! specialWARN(PL_compiling.cop_warnings)) {
599cee73
PM		 2143 PL_compiling.cop_warnings = newSVsv(PL_compiling.cop_warnings) ;
2144 SAVEFREESV(PL_compiling.cop_warnings) ;
2145 }
ac27b0f5
NIS		 2146 SAVESPTR(PL_compiling.cop_io);
2147 if (! specialCopIO(PL_compiling.cop_io)) {
2148 PL_compiling.cop_io = newSVsv(PL_compiling.cop_io) ;
2149 SAVEFREESV(PL_compiling.cop_io) ;
2150 }
a0d0e21e
LW		 2151 return retval;
2152}
2153
2154OP*
864dbfa3 2155Perl_block_end(pTHX_ I32 floor, OP *seq)
a0d0e21e 2156{
3280af22 2157 int needblockscope = PL_hints & HINT_BLOCK_SCOPE;
d8a34499
IK		 2158 line_t copline = PL_copline;
2159 /* there should be a nextstate in every block */
2160 OP* retval = seq ? scalarseq(seq) : newSTATEOP(0, Nullch, seq);
2161 PL_copline = copline; /* XXX newSTATEOP may reset PL_copline */
e9818f4e 2162 LEAVE_SCOPE(floor);
3280af22 2163 PL_pad_reset_pending = FALSE;
e24b16f9 2164 PL_compiling.op_private = PL_hints;
a0d0e21e 2165 if (needblockscope)
3280af22
NIS		 2166 PL_hints |= HINT_BLOCK_SCOPE; /* propagate out */
2167 pad_leavemy(PL_comppad_name_fill);
2168 PL_cop_seqmax++;
a0d0e21e
LW		 2169 return retval;
2170}
2171
76e3520e 2172STATIC OP *
cea2e8a9 2173S_newDEFSVOP(pTHX)
54b9620d 2174{
4d1ff10f 2175#ifdef USE_5005THREADS
54b9620d
MB		 2176 OP *o = newOP(OP_THREADSV, 0);
2177 o->op_targ = find_threadsv("_");
2178 return o;
2179#else
3280af22 2180 return newSVREF(newGVOP(OP_GV, 0, PL_defgv));
4d1ff10f 2181#endif /* USE_5005THREADS */
54b9620d
MB		 2182}
2183
a0d0e21e 2184void
864dbfa3 2185Perl_newPROG(pTHX_ OP *o)
a0d0e21e 2186{
3280af22 2187 if (PL_in_eval) {
b295d113
TH		 2188 if (PL_eval_root)
2189 return;
faef0170
HS		 2190 PL_eval_root = newUNOP(OP_LEAVEEVAL,
2191 ((PL_in_eval & EVAL_KEEPERR)
2192 ? OPf_SPECIAL : 0), o);
3280af22 2193 PL_eval_start = linklist(PL_eval_root);
7934575e
GS		 2194 PL_eval_root->op_private |= OPpREFCOUNTED;
2195 OpREFCNT_set(PL_eval_root, 1);
3280af22 2196 PL_eval_root->op_next = 0;
a2efc822 2197 CALL_PEEP(PL_eval_start);
a0d0e21e
LW		 2198 }
2199 else {
5dc0d613 2200 if (!o)
a0d0e21e 2201 return;
3280af22
NIS		 2202 PL_main_root = scope(sawparens(scalarvoid(o)));
2203 PL_curcop = &PL_compiling;
2204 PL_main_start = LINKLIST(PL_main_root);
7934575e
GS		 2205 PL_main_root->op_private |= OPpREFCOUNTED;
2206 OpREFCNT_set(PL_main_root, 1);
3280af22 2207 PL_main_root->op_next = 0;
a2efc822 2208 CALL_PEEP(PL_main_start);
3280af22 2209 PL_compcv = 0;
3841441e 2210
4fdae800 2211 /* Register with debugger */
84902520 2212 if (PERLDB_INTER) {
864dbfa3 2213 CV *cv = get_cv("DB::postponed", FALSE);
3841441e
CS		 2214 if (cv) {
2215 dSP;
924508f0 2216 PUSHMARK(SP);
cc49e20b 2217 XPUSHs((SV*)CopFILEGV(&PL_compiling));
3841441e 2218 PUTBACK;
864dbfa3 2219 call_sv((SV*)cv, G_DISCARD);
3841441e
CS		 2220 }
2221 }
79072805 2222 }
79072805
LW		 2223}
2224
2225OP *
864dbfa3 2226Perl_localize(pTHX_ OP *o, I32 lex)
79072805
LW		 2227{
2228 if (o->op_flags & OPf_PARENS)
2229 list(o);
8990e307 2230 else {
64420d0d
JH		 2231 if (ckWARN(WARN_PARENTHESIS)
2232 && PL_bufptr > PL_oldbufptr && PL_bufptr[-1] == ',')
2233 {
2234 char *s = PL_bufptr;
2235
2236 while (*s && (isALNUM(*s) || UTF8_IS_CONTINUED(*s) || strchr("@$%, ", *s)))
2237 s++;
2238
a0d0e21e 2239 if (*s == ';' || *s == '=')
eb64745e
GS		 2240 Perl_warner(aTHX_ WARN_PARENTHESIS,
2241 "Parentheses missing around \"%s\" list",
2242 lex ? (PL_in_my == KEY_our ? "our" : "my") : "local");
8990e307
LW		 2243 }
2244 }
93a17b20 2245 if (lex)
eb64745e 2246 o = my(o);
93a17b20 2247 else
eb64745e
GS		 2248 o = mod(o, OP_NULL); /* a bit kludgey */
2249 PL_in_my = FALSE;
2250 PL_in_my_stash = Nullhv;
2251 return o;
79072805
LW		 2252}
2253
2254OP *
864dbfa3 2255Perl_jmaybe(pTHX_ OP *o)
79072805
LW		 2256{
2257 if (o->op_type == OP_LIST) {
554b3eca 2258 OP *o2;
4d1ff10f 2259#ifdef USE_5005THREADS
2faa37cc 2260 o2 = newOP(OP_THREADSV, 0);
54b9620d 2261 o2->op_targ = find_threadsv(";");
554b3eca
MB		 2262#else
2263 o2 = newSVREF(newGVOP(OP_GV, 0, gv_fetchpv(";", TRUE, SVt_PV))),
4d1ff10f 2264#endif /* USE_5005THREADS */
554b3eca 2265 o = convert(OP_JOIN, 0, prepend_elem(OP_LIST, o2, o));
79072805
LW		 2266 }
2267 return o;
2268}
2269
2270OP *
864dbfa3 2271Perl_fold_constants(pTHX_ register OP *o)
79072805
LW		 2272{
2273 register OP *curop;
2274 I32 type = o->op_type;
748a9306 2275 SV *sv;
79072805 2276
22c35a8c 2277 if (PL_opargs[type] & OA_RETSCALAR)
79072805 2278 scalar(o);
b162f9ea 2279 if (PL_opargs[type] & OA_TARGET && !o->op_targ)
ed6116ce 2280 o->op_targ = pad_alloc(type, SVs_PADTMP);
79072805 2281
eac055e9
GS		 2282 /* integerize op, unless it happens to be C<-foo>.
2283 * XXX should pp_i_negate() do magic string negation instead? */
2284 if ((PL_opargs[type] & OA_OTHERINT) && (PL_hints & HINT_INTEGER)
2285 && !(type == OP_NEGATE && cUNOPo->op_first->op_type == OP_CONST
2286 && (cUNOPo->op_first->op_private & OPpCONST_BARE)))
2287 {
22c35a8c 2288 o->op_ppaddr = PL_ppaddr[type = ++(o->op_type)];
eac055e9 2289 }
85e6fe83 2290
22c35a8c 2291 if (!(PL_opargs[type] & OA_FOLDCONST))
79072805
LW		 2292 goto nope;
2293
de939608 2294 switch (type) {
7a52d87a
GS		 2295 case OP_NEGATE:
2296 /* XXX might want a ck_negate() for this */
2297 cUNOPo->op_first->op_private &= ~OPpCONST_STRICT;
2298 break;
de939608
CS		 2299 case OP_SPRINTF:
2300 case OP_UCFIRST:
2301 case OP_LCFIRST:
2302 case OP_UC:
2303 case OP_LC:
69dcf70c
MB		 2304 case OP_SLT:
2305 case OP_SGT:
2306 case OP_SLE:
2307 case OP_SGE:
2308 case OP_SCMP:
2de3dbcc
JH		 2309 /* XXX what about the numeric ops? */
2310 if (PL_hints & HINT_LOCALE)
de939608
CS		 2311 goto nope;
2312 }
2313
3280af22 2314 if (PL_error_count)
a0d0e21e
LW		 2315 goto nope; /* Don't try to run w/ errors */
2316
79072805 2317 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
11fa937b
GS		 2318 if ((curop->op_type != OP_CONST ||
2319 (curop->op_private & OPpCONST_BARE)) &&
7a52d87a
GS		 2320 curop->op_type != OP_LIST &&
2321 curop->op_type != OP_SCALAR &&
2322 curop->op_type != OP_NULL &&
2323 curop->op_type != OP_PUSHMARK)
2324 {
79072805
LW		 2325 goto nope;
2326 }
2327 }
2328
2329 curop = LINKLIST(o);
2330 o->op_next = 0;
533c011a 2331 PL_op = curop;
cea2e8a9 2332 CALLRUNOPS(aTHX);
3280af22 2333 sv = *(PL_stack_sp--);
748a9306 2334 if (o->op_targ && sv == PAD_SV(o->op_targ)) /* grab pad temp? */
79072805 2335 pad_swipe(o->op_targ);
748a9306
LW		 2336 else if (SvTEMP(sv)) { /* grab mortal temp? */
2337 (void)SvREFCNT_inc(sv);
2338 SvTEMP_off(sv);
85e6fe83 2339 }
79072805
LW		 2340 op_free(o);
2341 if (type == OP_RV2GV)
b1cb66bf 2342 return newGVOP(OP_GV, 0, (GV*)sv);
748a9306 2343 else {
ee580363
GS		 2344 /* try to smush double to int, but don't smush -2.0 to -2 */
2345 if ((SvFLAGS(sv) & (SVf_IOK|SVf_NOK|SVf_POK)) == SVf_NOK &&
2346 type != OP_NEGATE)
2347 {
28e5dec8
JH		 2348#ifdef PERL_PRESERVE_IVUV
2349 /* Only bother to attempt to fold to IV if
2350 most operators will benefit */
2351 SvIV_please(sv);
2352#endif
748a9306 2353 }
a86a20aa 2354 return newSVOP(OP_CONST, 0, sv);
748a9306 2355 }
aeea060c 2356
79072805 2357 nope:
22c35a8c 2358 if (!(PL_opargs[type] & OA_OTHERINT))
79072805 2359 return o;
79072805 2360
3280af22 2361 if (!(PL_hints & HINT_INTEGER)) {
4bb9f687
GS		 2362 if (type == OP_MODULO
2363 || type == OP_DIVIDE
2364 || !(o->op_flags & OPf_KIDS))
2365 {
85e6fe83 2366 return o;
4bb9f687 2367 }
85e6fe83
LW		 2368
2369 for (curop = ((UNOP*)o)->op_first; curop; curop = curop->op_sibling) {
2370 if (curop->op_type == OP_CONST) {
b1cb66bf 2371 if (SvIOK(((SVOP*)curop)->op_sv))
85e6fe83
LW		 2372 continue;
2373 return o;
2374 }
22c35a8c 2375 if (PL_opargs[curop->op_type] & OA_RETINTEGER)
79072805
LW		 2376 continue;
2377 return o;
2378 }
22c35a8c 2379 o->op_ppaddr = PL_ppaddr[++(o->op_type)];
79072805
LW		 2380 }
2381
79072805
LW		 2382 return o;
2383}
2384
2385OP *
864dbfa3 2386Perl_gen_constant_list(pTHX_ register OP *o)
79072805
LW		 2387{
2388 register OP *curop;
3280af22 2389 I32 oldtmps_floor = PL_tmps_floor;
79072805 2390
a0d0e21e 2391 list(o);
3280af22 2392 if (PL_error_count)
a0d0e21e
LW		 2393 return o; /* Don't attempt to run with errors */
2394
533c011a 2395 PL_op = curop = LINKLIST(o);
a0d0e21e 2396 o->op_next = 0;
a2efc822 2397 CALL_PEEP(curop);
cea2e8a9
GS		 2398 pp_pushmark();
2399 CALLRUNOPS(aTHX);
533c011a 2400 PL_op = curop;
cea2e8a9 2401 pp_anonlist();
3280af22 2402 PL_tmps_floor = oldtmps_floor;
79072805
LW		 2403
2404 o->op_type = OP_RV2AV;
22c35a8c 2405 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
79072805 2406 curop = ((UNOP*)o)->op_first;
3280af22 2407 ((UNOP*)o)->op_first = newSVOP(OP_CONST, 0, SvREFCNT_inc(*PL_stack_sp--));
79072805 2408 op_free(curop);
79072805
LW		 2409 linklist(o);
2410 return list(o);
2411}
2412
2413OP *
864dbfa3 2414Perl_convert(pTHX_ I32 type, I32 flags, OP *o)
79072805 2415{
11343788
MB		 2416 if (!o || o->op_type != OP_LIST)
2417 o = newLISTOP(OP_LIST, 0, o, Nullop);
748a9306 2418 else
5dc0d613 2419 o->op_flags &= ~OPf_WANT;
79072805 2420
22c35a8c 2421 if (!(PL_opargs[type] & OA_MARK))
93c66552 2422 op_null(cLISTOPo->op_first);
8990e307 2423
11343788 2424 o->op_type = type;
22c35a8c 2425 o->op_ppaddr = PL_ppaddr[type];
11343788 2426 o->op_flags |= flags;
79072805 2427
11343788
MB		 2428 o = CHECKOP(type, o);
2429 if (o->op_type != type)
2430 return o;
79072805 2431
11343788 2432 return fold_constants(o);
79072805
LW		 2433}
2434
2435/* List constructors */
2436
2437OP *
864dbfa3 2438Perl_append_elem(pTHX_ I32 type, OP *first, OP *last)
79072805
LW		 2439{
2440 if (!first)
2441 return last;
8990e307
LW		 2442
2443 if (!last)
79072805 2444 return first;
8990e307 2445
155aba94
GS		 2446 if (first->op_type != type
2447 || (type == OP_LIST && (first->op_flags & OPf_PARENS)))
2448 {
2449 return newLISTOP(type, 0, first, last);
2450 }
79072805 2451
a0d0e21e
LW		 2452 if (first->op_flags & OPf_KIDS)
2453 ((LISTOP*)first)->op_last->op_sibling = last;
2454 else {
2455 first->op_flags |= OPf_KIDS;
2456 ((LISTOP*)first)->op_first = last;
2457 }
2458 ((LISTOP*)first)->op_last = last;
a0d0e21e 2459 return first;
79072805
LW		 2460}
2461
2462OP *
864dbfa3 2463Perl_append_list(pTHX_ I32 type, LISTOP *first, LISTOP *last)
79072805
LW		 2464{
2465 if (!first)
2466 return (OP*)last;
8990e307
LW		 2467
2468 if (!last)
79072805 2469 return (OP*)first;
8990e307
LW		 2470
2471 if (first->op_type != type)
79072805 2472 return prepend_elem(type, (OP*)first, (OP*)last);
8990e307
LW		 2473
2474 if (last->op_type != type)
79072805
LW		 2475 return append_elem(type, (OP*)first, (OP*)last);
2476
2477 first->op_last->op_sibling = last->op_first;
2478 first->op_last = last->op_last;
117dada2 2479 first->op_flags |= (last->op_flags & OPf_KIDS);
1c846c1f 2480
b7dc083c
NIS		 2481#ifdef PL_OP_SLAB_ALLOC
2482#else
1c846c1f 2483 Safefree(last);
b7dc083c 2484#endif
79072805
LW		 2485 return (OP*)first;
2486}
2487
2488OP *
864dbfa3 2489Perl_prepend_elem(pTHX_ I32 type, OP *first, OP *last)
79072805
LW		 2490{
2491 if (!first)
2492 return last;
8990e307
LW		 2493
2494 if (!last)
79072805 2495 return first;
8990e307
LW		 2496
2497 if (last->op_type == type) {
2498 if (type == OP_LIST) { /* already a PUSHMARK there */
2499 first->op_sibling = ((LISTOP*)last)->op_first->op_sibling;
2500 ((LISTOP*)last)->op_first->op_sibling = first;
36a5d4ba
DC		 2501 if (!(first->op_flags & OPf_PARENS))
2502 last->op_flags &= ~OPf_PARENS;
8990e307
LW		 2503 }
2504 else {
2505 if (!(last->op_flags & OPf_KIDS)) {
2506 ((LISTOP*)last)->op_last = first;
2507 last->op_flags |= OPf_KIDS;
2508 }
2509 first->op_sibling = ((LISTOP*)last)->op_first;
2510 ((LISTOP*)last)->op_first = first;
79072805 2511 }
117dada2 2512 last->op_flags |= OPf_KIDS;
79072805
LW		 2513 return last;
2514 }
2515
2516 return newLISTOP(type, 0, first, last);
2517}
2518
2519/* Constructors */
2520
2521OP *
864dbfa3 2522Perl_newNULLLIST(pTHX)
79072805 2523{
8990e307
LW		 2524 return newOP(OP_STUB, 0);
2525}
2526
2527OP *
864dbfa3 2528Perl_force_list(pTHX_ OP *o)
8990e307 2529{
11343788
MB		 2530 if (!o || o->op_type != OP_LIST)
2531 o = newLISTOP(OP_LIST, 0, o, Nullop);
93c66552 2532 op_null(o);
11343788 2533 return o;
79072805
LW		 2534}
2535
2536OP *
864dbfa3 2537Perl_newLISTOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
79072805
LW		 2538{
2539 LISTOP *listop;
2540
b7dc083c 2541 NewOp(1101, listop, 1, LISTOP);
79072805
LW		 2542
2543 listop->op_type = type;
22c35a8c 2544 listop->op_ppaddr = PL_ppaddr[type];
117dada2
SM		 2545 if (first || last)
2546 flags |= OPf_KIDS;
79072805 2547 listop->op_flags = flags;
79072805
LW		 2548
2549 if (!last && first)
2550 last = first;
2551 else if (!first && last)
2552 first = last;
8990e307
LW		 2553 else if (first)
2554 first->op_sibling = last;
79072805
LW		 2555 listop->op_first = first;
2556 listop->op_last = last;
8990e307
LW		 2557 if (type == OP_LIST) {
2558 OP* pushop;
2559 pushop = newOP(OP_PUSHMARK, 0);
2560 pushop->op_sibling = first;
2561 listop->op_first = pushop;
2562 listop->op_flags |= OPf_KIDS;
2563 if (!last)
2564 listop->op_last = pushop;
2565 }
79072805
LW		 2566
2567 return (OP*)listop;
2568}
2569
2570OP *
864dbfa3 2571Perl_newOP(pTHX_ I32 type, I32 flags)
79072805 2572{
11343788 2573 OP *o;
b7dc083c 2574 NewOp(1101, o, 1, OP);
11343788 2575 o->op_type = type;
22c35a8c 2576 o->op_ppaddr = PL_ppaddr[type];
11343788 2577 o->op_flags = flags;
79072805 2578
11343788
MB		 2579 o->op_next = o;
2580 o->op_private = 0 + (flags >> 8);
22c35a8c 2581 if (PL_opargs[type] & OA_RETSCALAR)
11343788 2582 scalar(o);
22c35a8c 2583 if (PL_opargs[type] & OA_TARGET)
11343788
MB		 2584 o->op_targ = pad_alloc(type, SVs_PADTMP);
2585 return CHECKOP(type, o);
79072805
LW		 2586}
2587
2588OP *
864dbfa3 2589Perl_newUNOP(pTHX_ I32 type, I32 flags, OP *first)
79072805
LW		 2590{
2591 UNOP *unop;
2592
93a17b20 2593 if (!first)
aeea060c 2594 first = newOP(OP_STUB, 0);
22c35a8c 2595 if (PL_opargs[type] & OA_MARK)
8990e307 2596 first = force_list(first);
93a17b20 2597
b7dc083c 2598 NewOp(1101, unop, 1, UNOP);
79072805 2599 unop->op_type = type;
22c35a8c 2600 unop->op_ppaddr = PL_ppaddr[type];
79072805
LW		 2601 unop->op_first = first;
2602 unop->op_flags = flags | OPf_KIDS;
c07a80fd 2603 unop->op_private = 1 | (flags >> 8);
e50aee73 2604 unop = (UNOP*) CHECKOP(type, unop);
79072805
LW		 2605 if (unop->op_next)
2606 return (OP*)unop;
2607
a0d0e21e 2608 return fold_constants((OP *) unop);
79072805
LW		 2609}
2610
2611OP *
864dbfa3 2612Perl_newBINOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
79072805
LW		 2613{
2614 BINOP *binop;
b7dc083c 2615 NewOp(1101, binop, 1, BINOP);
79072805
LW		 2616
2617 if (!first)
2618 first = newOP(OP_NULL, 0);
2619
2620 binop->op_type = type;
22c35a8c 2621 binop->op_ppaddr = PL_ppaddr[type];
79072805
LW		 2622 binop->op_first = first;
2623 binop->op_flags = flags | OPf_KIDS;
2624 if (!last) {
2625 last = first;
c07a80fd 2626 binop->op_private = 1 | (flags >> 8);
79072805
LW		 2627 }
2628 else {
c07a80fd 2629 binop->op_private = 2 | (flags >> 8);
79072805
LW		 2630 first->op_sibling = last;
2631 }
2632
e50aee73 2633 binop = (BINOP*)CHECKOP(type, binop);
b162f9ea 2634 if (binop->op_next || binop->op_type != type)
79072805
LW		 2635 return (OP*)binop;
2636
7284ab6f 2637 binop->op_last = binop->op_first->op_sibling;
79072805 2638
a0d0e21e 2639 return fold_constants((OP *)binop);
79072805
LW		 2640}
2641
a0ed51b3 2642static int
2b9d42f0
NIS		 2643uvcompare(const void *a, const void *b)
2644{
2645 if (*((UV *)a) < (*(UV *)b))
2646 return -1;
2647 if (*((UV *)a) > (*(UV *)b))
2648 return 1;
2649 if (*((UV *)a+1) < (*(UV *)b+1))
2650 return -1;
2651 if (*((UV *)a+1) > (*(UV *)b+1))
2652 return 1;
a0ed51b3
LW		 2653 return 0;
2654}
2655
79072805 2656OP *
864dbfa3 2657Perl_pmtrans(pTHX_ OP *o, OP *expr, OP *repl)
79072805 2658{
79072805
LW		 2659 SV *tstr = ((SVOP*)expr)->op_sv;
2660 SV *rstr = ((SVOP*)repl)->op_sv;
463ee0b2
LW		 2661 STRLEN tlen;
2662 STRLEN rlen;
9b877dbb
IH		 2663 U8 *t = (U8*)SvPV(tstr, tlen);
2664 U8 *r = (U8*)SvPV(rstr, rlen);
79072805
LW		 2665 register I32 i;
2666 register I32 j;
a0ed51b3 2667 I32 del;
79072805 2668 I32 complement;
5d06d08e 2669 I32 squash;
9b877dbb 2670 I32 grows = 0;
79072805
LW		 2671 register short *tbl;
2672
800b4dc4 2673 PL_hints |= HINT_BLOCK_SCOPE;
11343788 2674 complement = o->op_private & OPpTRANS_COMPLEMENT;
a0ed51b3 2675 del = o->op_private & OPpTRANS_DELETE;
5d06d08e 2676 squash = o->op_private & OPpTRANS_SQUASH;
1c846c1f 2677
036b4402
GS		 2678 if (SvUTF8(tstr))
2679 o->op_private |= OPpTRANS_FROM_UTF;
1c846c1f
NIS		 2680
2681 if (SvUTF8(rstr))
036b4402 2682 o->op_private |= OPpTRANS_TO_UTF;
79072805 2683
a0ed51b3 2684 if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
79cb57f6 2685 SV* listsv = newSVpvn("# comment\n",10);
a0ed51b3
LW		 2686 SV* transv = 0;
2687 U8* tend = t + tlen;
2688 U8* rend = r + rlen;
ba210ebe 2689 STRLEN ulen;
a0ed51b3
LW		 2690 U32 tfirst = 1;
2691 U32 tlast = 0;
2692 I32 tdiff;
2693 U32 rfirst = 1;
2694 U32 rlast = 0;
2695 I32 rdiff;
2696 I32 diff;
2697 I32 none = 0;
2698 U32 max = 0;
2699 I32 bits;
a0ed51b3 2700 I32 havefinal = 0;
9c5ffd7c 2701 U32 final = 0;
a0ed51b3
LW		 2702 I32 from_utf = o->op_private & OPpTRANS_FROM_UTF;
2703 I32 to_utf = o->op_private & OPpTRANS_TO_UTF;
bf4a1e57
JH		 2704 U8* tsave = NULL;
2705 U8* rsave = NULL;
2706
2707 if (!from_utf) {
2708 STRLEN len = tlen;
2709 tsave = t = bytes_to_utf8(t, &len);
2710 tend = t + len;
2711 }
2712 if (!to_utf && rlen) {
2713 STRLEN len = rlen;
2714 rsave = r = bytes_to_utf8(r, &len);
2715 rend = r + len;
2716 }
a0ed51b3 2717
2b9d42f0
NIS		 2718/* There are several snags with this code on EBCDIC:
2719 1. 0xFF is a legal UTF-EBCDIC byte (there are no illegal bytes).
2720 2. scan_const() in toke.c has encoded chars in native encoding which makes
2721 ranges at least in EBCDIC 0..255 range the bottom odd.
2722*/
2723
a0ed51b3 2724 if (complement) {
ad391ad9 2725 U8 tmpbuf[UTF8_MAXLEN+1];
2b9d42f0 2726 UV *cp;
a0ed51b3 2727 UV nextmin = 0;
2b9d42f0 2728 New(1109, cp, 2*tlen, UV);
a0ed51b3 2729 i = 0;
79cb57f6 2730 transv = newSVpvn("",0);
a0ed51b3 2731 while (t < tend) {
2b9d42f0
NIS		 2732 cp[2*i] = utf8n_to_uvuni(t, tend-t, &ulen, 0);
2733 t += ulen;
2734 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) {
a0ed51b3 2735 t++;
2b9d42f0
NIS		 2736 cp[2*i+1] = utf8n_to_uvuni(t, tend-t, &ulen, 0);
2737 t += ulen;
a0ed51b3 2738 }
2b9d42f0
NIS		 2739 else {
2740 cp[2*i+1] = cp[2*i];
2741 }
2742 i++;
a0ed51b3 2743 }
2b9d42f0 2744 qsort(cp, i, 2*sizeof(UV), uvcompare);
a0ed51b3 2745 for (j = 0; j < i; j++) {
2b9d42f0 2746 UV val = cp[2*j];
a0ed51b3
LW		 2747 diff = val - nextmin;
2748 if (diff > 0) {
9041c2e3 2749 t = uvuni_to_utf8(tmpbuf,nextmin);
dfe13c55 2750 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
a0ed51b3 2751 if (diff > 1) {
2b9d42f0 2752 U8 range_mark = UTF_TO_NATIVE(0xff);
9041c2e3 2753 t = uvuni_to_utf8(tmpbuf, val - 1);
2b9d42f0 2754 sv_catpvn(transv, (char *)&range_mark, 1);
dfe13c55 2755 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
a0ed51b3
LW		 2756 }
2757 }
2b9d42f0 2758 val = cp[2*j+1];
a0ed51b3
LW		 2759 if (val >= nextmin)
2760 nextmin = val + 1;
2761 }
9041c2e3 2762 t = uvuni_to_utf8(tmpbuf,nextmin);
dfe13c55 2763 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2b9d42f0
NIS		 2764 {
2765 U8 range_mark = UTF_TO_NATIVE(0xff);
2766 sv_catpvn(transv, (char *)&range_mark, 1);
2767 }
9041c2e3 2768 t = uvuni_to_utf8(tmpbuf, 0x7fffffff);
dfe13c55
GS		 2769 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2770 t = (U8*)SvPVX(transv);
a0ed51b3
LW		 2771 tlen = SvCUR(transv);
2772 tend = t + tlen;
455d824a 2773 Safefree(cp);
a0ed51b3
LW		 2774 }
2775 else if (!rlen && !del) {
2776 r = t; rlen = tlen; rend = tend;
4757a243
LW		 2777 }
2778 if (!squash) {
05d340b8 2779 if ((!rlen && !del) || t == r ||
12ae5dfc 2780 (tlen == rlen && memEQ((char *)t, (char *)r, tlen)))
01ec43d0 2781 {
4757a243 2782 o->op_private |= OPpTRANS_IDENTICAL;
01ec43d0 2783 }
a0ed51b3
LW		 2784 }
2785
2786 while (t < tend || tfirst <= tlast) {
2787 /* see if we need more "t" chars */
2788 if (tfirst > tlast) {
9041c2e3 2789 tfirst = (I32)utf8n_to_uvuni(t, tend - t, &ulen, 0);
a0ed51b3 2790 t += ulen;
2b9d42f0 2791 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) { /* illegal utf8 val indicates range */
ba210ebe 2792 t++;
9041c2e3 2793 tlast = (I32)utf8n_to_uvuni(t, tend - t, &ulen, 0);
a0ed51b3
LW		 2794 t += ulen;
2795 }
2796 else
2797 tlast = tfirst;
2798 }
2799
2800 /* now see if we need more "r" chars */
2801 if (rfirst > rlast) {
2802 if (r < rend) {
9041c2e3 2803 rfirst = (I32)utf8n_to_uvuni(r, rend - r, &ulen, 0);
a0ed51b3 2804 r += ulen;
2b9d42f0 2805 if (r < rend && NATIVE_TO_UTF(*r) == 0xff) { /* illegal utf8 val indicates range */
ba210ebe 2806 r++;
9041c2e3 2807 rlast = (I32)utf8n_to_uvuni(r, rend - r, &ulen, 0);
a0ed51b3
LW		 2808 r += ulen;
2809 }
2810 else
2811 rlast = rfirst;
2812 }
2813 else {
2814 if (!havefinal++)
2815 final = rlast;
2816 rfirst = rlast = 0xffffffff;
2817 }
2818 }
2819
2820 /* now see which range will peter our first, if either. */
2821 tdiff = tlast - tfirst;
2822 rdiff = rlast - rfirst;
2823
2824 if (tdiff <= rdiff)
2825 diff = tdiff;
2826 else
2827 diff = rdiff;
2828
2829 if (rfirst == 0xffffffff) {
2830 diff = tdiff; /* oops, pretend rdiff is infinite */
2831 if (diff > 0)
894356b3
GS		 2832 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\tXXXX\n",
2833 (long)tfirst, (long)tlast);
a0ed51b3 2834 else
894356b3 2835 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\tXXXX\n", (long)tfirst);
a0ed51b3
LW		 2836 }
2837 else {
2838 if (diff > 0)
894356b3
GS		 2839 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\t%04lx\n",
2840 (long)tfirst, (long)(tfirst + diff),
2841 (long)rfirst);
a0ed51b3 2842 else
894356b3
GS		 2843 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\t%04lx\n",
2844 (long)tfirst, (long)rfirst);
a0ed51b3
LW		 2845
2846 if (rfirst + diff > max)
2847 max = rfirst + diff;
9b877dbb 2848 if (!grows)
45005bfb
JH		 2849 grows = (tfirst < rfirst &&
2850 UNISKIP(tfirst) < UNISKIP(rfirst + diff));
2851 rfirst += diff + 1;
a0ed51b3
LW		 2852 }
2853 tfirst += diff + 1;
2854 }
2855
2856 none = ++max;
2857 if (del)
2858 del = ++max;
2859
2860 if (max > 0xffff)
2861 bits = 32;
2862 else if (max > 0xff)
2863 bits = 16;
2864 else
2865 bits = 8;
2866
455d824a 2867 Safefree(cPVOPo->op_pv);
a0ed51b3
LW		 2868 cSVOPo->op_sv = (SV*)swash_init("utf8", "", listsv, bits, none);
2869 SvREFCNT_dec(listsv);
2870 if (transv)
2871 SvREFCNT_dec(transv);
2872
45005bfb 2873 if (!del && havefinal && rlen)
b448e4fe
JH		 2874 (void)hv_store((HV*)SvRV((cSVOPo->op_sv)), "FINAL", 5,
2875 newSVuv((UV)final), 0);
a0ed51b3 2876
9b877dbb 2877 if (grows)
a0ed51b3
LW		 2878 o->op_private |= OPpTRANS_GROWS;
2879
9b877dbb
IH		 2880 if (tsave)
2881 Safefree(tsave);
2882 if (rsave)
2883 Safefree(rsave);
2884
a0ed51b3
LW		 2885 op_free(expr);
2886 op_free(repl);
2887 return o;
2888 }
2889
2890 tbl = (short*)cPVOPo->op_pv;
79072805
LW		 2891 if (complement) {
2892 Zero(tbl, 256, short);
2893 for (i = 0; i < tlen; i++)
ec49126f 2894 tbl[t[i]] = -1;
79072805
LW		 2895 for (i = 0, j = 0; i < 256; i++) {
2896 if (!tbl[i]) {
2897 if (j >= rlen) {
a0ed51b3 2898 if (del)
79072805
LW		 2899 tbl[i] = -2;
2900 else if (rlen)
ec49126f 2901 tbl[i] = r[j-1];
79072805
LW		 2902 else
2903 tbl[i] = i;
2904 }
9b877dbb
IH		 2905 else {
2906 if (i < 128 && r[j] >= 128)
2907 grows = 1;
ec49126f 2908 tbl[i] = r[j++];
9b877dbb 2909 }
79072805
LW		 2910 }
2911 }
05d340b8
JH		 2912 if (!del) {
2913 if (!rlen) {
2914 j = rlen;
2915 if (!squash)
2916 o->op_private |= OPpTRANS_IDENTICAL;
2917 }
2918 else if (j >= rlen)
2919 j = rlen - 1;
2920 else
2921 cPVOPo->op_pv = (char*)Renew(tbl, 0x101+rlen-j, short);
8973db79
JH		 2922 tbl[0x100] = rlen - j;
2923 for (i=0; i < rlen - j; i++)
2924 tbl[0x101+i] = r[j+i];
2925 }
79072805
LW		 2926 }
2927 else {
a0ed51b3 2928 if (!rlen && !del) {
79072805 2929 r = t; rlen = tlen;
5d06d08e 2930 if (!squash)
4757a243 2931 o->op_private |= OPpTRANS_IDENTICAL;
79072805
LW		 2932 }
2933 for (i = 0; i < 256; i++)
2934 tbl[i] = -1;
2935 for (i = 0, j = 0; i < tlen; i++,j++) {
2936 if (j >= rlen) {
a0ed51b3 2937 if (del) {
ec49126f 2938 if (tbl[t[i]] == -1)
2939 tbl[t[i]] = -2;
79072805
LW		 2940 continue;
2941 }
2942 --j;
2943 }
9b877dbb
IH		 2944 if (tbl[t[i]] == -1) {
2945 if (t[i] < 128 && r[j] >= 128)
2946 grows = 1;
ec49126f 2947 tbl[t[i]] = r[j];
9b877dbb 2948 }
79072805
LW		 2949 }
2950 }
9b877dbb
IH		 2951 if (grows)
2952 o->op_private |= OPpTRANS_GROWS;
79072805
LW		 2953 op_free(expr);
2954 op_free(repl);
2955
11343788 2956 return o;
79072805
LW		 2957}
2958
2959OP *
864dbfa3 2960Perl_newPMOP(pTHX_ I32 type, I32 flags)
79072805
LW		 2961{
2962 PMOP *pmop;
2963
b7dc083c 2964 NewOp(1101, pmop, 1, PMOP);
79072805 2965 pmop->op_type = type;
22c35a8c 2966 pmop->op_ppaddr = PL_ppaddr[type];
79072805 2967 pmop->op_flags = flags;
c07a80fd 2968 pmop->op_private = 0 | (flags >> 8);
79072805 2969
3280af22 2970 if (PL_hints & HINT_RE_TAINT)
b3eb6a9b 2971 pmop->op_pmpermflags |= PMf_RETAINT;
3280af22 2972 if (PL_hints & HINT_LOCALE)
b3eb6a9b
GS		 2973 pmop->op_pmpermflags |= PMf_LOCALE;
2974 pmop->op_pmflags = pmop->op_pmpermflags;
36477c24 2975
debc9467 2976#ifdef USE_ITHREADS
13137afc
AB		 2977 {
2978 SV* repointer;
2979 if(av_len((AV*) PL_regex_pad[0]) > -1) {
2980 repointer = av_pop((AV*)PL_regex_pad[0]);
2981 pmop->op_pmoffset = SvIV(repointer);
1cc8b4c5 2982 SvREPADTMP_off(repointer);
13137afc
AB		 2983 sv_setiv(repointer,0);
2984 } else {
2985 repointer = newSViv(0);
2986 av_push(PL_regex_padav,SvREFCNT_inc(repointer));
2987 pmop->op_pmoffset = av_len(PL_regex_padav);
2988 PL_regex_pad = AvARRAY(PL_regex_padav);
1fcf4c12 2989 }
13137afc 2990 }
debc9467 2991#endif
1fcf4c12
AB		 2992
2993 /* link into pm list */
3280af22
NIS		 2994 if (type != OP_TRANS && PL_curstash) {
2995 pmop->op_pmnext = HvPMROOT(PL_curstash);
2996 HvPMROOT(PL_curstash) = pmop;
cb55de95 2997 PmopSTASH_set(pmop,PL_curstash);
79072805
LW		 2998 }
2999
3000 return (OP*)pmop;
3001}
3002
3003OP *
864dbfa3 3004Perl_pmruntime(pTHX_ OP *o, OP *expr, OP *repl)
79072805
LW		 3005{
3006 PMOP *pm;
3007 LOGOP *rcop;
ce862d02 3008 I32 repl_has_vars = 0;
79072805 3009
11343788
MB		 3010 if (o->op_type == OP_TRANS)
3011 return pmtrans(o, expr, repl);
79072805 3012
3280af22 3013 PL_hints |= HINT_BLOCK_SCOPE;
11343788 3014 pm = (PMOP*)o;
79072805
LW		 3015
3016 if (expr->op_type == OP_CONST) {
463ee0b2 3017 STRLEN plen;
79072805 3018 SV *pat = ((SVOP*)expr)->op_sv;
463ee0b2 3019 char *p = SvPV(pat, plen);
11343788 3020 if ((o->op_flags & OPf_SPECIAL) && strEQ(p, " ")) {
93a17b20 3021 sv_setpvn(pat, "\\s+", 3);
463ee0b2 3022 p = SvPV(pat, plen);
79072805
LW		 3023 pm->op_pmflags |= PMf_SKIPWHITE;
3024 }
aaa362c4
RS		 3025 PM_SETRE(pm, CALLREGCOMP(aTHX_ p, p + plen, pm));
3026 if (strEQ("\\s+", PM_GETRE(pm)->precomp))
85e6fe83 3027 pm->op_pmflags |= PMf_WHITE;
79072805
LW		 3028 op_free(expr);
3029 }
3030 else {
3280af22 3031 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL))
1c846c1f 3032 expr = newUNOP((!(PL_hints & HINT_RE_EVAL)
2cd61cdb
IZ		 3033 ? OP_REGCRESET
3034 : OP_REGCMAYBE),0,expr);
463ee0b2 3035
b7dc083c 3036 NewOp(1101, rcop, 1, LOGOP);
79072805 3037 rcop->op_type = OP_REGCOMP;
22c35a8c 3038 rcop->op_ppaddr = PL_ppaddr[OP_REGCOMP];
79072805 3039 rcop->op_first = scalar(expr);
1c846c1f 3040 rcop->op_flags |= ((PL_hints & HINT_RE_EVAL)
2cd61cdb
IZ		 3041 ? (OPf_SPECIAL | OPf_KIDS)
3042 : OPf_KIDS);
79072805 3043 rcop->op_private = 1;
11343788 3044 rcop->op_other = o;
79072805
LW		 3045
3046 /* establish postfix order */
3280af22 3047 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL)) {
463ee0b2
LW		 3048 LINKLIST(expr);
3049 rcop->op_next = expr;
3050 ((UNOP*)expr)->op_first->op_next = (OP*)rcop;
3051 }
3052 else {
3053 rcop->op_next = LINKLIST(expr);
3054 expr->op_next = (OP*)rcop;
3055 }
79072805 3056
11343788 3057 prepend_elem(o->op_type, scalar((OP*)rcop), o);
79072805
LW		 3058 }
3059
3060 if (repl) {
748a9306 3061 OP *curop;
0244c3a4 3062 if (pm->op_pmflags & PMf_EVAL) {
748a9306 3063 curop = 0;
57843af0
GS		 3064 if (CopLINE(PL_curcop) < PL_multi_end)
3065 CopLINE_set(PL_curcop, PL_multi_end);
0244c3a4 3066 }
4d1ff10f 3067#ifdef USE_5005THREADS
2faa37cc 3068 else if (repl->op_type == OP_THREADSV
554b3eca 3069 && strchr("&`'123456789+",
533c011a 3070 PL_threadsv_names[repl->op_targ]))
554b3eca
MB		 3071 {
3072 curop = 0;
3073 }
4d1ff10f 3074#endif /* USE_5005THREADS */
748a9306
LW		 3075 else if (repl->op_type == OP_CONST)
3076 curop = repl;
79072805 3077 else {
79072805
LW		 3078 OP *lastop = 0;
3079 for (curop = LINKLIST(repl); curop!=repl; curop = LINKLIST(curop)) {
22c35a8c 3080 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
4d1ff10f 3081#ifdef USE_5005THREADS
ce862d02
IZ		 3082 if (curop->op_type == OP_THREADSV) {
3083 repl_has_vars = 1;
be949f6f 3084 if (strchr("&`'123456789+", curop->op_private))
ce862d02 3085 break;
554b3eca
MB		 3086 }
3087#else
79072805 3088 if (curop->op_type == OP_GV) {
638eceb6 3089 GV *gv = cGVOPx_gv(curop);
ce862d02 3090 repl_has_vars = 1;
93a17b20 3091 if (strchr("&`'123456789+", *GvENAME(gv)))
79072805
LW		 3092 break;
3093 }
4d1ff10f 3094#endif /* USE_5005THREADS */
79072805
LW		 3095 else if (curop->op_type == OP_RV2CV)
3096 break;
3097 else if (curop->op_type == OP_RV2SV ||
3098 curop->op_type == OP_RV2AV ||
3099 curop->op_type == OP_RV2HV ||
3100 curop->op_type == OP_RV2GV) {
3101 if (lastop && lastop->op_type != OP_GV) /*funny deref?*/
3102 break;
3103 }
748a9306
LW		 3104 else if (curop->op_type == OP_PADSV ||
3105 curop->op_type == OP_PADAV ||
3106 curop->op_type == OP_PADHV ||
554b3eca 3107 curop->op_type == OP_PADANY) {
ce862d02 3108 repl_has_vars = 1;
748a9306 3109 }
1167e5da
SM		 3110 else if (curop->op_type == OP_PUSHRE)
3111 ; /* Okay here, dangerous in newASSIGNOP */
79072805
LW		 3112 else
3113 break;
3114 }
3115 lastop = curop;
3116 }
748a9306 3117 }
ce862d02 3118 if (curop == repl
1c846c1f 3119 && !(repl_has_vars
aaa362c4
RS		 3120 && (!PM_GETRE(pm)
3121 || PM_GETRE(pm)->reganch & ROPT_EVAL_SEEN))) {
748a9306 3122 pm->op_pmflags |= PMf_CONST; /* const for long enough */
4633a7c4 3123 pm->op_pmpermflags |= PMf_CONST; /* const for long enough */
11343788 3124 prepend_elem(o->op_type, scalar(repl), o);
748a9306
LW		 3125 }
3126 else {
aaa362c4 3127 if (curop == repl && !PM_GETRE(pm)) { /* Has variables. */
ce862d02
IZ		 3128 pm->op_pmflags |= PMf_MAYBE_CONST;
3129 pm->op_pmpermflags |= PMf_MAYBE_CONST;
3130 }
b7dc083c 3131 NewOp(1101, rcop, 1, LOGOP);
748a9306 3132 rcop->op_type = OP_SUBSTCONT;
22c35a8c 3133 rcop->op_ppaddr = PL_ppaddr[OP_SUBSTCONT];
748a9306
LW		 3134 rcop->op_first = scalar(repl);
3135 rcop->op_flags |= OPf_KIDS;
3136 rcop->op_private = 1;
11343788 3137 rcop->op_other = o;
748a9306
LW		 3138
3139 /* establish postfix order */
3140 rcop->op_next = LINKLIST(repl);
3141 repl->op_next = (OP*)rcop;
3142
3143 pm->op_pmreplroot = scalar((OP*)rcop);
3144 pm->op_pmreplstart = LINKLIST(rcop);
3145 rcop->op_next = 0;
79072805
LW		 3146 }
3147 }
3148
3149 return (OP*)pm;
3150}
3151
3152OP *
864dbfa3 3153Perl_newSVOP(pTHX_ I32 type, I32 flags, SV *sv)
79072805
LW		 3154{
3155 SVOP *svop;
b7dc083c 3156 NewOp(1101, svop, 1, SVOP);
79072805 3157 svop->op_type = type;
22c35a8c 3158 svop->op_ppaddr = PL_ppaddr[type];
79072805
LW		 3159 svop->op_sv = sv;
3160 svop->op_next = (OP*)svop;
3161 svop->op_flags = flags;
22c35a8c 3162 if (PL_opargs[type] & OA_RETSCALAR)
463ee0b2 3163 scalar((OP*)svop);
22c35a8c 3164 if (PL_opargs[type] & OA_TARGET)
ed6116ce 3165 svop->op_targ = pad_alloc(type, SVs_PADTMP);
e50aee73 3166 return CHECKOP(type, svop);
79072805
LW		 3167}
3168
3169OP *
350de78d
GS		 3170Perl_newPADOP(pTHX_ I32 type, I32 flags, SV *sv)
3171{
3172 PADOP *padop;
3173 NewOp(1101, padop, 1, PADOP);
3174 padop->op_type = type;
3175 padop->op_ppaddr = PL_ppaddr[type];
3176 padop->op_padix = pad_alloc(type, SVs_PADTMP);
7766f137 3177 SvREFCNT_dec(PL_curpad[padop->op_padix]);
350de78d 3178 PL_curpad[padop->op_padix] = sv;
7766f137 3179 SvPADTMP_on(sv);
350de78d
GS		 3180 padop->op_next = (OP*)padop;
3181 padop->op_flags = flags;
3182 if (PL_opargs[type] & OA_RETSCALAR)
3183 scalar((OP*)padop);
3184 if (PL_opargs[type] & OA_TARGET)
3185 padop->op_targ = pad_alloc(type, SVs_PADTMP);
3186 return CHECKOP(type, padop);
3187}
3188
3189OP *
864dbfa3 3190Perl_newGVOP(pTHX_ I32 type, I32 flags, GV *gv)
79072805 3191{
350de78d 3192#ifdef USE_ITHREADS
743e66e6 3193 GvIN_PAD_on(gv);
350de78d
GS		 3194 return newPADOP(type, flags, SvREFCNT_inc(gv));
3195#else
7934575e 3196 return newSVOP(type, flags, SvREFCNT_inc(gv));
350de78d 3197#endif
79072805
LW		 3198}
3199
3200OP *
864dbfa3 3201Perl_newPVOP(pTHX_ I32 type, I32 flags, char *pv)
79072805
LW		 3202{
3203 PVOP *pvop;
b7dc083c 3204 NewOp(1101, pvop, 1, PVOP);
79072805 3205 pvop->op_type = type;
22c35a8c 3206 pvop->op_ppaddr = PL_ppaddr[type];
79072805
LW		 3207 pvop->op_pv = pv;
3208 pvop->op_next = (OP*)pvop;
3209 pvop->op_flags = flags;
22c35a8c 3210 if (PL_opargs[type] & OA_RETSCALAR)
463ee0b2 3211 scalar((OP*)pvop);
22c35a8c 3212 if (PL_opargs[type] & OA_TARGET)
ed6116ce 3213 pvop->op_targ = pad_alloc(type, SVs_PADTMP);
e50aee73 3214 return CHECKOP(type, pvop);
79072805
LW		 3215}
3216
79072805 3217void
864dbfa3 3218Perl_package(pTHX_ OP *o)
79072805 3219{
93a17b20 3220 SV *sv;
79072805 3221
3280af22
NIS		 3222 save_hptr(&PL_curstash);
3223 save_item(PL_curstname);
11343788 3224 if (o) {
463ee0b2
LW		 3225 STRLEN len;
3226 char *name;
11343788 3227 sv = cSVOPo->op_sv;
463ee0b2 3228 name = SvPV(sv, len);
3280af22
NIS		 3229 PL_curstash = gv_stashpvn(name,len,TRUE);
3230 sv_setpvn(PL_curstname, name, len);
11343788 3231 op_free(o);
93a17b20
LW		 3232 }
3233 else {
f2c0fa37 3234 deprecate("\"package\" with no arguments");
3280af22
NIS		 3235 sv_setpv(PL_curstname,"<none>");
3236 PL_curstash = Nullhv;
93a17b20 3237 }
7ad382f4 3238 PL_hints |= HINT_BLOCK_SCOPE;
3280af22
NIS		 3239 PL_copline = NOLINE;
3240 PL_expect = XSTATE;
79072805
LW		 3241}
3242
85e6fe83 3243void
864dbfa3 3244Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *id, OP *arg)
85e6fe83 3245{
a0d0e21e 3246 OP *pack;
a0d0e21e 3247 OP *imop;
b1cb66bf 3248 OP *veop;
18fc9488 3249 char *packname = Nullch;
c4e33207 3250 STRLEN packlen = 0;
18fc9488 3251 SV *packsv;
85e6fe83 3252
a0d0e21e 3253 if (id->op_type != OP_CONST)
cea2e8a9 3254 Perl_croak(aTHX_ "Module name must be constant");
85e6fe83 3255
b1cb66bf 3256 veop = Nullop;
3257
0f79a09d 3258 if (version != Nullop) {
b1cb66bf 3259 SV *vesv = ((SVOP*)version)->op_sv;
3260
44dcb63b 3261 if (arg == Nullop && !SvNIOKp(vesv)) {
b1cb66bf 3262 arg = version;
3263 }
3264 else {
3265 OP *pack;
0f79a09d 3266 SV *meth;
b1cb66bf 3267
44dcb63b 3268 if (version->op_type != OP_CONST || !SvNIOKp(vesv))
cea2e8a9 3269 Perl_croak(aTHX_ "Version number must be constant number");
b1cb66bf 3270
3271 /* Make copy of id so we don't free it twice */
3272 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)id)->op_sv));
3273
3274 /* Fake up a method call to VERSION */
0f79a09d
GS		 3275 meth = newSVpvn("VERSION",7);
3276 sv_upgrade(meth, SVt_PVIV);
155aba94 3277 (void)SvIOK_on(meth);
0f79a09d 3278 PERL_HASH(SvUVX(meth), SvPVX(meth), SvCUR(meth));
b1cb66bf 3279 veop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
3280 append_elem(OP_LIST,
0f79a09d
GS		 3281 prepend_elem(OP_LIST, pack, list(version)),
3282 newSVOP(OP_METHOD_NAMED, 0, meth)));
b1cb66bf 3283 }
3284 }
aeea060c 3285
a0d0e21e 3286 /* Fake up an import/unimport */
4633a7c4
LW		 3287 if (arg && arg->op_type == OP_STUB)
3288 imop = arg; /* no import on explicit () */
44dcb63b 3289 else if (SvNIOKp(((SVOP*)id)->op_sv)) {
b1cb66bf 3290 imop = Nullop; /* use 5.0; */
3291 }
4633a7c4 3292 else {
0f79a09d
GS		 3293 SV *meth;
3294
4633a7c4
LW		 3295 /* Make copy of id so we don't free it twice */
3296 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)id)->op_sv));
0f79a09d
GS		 3297
3298 /* Fake up a method call to import/unimport */
3299 meth = aver ? newSVpvn("import",6) : newSVpvn("unimport", 8);;
3300 sv_upgrade(meth, SVt_PVIV);
155aba94 3301 (void)SvIOK_on(meth);
0f79a09d 3302 PERL_HASH(SvUVX(meth), SvPVX(meth), SvCUR(meth));
4633a7c4 3303 imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
0f79a09d
GS		 3304 append_elem(OP_LIST,
3305 prepend_elem(OP_LIST, pack, list(arg)),
3306 newSVOP(OP_METHOD_NAMED, 0, meth)));
4633a7c4
LW		 3307 }
3308
d04f2e46
DM		 3309 if (ckWARN(WARN_MISC) &&
3310 imop && (imop != arg) && /* no warning on use 5.0; or explicit () */
3311 SvPOK(packsv = ((SVOP*)id)->op_sv))
3312 {
18fc9488
DM		 3313 /* BEGIN will free the ops, so we need to make a copy */
3314 packlen = SvCUR(packsv);
3315 packname = savepvn(SvPVX(packsv), packlen);
3316 }
3317
a0d0e21e 3318 /* Fake up the BEGIN {}, which does its thing immediately. */
09bef843 3319 newATTRSUB(floor,
79cb57f6 3320 newSVOP(OP_CONST, 0, newSVpvn("BEGIN", 5)),
4633a7c4 3321 Nullop,
09bef843 3322 Nullop,
a0d0e21e 3323 append_elem(OP_LINESEQ,
b1cb66bf 3324 append_elem(OP_LINESEQ,
ec4ab249 3325 newSTATEOP(0, Nullch, newUNOP(OP_REQUIRE, 0, id)),
b1cb66bf 3326 newSTATEOP(0, Nullch, veop)),
a0d0e21e 3327 newSTATEOP(0, Nullch, imop) ));
85e6fe83 3328
18fc9488
DM		 3329 if (packname) {
3330 if (ckWARN(WARN_MISC) && !gv_stashpvn(packname, packlen, FALSE)) {
3331 Perl_warner(aTHX_ WARN_MISC,
3332 "Package `%s' not found "
3333 "(did you use the incorrect case?)", packname);
3334 }
3335 safefree(packname);
3336 }
3337
c305c6a0 3338 PL_hints |= HINT_BLOCK_SCOPE;
3280af22
NIS		 3339 PL_copline = NOLINE;
3340 PL_expect = XSTATE;
85e6fe83
LW		 3341}
3342
7d3fb230
BS		 3343/*
3344=for apidoc load_module
3345
3346Loads the module whose name is pointed to by the string part of name.
3347Note that the actual module name, not its filename, should be given.
3348Eg, "Foo::Bar" instead of "Foo/Bar.pm". flags can be any of
3349PERL_LOADMOD_DENY, PERL_LOADMOD_NOIMPORT, or PERL_LOADMOD_IMPORT_OPS
3350(or 0 for no flags). ver, if specified, provides version semantics
3351similar to C<use Foo::Bar VERSION>. The optional trailing SV*
3352arguments can be used to specify arguments to the module's import()
3353method, similar to C<use Foo::Bar VERSION LIST>.
3354
3355=cut */
3356
e4783991
GS		 3357void
3358Perl_load_module(pTHX_ U32 flags, SV *name, SV *ver, ...)
3359{
3360 va_list args;
3361 va_start(args, ver);
3362 vload_module(flags, name, ver, &args);
3363 va_end(args);
3364}
3365
3366#ifdef PERL_IMPLICIT_CONTEXT
3367void
3368Perl_load_module_nocontext(U32 flags, SV *name, SV *ver, ...)
3369{
3370 dTHX;
3371 va_list args;
3372 va_start(args, ver);
3373 vload_module(flags, name, ver, &args);
3374 va_end(args);
3375}
3376#endif
3377
3378void
3379Perl_vload_module(pTHX_ U32 flags, SV *name, SV *ver, va_list *args)
3380{
3381 OP *modname, *veop, *imop;
3382
3383 modname = newSVOP(OP_CONST, 0, name);
3384 modname->op_private |= OPpCONST_BARE;
3385 if (ver) {
3386 veop = newSVOP(OP_CONST, 0, ver);
3387 }
3388 else
3389 veop = Nullop;
3390 if (flags & PERL_LOADMOD_NOIMPORT) {
3391 imop = sawparens(newNULLLIST());
3392 }
3393 else if (flags & PERL_LOADMOD_IMPORT_OPS) {
3394 imop = va_arg(*args, OP*);
3395 }
3396 else {
3397 SV *sv;
3398 imop = Nullop;
3399 sv = va_arg(*args, SV*);
3400 while (sv) {
3401 imop = append_elem(OP_LIST, imop, newSVOP(OP_CONST, 0, sv));
3402 sv = va_arg(*args, SV*);
3403 }
3404 }
81885997
GS		 3405 {
3406 line_t ocopline = PL_copline;
3407 int oexpect = PL_expect;
3408
3409 utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(FALSE, 0),
3410 veop, modname, imop);
3411 PL_expect = oexpect;
3412 PL_copline = ocopline;
3413 }
e4783991
GS		 3414}
3415
79072805 3416OP *
864dbfa3 3417Perl_dofile(pTHX_ OP *term)
78ca652e
GS		 3418{
3419 OP *doop;
3420 GV *gv;
3421
3422 gv = gv_fetchpv("do", FALSE, SVt_PVCV);
3423 if (!(gv && GvIMPORTED_CV(gv)))
3424 gv = gv_fetchpv("CORE::GLOBAL::do", FALSE, SVt_PVCV);
3425
3426 if (gv && GvIMPORTED_CV(gv)) {
3427 doop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
3428 append_elem(OP_LIST, term,
3429 scalar(newUNOP(OP_RV2CV, 0,
3430 newGVOP(OP_GV, 0,
3431 gv))))));
3432 }
3433 else {
3434 doop = newUNOP(OP_DOFILE, 0, scalar(term));
3435 }
3436 return doop;
3437}
3438
3439OP *
864dbfa3 3440Perl_newSLICEOP(pTHX_ I32 flags, OP *subscript, OP *listval)
79072805
LW		 3441{
3442 return newBINOP(OP_LSLICE, flags,
8990e307
LW		 3443 list(force_list(subscript)),
3444 list(force_list(listval)) );
79072805
LW		 3445}
3446
76e3520e 3447STATIC I32
cea2e8a9 3448S_list_assignment(pTHX_ register OP *o)
79072805 3449{
11343788 3450 if (!o)
79072805
LW		 3451 return TRUE;
3452
11343788
MB		 3453 if (o->op_type == OP_NULL && o->op_flags & OPf_KIDS)
3454 o = cUNOPo->op_first;
79072805 3455
11343788 3456 if (o->op_type == OP_COND_EXPR) {
1a67a97c
SM		 3457 I32 t = list_assignment(cLOGOPo->op_first->op_sibling);
3458 I32 f = list_assignment(cLOGOPo->op_first->op_sibling->op_sibling);
79072805
LW		 3459
3460 if (t && f)
3461 return TRUE;
3462 if (t || f)
3463 yyerror("Assignment to both a list and a scalar");
3464 return FALSE;
3465 }
3466
11343788
MB		 3467 if (o->op_type == OP_LIST || o->op_flags & OPf_PARENS ||
3468 o->op_type == OP_RV2AV || o->op_type == OP_RV2HV ||
3469 o->op_type == OP_ASLICE || o->op_type == OP_HSLICE)
79072805
LW		 3470 return TRUE;
3471
11343788 3472 if (o->op_type == OP_PADAV || o->op_type == OP_PADHV)
93a17b20
LW		 3473 return TRUE;
3474
11343788 3475 if (o->op_type == OP_RV2SV)
79072805
LW		 3476 return FALSE;
3477
3478 return FALSE;
3479}
3480
3481OP *
864dbfa3 3482Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right)
79072805 3483{
11343788 3484 OP *o;
79072805 3485
a0d0e21e
LW		 3486 if (optype) {
3487 if (optype == OP_ANDASSIGN || optype == OP_ORASSIGN) {
3488 return newLOGOP(optype, 0,
3489 mod(scalar(left), optype),
3490 newUNOP(OP_SASSIGN, 0, scalar(right)));
3491 }
3492 else {
3493 return newBINOP(optype, OPf_STACKED,
3494 mod(scalar(left), optype), scalar(right));
3495 }
3496 }
3497
79072805 3498 if (list_assignment(left)) {
10c8fecd
GS		 3499 OP *curop;
3500
3280af22
NIS		 3501 PL_modcount = 0;
3502 PL_eval_start = right; /* Grandfathering $[ assignment here. Bletch.*/
463ee0b2 3503 left = mod(left, OP_AASSIGN);
3280af22
NIS		 3504 if (PL_eval_start)
3505 PL_eval_start = 0;
748a9306 3506 else {
a0d0e21e
LW		 3507 op_free(left);
3508 op_free(right);
3509 return Nullop;
3510 }
10c8fecd
GS		 3511 curop = list(force_list(left));
3512 o = newBINOP(OP_AASSIGN, flags, list(force_list(right)), curop);
11343788 3513 o->op_private = 0 | (flags >> 8);
10c8fecd
GS		 3514 for (curop = ((LISTOP*)curop)->op_first;
3515 curop; curop = curop->op_sibling)
3516 {
3517 if (curop->op_type == OP_RV2HV &&
3518 ((UNOP*)curop)->op_first->op_type != OP_GV) {
3519 o->op_private |= OPpASSIGN_HASH;
3520 break;
3521 }
3522 }
a0d0e21e 3523 if (!(left->op_private & OPpLVAL_INTRO)) {
11343788 3524 OP *lastop = o;
3280af22 3525 PL_generation++;
11343788 3526 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
22c35a8c 3527 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
79072805 3528 if (curop->op_type == OP_GV) {
638eceb6 3529 GV *gv = cGVOPx_gv(curop);
3280af22 3530 if (gv == PL_defgv || SvCUR(gv) == PL_generation)
79072805 3531 break;
3280af22 3532 SvCUR(gv) = PL_generation;
79072805 3533 }
748a9306
LW		 3534 else if (curop->op_type == OP_PADSV ||
3535 curop->op_type == OP_PADAV ||
3536 curop->op_type == OP_PADHV ||
3537 curop->op_type == OP_PADANY) {
3280af22 3538 SV **svp = AvARRAY(PL_comppad_name);
8e07c86e 3539 SV *sv = svp[curop->op_targ];
3280af22 3540 if (SvCUR(sv) == PL_generation)
748a9306 3541 break;
3280af22 3542 SvCUR(sv) = PL_generation; /* (SvCUR not used any more) */
748a9306 3543 }
79072805
LW		 3544 else if (curop->op_type == OP_RV2CV)
3545 break;
3546 else if (curop->op_type == OP_RV2SV ||
3547 curop->op_type == OP_RV2AV ||
3548 curop->op_type == OP_RV2HV ||
3549 curop->op_type == OP_RV2GV) {
3550 if (lastop->op_type != OP_GV) /* funny deref? */
3551 break;
3552 }
1167e5da
SM		 3553 else if (curop->op_type == OP_PUSHRE) {
3554 if (((PMOP*)curop)->op_pmreplroot) {
b3f5893f 3555#ifdef USE_ITHREADS
ba89bb6e 3556 GV *gv = (GV*)PL_curpad[INT2PTR(PADOFFSET,((PMOP*)curop)->op_pmreplroot)];
b3f5893f 3557#else
1167e5da 3558 GV *gv = (GV*)((PMOP*)curop)->op_pmreplroot;
b3f5893f 3559#endif
3280af22 3560 if (gv == PL_defgv || SvCUR(gv) == PL_generation)
1167e5da 3561 break;
3280af22 3562 SvCUR(gv) = PL_generation;
1167e5da
SM		 3563 }
3564 }
79072805
LW		 3565 else
3566 break;
3567 }
3568 lastop = curop;
3569 }
11343788 3570 if (curop != o)
10c8fecd 3571 o->op_private |= OPpASSIGN_COMMON;
79072805 3572 }
c07a80fd 3573 if (right && right->op_type == OP_SPLIT) {
3574 OP* tmpop;
3575 if ((tmpop = ((LISTOP*)right)->op_first) &&
3576 tmpop->op_type == OP_PUSHRE)
3577 {
3578 PMOP *pm = (PMOP*)tmpop;
3579 if (left->op_type == OP_RV2AV &&
3580 !(left->op_private & OPpLVAL_INTRO) &&
11343788 3581 !(o->op_private & OPpASSIGN_COMMON) )
c07a80fd 3582 {
3583 tmpop = ((UNOP*)left)->op_first;
3584 if (tmpop->op_type == OP_GV && !pm->op_pmreplroot) {
971a9dd3 3585#ifdef USE_ITHREADS
ba89bb6e 3586 pm->op_pmreplroot = INT2PTR(OP*, cPADOPx(tmpop)->op_padix);
971a9dd3
GS		 3587 cPADOPx(tmpop)->op_padix = 0; /* steal it */
3588#else
3589 pm->op_pmreplroot = (OP*)cSVOPx(tmpop)->op_sv;
3590 cSVOPx(tmpop)->op_sv = Nullsv; /* steal it */
3591#endif
c07a80fd 3592 pm->op_pmflags |= PMf_ONCE;
11343788 3593 tmpop = cUNOPo->op_first; /* to list (nulled) */
c07a80fd 3594 tmpop = ((UNOP*)tmpop)->op_first; /* to pushmark */
3595 tmpop->op_sibling = Nullop; /* don't free split */
3596 right->op_next = tmpop->op_next; /* fix starting loc */
11343788 3597 op_free(o); /* blow off assign */
54310121 3598 right->op_flags &= ~OPf_WANT;
a5f75d66 3599 /* "I don't know and I don't care." */
c07a80fd 3600 return right;
3601 }
3602 }
3603 else {
e6438c1a 3604 if (PL_modcount < RETURN_UNLIMITED_NUMBER &&
c07a80fd 3605 ((LISTOP*)right)->op_last->op_type == OP_CONST)
3606 {
3607 SV *sv = ((SVOP*)((LISTOP*)right)->op_last)->op_sv;
3608 if (SvIVX(sv) == 0)
3280af22 3609 sv_setiv(sv, PL_modcount+1);
c07a80fd 3610 }
3611 }
3612 }
3613 }
11343788 3614 return o;
79072805
LW		 3615 }
3616 if (!right)
3617 right = newOP(OP_UNDEF, 0);
3618 if (right->op_type == OP_READLINE) {
3619 right->op_flags |= OPf_STACKED;
463ee0b2 3620 return newBINOP(OP_NULL, flags, mod(scalar(left), OP_SASSIGN), scalar(right));
79072805 3621 }
a0d0e21e 3622 else {
3280af22 3623 PL_eval_start = right; /* Grandfathering $[ assignment here. Bletch.*/
11343788 3624 o = newBINOP(OP_SASSIGN, flags,
463ee0b2 3625 scalar(right), mod(scalar(left), OP_SASSIGN) );
3280af22
NIS		 3626 if (PL_eval_start)
3627 PL_eval_start = 0;
748a9306 3628 else {
11343788 3629 op_free(o);
a0d0e21e
LW		 3630 return Nullop;
3631 }
3632 }
11343788 3633 return o;
79072805
LW		 3634}
3635
3636OP *
864dbfa3 3637Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o)
79072805 3638{
bbce6d69 3639 U32 seq = intro_my();
79072805
LW		 3640 register COP *cop;
3641
b7dc083c 3642 NewOp(1101, cop, 1, COP);
57843af0 3643 if (PERLDB_LINE && CopLINE(PL_curcop) && PL_curstash != PL_debstash) {
8990e307 3644 cop->op_type = OP_DBSTATE;
22c35a8c 3645 cop->op_ppaddr = PL_ppaddr[ OP_DBSTATE ];
8990e307
LW		 3646 }
3647 else {
3648 cop->op_type = OP_NEXTSTATE;
22c35a8c 3649 cop->op_ppaddr = PL_ppaddr[ OP_NEXTSTATE ];
8990e307 3650 }
79072805 3651 cop->op_flags = flags;
9d43a755 3652 cop->op_private = (PL_hints & HINT_PRIVATE_MASK);
ff0cee69 3653#ifdef NATIVE_HINTS
3654 cop->op_private |= NATIVE_HINTS;
3655#endif
e24b16f9 3656 PL_compiling.op_private = cop->op_private;
79072805
LW		 3657 cop->op_next = (OP*)cop;
3658
463ee0b2
LW		 3659 if (label) {
3660 cop->cop_label = label;
3280af22 3661 PL_hints |= HINT_BLOCK_SCOPE;
463ee0b2 3662 }
bbce6d69 3663 cop->cop_seq = seq;
3280af22 3664 cop->cop_arybase = PL_curcop->cop_arybase;
0453d815 3665 if (specialWARN(PL_curcop->cop_warnings))
599cee73 3666 cop->cop_warnings = PL_curcop->cop_warnings ;
1c846c1f 3667 else
599cee73 3668 cop->cop_warnings = newSVsv(PL_curcop->cop_warnings) ;
ac27b0f5
NIS		 3669 if (specialCopIO(PL_curcop->cop_io))
3670 cop->cop_io = PL_curcop->cop_io;
3671 else
3672 cop->cop_io = newSVsv(PL_curcop->cop_io) ;
599cee73 3673
79072805 3674
3280af22 3675 if (PL_copline == NOLINE)
57843af0 3676 CopLINE_set(cop, CopLINE(PL_curcop));
79072805 3677 else {
57843af0 3678 CopLINE_set(cop, PL_copline);
3280af22 3679 PL_copline = NOLINE;
79072805 3680 }
57843af0 3681#ifdef USE_ITHREADS
f4dd75d9 3682 CopFILE_set(cop, CopFILE(PL_curcop)); /* XXX share in a pvtable? */
57843af0 3683#else
f4dd75d9 3684 CopFILEGV_set(cop, CopFILEGV(PL_curcop));
57843af0 3685#endif
11faa288 3686 CopSTASH_set(cop, PL_curstash);
79072805 3687
3280af22 3688 if (PERLDB_LINE && PL_curstash != PL_debstash) {
cc49e20b 3689 SV **svp = av_fetch(CopFILEAV(PL_curcop), (I32)CopLINE(cop), FALSE);
3280af22 3690 if (svp && *svp != &PL_sv_undef && !SvIOK(*svp)) {
a0d0e21e 3691 (void)SvIOK_on(*svp);
57b2e452 3692 SvIVX(*svp) = PTR2IV(cop);
93a17b20
LW		 3693 }
3694 }
3695
11343788 3696 return prepend_elem(OP_LINESEQ, (OP*)cop, o);
79072805
LW		 3697}
3698
bbce6d69 3699/* "Introduce" my variables to visible status. */
3700U32
864dbfa3 3701Perl_intro_my(pTHX)
bbce6d69 3702{
3703 SV **svp;
3704 SV *sv;
3705 I32 i;
3706
3280af22
NIS		 3707 if (! PL_min_intro_pending)
3708 return PL_cop_seqmax;
bbce6d69 3709
3280af22
NIS		 3710 svp = AvARRAY(PL_comppad_name);
3711 for (i = PL_min_intro_pending; i <= PL_max_intro_pending; i++) {
3712 if ((sv = svp[i]) && sv != &PL_sv_undef && !SvIVX(sv)) {
c53d7c7d 3713 SvIVX(sv) = PAD_MAX; /* Don't know scope end yet. */
65202027 3714 SvNVX(sv) = (NV)PL_cop_seqmax;
bbce6d69 3715 }
3716 }
3280af22
NIS		 3717 PL_min_intro_pending = 0;
3718 PL_comppad_name_fill = PL_max_intro_pending; /* Needn't search higher */
3719 return PL_cop_seqmax++;
bbce6d69 3720}
3721
79072805 3722OP *
864dbfa3 3723Perl_newLOGOP(pTHX_ I32 type, I32 flags, OP *first, OP *other)
79072805 3724{
883ffac3
CS		 3725 return new_logop(type, flags, &first, &other);
3726}
3727
3bd495df 3728STATIC OP *
cea2e8a9 3729S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp)
883ffac3 3730{
79072805 3731 LOGOP *logop;
11343788 3732 OP *o;
883ffac3
CS		 3733 OP *first = *firstp;
3734 OP *other = *otherp;
79072805 3735
a0d0e21e
LW		 3736 if (type == OP_XOR) /* Not short circuit, but here by precedence. */
3737 return newBINOP(type, flags, scalar(first), scalar(other));
3738
8990e307 3739 scalarboolean(first);
79072805
LW		 3740 /* optimize "!a && b" to "a || b", and "!a || b" to "a && b" */
3741 if (first->op_type == OP_NOT && (first->op_flags & OPf_SPECIAL)) {
3742 if (type == OP_AND || type == OP_OR) {
3743 if (type == OP_AND)
3744 type = OP_OR;
3745 else
3746 type = OP_AND;
11343788 3747 o = first;
883ffac3 3748 first = *firstp = cUNOPo->op_first;
11343788
MB		 3749 if (o->op_next)
3750 first->op_next = o->op_next;
3751 cUNOPo->op_first = Nullop;
3752 op_free(o);
79072805
LW		 3753 }
3754 }
3755 if (first->op_type == OP_CONST) {
4673fc70 3756 if (ckWARN(WARN_BAREWORD) && (first->op_private & OPpCONST_BARE))
1c846c1f 3757 Perl_warner(aTHX_ WARN_BAREWORD, "Bareword found in conditional");
79072805
LW		 3758 if ((type == OP_AND) == (SvTRUE(((SVOP*)first)->op_sv))) {
3759 op_free(first);
883ffac3 3760 *firstp = Nullop;
79072805
LW		 3761 return other;
3762 }
3763 else {
3764 op_free(other);
883ffac3 3765 *otherp = Nullop;
79072805
LW		 3766 return first;
3767 }
3768 }
3769 else if (first->op_type == OP_WANTARRAY) {
3770 if (type == OP_AND)
3771 list(other);
3772 else
3773 scalar(other);
3774 }
e476b1b5 3775 else if (ckWARN(WARN_MISC) && (first->op_flags & OPf_KIDS)) {
a6006777 3776 OP *k1 = ((UNOP*)first)->op_first;
3777 OP *k2 = k1->op_sibling;
3778 OPCODE warnop = 0;
3779 switch (first->op_type)
3780 {
3781 case OP_NULL:
3782 if (k2 && k2->op_type == OP_READLINE
3783 && (k2->op_flags & OPf_STACKED)
1c846c1f 3784 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
72b16652 3785 {
a6006777 3786 warnop = k2->op_type;
72b16652 3787 }
a6006777 3788 break;
3789
3790 case OP_SASSIGN:
68dc0745 3791 if (k1->op_type == OP_READDIR
3792 || k1->op_type == OP_GLOB
72b16652 3793 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
68dc0745 3794 || k1->op_type == OP_EACH)
72b16652
GS		 3795 {
3796 warnop = ((k1->op_type == OP_NULL)
3797 ? k1->op_targ : k1->op_type);
3798 }
a6006777 3799 break;
3800 }
8ebc5c01 3801 if (warnop) {
57843af0
GS		 3802 line_t oldline = CopLINE(PL_curcop);
3803 CopLINE_set(PL_curcop, PL_copline);
e476b1b5 3804 Perl_warner(aTHX_ WARN_MISC,
599cee73 3805 "Value of %s%s can be \"0\"; test with defined()",
22c35a8c 3806 PL_op_desc[warnop],
68dc0745 3807 ((warnop == OP_READLINE || warnop == OP_GLOB)
3808 ? " construct" : "() operator"));
57843af0 3809 CopLINE_set(PL_curcop, oldline);
8ebc5c01 3810 }
a6006777 3811 }
79072805
LW		 3812
3813 if (!other)
3814 return first;
3815
a0d0e21e
LW		 3816 if (type == OP_ANDASSIGN || type == OP_ORASSIGN)
3817 other->op_private |= OPpASSIGN_BACKWARDS; /* other is an OP_SASSIGN */
3818
b7dc083c 3819 NewOp(1101, logop, 1, LOGOP);
79072805
LW		 3820
3821 logop->op_type = type;
22c35a8c 3822 logop->op_ppaddr = PL_ppaddr[type];
79072805
LW		 3823 logop->op_first = first;
3824 logop->op_flags = flags | OPf_KIDS;
3825 logop->op_other = LINKLIST(other);
c07a80fd 3826 logop->op_private = 1 | (flags >> 8);
79072805
LW		 3827
3828 /* establish postfix order */
3829 logop->op_next = LINKLIST(first);
3830 first->op_next = (OP*)logop;
3831 first->op_sibling = other;
3832
11343788
MB		 3833 o = newUNOP(OP_NULL, 0, (OP*)logop);
3834 other->op_next = o;
79072805 3835
11343788 3836 return o;
79072805
LW		 3837}
3838
3839OP *
864dbfa3 3840Perl_newCONDOP(pTHX_ I32 flags, OP *first, OP *trueop, OP *falseop)
79072805 3841{
1a67a97c
SM		 3842 LOGOP *logop;
3843 OP *start;
11343788 3844 OP *o;
79072805 3845
b1cb66bf 3846 if (!falseop)
3847 return newLOGOP(OP_AND, 0, first, trueop);
3848 if (!trueop)
3849 return newLOGOP(OP_OR, 0, first, falseop);
79072805 3850
8990e307 3851 scalarboolean(first);
79072805
LW		 3852 if (first->op_type == OP_CONST) {
3853 if (SvTRUE(((SVOP*)first)->op_sv)) {
3854 op_free(first);
b1cb66bf 3855 op_free(falseop);
3856 return trueop;
79072805
LW		 3857 }
3858 else {
3859 op_free(first);
b1cb66bf 3860 op_free(trueop);
3861 return falseop;
79072805
LW		 3862 }
3863 }
3864 else if (first->op_type == OP_WANTARRAY) {
b1cb66bf 3865 list(trueop);
3866 scalar(falseop);
79072805 3867 }
1a67a97c
SM		 3868 NewOp(1101, logop, 1, LOGOP);
3869 logop->op_type = OP_COND_EXPR;
3870 logop->op_ppaddr = PL_ppaddr[OP_COND_EXPR];
3871 logop->op_first = first;
3872 logop->op_flags = flags | OPf_KIDS;
3873 logop->op_private = 1 | (flags >> 8);
3874 logop->op_other = LINKLIST(trueop);
3875 logop->op_next = LINKLIST(falseop);
79072805 3876
79072805
LW		 3877
3878 /* establish postfix order */
1a67a97c
SM		 3879 start = LINKLIST(first);
3880 first->op_next = (OP*)logop;
79072805 3881
b1cb66bf 3882 first->op_sibling = trueop;
3883 trueop->op_sibling = falseop;
1a67a97c 3884 o = newUNOP(OP_NULL, 0, (OP*)logop);
79072805 3885
1a67a97c 3886 trueop->op_next = falseop->op_next = o;
79072805 3887
1a67a97c 3888 o->op_next = start;
11343788 3889 return o;
79072805
LW		 3890}
3891
3892OP *
864dbfa3 3893Perl_newRANGE(pTHX_ I32 flags, OP *left, OP *right)
79072805 3894{
1a67a97c 3895 LOGOP *range;
79072805
LW		 3896 OP *flip;
3897 OP *flop;
1a67a97c 3898 OP *leftstart;
11343788 3899 OP *o;
79072805 3900
1a67a97c 3901 NewOp(1101, range, 1, LOGOP);
79072805 3902
1a67a97c
SM		 3903 range->op_type = OP_RANGE;
3904 range->op_ppaddr = PL_ppaddr[OP_RANGE];
3905 range->op_first = left;
3906 range->op_flags = OPf_KIDS;
3907 leftstart = LINKLIST(left);
3908 range->op_other = LINKLIST(right);
3909 range->op_private = 1 | (flags >> 8);
79072805
LW		 3910
3911 left->op_sibling = right;
3912
1a67a97c
SM		 3913 range->op_next = (OP*)range;
3914 flip = newUNOP(OP_FLIP, flags, (OP*)range);
79072805 3915 flop = newUNOP(OP_FLOP, 0, flip);
11343788 3916 o = newUNOP(OP_NULL, 0, flop);
79072805 3917 linklist(flop);
1a67a97c 3918 range->op_next = leftstart;
79072805
LW		 3919
3920 left->op_next = flip;
3921 right->op_next = flop;
3922
1a67a97c
SM		 3923 range->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
3924 sv_upgrade(PAD_SV(range->op_targ), SVt_PVNV);
ed6116ce 3925 flip->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
79072805
LW		 3926 sv_upgrade(PAD_SV(flip->op_targ), SVt_PVNV);
3927
3928 flip->op_private = left->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
3929 flop->op_private = right->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
3930
11343788 3931 flip->op_next = o;
79072805 3932 if (!flip->op_private || !flop->op_private)
11343788 3933 linklist(o); /* blow off optimizer unless constant */
79072805 3934
11343788 3935 return o;
79072805
LW		 3936}
3937
3938OP *
864dbfa3 3939Perl_newLOOPOP(pTHX_ I32 flags, I32 debuggable, OP *expr, OP *block)
79072805 3940{
463ee0b2 3941 OP* listop;
11343788 3942 OP* o;
463ee0b2 3943 int once = block && block->op_flags & OPf_SPECIAL &&
a0d0e21e 3944 (block->op_type == OP_ENTERSUB || block->op_type == OP_NULL);
93a17b20 3945
463ee0b2
LW		 3946 if (expr) {
3947 if (once && expr->op_type == OP_CONST && !SvTRUE(((SVOP*)expr)->op_sv))
3948 return block; /* do {} while 0 does once */
fb73857a 3949 if (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
3950 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
774d564b 3951 expr = newUNOP(OP_DEFINED, 0,
54b9620d 3952 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
55d729e4
GS		 3953 } else if (expr->op_flags & OPf_KIDS) {
3954 OP *k1 = ((UNOP*)expr)->op_first;
3955 OP *k2 = (k1) ? k1->op_sibling : NULL;
3956 switch (expr->op_type) {
1c846c1f 3957 case OP_NULL:
55d729e4
GS		 3958 if (k2 && k2->op_type == OP_READLINE
3959 && (k2->op_flags & OPf_STACKED)
1c846c1f 3960 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
55d729e4 3961 expr = newUNOP(OP_DEFINED, 0, expr);
1c846c1f 3962 break;
55d729e4
GS		 3963
3964 case OP_SASSIGN:
3965 if (k1->op_type == OP_READDIR
3966 || k1->op_type == OP_GLOB
72b16652 3967 || (k1->op_type == OP_NULL && k1->op_targ == OP_NULL)
55d729e4
GS		 3968 || k1->op_type == OP_EACH)
3969 expr = newUNOP(OP_DEFINED, 0, expr);
3970 break;
3971 }
774d564b 3972 }
463ee0b2 3973 }
93a17b20 3974
8990e307 3975 listop = append_elem(OP_LINESEQ, block, newOP(OP_UNSTACK, 0));
883ffac3 3976 o = new_logop(OP_AND, 0, &expr, &listop);
463ee0b2 3977
883ffac3
CS		 3978 if (listop)
3979 ((LISTOP*)listop)->op_last->op_next = LINKLIST(o);
79072805 3980
11343788
MB		 3981 if (once && o != listop)
3982 o->op_next = ((LOGOP*)cUNOPo->op_first)->op_other;
79072805 3983
11343788
MB		 3984 if (o == listop)
3985 o = newUNOP(OP_NULL, 0, o); /* or do {} while 1 loses outer block */
748a9306 3986
11343788
MB		 3987 o->op_flags |= flags;
3988 o = scope(o);
3989 o->op_flags |= OPf_SPECIAL; /* suppress POPBLOCK curpm restoration*/
3990 return o;
79072805
LW		 3991}
3992
3993OP *
864dbfa3 3994Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP *loop, I32 whileline, OP *expr, OP *block, OP *cont)
79072805
LW		 3995{
3996 OP *redo;
3997 OP *next = 0;
3998 OP *listop;
11343788 3999 OP *o;
1ba6ee2b 4000 U8 loopflags = 0;
79072805 4001
fb73857a 4002 if (expr && (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
4003 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB))) {
748a9306 4004 expr = newUNOP(OP_DEFINED, 0,
54b9620d 4005 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
55d729e4
GS		 4006 } else if (expr && (expr->op_flags & OPf_KIDS)) {
4007 OP *k1 = ((UNOP*)expr)->op_first;
4008 OP *k2 = (k1) ? k1->op_sibling : NULL;
4009 switch (expr->op_type) {
1c846c1f 4010 case OP_NULL:
55d729e4
GS		 4011 if (k2 && k2->op_type == OP_READLINE
4012 && (k2->op_flags & OPf_STACKED)
1c846c1f 4013 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
55d729e4 4014 expr = newUNOP(OP_DEFINED, 0, expr);
1c846c1f 4015 break;
55d729e4
GS		 4016
4017 case OP_SASSIGN:
4018 if (k1->op_type == OP_READDIR
4019 || k1->op_type == OP_GLOB
72b16652 4020 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
55d729e4
GS		 4021 || k1->op_type == OP_EACH)
4022 expr = newUNOP(OP_DEFINED, 0, expr);
4023 break;
4024 }
748a9306 4025 }
79072805
LW		 4026
4027 if (!block)
4028 block = newOP(OP_NULL, 0);
87246558
GS		 4029 else if (cont) {
4030 block = scope(block);
4031 }
79072805 4032
1ba6ee2b 4033 if (cont) {
79072805 4034 next = LINKLIST(cont);
1ba6ee2b 4035 }
fb73857a 4036 if (expr) {
85538317
GS		 4037 OP *unstack = newOP(OP_UNSTACK, 0);
4038 if (!next)
4039 next = unstack;
4040 cont = append_elem(OP_LINESEQ, cont, unstack);
fb73857a 4041 if ((line_t)whileline != NOLINE) {
3280af22 4042 PL_copline = whileline;
fb73857a 4043 cont = append_elem(OP_LINESEQ, cont,
4044 newSTATEOP(0, Nullch, Nullop));
4045 }
4046 }
79072805 4047
463ee0b2 4048 listop = append_list(OP_LINESEQ, (LISTOP*)block, (LISTOP*)cont);
79072805
LW		 4049 redo = LINKLIST(listop);
4050
4051 if (expr) {
3280af22 4052 PL_copline = whileline;
883ffac3
CS		 4053 scalar(listop);
4054 o = new_logop(OP_AND, 0, &expr, &listop);
11343788 4055 if (o == expr && o->op_type == OP_CONST && !SvTRUE(cSVOPo->op_sv)) {
85e6fe83 4056 op_free(expr); /* oops, it's a while (0) */
463ee0b2 4057 op_free((OP*)loop);
883ffac3 4058 return Nullop; /* listop already freed by new_logop */
463ee0b2 4059 }
883ffac3 4060 if (listop)
497b47a8 4061 ((LISTOP*)listop)->op_last->op_next =
883ffac3 4062 (o == listop ? redo : LINKLIST(o));
79072805
LW		 4063 }
4064 else
11343788 4065 o = listop;
79072805
LW		 4066
4067 if (!loop) {
b7dc083c 4068 NewOp(1101,loop,1,LOOP);
79072805 4069 loop->op_type = OP_ENTERLOOP;
22c35a8c 4070 loop->op_ppaddr = PL_ppaddr[OP_ENTERLOOP];
79072805
LW		 4071 loop->op_private = 0;
4072 loop->op_next = (OP*)loop;
4073 }
4074
11343788 4075 o = newBINOP(OP_LEAVELOOP, 0, (OP*)loop, o);
79072805
LW		 4076
4077 loop->op_redoop = redo;
11343788 4078 loop->op_lastop = o;
1ba6ee2b 4079 o->op_private |= loopflags;
79072805
LW		 4080
4081 if (next)
4082 loop->op_nextop = next;
4083 else
11343788 4084 loop->op_nextop = o;
79072805 4085
11343788
MB		 4086 o->op_flags |= flags;
4087 o->op_private |= (flags >> 8);
4088 return o;
79072805
LW		 4089}
4090
4091OP *
864dbfa3 4092Perl_newFOROP(pTHX_ I32 flags,char *label,line_t forline,OP *sv,OP *expr,OP *block,OP *cont)
79072805
LW		 4093{
4094 LOOP *loop;
fb73857a 4095 OP *wop;
85e6fe83 4096 int padoff = 0;
4633a7c4 4097 I32 iterflags = 0;
79072805 4098
79072805 4099 if (sv) {
85e6fe83 4100 if (sv->op_type == OP_RV2SV) { /* symbol table variable */
748a9306 4101 sv->op_type = OP_RV2GV;
22c35a8c 4102 sv->op_ppaddr = PL_ppaddr[OP_RV2GV];
79072805 4103 }
85e6fe83
LW		 4104 else if (sv->op_type == OP_PADSV) { /* private variable */
4105 padoff = sv->op_targ;
743e66e6 4106 sv->op_targ = 0;
85e6fe83
LW		 4107 op_free(sv);
4108 sv = Nullop;
4109 }
54b9620d
MB		 4110 else if (sv->op_type == OP_THREADSV) { /* per-thread variable */
4111 padoff = sv->op_targ;
743e66e6 4112 sv->op_targ = 0;
54b9620d
MB		 4113 iterflags |= OPf_SPECIAL;
4114 op_free(sv);
4115 sv = Nullop;
4116 }
79072805 4117 else
cea2e8a9 4118 Perl_croak(aTHX_ "Can't use %s for loop variable", PL_op_desc[sv->op_type]);
79072805
LW		 4119 }
4120 else {
4d1ff10f 4121#ifdef USE_5005THREADS
54b9620d
MB		 4122 padoff = find_threadsv("_");
4123 iterflags |= OPf_SPECIAL;
4124#else
3280af22 4125 sv = newGVOP(OP_GV, 0, PL_defgv);
54b9620d 4126#endif
79072805 4127 }
5f05dabc 4128 if (expr->op_type == OP_RV2AV || expr->op_type == OP_PADAV) {
89ea2908 4129 expr = mod(force_list(scalar(ref(expr, OP_ITER))), OP_GREPSTART);
4633a7c4
LW		 4130 iterflags |= OPf_STACKED;
4131 }
89ea2908
GA		 4132 else if (expr->op_type == OP_NULL &&
4133 (expr->op_flags & OPf_KIDS) &&
4134 ((BINOP*)expr)->op_first->op_type == OP_FLOP)
4135 {
4136 /* Basically turn for($x..$y) into the same as for($x,$y), but we
4137 * set the STACKED flag to indicate that these values are to be
4138 * treated as min/max values by 'pp_iterinit'.
4139 */
4140 UNOP* flip = (UNOP*)((UNOP*)((BINOP*)expr)->op_first)->op_first;
1a67a97c 4141 LOGOP* range = (LOGOP*) flip->op_first;
89ea2908
GA		 4142 OP* left = range->op_first;
4143 OP* right = left->op_sibling;
5152d7c7 4144 LISTOP* listop;
89ea2908
GA		 4145
4146 range->op_flags &= ~OPf_KIDS;
4147 range->op_first = Nullop;
4148
5152d7c7 4149 listop = (LISTOP*)newLISTOP(OP_LIST, 0, left, right);
1a67a97c
SM		 4150 listop->op_first->op_next = range->op_next;
4151 left->op_next = range->op_other;
5152d7c7
GS		 4152 right->op_next = (OP*)listop;
4153 listop->op_next = listop->op_first;
89ea2908
GA		 4154
4155 op_free(expr);
5152d7c7 4156 expr = (OP*)(listop);
93c66552 4157 op_null(expr);
89ea2908
GA		 4158 iterflags |= OPf_STACKED;
4159 }
4160 else {
4161 expr = mod(force_list(expr), OP_GREPSTART);
4162 }
4163
4164
4633a7c4 4165 loop = (LOOP*)list(convert(OP_ENTERITER, iterflags,
89ea2908 4166 append_elem(OP_LIST, expr, scalar(sv))));
85e6fe83 4167 assert(!loop->op_next);
b7dc083c 4168#ifdef PL_OP_SLAB_ALLOC
155aba94
GS		 4169 {
4170 LOOP *tmp;
4171 NewOp(1234,tmp,1,LOOP);
4172 Copy(loop,tmp,1,LOOP);
4173 loop = tmp;
4174 }
b7dc083c 4175#else
85e6fe83 4176 Renew(loop, 1, LOOP);
1c846c1f 4177#endif
85e6fe83 4178 loop->op_targ = padoff;
fb73857a 4179 wop = newWHILEOP(flags, 1, loop, forline, newOP(OP_ITER, 0), block, cont);
3280af22 4180 PL_copline = forline;
fb73857a 4181 return newSTATEOP(0, label, wop);
79072805
LW		 4182}
4183
8990e307 4184OP*
864dbfa3 4185Perl_newLOOPEX(pTHX_ I32 type, OP *label)
8990e307 4186{
11343788 4187 OP *o;
2d8e6c8d
GS		 4188 STRLEN n_a;
4189
8990e307 4190 if (type != OP_GOTO || label->op_type == OP_CONST) {
cdaebead
MB		 4191 /* "last()" means "last" */
4192 if (label->op_type == OP_STUB && (label->op_flags & OPf_PARENS))
4193 o = newOP(type, OPf_SPECIAL);
4194 else {
4195 o = newPVOP(type, 0, savepv(label->op_type == OP_CONST
2d8e6c8d 4196 ? SvPVx(((SVOP*)label)->op_sv, n_a)
cdaebead
MB		 4197 : ""));
4198 }
8990e307
LW		 4199 op_free(label);
4200 }
4201 else {
a0d0e21e
LW		 4202 if (label->op_type == OP_ENTERSUB)
4203 label = newUNOP(OP_REFGEN, 0, mod(label, OP_REFGEN));
11343788 4204 o = newUNOP(type, OPf_STACKED, label);
8990e307 4205 }
3280af22 4206 PL_hints |= HINT_BLOCK_SCOPE;
11343788 4207 return o;
8990e307
LW		 4208}
4209
79072805 4210void
864dbfa3 4211Perl_cv_undef(pTHX_ CV *cv)
79072805 4212{
4d1ff10f 4213#ifdef USE_5005THREADS
e858de61
MB		 4214 if (CvMUTEXP(cv)) {
4215 MUTEX_DESTROY(CvMUTEXP(cv));
4216 Safefree(CvMUTEXP(cv));
4217 CvMUTEXP(cv) = 0;
4218 }
4d1ff10f 4219#endif /* USE_5005THREADS */
11343788 4220
a636914a
RH		 4221#ifdef USE_ITHREADS
4222 if (CvFILE(cv) && !CvXSUB(cv)) {
f3e31eb5 4223 /* for XSUBs CvFILE point directly to static memory; __FILE__ */
a636914a 4224 Safefree(CvFILE(cv));
a636914a 4225 }
f3e31eb5 4226 CvFILE(cv) = 0;
a636914a
RH		 4227#endif
4228
a0d0e21e 4229 if (!CvXSUB(cv) && CvROOT(cv)) {
4d1ff10f 4230#ifdef USE_5005THREADS
11343788 4231 if (CvDEPTH(cv) || (CvOWNER(cv) && CvOWNER(cv) != thr))
cea2e8a9 4232 Perl_croak(aTHX_ "Can't undef active subroutine");
11343788 4233#else
a0d0e21e 4234 if (CvDEPTH(cv))
cea2e8a9 4235 Perl_croak(aTHX_ "Can't undef active subroutine");
4d1ff10f 4236#endif /* USE_5005THREADS */
8990e307 4237 ENTER;
a0d0e21e 4238
7766f137 4239 SAVEVPTR(PL_curpad);
3280af22 4240 PL_curpad = 0;
a0d0e21e 4241
282f25c9 4242 op_free(CvROOT(cv));
79072805 4243 CvROOT(cv) = Nullop;
8990e307 4244 LEAVE;
79072805 4245 }
1d5db326 4246 SvPOK_off((SV*)cv); /* forget prototype */
8e07c86e 4247 CvGV(cv) = Nullgv;
282f25c9
JH		 4248 /* Since closure prototypes have the same lifetime as the containing
4249 * CV, they don't hold a refcount on the outside CV. This avoids
4250 * the refcount loop between the outer CV (which keeps a refcount to
4251 * the closure prototype in the pad entry for pp_anoncode()) and the
afa38808
JH		 4252 * closure prototype, and the ensuing memory leak. --GSAR */
4253 if (!CvANON(cv) || CvCLONED(cv))
282f25c9 4254 SvREFCNT_dec(CvOUTSIDE(cv));
8e07c86e 4255 CvOUTSIDE(cv) = Nullcv;
beab0874
JT		 4256 if (CvCONST(cv)) {
4257 SvREFCNT_dec((SV*)CvXSUBANY(cv).any_ptr);
4258 CvCONST_off(cv);
4259 }
8e07c86e 4260 if (CvPADLIST(cv)) {
8ebc5c01 4261 /* may be during global destruction */
4262 if (SvREFCNT(CvPADLIST(cv))) {
93965878 4263 I32 i = AvFILLp(CvPADLIST(cv));
8ebc5c01 4264 while (i >= 0) {
4265 SV** svp = av_fetch(CvPADLIST(cv), i--, FALSE);
46fc3d4c 4266 SV* sv = svp ? *svp : Nullsv;
4267 if (!sv)
4268 continue;
3280af22
NIS		 4269 if (sv == (SV*)PL_comppad_name)
4270 PL_comppad_name = Nullav;
4271 else if (sv == (SV*)PL_comppad) {
4272 PL_comppad = Nullav;
4273 PL_curpad = Null(SV**);
46fc3d4c 4274 }
4275 SvREFCNT_dec(sv);
8ebc5c01 4276 }
4277 SvREFCNT_dec((SV*)CvPADLIST(cv));
8e07c86e 4278 }
8e07c86e
AD		 4279 CvPADLIST(cv) = Nullav;
4280 }
50762d59
DM		 4281 if (CvXSUB(cv)) {
4282 CvXSUB(cv) = 0;
4283 }
a2c090b3 4284 CvFLAGS(cv) = 0;
79072805
LW		 4285}
4286
9cbac4c7 4287#ifdef DEBUG_CLOSURES
76e3520e 4288STATIC void
743e66e6 4289S_cv_dump(pTHX_ CV *cv)
5f05dabc 4290{
62fde642 4291#ifdef DEBUGGING
5f05dabc 4292 CV *outside = CvOUTSIDE(cv);
4293 AV* padlist = CvPADLIST(cv);
4fdae800 4294 AV* pad_name;
4295 AV* pad;
4296 SV** pname;
4297 SV** ppad;
5f05dabc 4298 I32 ix;
4299
b900a521
JH		 4300 PerlIO_printf(Perl_debug_log,
4301 "\tCV=0x%"UVxf" (%s), OUTSIDE=0x%"UVxf" (%s)\n",
4302 PTR2UV(cv),
ab50184a 4303 (CvANON(cv) ? "ANON"
6b88bc9c 4304 : (cv == PL_main_cv) ? "MAIN"
33b8ce05 4305 : CvUNIQUE(cv) ? "UNIQUE"
44a8e56a 4306 : CvGV(cv) ? GvNAME(CvGV(cv)) : "UNDEFINED"),
b900a521 4307 PTR2UV(outside),
ab50184a
CS		 4308 (!outside ? "null"
4309 : CvANON(outside) ? "ANON"
6b88bc9c 4310 : (outside == PL_main_cv) ? "MAIN"
07055b4c 4311 : CvUNIQUE(outside) ? "UNIQUE"
44a8e56a 4312 : CvGV(outside) ? GvNAME(CvGV(outside)) : "UNDEFINED"));
5f05dabc 4313
4fdae800 4314 if (!padlist)
4315 return;
4316
4317 pad_name = (AV*)*av_fetch(padlist, 0, FALSE);
4318 pad = (AV*)*av_fetch(padlist, 1, FALSE);
4319 pname = AvARRAY(pad_name);
4320 ppad = AvARRAY(pad);
4321
93965878 4322 for (ix = 1; ix <= AvFILLp(pad_name); ix++) {
5f05dabc 4323 if (SvPOK(pname[ix]))
b900a521
JH		 4324 PerlIO_printf(Perl_debug_log,
4325 "\t%4d. 0x%"UVxf" (%s\"%s\" %"IVdf"-%"IVdf")\n",
894356b3 4326 (int)ix, PTR2UV(ppad[ix]),
4fdae800 4327 SvFAKE(pname[ix]) ? "FAKE " : "",
4328 SvPVX(pname[ix]),
b900a521
JH		 4329 (IV)I_32(SvNVX(pname[ix])),
4330 SvIVX(pname[ix]));
5f05dabc 4331 }
743e66e6 4332#endif /* DEBUGGING */
62fde642 4333}
9cbac4c7 4334#endif /* DEBUG_CLOSURES */
5f05dabc 4335
76e3520e 4336STATIC CV *
cea2e8a9 4337S_cv_clone2(pTHX_ CV *proto, CV *outside)
748a9306
LW		 4338{
4339 AV* av;
4340 I32 ix;
4341 AV* protopadlist = CvPADLIST(proto);
4342 AV* protopad_name = (AV*)*av_fetch(protopadlist, 0, FALSE);
4343 AV* protopad = (AV*)*av_fetch(protopadlist, 1, FALSE);
5f05dabc 4344 SV** pname = AvARRAY(protopad_name);
4345 SV** ppad = AvARRAY(protopad);
93965878
NIS		 4346 I32 fname = AvFILLp(protopad_name);
4347 I32 fpad = AvFILLp(protopad);
748a9306
LW		 4348 AV* comppadlist;
4349 CV* cv;
4350
07055b4c
CS		 4351 assert(!CvUNIQUE(proto));
4352
748a9306 4353 ENTER;
354992b1 4354 SAVECOMPPAD();
3280af22
NIS		 4355 SAVESPTR(PL_comppad_name);
4356 SAVESPTR(PL_compcv);
748a9306 4357
3280af22 4358 cv = PL_compcv = (CV*)NEWSV(1104,0);
fa83b5b6 4359 sv_upgrade((SV *)cv, SvTYPE(proto));
a57ec3bd 4360 CvFLAGS(cv) = CvFLAGS(proto) & ~CVf_CLONE;
a5f75d66 4361 CvCLONED_on(cv);
748a9306 4362
4d1ff10f 4363#ifdef USE_5005THREADS
12ca11f6 4364 New(666, CvMUTEXP(cv), 1, perl_mutex);
11343788 4365 MUTEX_INIT(CvMUTEXP(cv));
11343788 4366 CvOWNER(cv) = 0;
4d1ff10f 4367#endif /* USE_5005THREADS */
a636914a
RH		 4368#ifdef USE_ITHREADS
4369 CvFILE(cv) = CvXSUB(proto) ? CvFILE(proto)
4370 : savepv(CvFILE(proto));
4371#else
57843af0 4372 CvFILE(cv) = CvFILE(proto);
a636914a 4373#endif
65c50114 4374 CvGV(cv) = CvGV(proto);
748a9306 4375 CvSTASH(cv) = CvSTASH(proto);
282f25c9 4376 CvROOT(cv) = OpREFCNT_inc(CvROOT(proto));
748a9306 4377 CvSTART(cv) = CvSTART(proto);
5f05dabc 4378 if (outside)
4379 CvOUTSIDE(cv) = (CV*)SvREFCNT_inc(outside);
748a9306 4380
68dc0745 4381 if (SvPOK(proto))
4382 sv_setpvn((SV*)cv, SvPVX(proto), SvCUR(proto));
4383
3280af22 4384 PL_comppad_name = newAV();
46fc3d4c 4385 for (ix = fname; ix >= 0; ix--)
3280af22 4386 av_store(PL_comppad_name, ix, SvREFCNT_inc(pname[ix]));
748a9306 4387
3280af22 4388 PL_comppad = newAV();
748a9306
LW		 4389
4390 comppadlist = newAV();
4391 AvREAL_off(comppadlist);
3280af22
NIS		 4392 av_store(comppadlist, 0, (SV*)PL_comppad_name);
4393 av_store(comppadlist, 1, (SV*)PL_comppad);
748a9306 4394 CvPADLIST(cv) = comppadlist;
3280af22
NIS		 4395 av_fill(PL_comppad, AvFILLp(protopad));
4396 PL_curpad = AvARRAY(PL_comppad);
748a9306
LW		 4397
4398 av = newAV(); /* will be @_ */
4399 av_extend(av, 0);
3280af22 4400 av_store(PL_comppad, 0, (SV*)av);
748a9306
LW		 4401 AvFLAGS(av) = AVf_REIFY;
4402
9607fc9c 4403 for (ix = fpad; ix > 0; ix--) {
4404 SV* namesv = (ix <= fname) ? pname[ix] : Nullsv;
3280af22 4405 if (namesv && namesv != &PL_sv_undef) {
aa689395 4406 char *name = SvPVX(namesv); /* XXX */
4407 if (SvFLAGS(namesv) & SVf_FAKE) { /* lexical from outside? */
4408 I32 off = pad_findlex(name, ix, SvIVX(namesv),
2680586e 4409 CvOUTSIDE(cv), cxstack_ix, 0, 0);
5f05dabc 4410 if (!off)
3280af22 4411 PL_curpad[ix] = SvREFCNT_inc(ppad[ix]);
5f05dabc 4412 else if (off != ix)
cea2e8a9 4413 Perl_croak(aTHX_ "panic: cv_clone: %s", name);
748a9306
LW		 4414 }
4415 else { /* our own lexical */
aa689395 4416 SV* sv;
5f05dabc 4417 if (*name == '&') {
4418 /* anon code -- we'll come back for it */
4419 sv = SvREFCNT_inc(ppad[ix]);
4420 }
4421 else if (*name == '@')
4422 sv = (SV*)newAV();
748a9306 4423 else if (*name == '%')
5f05dabc 4424 sv = (SV*)newHV();
748a9306 4425 else
5f05dabc 4426 sv = NEWSV(0,0);
4427 if (!SvPADBUSY(sv))
4428 SvPADMY_on(sv);
3280af22 4429 PL_curpad[ix] = sv;
748a9306
LW		 4430 }
4431 }
7766f137 4432 else if (IS_PADGV(ppad[ix]) || IS_PADCONST(ppad[ix])) {
743e66e6
GS		 4433 PL_curpad[ix] = SvREFCNT_inc(ppad[ix]);
4434 }
748a9306 4435 else {
aa689395 4436 SV* sv = NEWSV(0,0);
748a9306 4437 SvPADTMP_on(sv);
3280af22 4438 PL_curpad[ix] = sv;
748a9306
LW		 4439 }
4440 }
4441
5f05dabc 4442 /* Now that vars are all in place, clone nested closures. */
4443
9607fc9c 4444 for (ix = fpad; ix > 0; ix--) {
4445 SV* namesv = (ix <= fname) ? pname[ix] : Nullsv;
aa689395 4446 if (namesv
3280af22 4447 && namesv != &PL_sv_undef
aa689395 4448 && !(SvFLAGS(namesv) & SVf_FAKE)
4449 && *SvPVX(namesv) == '&'
5f05dabc 4450 && CvCLONE(ppad[ix]))
4451 {
4452 CV *kid = cv_clone2((CV*)ppad[ix], cv);
4453 SvREFCNT_dec(ppad[ix]);
4454 CvCLONE_on(kid);
4455 SvPADMY_on(kid);
3280af22 4456 PL_curpad[ix] = (SV*)kid;
748a9306
LW		 4457 }
4458 }
4459
5f05dabc 4460#ifdef DEBUG_CLOSURES
ab50184a
CS		 4461 PerlIO_printf(Perl_debug_log, "Cloned inside:\n");
4462 cv_dump(outside);
4463 PerlIO_printf(Perl_debug_log, " from:\n");
5f05dabc 4464 cv_dump(proto);
ab50184a 4465 PerlIO_printf(Perl_debug_log, " to:\n");
5f05dabc 4466 cv_dump(cv);
4467#endif
4468
748a9306 4469 LEAVE;
beab0874
JT		 4470
4471 if (CvCONST(cv)) {
4472 SV* const_sv = op_const_sv(CvSTART(cv), cv);
4473 assert(const_sv);
4474 /* constant sub () { $x } closing over $x - see lib/constant.pm */
4475 SvREFCNT_dec(cv);
4476 cv = newCONSTSUB(CvSTASH(proto), 0, const_sv);
4477 }
4478
748a9306
LW		 4479 return cv;
4480}
4481
4482CV *
864dbfa3 4483Perl_cv_clone(pTHX_ CV *proto)
5f05dabc 4484{
b099ddc0 4485 CV *cv;
1feb2720 4486 LOCK_CRED_MUTEX; /* XXX create separate mutex */
b099ddc0 4487 cv = cv_clone2(proto, CvOUTSIDE(proto));
1feb2720 4488 UNLOCK_CRED_MUTEX; /* XXX create separate mutex */
b099ddc0 4489 return cv;
5f05dabc 4490}
4491
3fe9a6f1 4492void
864dbfa3 4493Perl_cv_ckproto(pTHX_ CV *cv, GV *gv, char *p)
3fe9a6f1 4494{
e476b1b5 4495 if (((!p != !SvPOK(cv)) || (p && strNE(p, SvPVX(cv)))) && ckWARN_d(WARN_PROTOTYPE)) {
46fc3d4c 4496 SV* msg = sv_newmortal();
3fe9a6f1 4497 SV* name = Nullsv;
4498
4499 if (gv)
46fc3d4c 4500 gv_efullname3(name = sv_newmortal(), gv, Nullch);
4501 sv_setpv(msg, "Prototype mismatch:");
4502 if (name)
894356b3 4503 Perl_sv_catpvf(aTHX_ msg, " sub %"SVf, name);
3fe9a6f1 4504 if (SvPOK(cv))
cea2e8a9 4505 Perl_sv_catpvf(aTHX_ msg, " (%s)", SvPVX(cv));
46fc3d4c 4506 sv_catpv(msg, " vs ");
4507 if (p)
cea2e8a9 4508 Perl_sv_catpvf(aTHX_ msg, "(%s)", p);
46fc3d4c 4509 else
4510 sv_catpv(msg, "none");
e476b1b5 4511 Perl_warner(aTHX_ WARN_PROTOTYPE, "%"SVf, msg);
3fe9a6f1 4512 }
4513}
4514
acfe0abc 4515static void const_sv_xsub(pTHX_ CV* cv);
beab0874
JT		 4516
4517/*
4518=for apidoc cv_const_sv
4519
4520If C<cv> is a constant sub eligible for inlining. returns the constant
4521value returned by the sub. Otherwise, returns NULL.
4522
4523Constant subs can be created with C<newCONSTSUB> or as described in
4524L<perlsub/"Constant Functions">.
4525
4526=cut
4527*/
760ac839 4528SV *
864dbfa3 4529Perl_cv_const_sv(pTHX_ CV *cv)
760ac839 4530{
beab0874 4531 if (!cv || !CvCONST(cv))
54310121 4532 return Nullsv;
beab0874 4533 return (SV*)CvXSUBANY(cv).any_ptr;
fe5e78ed 4534}
760ac839 4535
fe5e78ed 4536SV *
864dbfa3 4537Perl_op_const_sv(pTHX_ OP *o, CV *cv)
fe5e78ed
GS		 4538{
4539 SV *sv = Nullsv;
4540
0f79a09d 4541 if (!o)
fe5e78ed 4542 return Nullsv;
1c846c1f
NIS		 4543
4544 if (o->op_type == OP_LINESEQ && cLISTOPo->op_first)
fe5e78ed
GS		 4545 o = cLISTOPo->op_first->op_sibling;
4546
4547 for (; o; o = o->op_next) {
54310121 4548 OPCODE type = o->op_type;
fe5e78ed 4549
1c846c1f 4550 if (sv && o->op_next == o)
fe5e78ed 4551 return sv;
e576b457
JT		 4552 if (o->op_next != o) {
4553 if (type == OP_NEXTSTATE || type == OP_NULL || type == OP_PUSHMARK)
4554 continue;
4555 if (type == OP_DBSTATE)
4556 continue;
4557 }
54310121 4558 if (type == OP_LEAVESUB || type == OP_RETURN)
4559 break;
4560 if (sv)
4561 return Nullsv;
7766f137 4562 if (type == OP_CONST && cSVOPo->op_sv)
5dc0d613 4563 sv = cSVOPo->op_sv;
7766f137 4564 else if ((type == OP_PADSV || type == OP_CONST) && cv) {
e858de61
MB		 4565 AV* padav = (AV*)(AvARRAY(CvPADLIST(cv))[1]);
4566 sv = padav ? AvARRAY(padav)[o->op_targ] : Nullsv;
beab0874
JT		 4567 if (!sv)
4568 return Nullsv;
4569 if (CvCONST(cv)) {
4570 /* We get here only from cv_clone2() while creating a closure.
4571 Copy the const value here instead of in cv_clone2 so that
4572 SvREADONLY_on doesn't lead to problems when leaving
4573 scope.
4574 */
4575 sv = newSVsv(sv);
4576 }
4577 if (!SvREADONLY(sv) && SvREFCNT(sv) > 1)
54310121 4578 return Nullsv;
760ac839 4579 }
54310121 4580 else
4581 return Nullsv;
760ac839 4582 }
5aabfad6 4583 if (sv)
4584 SvREADONLY_on(sv);
760ac839
LW		 4585 return sv;
4586}
4587
09bef843
SB		 4588void
4589Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
4590{
4591 if (o)
4592 SAVEFREEOP(o);
4593 if (proto)
4594 SAVEFREEOP(proto);
4595 if (attrs)
4596 SAVEFREEOP(attrs);
4597 if (block)
4598 SAVEFREEOP(block);
4599 Perl_croak(aTHX_ "\"my sub\" not yet implemented");
4600}
4601
748a9306 4602CV *
864dbfa3 4603Perl_newSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *block)
79072805 4604{
09bef843
SB		 4605 return Perl_newATTRSUB(aTHX_ floor, o, proto, Nullop, block);
4606}
4607
4608CV *
4609Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
4610{
2d8e6c8d 4611 STRLEN n_a;
83ee9e09
GS		 4612 char *name;
4613 char *aname;
4614 GV *gv;
2d8e6c8d 4615 char *ps = proto ? SvPVx(((SVOP*)proto)->op_sv, n_a) : Nullch;
a2008d6d 4616 register CV *cv=0;
a0d0e21e 4617 I32 ix;
beab0874 4618 SV *const_sv;
79072805 4619
83ee9e09
GS		 4620 name = o ? SvPVx(cSVOPo->op_sv, n_a) : Nullch;
4621 if (!name && PERLDB_NAMEANON && CopLINE(PL_curcop)) {
4622 SV *sv = sv_newmortal();
4623 Perl_sv_setpvf(aTHX_ sv, "__ANON__[%s:%"IVdf"]",
4624 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
4625 aname = SvPVX(sv);
4626 }
4627 else
4628 aname = Nullch;
4629 gv = gv_fetchpv(name ? name : (aname ? aname : "__ANON__"),
4630 GV_ADDMULTI | ((block || attrs) ? 0 : GV_NOINIT),
4631 SVt_PVCV);
4632
11343788 4633 if (o)
5dc0d613 4634 SAVEFREEOP(o);
3fe9a6f1 4635 if (proto)
4636 SAVEFREEOP(proto);
09bef843
SB		 4637 if (attrs)
4638 SAVEFREEOP(attrs);
3fe9a6f1 4639
09bef843 4640 if (SvTYPE(gv) != SVt_PVGV) { /* Maybe prototype now, and had at
55d729e4
GS		 4641 maximum a prototype before. */
4642 if (SvTYPE(gv) > SVt_NULL) {
0453d815 4643 if (!SvPOK((SV*)gv) && !(SvIOK((SV*)gv) && SvIVX((SV*)gv) == -1)
e476b1b5 4644 && ckWARN_d(WARN_PROTOTYPE))
f248d071 4645 {
e476b1b5 4646 Perl_warner(aTHX_ WARN_PROTOTYPE, "Runaway prototype");
f248d071 4647 }
55d729e4
GS		 4648 cv_ckproto((CV*)gv, NULL, ps);
4649 }
4650 if (ps)
4651 sv_setpv((SV*)gv, ps);
4652 else
4653 sv_setiv((SV*)gv, -1);
3280af22
NIS		 4654 SvREFCNT_dec(PL_compcv);
4655 cv = PL_compcv = NULL;
4656 PL_sub_generation++;
beab0874 4657 goto done;
55d729e4
GS		 4658 }
4659
beab0874
JT		 4660 cv = (!name || GvCVGEN(gv)) ? Nullcv : GvCV(gv);
4661
7fb37951
AMS		 4662#ifdef GV_UNIQUE_CHECK
4663 if (cv && GvUNIQUE(gv) && SvREADONLY(cv)) {
4664 Perl_croak(aTHX_ "Can't define subroutine %s (GV is unique)", name);
5bd07a3d
DM		 4665 }
4666#endif
4667
beab0874
JT		 4668 if (!block || !ps || *ps || attrs)
4669 const_sv = Nullsv;
4670 else
4671 const_sv = op_const_sv(block, Nullcv);
4672
4673 if (cv) {
60ed1d8c 4674 bool exists = CvROOT(cv) || CvXSUB(cv);
5bd07a3d 4675
7fb37951
AMS		 4676#ifdef GV_UNIQUE_CHECK
4677 if (exists && GvUNIQUE(gv)) {
4678 Perl_croak(aTHX_ "Can't redefine unique subroutine %s", name);
5bd07a3d
DM		 4679 }
4680#endif
4681
60ed1d8c
GS		 4682 /* if the subroutine doesn't exist and wasn't pre-declared
4683 * with a prototype, assume it will be AUTOLOADed,
4684 * skipping the prototype check
4685 */
4686 if (exists || SvPOK(cv))
01ec43d0 4687 cv_ckproto(cv, gv, ps);
68dc0745 4688 /* already defined (or promised)? */
60ed1d8c 4689 if (exists || GvASSUMECV(gv)) {
09bef843 4690 if (!block && !attrs) {
aa689395 4691 /* just a "sub foo;" when &foo is already defined */
3280af22 4692 SAVEFREESV(PL_compcv);
aa689395 4693 goto done;
4694 }
7bac28a0 4695 /* ahem, death to those who redefine active sort subs */
3280af22 4696 if (PL_curstackinfo->si_type == PERLSI_SORT && PL_sortcop == CvSTART(cv))
cea2e8a9 4697 Perl_croak(aTHX_ "Can't redefine active sort subroutine %s", name);
beab0874
JT		 4698 if (block) {
4699 if (ckWARN(WARN_REDEFINE)
4700 || (CvCONST(cv)
4701 && (!const_sv || sv_cmp(cv_const_sv(cv), const_sv))))
4702 {
4703 line_t oldline = CopLINE(PL_curcop);
d8a34499
IK		 4704 if (PL_copline != NOLINE)
4705 CopLINE_set(PL_curcop, PL_copline);
beab0874
JT		 4706 Perl_warner(aTHX_ WARN_REDEFINE,
4707 CvCONST(cv) ? "Constant subroutine %s redefined"
4708 : "Subroutine %s redefined", name);
4709 CopLINE_set(PL_curcop, oldline);
4710 }
4711 SvREFCNT_dec(cv);
4712 cv = Nullcv;
79072805 4713 }
79072805
LW		 4714 }
4715 }
beab0874
JT		 4716 if (const_sv) {
4717 SvREFCNT_inc(const_sv);
4718 if (cv) {
0768512c 4719 assert(!CvROOT(cv) && !CvCONST(cv));
beab0874
JT		 4720 sv_setpv((SV*)cv, ""); /* prototype is "" */
4721 CvXSUBANY(cv).any_ptr = const_sv;
4722 CvXSUB(cv) = const_sv_xsub;
4723 CvCONST_on(cv);
beab0874
JT		 4724 }
4725 else {
4726 GvCV(gv) = Nullcv;
4727 cv = newCONSTSUB(NULL, name, const_sv);
4728 }
4729 op_free(block);
4730 SvREFCNT_dec(PL_compcv);
4731 PL_compcv = NULL;
4732 PL_sub_generation++;
4733 goto done;
4734 }
09bef843
SB		 4735 if (attrs) {
4736 HV *stash;
4737 SV *rcv;
4738
4739 /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>
4740 * before we clobber PL_compcv.
4741 */
4742 if (cv && !block) {
4743 rcv = (SV*)cv;
a9164de8 4744 if (CvGV(cv) && GvSTASH(CvGV(cv)))
09bef843 4745 stash = GvSTASH(CvGV(cv));
a9164de8 4746 else if (CvSTASH(cv))
09bef843
SB		 4747 stash = CvSTASH(cv);
4748 else
4749 stash = PL_curstash;
4750 }
4751 else {
4752 /* possibly about to re-define existing subr -- ignore old cv */
4753 rcv = (SV*)PL_compcv;
a9164de8 4754 if (name && GvSTASH(gv))
09bef843
SB		 4755 stash = GvSTASH(gv);
4756 else
4757 stash = PL_curstash;
4758 }
4759 apply_attrs(stash, rcv, attrs);
4760 }
a0d0e21e 4761 if (cv) { /* must reuse cv if autoloaded */
09bef843
SB		 4762 if (!block) {
4763 /* got here with just attrs -- work done, so bug out */
4764 SAVEFREESV(PL_compcv);
4765 goto done;
4766 }
4633a7c4 4767 cv_undef(cv);
3280af22
NIS		 4768 CvFLAGS(cv) = CvFLAGS(PL_compcv);
4769 CvOUTSIDE(cv) = CvOUTSIDE(PL_compcv);
4770 CvOUTSIDE(PL_compcv) = 0;
4771 CvPADLIST(cv) = CvPADLIST(PL_compcv);
4772 CvPADLIST(PL_compcv) = 0;
282f25c9
JH		 4773 /* inner references to PL_compcv must be fixed up ... */
4774 {
4775 AV *padlist = CvPADLIST(cv);
4776 AV *comppad_name = (AV*)AvARRAY(padlist)[0];
4777 AV *comppad = (AV*)AvARRAY(padlist)[1];
4778 SV **namepad = AvARRAY(comppad_name);
4779 SV **curpad = AvARRAY(comppad);
4780 for (ix = AvFILLp(comppad_name); ix > 0; ix--) {
4781 SV *namesv = namepad[ix];
4782 if (namesv && namesv != &PL_sv_undef
4783 && *SvPVX(namesv) == '&')
4784 {
4785 CV *innercv = (CV*)curpad[ix];
4786 if (CvOUTSIDE(innercv) == PL_compcv) {
4787 CvOUTSIDE(innercv) = cv;
4788 if (!CvANON(innercv) || CvCLONED(innercv)) {
4789 (void)SvREFCNT_inc(cv);
4790 SvREFCNT_dec(PL_compcv);
4791 }
4792 }
4793 }
4794 }
4795 }
4796 /* ... before we throw it away */
3280af22 4797 SvREFCNT_dec(PL_compcv);
a933f601
IZ		 4798 if (PERLDB_INTER)/* Advice debugger on the new sub. */
4799 ++PL_sub_generation;
a0d0e21e
LW		 4800 }
4801 else {
3280af22 4802 cv = PL_compcv;
44a8e56a 4803 if (name) {
4804 GvCV(gv) = cv;
4805 GvCVGEN(gv) = 0;
3280af22 4806 PL_sub_generation++;
44a8e56a 4807 }
a0d0e21e 4808 }
65c50114 4809 CvGV(cv) = gv;
a636914a 4810 CvFILE_set_from_cop(cv, PL_curcop);
3280af22 4811 CvSTASH(cv) = PL_curstash;
4d1ff10f 4812#ifdef USE_5005THREADS
11343788 4813 CvOWNER(cv) = 0;
1cfa4ec7 4814 if (!CvMUTEXP(cv)) {
f6aaf501 4815 New(666, CvMUTEXP(cv), 1, perl_mutex);
1cfa4ec7
GS		 4816 MUTEX_INIT(CvMUTEXP(cv));
4817 }
4d1ff10f 4818#endif /* USE_5005THREADS */
8990e307 4819
3fe9a6f1 4820 if (ps)
4821 sv_setpv((SV*)cv, ps);
4633a7c4 4822
3280af22 4823 if (PL_error_count) {
c07a80fd 4824 op_free(block);
4825 block = Nullop;
68dc0745 4826 if (name) {
4827 char *s = strrchr(name, ':');
4828 s = s ? s+1 : name;
6d4c2119
CS		 4829 if (strEQ(s, "BEGIN")) {
4830 char *not_safe =
4831 "BEGIN not safe after errors--compilation aborted";
faef0170 4832 if (PL_in_eval & EVAL_KEEPERR)
cea2e8a9 4833 Perl_croak(aTHX_ not_safe);
6d4c2119
CS		 4834 else {
4835 /* force display of errors found but not reported */
38a03e6e 4836 sv_catpv(ERRSV, not_safe);
cea2e8a9 4837 Perl_croak(aTHX_ "%s", SvPVx(ERRSV, n_a));
6d4c2119
CS		 4838 }
4839 }
68dc0745 4840 }
c07a80fd 4841 }
beab0874
JT		 4842 if (!block)
4843 goto done;
a0d0e21e 4844
3280af22
NIS		 4845 if (AvFILLp(PL_comppad_name) < AvFILLp(PL_comppad))
4846 av_store(PL_comppad_name, AvFILLp(PL_comppad), Nullsv);
a0d0e21e 4847
7766f137 4848 if (CvLVALUE(cv)) {
78f9721b
SM		 4849 CvROOT(cv) = newUNOP(OP_LEAVESUBLV, 0,
4850 mod(scalarseq(block), OP_LEAVESUBLV));
7766f137
GS		 4851 }
4852 else {
4853 CvROOT(cv) = newUNOP(OP_LEAVESUB, 0, scalarseq(block));
4854 }
4855 CvROOT(cv)->op_private |= OPpREFCOUNTED;
4856 OpREFCNT_set(CvROOT(cv), 1);
4857 CvSTART(cv) = LINKLIST(CvROOT(cv));
4858 CvROOT(cv)->op_next = 0;
a2efc822 4859 CALL_PEEP(CvSTART(cv));
7766f137
GS		 4860
4861 /* now that optimizer has done its work, adjust pad values */
54310121 4862 if (CvCLONE(cv)) {
3280af22
NIS		 4863 SV **namep = AvARRAY(PL_comppad_name);
4864 for (ix = AvFILLp(PL_comppad); ix > 0; ix--) {
54310121 4865 SV *namesv;
4866
7766f137 4867 if (SvIMMORTAL(PL_curpad[ix]) || IS_PADGV(PL_curpad[ix]) || IS_PADCONST(PL_curpad[ix]))
54310121 4868 continue;
4869 /*
4870 * The only things that a clonable function needs in its
4871 * pad are references to outer lexicals and anonymous subs.
4872 * The rest are created anew during cloning.
4873 */
4874 if (!((namesv = namep[ix]) != Nullsv &&
3280af22 4875 namesv != &PL_sv_undef &&
54310121 4876 (SvFAKE(namesv) ||
4877 *SvPVX(namesv) == '&')))
4878 {
3280af22
NIS		 4879 SvREFCNT_dec(PL_curpad[ix]);
4880 PL_curpad[ix] = Nullsv;
54310121 4881 }
4882 }
beab0874
JT		 4883 assert(!CvCONST(cv));
4884 if (ps && !*ps && op_const_sv(block, cv))
4885 CvCONST_on(cv);
a0d0e21e 4886 }
54310121 4887 else {
4888 AV *av = newAV(); /* Will be @_ */
4889 av_extend(av, 0);
3280af22 4890 av_store(PL_comppad, 0, (SV*)av);
54310121 4891 AvFLAGS(av) = AVf_REIFY;
79072805 4892
3280af22 4893 for (ix = AvFILLp(PL_comppad); ix > 0; ix--) {
7766f137 4894 if (SvIMMORTAL(PL_curpad[ix]) || IS_PADGV(PL_curpad[ix]) || IS_PADCONST(PL_curpad[ix]))
54310121 4895 continue;
3280af22
NIS		 4896 if (!SvPADMY(PL_curpad[ix]))
4897 SvPADTMP_on(PL_curpad[ix]);
54310121 4898 }
4899 }
79072805 4900
afa38808 4901 /* If a potential closure prototype, don't keep a refcount on outer CV.
282f25c9
JH		 4902 * This is okay as the lifetime of the prototype is tied to the
4903 * lifetime of the outer CV. Avoids memory leak due to reference
4904 * loop. --GSAR */
afa38808 4905 if (!name)
282f25c9
JH		 4906 SvREFCNT_dec(CvOUTSIDE(cv));
4907
83ee9e09 4908 if (name || aname) {
44a8e56a 4909 char *s;
83ee9e09 4910 char *tname = (name ? name : aname);
44a8e56a 4911
3280af22 4912 if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
46fc3d4c 4913 SV *sv = NEWSV(0,0);
44a8e56a 4914 SV *tmpstr = sv_newmortal();
549bb64a 4915 GV *db_postponed = gv_fetchpv("DB::postponed", GV_ADDMULTI, SVt_PVHV);
83ee9e09 4916 CV *pcv;
44a8e56a 4917 HV *hv;
4918
ed094faf
GS		 4919 Perl_sv_setpvf(aTHX_ sv, "%s:%ld-%ld",
4920 CopFILE(PL_curcop),
cc49e20b 4921 (long)PL_subline, (long)CopLINE(PL_curcop));
44a8e56a 4922 gv_efullname3(tmpstr, gv, Nullch);
3280af22 4923 hv_store(GvHV(PL_DBsub), SvPVX(tmpstr), SvCUR(tmpstr), sv, 0);
44a8e56a 4924 hv = GvHVn(db_postponed);
9607fc9c 4925 if (HvFILL(hv) > 0 && hv_exists(hv, SvPVX(tmpstr), SvCUR(tmpstr))
83ee9e09
GS		 4926 && (pcv = GvCV(db_postponed)))
4927 {
44a8e56a 4928 dSP;
924508f0 4929 PUSHMARK(SP);
44a8e56a 4930 XPUSHs(tmpstr);
4931 PUTBACK;
83ee9e09 4932 call_sv((SV*)pcv, G_DISCARD);
44a8e56a 4933 }
4934 }
79072805 4935
83ee9e09 4936 if ((s = strrchr(tname,':')))
28757baa 4937 s++;
4938 else
83ee9e09 4939 s = tname;
ed094faf 4940
7d30b5c4 4941 if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I')
ed094faf
GS		 4942 goto done;
4943
68dc0745 4944 if (strEQ(s, "BEGIN")) {
3280af22 4945 I32 oldscope = PL_scopestack_ix;
28757baa 4946 ENTER;
57843af0
GS		 4947 SAVECOPFILE(&PL_compiling);
4948 SAVECOPLINE(&PL_compiling);
28757baa 4949
3280af22
NIS		 4950 if (!PL_beginav)
4951 PL_beginav = newAV();
28757baa 4952 DEBUG_x( dump_sub(gv) );
ea2f84a3
GS		 4953 av_push(PL_beginav, (SV*)cv);
4954 GvCV(gv) = 0; /* cv has been hijacked */
3280af22 4955 call_list(oldscope, PL_beginav);
a6006777 4956
3280af22 4957 PL_curcop = &PL_compiling;
a0ed51b3 4958 PL_compiling.op_private = PL_hints;
28757baa 4959 LEAVE;
4960 }
3280af22
NIS		 4961 else if (strEQ(s, "END") && !PL_error_count) {
4962 if (!PL_endav)
4963 PL_endav = newAV();
ed094faf 4964 DEBUG_x( dump_sub(gv) );
3280af22 4965 av_unshift(PL_endav, 1);
ea2f84a3
GS		 4966 av_store(PL_endav, 0, (SV*)cv);
4967 GvCV(gv) = 0; /* cv has been hijacked */
28757baa 4968 }
7d30b5c4
GS		 4969 else if (strEQ(s, "CHECK") && !PL_error_count) {
4970 if (!PL_checkav)
4971 PL_checkav = newAV();
ed094faf 4972 DEBUG_x( dump_sub(gv) );
ddda08b7
GS		 4973 if (PL_main_start && ckWARN(WARN_VOID))
4974 Perl_warner(aTHX_ WARN_VOID, "Too late to run CHECK block");
7d30b5c4 4975 av_unshift(PL_checkav, 1);
ea2f84a3
GS		 4976 av_store(PL_checkav, 0, (SV*)cv);
4977 GvCV(gv) = 0; /* cv has been hijacked */
4f25aa18 4978 }
3280af22
NIS		 4979 else if (strEQ(s, "INIT") && !PL_error_count) {
4980 if (!PL_initav)
4981 PL_initav = newAV();
ed094faf 4982 DEBUG_x( dump_sub(gv) );
ddda08b7
GS		 4983 if (PL_main_start && ckWARN(WARN_VOID))
4984 Perl_warner(aTHX_ WARN_VOID, "Too late to run INIT block");
ea2f84a3
GS		 4985 av_push(PL_initav, (SV*)cv);
4986 GvCV(gv) = 0; /* cv has been hijacked */
ae77835f 4987 }
79072805 4988 }
a6006777 4989
aa689395 4990 done:
3280af22 4991 PL_copline = NOLINE;
8990e307 4992 LEAVE_SCOPE(floor);
a0d0e21e 4993 return cv;
79072805
LW		 4994}
4995
b099ddc0 4996/* XXX unsafe for threads if eval_owner isn't held */
954c1994
GS		 4997/*
4998=for apidoc newCONSTSUB
4999
5000Creates a constant sub equivalent to Perl C<sub FOO () { 123 }> which is
5001eligible for inlining at compile-time.
5002
5003=cut
5004*/
5005
beab0874 5006CV *
864dbfa3 5007Perl_newCONSTSUB(pTHX_ HV *stash, char *name, SV *sv)
5476c433 5008{
beab0874 5009 CV* cv;
5476c433 5010
11faa288 5011 ENTER;
11faa288 5012
f4dd75d9 5013 SAVECOPLINE(PL_curcop);
11faa288 5014 CopLINE_set(PL_curcop, PL_copline);
f4dd75d9
GS		 5015
5016 SAVEHINTS();
3280af22 5017 PL_hints &= ~HINT_BLOCK_SCOPE;
11faa288
GS		 5018
5019 if (stash) {
5020 SAVESPTR(PL_curstash);
5021 SAVECOPSTASH(PL_curcop);
5022 PL_curstash = stash;
5023#ifdef USE_ITHREADS
5024 CopSTASHPV(PL_curcop) = stash ? HvNAME(stash) : Nullch;
5025#else
5026 CopSTASH(PL_curcop) = stash;
5027#endif
5028 }
5476c433 5029
beab0874
JT		 5030 cv = newXS(name, const_sv_xsub, __FILE__);
5031 CvXSUBANY(cv).any_ptr = sv;
5032 CvCONST_on(cv);
5033 sv_setpv((SV*)cv, ""); /* prototype is "" */
5476c433 5034
11faa288 5035 LEAVE;
beab0874
JT		 5036
5037 return cv;
5476c433
JD		 5038}
5039
954c1994
GS		 5040/*
5041=for apidoc U||newXS
5042
5043Used by C<xsubpp> to hook up XSUBs as Perl subs.
5044
5045=cut
5046*/
5047
57d3b86d 5048CV *
864dbfa3 5049Perl_newXS(pTHX_ char *name, XSUBADDR_t subaddr, char *filename)
a0d0e21e 5050{
44a8e56a 5051 GV *gv = gv_fetchpv(name ? name : "__ANON__", GV_ADDMULTI, SVt_PVCV);
79072805 5052 register CV *cv;
44a8e56a 5053
155aba94 5054 if ((cv = (name ? GvCV(gv) : Nullcv))) {
44a8e56a 5055 if (GvCVGEN(gv)) {
5056 /* just a cached method */
5057 SvREFCNT_dec(cv);
5058 cv = 0;
5059 }
5060 else if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) {
5061 /* already defined (or promised) */
599cee73 5062 if (ckWARN(WARN_REDEFINE) && !(CvGV(cv) && GvSTASH(CvGV(cv))
2f34f9d4 5063 && strEQ(HvNAME(GvSTASH(CvGV(cv))), "autouse"))) {
57843af0 5064 line_t oldline = CopLINE(PL_curcop);
51f6edd3 5065 if (PL_copline != NOLINE)
57843af0 5066 CopLINE_set(PL_curcop, PL_copline);
beab0874
JT		 5067 Perl_warner(aTHX_ WARN_REDEFINE,
5068 CvCONST(cv) ? "Constant subroutine %s redefined"
5069 : "Subroutine %s redefined"
5070 ,name);
57843af0 5071 CopLINE_set(PL_curcop, oldline);
a0d0e21e
LW		 5072 }
5073 SvREFCNT_dec(cv);
5074 cv = 0;
79072805 5075 }
79072805 5076 }
44a8e56a 5077
5078 if (cv) /* must reuse cv if autoloaded */
5079 cv_undef(cv);
a0d0e21e
LW		 5080 else {
5081 cv = (CV*)NEWSV(1105,0);
5082 sv_upgrade((SV *)cv, SVt_PVCV);
44a8e56a 5083 if (name) {
5084 GvCV(gv) = cv;
5085 GvCVGEN(gv) = 0;
3280af22 5086 PL_sub_generation++;
44a8e56a 5087 }
a0d0e21e 5088 }
65c50114 5089 CvGV(cv) = gv;
4d1ff10f 5090#ifdef USE_5005THREADS
12ca11f6 5091 New(666, CvMUTEXP(cv), 1, perl_mutex);
11343788 5092 MUTEX_INIT(CvMUTEXP(cv));
11343788 5093 CvOWNER(cv) = 0;
4d1ff10f 5094#endif /* USE_5005THREADS */
b195d487 5095 (void)gv_fetchfile(filename);
57843af0
GS		 5096 CvFILE(cv) = filename; /* NOTE: not copied, as it is expected to be
5097 an external constant string */
a0d0e21e 5098 CvXSUB(cv) = subaddr;
44a8e56a 5099
28757baa 5100 if (name) {
5101 char *s = strrchr(name,':');
5102 if (s)
5103 s++;
5104 else
5105 s = name;
ed094faf 5106
7d30b5c4 5107 if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I')
ed094faf
GS		 5108 goto done;
5109
28757baa 5110 if (strEQ(s, "BEGIN")) {
3280af22
NIS		 5111 if (!PL_beginav)
5112 PL_beginav = newAV();
ea2f84a3
GS		 5113 av_push(PL_beginav, (SV*)cv);
5114 GvCV(gv) = 0; /* cv has been hijacked */
28757baa 5115 }
5116 else if (strEQ(s, "END")) {
3280af22
NIS		 5117 if (!PL_endav)
5118 PL_endav = newAV();
5119 av_unshift(PL_endav, 1);
ea2f84a3
GS		 5120 av_store(PL_endav, 0, (SV*)cv);
5121 GvCV(gv) = 0; /* cv has been hijacked */
28757baa 5122 }
7d30b5c4
GS		 5123 else if (strEQ(s, "CHECK")) {
5124 if (!PL_checkav)
5125 PL_checkav = newAV();
ddda08b7
GS		 5126 if (PL_main_start && ckWARN(WARN_VOID))
5127 Perl_warner(aTHX_ WARN_VOID, "Too late to run CHECK block");
7d30b5c4 5128 av_unshift(PL_checkav, 1);
ea2f84a3
GS		 5129 av_store(PL_checkav, 0, (SV*)cv);
5130 GvCV(gv) = 0; /* cv has been hijacked */
4f25aa18 5131 }
7d07dbc2 5132 else if (strEQ(s, "INIT")) {
3280af22
NIS		 5133 if (!PL_initav)
5134 PL_initav = newAV();
ddda08b7
GS		 5135 if (PL_main_start && ckWARN(WARN_VOID))
5136 Perl_warner(aTHX_ WARN_VOID, "Too late to run INIT block");
ea2f84a3
GS		 5137 av_push(PL_initav, (SV*)cv);
5138 GvCV(gv) = 0; /* cv has been hijacked */
ae77835f 5139 }
28757baa 5140 }
8990e307 5141 else
a5f75d66 5142 CvANON_on(cv);
44a8e56a 5143
ed094faf 5144done:
a0d0e21e 5145 return cv;
79072805
LW		 5146}
5147
5148void
864dbfa3 5149Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block)
79072805
LW		 5150{
5151 register CV *cv;
5152 char *name;
5153 GV *gv;
a0d0e21e 5154 I32 ix;
2d8e6c8d 5155 STRLEN n_a;
79072805 5156
11343788 5157 if (o)
2d8e6c8d 5158 name = SvPVx(cSVOPo->op_sv, n_a);
79072805
LW		 5159 else
5160 name = "STDOUT";
85e6fe83 5161 gv = gv_fetchpv(name,TRUE, SVt_PVFM);
7fb37951
AMS		 5162#ifdef GV_UNIQUE_CHECK
5163 if (GvUNIQUE(gv)) {
5164 Perl_croak(aTHX_ "Bad symbol for form (GV is unique)");
5bd07a3d
DM		 5165 }
5166#endif
a5f75d66 5167 GvMULTI_on(gv);
155aba94 5168 if ((cv = GvFORM(gv))) {
599cee73 5169 if (ckWARN(WARN_REDEFINE)) {
57843af0 5170 line_t oldline = CopLINE(PL_curcop);
d8a34499
IK		 5171 if (PL_copline != NOLINE)
5172 CopLINE_set(PL_curcop, PL_copline);
cea2e8a9 5173 Perl_warner(aTHX_ WARN_REDEFINE, "Format %s redefined",name);
57843af0 5174 CopLINE_set(PL_curcop, oldline);
79072805 5175 }
8990e307 5176 SvREFCNT_dec(cv);
79072805 5177 }
3280af22 5178 cv = PL_compcv;
79072805 5179 GvFORM(gv) = cv;
65c50114 5180 CvGV(cv) = gv;
a636914a 5181 CvFILE_set_from_cop(cv, PL_curcop);
79072805 5182
3280af22
NIS		 5183 for (ix = AvFILLp(PL_comppad); ix > 0; ix--) {
5184 if (!SvPADMY(PL_curpad[ix]) && !SvIMMORTAL(PL_curpad[ix]))
5185 SvPADTMP_on(PL_curpad[ix]);
a0d0e21e
LW		 5186 }
5187
79072805 5188 CvROOT(cv) = newUNOP(OP_LEAVEWRITE, 0, scalarseq(block));
7934575e
GS		 5189 CvROOT(cv)->op_private |= OPpREFCOUNTED;
5190 OpREFCNT_set(CvROOT(cv), 1);
79072805
LW		 5191 CvSTART(cv) = LINKLIST(CvROOT(cv));
5192 CvROOT(cv)->op_next = 0;
a2efc822 5193 CALL_PEEP(CvSTART(cv));
11343788 5194 op_free(o);
3280af22 5195 PL_copline = NOLINE;
8990e307 5196 LEAVE_SCOPE(floor);
79072805
LW		 5197}
5198
5199OP *
864dbfa3 5200Perl_newANONLIST(pTHX_ OP *o)
79072805 5201{
93a17b20 5202 return newUNOP(OP_REFGEN, 0,
11343788 5203 mod(list(convert(OP_ANONLIST, 0, o)), OP_REFGEN));
79072805
LW		 5204}
5205
5206OP *
864dbfa3 5207Perl_newANONHASH(pTHX_ OP *o)
79072805 5208{
93a17b20 5209 return newUNOP(OP_REFGEN, 0,
11343788 5210 mod(list(convert(OP_ANONHASH, 0, o)), OP_REFGEN));
a0d0e21e
LW		 5211}
5212
5213OP *
864dbfa3 5214Perl_newANONSUB(pTHX_ I32 floor, OP *proto, OP *block)
a0d0e21e 5215{
09bef843
SB		 5216 return newANONATTRSUB(floor, proto, Nullop, block);
5217}
5218
5219OP *
5220Perl_newANONATTRSUB(pTHX_ I32 floor, OP *proto, OP *attrs, OP *block)
5221{
a0d0e21e 5222 return newUNOP(OP_REFGEN, 0,
09bef843
SB		 5223 newSVOP(OP_ANONCODE, 0,
5224 (SV*)newATTRSUB(floor, 0, proto, attrs, block)));
79072805
LW		 5225}
5226
5227OP *
864dbfa3 5228Perl_oopsAV(pTHX_ OP *o)
79072805 5229{
ed6116ce
LW		 5230 switch (o->op_type) {
5231 case OP_PADSV:
5232 o->op_type = OP_PADAV;
22c35a8c 5233 o->op_ppaddr = PL_ppaddr[OP_PADAV];
51e247a3 5234 return ref(o, OP_RV2AV);
ed6116ce
LW		 5235
5236 case OP_RV2SV:
79072805 5237 o->op_type = OP_RV2AV;
22c35a8c 5238 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
79072805 5239 ref(o, OP_RV2AV);
ed6116ce
LW		 5240 break;
5241
5242 default:
0453d815
PM		 5243 if (ckWARN_d(WARN_INTERNAL))
5244 Perl_warner(aTHX_ WARN_INTERNAL, "oops: oopsAV");
ed6116ce
LW		 5245 break;
5246 }
79072805
LW		 5247 return o;
5248}
5249
5250OP *
864dbfa3 5251Perl_oopsHV(pTHX_ OP *o)
79072805 5252{
ed6116ce
LW		 5253 switch (o->op_type) {
5254 case OP_PADSV:
5255 case OP_PADAV:
5256 o->op_type = OP_PADHV;
22c35a8c 5257 o->op_ppaddr = PL_ppaddr[OP_PADHV];
51e247a3 5258 return ref(o, OP_RV2HV);
ed6116ce
LW		 5259
5260 case OP_RV2SV:
5261 case OP_RV2AV:
79072805 5262 o->op_type = OP_RV2HV;
22c35a8c 5263 o->op_ppaddr = PL_ppaddr[OP_RV2HV];
79072805 5264 ref(o, OP_RV2HV);
ed6116ce
LW		 5265 break;
5266
5267 default:
0453d815
PM		 5268 if (ckWARN_d(WARN_INTERNAL))
5269 Perl_warner(aTHX_ WARN_INTERNAL, "oops: oopsHV");
ed6116ce
LW		 5270 break;
5271 }
79072805
LW		 5272 return o;
5273}
5274
5275OP *
864dbfa3 5276Perl_newAVREF(pTHX_ OP *o)
79072805 5277{
ed6116ce
LW		 5278 if (o->op_type == OP_PADANY) {
5279 o->op_type = OP_PADAV;
22c35a8c 5280 o->op_ppaddr = PL_ppaddr[OP_PADAV];
93a17b20 5281 return o;
ed6116ce 5282 }
a1063b2d
RH		 5283 else if ((o->op_type == OP_RV2AV || o->op_type == OP_PADAV)
5284 && ckWARN(WARN_DEPRECATED)) {
5285 Perl_warner(aTHX_ WARN_DEPRECATED,
5286 "Using an array as a reference is deprecated");
5287 }
79072805
LW		 5288 return newUNOP(OP_RV2AV, 0, scalar(o));
5289}
5290
5291OP *
864dbfa3 5292Perl_newGVREF(pTHX_ I32 type, OP *o)
79072805 5293{
82092f1d 5294 if (type == OP_MAPSTART || type == OP_GREPSTART || type == OP_SORT)
a0d0e21e 5295 return newUNOP(OP_NULL, 0, o);
748a9306 5296 return ref(newUNOP(OP_RV2GV, OPf_REF, o), type);
79072805
LW		 5297}
5298
5299OP *
864dbfa3 5300Perl_newHVREF(pTHX_ OP *o)
79072805 5301{
ed6116ce
LW		 5302 if (o->op_type == OP_PADANY) {
5303 o->op_type = OP_PADHV;
22c35a8c 5304 o->op_ppaddr = PL_ppaddr[OP_PADHV];
93a17b20 5305 return o;
ed6116ce 5306 }
a1063b2d
RH		 5307 else if ((o->op_type == OP_RV2HV || o->op_type == OP_PADHV)
5308 && ckWARN(WARN_DEPRECATED)) {
5309 Perl_warner(aTHX_ WARN_DEPRECATED,
5310 "Using a hash as a reference is deprecated");
5311 }
79072805
LW		 5312 return newUNOP(OP_RV2HV, 0, scalar(o));
5313}
5314
5315OP *
864dbfa3 5316Perl_oopsCV(pTHX_ OP *o)
79072805 5317{
cea2e8a9 5318 Perl_croak(aTHX_ "NOT IMPL LINE %d",__LINE__);
79072805
LW		 5319 /* STUB */
5320 return o;
5321}
5322
5323OP *
864dbfa3 5324Perl_newCVREF(pTHX_ I32 flags, OP *o)
79072805 5325{
c07a80fd 5326 return newUNOP(OP_RV2CV, flags, scalar(o));
79072805
LW		 5327}
5328
5329OP *
864dbfa3 5330Perl_newSVREF(pTHX_ OP *o)
79072805 5331{
ed6116ce
LW		 5332 if (o->op_type == OP_PADANY) {
5333 o->op_type = OP_PADSV;
22c35a8c 5334 o->op_ppaddr = PL_ppaddr[OP_PADSV];
93a17b20 5335 return o;
ed6116ce 5336 }
224a4551
MB		 5337 else if (o->op_type == OP_THREADSV && !(o->op_flags & OPpDONE_SVREF)) {
5338 o->op_flags |= OPpDONE_SVREF;
a863c7d1 5339 return o;
224a4551 5340 }
79072805
LW		 5341 return newUNOP(OP_RV2SV, 0, scalar(o));
5342}
5343
5344/* Check routines. */
5345
5346OP *
cea2e8a9 5347Perl_ck_anoncode(pTHX_ OP *o)
5f05dabc 5348{
178c6305
CS		 5349 PADOFFSET ix;
5350 SV* name;
5351
5352 name = NEWSV(1106,0);
5353 sv_upgrade(name, SVt_PVNV);
5354 sv_setpvn(name, "&", 1);
5355 SvIVX(name) = -1;
5356 SvNVX(name) = 1;
5dc0d613 5357 ix = pad_alloc(o->op_type, SVs_PADMY);
3280af22
NIS		 5358 av_store(PL_comppad_name, ix, name);
5359 av_store(PL_comppad, ix, cSVOPo->op_sv);
5dc0d613
MB		 5360 SvPADMY_on(cSVOPo->op_sv);
5361 cSVOPo->op_sv = Nullsv;
5362 cSVOPo->op_targ = ix;
5363 return o;
5f05dabc 5364}
5365
5366OP *
cea2e8a9 5367Perl_ck_bitop(pTHX_ OP *o)
55497cff 5368{
3280af22 5369 o->op_private = PL_hints;
5dc0d613 5370 return o;
55497cff 5371}
5372
5373OP *
cea2e8a9 5374Perl_ck_concat(pTHX_ OP *o)
79072805 5375{
11343788
MB		 5376 if (cUNOPo->op_first->op_type == OP_CONCAT)
5377 o->op_flags |= OPf_STACKED;
5378 return o;
79072805
LW		 5379}
5380
5381OP *
cea2e8a9 5382Perl_ck_spair(pTHX_ OP *o)
79072805 5383{
11343788 5384 if (o->op_flags & OPf_KIDS) {
79072805 5385 OP* newop;
a0d0e21e 5386 OP* kid;
5dc0d613
MB		 5387 OPCODE type = o->op_type;
5388 o = modkids(ck_fun(o), type);
11343788 5389 kid = cUNOPo->op_first;
a0d0e21e
LW		 5390 newop = kUNOP->op_first->op_sibling;
5391 if (newop &&
5392 (newop->op_sibling ||
22c35a8c 5393 !(PL_opargs[newop->op_type] & OA_RETSCALAR) ||
a0d0e21e
LW		 5394 newop->op_type == OP_PADAV || newop->op_type == OP_PADHV ||
5395 newop->op_type == OP_RV2AV || newop->op_type == OP_RV2HV)) {
aeea060c 5396
11343788 5397 return o;
a0d0e21e
LW		 5398 }
5399 op_free(kUNOP->op_first);
5400 kUNOP->op_first = newop;
5401 }
22c35a8c 5402 o->op_ppaddr = PL_ppaddr[++o->op_type];
11343788 5403 return ck_fun(o);
a0d0e21e
LW		 5404}
5405
5406OP *
cea2e8a9 5407Perl_ck_delete(pTHX_ OP *o)
a0d0e21e 5408{
11343788 5409 o = ck_fun(o);
5dc0d613 5410 o->op_private = 0;
11343788
MB		 5411 if (o->op_flags & OPf_KIDS) {
5412 OP *kid = cUNOPo->op_first;
01020589
GS		 5413 switch (kid->op_type) {
5414 case OP_ASLICE:
5415 o->op_flags |= OPf_SPECIAL;
5416 /* FALL THROUGH */
5417 case OP_HSLICE:
5dc0d613 5418 o->op_private |= OPpSLICE;
01020589
GS		 5419 break;
5420 case OP_AELEM:
5421 o->op_flags |= OPf_SPECIAL;
5422 /* FALL THROUGH */
5423 case OP_HELEM:
5424 break;
5425 default:
5426 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element or slice",
53e06cf0 5427 OP_DESC(o));
01020589 5428 }
93c66552 5429 op_null(kid);
79072805 5430 }
11343788 5431 return o;
79072805
LW		 5432}
5433
5434OP *
96e176bf
CL		 5435Perl_ck_die(pTHX_ OP *o)
5436{
5437#ifdef VMS
5438 if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
5439#endif
5440 return ck_fun(o);
5441}
5442
5443OP *
cea2e8a9 5444Perl_ck_eof(pTHX_ OP *o)
79072805 5445{
11343788 5446 I32 type = o->op_type;
79072805 5447
11343788
MB		 5448 if (o->op_flags & OPf_KIDS) {
5449 if (cLISTOPo->op_first->op_type == OP_STUB) {
5450 op_free(o);
5451 o = newUNOP(type, OPf_SPECIAL,
d58bf5aa 5452 newGVOP(OP_GV, 0, gv_fetchpv("main::ARGV", TRUE, SVt_PVAV)));
8990e307 5453 }
11343788 5454 return ck_fun(o);
79072805 5455 }
11343788 5456 return o;
79072805
LW		 5457}
5458
5459OP *
cea2e8a9 5460Perl_ck_eval(pTHX_ OP *o)
79072805 5461{
3280af22 5462 PL_hints |= HINT_BLOCK_SCOPE;
11343788
MB		 5463 if (o->op_flags & OPf_KIDS) {
5464 SVOP *kid = (SVOP*)cUNOPo->op_first;
79072805 5465
93a17b20 5466 if (!kid) {
11343788 5467 o->op_flags &= ~OPf_KIDS;
93c66552 5468 op_null(o);
79072805
LW		 5469 }
5470 else if (kid->op_type == OP_LINESEQ) {
5471 LOGOP *enter;
5472
11343788
MB		 5473 kid->op_next = o->op_next;
5474 cUNOPo->op_first = 0;
5475 op_free(o);
79072805 5476
b7dc083c 5477 NewOp(1101, enter, 1, LOGOP);
79072805 5478 enter->op_type = OP_ENTERTRY;
22c35a8c 5479 enter->op_ppaddr = PL_ppaddr[OP_ENTERTRY];
79072805
LW		 5480 enter->op_private = 0;
5481
5482 /* establish postfix order */
5483 enter->op_next = (OP*)enter;
5484
11343788
MB		 5485 o = prepend_elem(OP_LINESEQ, (OP*)enter, (OP*)kid);
5486 o->op_type = OP_LEAVETRY;
22c35a8c 5487 o->op_ppaddr = PL_ppaddr[OP_LEAVETRY];
11343788
MB		 5488 enter->op_other = o;
5489 return o;
79072805 5490 }
c7cc6f1c 5491 else
473986ff 5492 scalar((OP*)kid);
79072805
LW		 5493 }
5494 else {
11343788 5495 op_free(o);
54b9620d 5496 o = newUNOP(OP_ENTEREVAL, 0, newDEFSVOP());
79072805 5497 }
3280af22 5498 o->op_targ = (PADOFFSET)PL_hints;
11343788 5499 return o;
79072805
LW		 5500}
5501
5502OP *
d98f61e7
GS		 5503Perl_ck_exit(pTHX_ OP *o)
5504{
5505#ifdef VMS
5506 HV *table = GvHV(PL_hintgv);
5507 if (table) {
5508 SV **svp = hv_fetch(table, "vmsish_exit", 11, FALSE);
5509 if (svp && *svp && SvTRUE(*svp))
5510 o->op_private |= OPpEXIT_VMSISH;
5511 }
96e176bf 5512 if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
d98f61e7
GS		 5513#endif
5514 return ck_fun(o);
5515}
5516
5517OP *
cea2e8a9 5518Perl_ck_exec(pTHX_ OP *o)
79072805
LW		 5519{
5520 OP *kid;
11343788
MB		 5521 if (o->op_flags & OPf_STACKED) {
5522 o = ck_fun(o);
5523 kid = cUNOPo->op_first->op_sibling;
8990e307 5524 if (kid->op_type == OP_RV2GV)
93c66552 5525 op_null(kid);
79072805 5526 }
463ee0b2 5527 else
11343788
MB		 5528 o = listkids(o);
5529 return o;
79072805
LW		 5530}
5531
5532OP *
cea2e8a9 5533Perl_ck_exists(pTHX_ OP *o)
5f05dabc 5534{
5196be3e
MB		 5535 o = ck_fun(o);
5536 if (o->op_flags & OPf_KIDS) {
5537 OP *kid = cUNOPo->op_first;
afebc493
GS		 5538 if (kid->op_type == OP_ENTERSUB) {
5539 (void) ref(kid, o->op_type);
5540 if (kid->op_type != OP_RV2CV && !PL_error_count)
5541 Perl_croak(aTHX_ "%s argument is not a subroutine name",
53e06cf0 5542 OP_DESC(o));
afebc493
GS		 5543 o->op_private |= OPpEXISTS_SUB;
5544 }
5545 else if (kid->op_type == OP_AELEM)
01020589
GS		 5546 o->op_flags |= OPf_SPECIAL;
5547 else if (kid->op_type != OP_HELEM)
5548 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element",
53e06cf0 5549 OP_DESC(o));
93c66552 5550 op_null(kid);
5f05dabc 5551 }
5196be3e 5552 return o;
5f05dabc 5553}
5554
22c35a8c 5555#if 0
5f05dabc 5556OP *
cea2e8a9 5557Perl_ck_gvconst(pTHX_ register OP *o)
79072805
LW		 5558{
5559 o = fold_constants(o);
5560 if (o->op_type == OP_CONST)
5561 o->op_type = OP_GV;
5562 return o;
5563}
22c35a8c 5564#endif
79072805
LW		 5565
5566OP *
cea2e8a9 5567Perl_ck_rvconst(pTHX_ register OP *o)
79072805 5568{
11343788 5569 SVOP *kid = (SVOP*)cUNOPo->op_first;
85e6fe83 5570
3280af22 5571 o->op_private |= (PL_hints & HINT_STRICT_REFS);
79072805 5572 if (kid->op_type == OP_CONST) {
44a8e56a 5573 char *name;
5574 int iscv;
5575 GV *gv;
779c5bc9 5576 SV *kidsv = kid->op_sv;
2d8e6c8d 5577 STRLEN n_a;
44a8e56a 5578
779c5bc9
GS		 5579 /* Is it a constant from cv_const_sv()? */
5580 if (SvROK(kidsv) && SvREADONLY(kidsv)) {
5581 SV *rsv = SvRV(kidsv);
5582 int svtype = SvTYPE(rsv);
5583 char *badtype = Nullch;
5584
5585 switch (o->op_type) {
5586 case OP_RV2SV:
5587 if (svtype > SVt_PVMG)
5588 badtype = "a SCALAR";
5589 break;
5590 case OP_RV2AV:
5591 if (svtype != SVt_PVAV)
5592 badtype = "an ARRAY";
5593 break;
5594 case OP_RV2HV:
5595 if (svtype != SVt_PVHV) {
5596 if (svtype == SVt_PVAV) { /* pseudohash? */
5597 SV **ksv = av_fetch((AV*)rsv, 0, FALSE);
5598 if (ksv && SvROK(*ksv)
5599 && SvTYPE(SvRV(*ksv)) == SVt_PVHV)
5600 {
5601 break;
5602 }
5603 }
5604 badtype = "a HASH";
5605 }
5606 break;
5607 case OP_RV2CV:
5608 if (svtype != SVt_PVCV)
5609 badtype = "a CODE";
5610 break;
5611 }
5612 if (badtype)
cea2e8a9 5613 Perl_croak(aTHX_ "Constant is not %s reference", badtype);
779c5bc9
GS		 5614 return o;
5615 }
2d8e6c8d 5616 name = SvPV(kidsv, n_a);
3280af22 5617 if ((PL_hints & HINT_STRICT_REFS) && (kid->op_private & OPpCONST_BARE)) {
44a8e56a 5618 char *badthing = Nullch;
5dc0d613 5619 switch (o->op_type) {
44a8e56a 5620 case OP_RV2SV:
5621 badthing = "a SCALAR";
5622 break;
5623 case OP_RV2AV:
5624 badthing = "an ARRAY";
5625 break;
5626 case OP_RV2HV:
5627 badthing = "a HASH";
5628 break;
5629 }
5630 if (badthing)
1c846c1f 5631 Perl_croak(aTHX_
44a8e56a 5632 "Can't use bareword (\"%s\") as %s ref while \"strict refs\" in use",
5633 name, badthing);
5634 }
93233ece
CS		 5635 /*
5636 * This is a little tricky. We only want to add the symbol if we
5637 * didn't add it in the lexer. Otherwise we get duplicate strict
5638 * warnings. But if we didn't add it in the lexer, we must at
5639 * least pretend like we wanted to add it even if it existed before,
5640 * or we get possible typo warnings. OPpCONST_ENTERED says
5641 * whether the lexer already added THIS instance of this symbol.
5642 */
5196be3e 5643 iscv = (o->op_type == OP_RV2CV) * 2;
93233ece 5644 do {
44a8e56a 5645 gv = gv_fetchpv(name,
748a9306 5646 iscv | !(kid->op_private & OPpCONST_ENTERED),
a0d0e21e
LW		 5647 iscv
5648 ? SVt_PVCV
11343788 5649 : o->op_type == OP_RV2SV
a0d0e21e 5650 ? SVt_PV
11343788 5651 : o->op_type == OP_RV2AV
a0d0e21e 5652 ? SVt_PVAV
11343788 5653 : o->op_type == OP_RV2HV
a0d0e21e
LW		 5654 ? SVt_PVHV
5655 : SVt_PVGV);
93233ece
CS		 5656 } while (!gv && !(kid->op_private & OPpCONST_ENTERED) && !iscv++);
5657 if (gv) {
5658 kid->op_type = OP_GV;
5659 SvREFCNT_dec(kid->op_sv);
350de78d 5660#ifdef USE_ITHREADS
638eceb6 5661 /* XXX hack: dependence on sizeof(PADOP) <= sizeof(SVOP) */
350de78d 5662 kPADOP->op_padix = pad_alloc(OP_GV, SVs_PADTMP);
63caf608 5663 SvREFCNT_dec(PL_curpad[kPADOP->op_padix]);
743e66e6 5664 GvIN_PAD_on(gv);
350de78d
GS		 5665 PL_curpad[kPADOP->op_padix] = SvREFCNT_inc(gv);
5666#else
93233ece 5667 kid->op_sv = SvREFCNT_inc(gv);
350de78d 5668#endif
23f1ca44 5669 kid->op_private = 0;
76cd736e 5670 kid->op_ppaddr = PL_ppaddr[OP_GV];
a0d0e21e 5671 }
79072805 5672 }
11343788 5673 return o;
79072805
LW		 5674}
5675
5676OP *
cea2e8a9 5677Perl_ck_ftst(pTHX_ OP *o)
79072805 5678{
11343788 5679 I32 type = o->op_type;
79072805 5680
d0dca557
JD		 5681 if (o->op_flags & OPf_REF) {
5682 /* nothing */
5683 }
5684 else if (o->op_flags & OPf_KIDS && cUNOPo->op_first->op_type != OP_STUB) {
11343788 5685 SVOP *kid = (SVOP*)cUNOPo->op_first;
79072805
LW		 5686
5687 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
2d8e6c8d 5688 STRLEN n_a;
a0d0e21e 5689 OP *newop = newGVOP(type, OPf_REF,
2d8e6c8d 5690 gv_fetchpv(SvPVx(kid->op_sv, n_a), TRUE, SVt_PVIO));
11343788 5691 op_free(o);
d0dca557 5692 o = newop;
79072805
LW		 5693 }
5694 }
5695 else {
11343788 5696 op_free(o);
79072805 5697 if (type == OP_FTTTY)
d0dca557 5698 o = newGVOP(type, OPf_REF, gv_fetchpv("main::STDIN", TRUE,
85e6fe83 5699 SVt_PVIO));
79072805 5700 else
d0dca557 5701 o = newUNOP(type, 0, newDEFSVOP());
79072805 5702 }
11343788 5703 return o;
79072805
LW		 5704}
5705
5706OP *
cea2e8a9 5707Perl_ck_fun(pTHX_ OP *o)
79072805
LW		 5708{
5709 register OP *kid;
5710 OP **tokid;
5711 OP *sibl;
5712 I32 numargs = 0;
11343788 5713 int type = o->op_type;
22c35a8c 5714 register I32 oa = PL_opargs[type] >> OASHIFT;
aeea060c 5715
11343788 5716 if (o->op_flags & OPf_STACKED) {
79072805
LW		 5717 if ((oa & OA_OPTIONAL) && (oa >> 4) && !((oa >> 4) & OA_OPTIONAL))
5718 oa &= ~OA_OPTIONAL;
5719 else
11343788 5720 return no_fh_allowed(o);
79072805
LW		 5721 }
5722
11343788 5723 if (o->op_flags & OPf_KIDS) {
2d8e6c8d 5724 STRLEN n_a;
11343788
MB		 5725 tokid = &cLISTOPo->op_first;
5726 kid = cLISTOPo->op_first;
8990e307 5727 if (kid->op_type == OP_PUSHMARK ||
155aba94 5728 (kid->op_type == OP_NULL && kid->op_targ == OP_PUSHMARK))
8990e307 5729 {
79072805
LW		 5730 tokid = &kid->op_sibling;
5731 kid = kid->op_sibling;
5732 }
22c35a8c 5733 if (!kid && PL_opargs[type] & OA_DEFGV)
54b9620d 5734 *tokid = kid = newDEFSVOP();
79072805
LW		 5735
5736 while (oa && kid) {
5737 numargs++;
5738 sibl = kid->op_sibling;
5739 switch (oa & 7) {
5740 case OA_SCALAR:
62c18ce2
GS		 5741 /* list seen where single (scalar) arg expected? */
5742 if (numargs == 1 && !(oa >> 4)
5743 && kid->op_type == OP_LIST && type != OP_SCALAR)
5744 {
5745 return too_many_arguments(o,PL_op_desc[type]);
5746 }
79072805
LW		 5747 scalar(kid);
5748 break;
5749 case OA_LIST:
5750 if (oa < 16) {
5751 kid = 0;
5752 continue;
5753 }
5754 else
5755 list(kid);
5756 break;
5757 case OA_AVREF:
936edb8b 5758 if ((type == OP_PUSH || type == OP_UNSHIFT)
f87c3213
JH		 5759 && !kid->op_sibling && ckWARN(WARN_SYNTAX))
5760 Perl_warner(aTHX_ WARN_SYNTAX,
de4864e4 5761 "Useless use of %s with no values",
936edb8b
RH		 5762 PL_op_desc[type]);
5763
79072805 5764 if (kid->op_type == OP_CONST &&
62c18ce2
GS		 5765 (kid->op_private & OPpCONST_BARE))
5766 {
2d8e6c8d 5767 char *name = SvPVx(((SVOP*)kid)->op_sv, n_a);
79072805 5768 OP *newop = newAVREF(newGVOP(OP_GV, 0,
85e6fe83 5769 gv_fetchpv(name, TRUE, SVt_PVAV) ));
e476b1b5
GS		 5770 if (ckWARN(WARN_DEPRECATED))
5771 Perl_warner(aTHX_ WARN_DEPRECATED,
57def98f 5772 "Array @%s missing the @ in argument %"IVdf" of %s()",
cf2093f6 5773 name, (IV)numargs, PL_op_desc[type]);
79072805
LW		 5774 op_free(kid);
5775 kid = newop;
5776 kid->op_sibling = sibl;
5777 *tokid = kid;
5778 }
8990e307 5779 else if (kid->op_type != OP_RV2AV && kid->op_type != OP_PADAV)
35cd451c 5780 bad_type(numargs, "array", PL_op_desc[type], kid);
a0d0e21e 5781 mod(kid, type);
79072805
LW		 5782 break;
5783 case OA_HVREF:
5784 if (kid->op_type == OP_CONST &&
62c18ce2
GS		 5785 (kid->op_private & OPpCONST_BARE))
5786 {
2d8e6c8d 5787 char *name = SvPVx(((SVOP*)kid)->op_sv, n_a);
79072805 5788 OP *newop = newHVREF(newGVOP(OP_GV, 0,
85e6fe83 5789 gv_fetchpv(name, TRUE, SVt_PVHV) ));
e476b1b5
GS		 5790 if (ckWARN(WARN_DEPRECATED))
5791 Perl_warner(aTHX_ WARN_DEPRECATED,
57def98f 5792 "Hash %%%s missing the %% in argument %"IVdf" of %s()",
cf2093f6 5793 name, (IV)numargs, PL_op_desc[type]);
79072805
LW		 5794 op_free(kid);
5795 kid = newop;
5796 kid->op_sibling = sibl;
5797 *tokid = kid;
5798 }
8990e307 5799 else if (kid->op_type != OP_RV2HV && kid->op_type != OP_PADHV)
35cd451c 5800 bad_type(numargs, "hash", PL_op_desc[type], kid);
a0d0e21e 5801 mod(kid, type);
79072805
LW		 5802 break;
5803 case OA_CVREF:
5804 {
a0d0e21e 5805 OP *newop = newUNOP(OP_NULL, 0, kid);
79072805
LW		 5806 kid->op_sibling = 0;
5807 linklist(kid);
5808 newop->op_next = newop;
5809 kid = newop;
5810 kid->op_sibling = sibl;
5811 *tokid = kid;
5812 }
5813 break;
5814 case OA_FILEREF:
c340be78 5815 if (kid->op_type != OP_GV && kid->op_type != OP_RV2GV) {
79072805 5816 if (kid->op_type == OP_CONST &&
62c18ce2
GS		 5817 (kid->op_private & OPpCONST_BARE))
5818 {
79072805 5819 OP *newop = newGVOP(OP_GV, 0,
2d8e6c8d 5820 gv_fetchpv(SvPVx(((SVOP*)kid)->op_sv, n_a), TRUE,
85e6fe83 5821 SVt_PVIO) );
79072805
LW		 5822 op_free(kid);
5823 kid = newop;
5824 }
1ea32a52
GS		 5825 else if (kid->op_type == OP_READLINE) {
5826 /* neophyte patrol: open(<FH>), close(<FH>) etc. */
53e06cf0 5827 bad_type(numargs, "HANDLE", OP_DESC(o), kid);
1ea32a52 5828 }
79072805 5829 else {
35cd451c 5830 I32 flags = OPf_SPECIAL;
a6c40364 5831 I32 priv = 0;
2c8ac474
GS		 5832 PADOFFSET targ = 0;
5833
35cd451c 5834 /* is this op a FH constructor? */
853846ea 5835 if (is_handle_constructor(o,numargs)) {
2c8ac474
GS		 5836 char *name = Nullch;
5837 STRLEN len;
5838
5839 flags = 0;
5840 /* Set a flag to tell rv2gv to vivify
853846ea
NIS		 5841 * need to "prove" flag does not mean something
5842 * else already - NI-S 1999/05/07
2c8ac474
GS		 5843 */
5844 priv = OPpDEREF;
5845 if (kid->op_type == OP_PADSV) {
5846 SV **namep = av_fetch(PL_comppad_name,
5847 kid->op_targ, 4);
5848 if (namep && *namep)
5849 name = SvPV(*namep, len);
5850 }
5851 else if (kid->op_type == OP_RV2SV
5852 && kUNOP->op_first->op_type == OP_GV)
5853 {
5854 GV *gv = cGVOPx_gv(kUNOP->op_first);
5855 name = GvNAME(gv);
5856 len = GvNAMELEN(gv);
5857 }
afd1915d
GS		 5858 else if (kid->op_type == OP_AELEM
5859 || kid->op_type == OP_HELEM)
5860 {
5861 name = "__ANONIO__";
5862 len = 10;
5863 mod(kid,type);
5864 }
2c8ac474
GS		 5865 if (name) {
5866 SV *namesv;
5867 targ = pad_alloc(OP_RV2GV, SVs_PADTMP);
5868 namesv = PL_curpad[targ];
155aba94 5869 (void)SvUPGRADE(namesv, SVt_PV);
2c8ac474
GS		 5870 if (*name != '$')
5871 sv_setpvn(namesv, "$", 1);
5872 sv_catpvn(namesv, name, len);
5873 }
853846ea 5874 }
79072805 5875 kid->op_sibling = 0;
35cd451c 5876 kid = newUNOP(OP_RV2GV, flags, scalar(kid));
2c8ac474
GS		 5877 kid->op_targ = targ;
5878 kid->op_private |= priv;
79072805
LW		 5879 }
5880 kid->op_sibling = sibl;
5881 *tokid = kid;
5882 }
5883 scalar(kid);
5884 break;
5885 case OA_SCALARREF:
a0d0e21e 5886 mod(scalar(kid), type);
79072805
LW		 5887 break;
5888 }
5889 oa >>= 4;
5890 tokid = &kid->op_sibling;
5891 kid = kid->op_sibling;
5892 }
11343788 5893 o->op_private |= numargs;
79072805 5894 if (kid)
53e06cf0 5895 return too_many_arguments(o,OP_DESC(o));
11343788 5896 listkids(o);
79072805 5897 }
22c35a8c 5898 else if (PL_opargs[type] & OA_DEFGV) {
11343788 5899 op_free(o);
54b9620d 5900 return newUNOP(type, 0, newDEFSVOP());
a0d0e21e
LW		 5901 }
5902
79072805
LW		 5903 if (oa) {
5904 while (oa & OA_OPTIONAL)
5905 oa >>= 4;
5906 if (oa && oa != OA_LIST)
53e06cf0 5907 return too_few_arguments(o,OP_DESC(o));
79072805 5908 }
11343788 5909 return o;
79072805
LW		 5910}
5911
5912OP *
cea2e8a9 5913Perl_ck_glob(pTHX_ OP *o)
79072805 5914{
fb73857a 5915 GV *gv;
5916
649da076 5917 o = ck_fun(o);
1f2bfc8a 5918 if ((o->op_flags & OPf_KIDS) && !cLISTOPo->op_first->op_sibling)
54b9620d 5919 append_elem(OP_GLOB, o, newDEFSVOP());
fb73857a 5920
5921 if (!((gv = gv_fetchpv("glob", FALSE, SVt_PVCV)) && GvIMPORTED_CV(gv)))
5922 gv = gv_fetchpv("CORE::GLOBAL::glob", FALSE, SVt_PVCV);
b1cb66bf 5923
52bb0670 5924#if !defined(PERL_EXTERNAL_GLOB)
72b16652
GS		 5925 /* XXX this can be tightened up and made more failsafe. */
5926 if (!gv) {
7d3fb230 5927 GV *glob_gv;
72b16652 5928 ENTER;
7d3fb230
BS		 5929 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT, newSVpvn("File::Glob", 10), Nullsv,
5930 Nullsv, Nullsv);
72b16652 5931 gv = gv_fetchpv("CORE::GLOBAL::glob", FALSE, SVt_PVCV);
7d3fb230
BS		 5932 glob_gv = gv_fetchpv("File::Glob::csh_glob", FALSE, SVt_PVCV);
5933 GvCV(gv) = GvCV(glob_gv);
445266f0 5934 SvREFCNT_inc((SV*)GvCV(gv));
7d3fb230 5935 GvIMPORTED_CV_on(gv);
72b16652
GS		 5936 LEAVE;
5937 }
52bb0670 5938#endif /* PERL_EXTERNAL_GLOB */
72b16652 5939
b1cb66bf 5940 if (gv && GvIMPORTED_CV(gv)) {
5196be3e 5941 append_elem(OP_GLOB, o,
80252599 5942 newSVOP(OP_CONST, 0, newSViv(PL_glob_index++)));
1f2bfc8a 5943 o->op_type = OP_LIST;
22c35a8c 5944 o->op_ppaddr = PL_ppaddr[OP_LIST];
1f2bfc8a 5945 cLISTOPo->op_first->op_type = OP_PUSHMARK;
22c35a8c 5946 cLISTOPo->op_first->op_ppaddr = PL_ppaddr[OP_PUSHMARK];
1f2bfc8a 5947 o = newUNOP(OP_ENTERSUB, OPf_STACKED,
aeea060c 5948 append_elem(OP_LIST, o,
1f2bfc8a
MB		 5949 scalar(newUNOP(OP_RV2CV, 0,
5950 newGVOP(OP_GV, 0, gv)))));
d58bf5aa
MB		 5951 o = newUNOP(OP_NULL, 0, ck_subr(o));
5952 o->op_targ = OP_GLOB; /* hint at what it used to be */
5953 return o;
b1cb66bf 5954 }
5955 gv = newGVgen("main");
a0d0e21e 5956 gv_IOadd(gv);
11343788
MB		 5957 append_elem(OP_GLOB, o, newGVOP(OP_GV, 0, gv));
5958 scalarkids(o);
649da076 5959 return o;
79072805
LW		 5960}
5961
5962OP *
cea2e8a9 5963Perl_ck_grep(pTHX_ OP *o)
79072805
LW		 5964{
5965 LOGOP *gwop;
5966 OP *kid;
11343788 5967 OPCODE type = o->op_type == OP_GREPSTART ? OP_GREPWHILE : OP_MAPWHILE;
79072805 5968
22c35a8c 5969 o->op_ppaddr = PL_ppaddr[OP_GREPSTART];
b7dc083c 5970 NewOp(1101, gwop, 1, LOGOP);
aeea060c 5971
11343788 5972 if (o->op_flags & OPf_STACKED) {
a0d0e21e 5973 OP* k;
11343788
MB		 5974 o = ck_sort(o);
5975 kid = cLISTOPo->op_first->op_sibling;
5976 for (k = cLISTOPo->op_first->op_sibling->op_next; k; k = k->op_next) {
a0d0e21e
LW		 5977 kid = k;
5978 }
5979 kid->op_next = (OP*)gwop;
11343788 5980 o->op_flags &= ~OPf_STACKED;
93a17b20 5981 }
11343788 5982 kid = cLISTOPo->op_first->op_sibling;
a0d0e21e
LW		 5983 if (type == OP_MAPWHILE)
5984 list(kid);
5985 else
5986 scalar(kid);
11343788 5987 o = ck_fun(o);
3280af22 5988 if (PL_error_count)
11343788 5989 return o;
aeea060c 5990 kid = cLISTOPo->op_first->op_sibling;
79072805 5991 if (kid->op_type != OP_NULL)
cea2e8a9 5992 Perl_croak(aTHX_ "panic: ck_grep");
79072805
LW		 5993 kid = kUNOP->op_first;
5994
a0d0e21e 5995 gwop->op_type = type;
22c35a8c 5996 gwop->op_ppaddr = PL_ppaddr[type];
11343788 5997 gwop->op_first = listkids(o);
79072805
LW		 5998 gwop->op_flags |= OPf_KIDS;
5999 gwop->op_private = 1;
6000 gwop->op_other = LINKLIST(kid);
a0d0e21e 6001 gwop->op_targ = pad_alloc(type, SVs_PADTMP);
79072805
LW		 6002 kid->op_next = (OP*)gwop;
6003
11343788 6004 kid = cLISTOPo->op_first->op_sibling;
a0d0e21e 6005 if (!kid || !kid->op_sibling)
53e06cf0 6006 return too_few_arguments(o,OP_DESC(o));
a0d0e21e
LW		 6007 for (kid = kid->op_sibling; kid; kid = kid->op_sibling)
6008 mod(kid, OP_GREPSTART);
6009
79072805
LW		 6010 return (OP*)gwop;
6011}
6012
6013OP *
cea2e8a9 6014Perl_ck_index(pTHX_ OP *o)
79072805 6015{
11343788
MB		 6016 if (o->op_flags & OPf_KIDS) {
6017 OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
0b71040e
LW		 6018 if (kid)
6019 kid = kid->op_sibling; /* get past "big" */
79072805 6020 if (kid && kid->op_type == OP_CONST)
2779dcf1 6021 fbm_compile(((SVOP*)kid)->op_sv, 0);
79072805 6022 }
11343788 6023 return ck_fun(o);
79072805
LW		 6024}
6025
6026OP *
cea2e8a9 6027Perl_ck_lengthconst(pTHX_ OP *o)
79072805
LW		 6028{
6029 /* XXX length optimization goes here */
11343788 6030 return ck_fun(o);
79072805
LW		 6031}
6032
6033OP *
cea2e8a9 6034Perl_ck_lfun(pTHX_ OP *o)
79072805 6035{
5dc0d613
MB		 6036 OPCODE type = o->op_type;
6037 return modkids(ck_fun(o), type);
79072805
LW		 6038}
6039
6040OP *
cea2e8a9 6041Perl_ck_defined(pTHX_ OP *o) /* 19990527 MJD */
69794302 6042{
d0334bed
GS		 6043 if ((o->op_flags & OPf_KIDS) && ckWARN(WARN_DEPRECATED)) {
6044 switch (cUNOPo->op_first->op_type) {
6045 case OP_RV2AV:
a8739d98
JH		 6046 /* This is needed for
6047 if (defined %stash::)
6048 to work. Do not break Tk.
6049 */
1c846c1f 6050 break; /* Globals via GV can be undef */
d0334bed
GS		 6051 case OP_PADAV:
6052 case OP_AASSIGN: /* Is this a good idea? */
6053 Perl_warner(aTHX_ WARN_DEPRECATED,
f10b0346 6054 "defined(@array) is deprecated");
d0334bed 6055 Perl_warner(aTHX_ WARN_DEPRECATED,
cc507455 6056 "\t(Maybe you should just omit the defined()?)\n");
69794302 6057 break;
d0334bed 6058 case OP_RV2HV:
a8739d98
JH		 6059 /* This is needed for
6060 if (defined %stash::)
6061 to work. Do not break Tk.
6062 */
1c846c1f 6063 break; /* Globals via GV can be undef */
d0334bed
GS		 6064 case OP_PADHV:
6065 Perl_warner(aTHX_ WARN_DEPRECATED,
894356b3 6066 "defined(%%hash) is deprecated");
d0334bed 6067 Perl_warner(aTHX_ WARN_DEPRECATED,
cc507455 6068 "\t(Maybe you should just omit the defined()?)\n");
d0334bed
GS		 6069 break;
6070 default:
6071 /* no warning */
6072 break;
6073 }
69794302
MJD		 6074 }
6075 return ck_rfun(o);
6076}
6077
6078OP *
cea2e8a9 6079Perl_ck_rfun(pTHX_ OP *o)
8990e307 6080{
5dc0d613
MB		 6081 OPCODE type = o->op_type;
6082 return refkids(ck_fun(o), type);
8990e307
LW		 6083}
6084
6085OP *
cea2e8a9 6086Perl_ck_listiob(pTHX_ OP *o)
79072805
LW		 6087{
6088 register OP *kid;
aeea060c 6089
11343788 6090 kid = cLISTOPo->op_first;
79072805 6091 if (!kid) {
11343788
MB		 6092 o = force_list(o);
6093 kid = cLISTOPo->op_first;
79072805
LW		 6094 }
6095 if (kid->op_type == OP_PUSHMARK)
6096 kid = kid->op_sibling;
11343788 6097 if (kid && o->op_flags & OPf_STACKED)
79072805
LW		 6098 kid = kid->op_sibling;
6099 else if (kid && !kid->op_sibling) { /* print HANDLE; */
6100 if (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE) {
11343788 6101 o->op_flags |= OPf_STACKED; /* make it a filehandle */
748a9306 6102 kid = newUNOP(OP_RV2GV, OPf_REF, scalar(kid));
11343788
MB		 6103 cLISTOPo->op_first->op_sibling = kid;
6104 cLISTOPo->op_last = kid;
79072805
LW		 6105 kid = kid->op_sibling;
6106 }
6107 }
6108
6109 if (!kid)
54b9620d 6110 append_elem(o->op_type, o, newDEFSVOP());
79072805 6111
2de3dbcc 6112 return listkids(o);
bbce6d69 6113}
6114
6115OP *
b162f9ea
IZ		 6116Perl_ck_sassign(pTHX_ OP *o)
6117{
6118 OP *kid = cLISTOPo->op_first;
6119 /* has a disposable target? */
6120 if ((PL_opargs[kid->op_type] & OA_TARGLEX)
6b66af17
GS		 6121 && !(kid->op_flags & OPf_STACKED)
6122 /* Cannot steal the second time! */
6123 && !(kid->op_private & OPpTARGET_MY))
b162f9ea
IZ		 6124 {
6125 OP *kkid = kid->op_sibling;
6126
6127 /* Can just relocate the target. */
2c2d71f5
JH		 6128 if (kkid && kkid->op_type == OP_PADSV
6129 && !(kkid->op_private & OPpLVAL_INTRO))
6130 {
b162f9ea 6131 kid->op_targ = kkid->op_targ;
743e66e6 6132 kkid->op_targ = 0;
b162f9ea
IZ		 6133 /* Now we do not need PADSV and SASSIGN. */
6134 kid->op_sibling = o->op_sibling; /* NULL */
6135 cLISTOPo->op_first = NULL;
6136 op_free(o);
6137 op_free(kkid);
6138 kid->op_private |= OPpTARGET_MY; /* Used for context settings */
6139 return kid;
6140 }
6141 }
6142 return o;
6143}
6144
6145OP *
cea2e8a9 6146Perl_ck_match(pTHX_ OP *o)
79072805 6147{
5dc0d613 6148 o->op_private |= OPpRUNTIME;
11343788 6149 return o;
79072805
LW		 6150}
6151
6152OP *
f5d5a27c
CS		 6153Perl_ck_method(pTHX_ OP *o)
6154{
6155 OP *kid = cUNOPo->op_first;
6156 if (kid->op_type == OP_CONST) {
6157 SV* sv = kSVOP->op_sv;
6158 if (!(strchr(SvPVX(sv), ':') || strchr(SvPVX(sv), '\''))) {
6159 OP *cmop;
1c846c1f
NIS		 6160 if (!SvREADONLY(sv) || !SvFAKE(sv)) {
6161 sv = newSVpvn_share(SvPVX(sv), SvCUR(sv), 0);
6162 }
6163 else {
6164 kSVOP->op_sv = Nullsv;
6165 }
f5d5a27c 6166 cmop = newSVOP(OP_METHOD_NAMED, 0, sv);
f5d5a27c
CS		 6167 op_free(o);
6168 return cmop;
6169 }
6170 }
6171 return o;
6172}
6173
6174OP *
cea2e8a9 6175Perl_ck_null(pTHX_ OP *o)
79072805 6176{
11343788 6177 return o;
79072805
LW		 6178}
6179
6180OP *
16fe6d59
GS		 6181Perl_ck_open(pTHX_ OP *o)
6182{
6183 HV *table = GvHV(PL_hintgv);
6184 if (table) {
6185 SV **svp;
6186 I32 mode;
6187 svp = hv_fetch(table, "open_IN", 7, FALSE);
6188 if (svp && *svp) {
6189 mode = mode_from_discipline(*svp);
6190 if (mode & O_BINARY)
6191 o->op_private |= OPpOPEN_IN_RAW;
6192 else if (mode & O_TEXT)
6193 o->op_private |= OPpOPEN_IN_CRLF;
6194 }
6195
6196 svp = hv_fetch(table, "open_OUT", 8, FALSE);
6197 if (svp && *svp) {
6198 mode = mode_from_discipline(*svp);
6199 if (mode & O_BINARY)
6200 o->op_private |= OPpOPEN_OUT_RAW;
6201 else if (mode & O_TEXT)
6202 o->op_private |= OPpOPEN_OUT_CRLF;
6203 }
6204 }
6205 if (o->op_type == OP_BACKTICK)
6206 return o;
6207 return ck_fun(o);
6208}
6209
6210OP *
cea2e8a9 6211Perl_ck_repeat(pTHX_ OP *o)
79072805 6212{
11343788
MB		 6213 if (cBINOPo->op_first->op_flags & OPf_PARENS) {
6214 o->op_private |= OPpREPEAT_DOLIST;
6215 cBINOPo->op_first = force_list(cBINOPo->op_first);
79072805
LW		 6216 }
6217 else
11343788
MB		 6218 scalar(o);
6219 return o;
79072805
LW		 6220}
6221
6222OP *
cea2e8a9 6223Perl_ck_require(pTHX_ OP *o)
8990e307 6224{
ec4ab249
GA		 6225 GV* gv;
6226
11343788
MB		 6227 if (o->op_flags & OPf_KIDS) { /* Shall we supply missing .pm? */
6228 SVOP *kid = (SVOP*)cUNOPo->op_first;
8990e307
LW		 6229
6230 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
8990e307 6231 char *s;
a0d0e21e
LW		 6232 for (s = SvPVX(kid->op_sv); *s; s++) {
6233 if (*s == ':' && s[1] == ':') {
6234 *s = '/';
1aef975c 6235 Move(s+2, s+1, strlen(s+2)+1, char);
a0d0e21e
LW		 6236 --SvCUR(kid->op_sv);
6237 }
8990e307 6238 }
ce3b816e
GS		 6239 if (SvREADONLY(kid->op_sv)) {
6240 SvREADONLY_off(kid->op_sv);
6241 sv_catpvn(kid->op_sv, ".pm", 3);
6242 SvREADONLY_on(kid->op_sv);
6243 }
6244 else
6245 sv_catpvn(kid->op_sv, ".pm", 3);
8990e307
LW		 6246 }
6247 }
ec4ab249
GA		 6248
6249 /* handle override, if any */
6250 gv = gv_fetchpv("require", FALSE, SVt_PVCV);
6251 if (!(gv && GvIMPORTED_CV(gv)))
6252 gv = gv_fetchpv("CORE::GLOBAL::require", FALSE, SVt_PVCV);
6253
6254 if (gv && GvIMPORTED_CV(gv)) {
6255 OP *kid = cUNOPo->op_first;
6256 cUNOPo->op_first = 0;
6257 op_free(o);
6258 return ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
6259 append_elem(OP_LIST, kid,
6260 scalar(newUNOP(OP_RV2CV, 0,
6261 newGVOP(OP_GV, 0,
6262 gv))))));
6263 }
6264
11343788 6265 return ck_fun(o);
8990e307
LW		 6266}
6267
78f9721b
SM		 6268OP *
6269Perl_ck_return(pTHX_ OP *o)
6270{
6271 OP *kid;
6272 if (CvLVALUE(PL_compcv)) {
6273 for (kid = cLISTOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
6274 mod(kid, OP_LEAVESUBLV);
6275 }
6276 return o;
6277}
6278
22c35a8c 6279#if 0
8990e307 6280OP *
cea2e8a9 6281Perl_ck_retarget(pTHX_ OP *o)
79072805 6282{
cea2e8a9 6283 Perl_croak(aTHX_ "NOT IMPL LINE %d",__LINE__);
79072805 6284 /* STUB */
11343788 6285 return o;
79072805 6286}
22c35a8c 6287#endif
79072805
LW		 6288
6289OP *
cea2e8a9 6290Perl_ck_select(pTHX_ OP *o)
79072805 6291{
c07a80fd 6292 OP* kid;
11343788
MB		 6293 if (o->op_flags & OPf_KIDS) {
6294 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
2304df62 6295 if (kid && kid->op_sibling) {
11343788 6296 o->op_type = OP_SSELECT;
22c35a8c 6297 o->op_ppaddr = PL_ppaddr[OP_SSELECT];
11343788
MB		 6298 o = ck_fun(o);
6299 return fold_constants(o);
79072805
LW		 6300 }
6301 }
11343788
MB		 6302 o = ck_fun(o);
6303 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
c07a80fd 6304 if (kid && kid->op_type == OP_RV2GV)
6305 kid->op_private &= ~HINT_STRICT_REFS;
11343788 6306 return o;
79072805
LW		 6307}
6308
6309OP *
cea2e8a9 6310Perl_ck_shift(pTHX_ OP *o)
79072805 6311{
11343788 6312 I32 type = o->op_type;
79072805 6313
11343788 6314 if (!(o->op_flags & OPf_KIDS)) {
6d4ff0d2
MB		 6315 OP *argop;
6316
11343788 6317 op_free(o);
4d1ff10f 6318#ifdef USE_5005THREADS
533c011a 6319 if (!CvUNIQUE(PL_compcv)) {
6d4ff0d2 6320 argop = newOP(OP_PADAV, OPf_REF);
6b88bc9c 6321 argop->op_targ = 0; /* PL_curpad[0] is @_ */
6d4ff0d2
MB		 6322 }
6323 else {
6324 argop = newUNOP(OP_RV2AV, 0,
6325 scalar(newGVOP(OP_GV, 0,
6326 gv_fetchpv("ARGV", TRUE, SVt_PVAV))));
6327 }
6328#else
6329 argop = newUNOP(OP_RV2AV, 0,
3280af22
NIS		 6330 scalar(newGVOP(OP_GV, 0, !CvUNIQUE(PL_compcv) ?
6331 PL_defgv : gv_fetchpv("ARGV", TRUE, SVt_PVAV))));
4d1ff10f 6332#endif /* USE_5005THREADS */
6d4ff0d2 6333 return newUNOP(type, 0, scalar(argop));
79072805 6334 }
11343788 6335 return scalar(modkids(ck_fun(o), type));
79072805
LW		 6336}
6337
6338OP *
cea2e8a9 6339Perl_ck_sort(pTHX_ OP *o)
79072805 6340{
8e3f9bdf 6341 OP *firstkid;
bbce6d69 6342
9ea6e965 6343 if (o->op_type == OP_SORT && o->op_flags & OPf_STACKED)
51a19bc0 6344 simplify_sort(o);
8e3f9bdf
GS		 6345 firstkid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6346 if (o->op_flags & OPf_STACKED) { /* may have been cleared */
9c5ffd7c 6347 OP *k = NULL;
8e3f9bdf 6348 OP *kid = cUNOPx(firstkid)->op_first; /* get past null */
79072805 6349
463ee0b2 6350 if (kid->op_type == OP_SCOPE || kid->op_type == OP_LEAVE) {
79072805 6351 linklist(kid);
463ee0b2
LW		 6352 if (kid->op_type == OP_SCOPE) {
6353 k = kid->op_next;
6354 kid->op_next = 0;
79072805 6355 }
463ee0b2 6356 else if (kid->op_type == OP_LEAVE) {
11343788 6357 if (o->op_type == OP_SORT) {
93c66552 6358 op_null(kid); /* wipe out leave */
748a9306 6359 kid->op_next = kid;
463ee0b2 6360
748a9306
LW		 6361 for (k = kLISTOP->op_first->op_next; k; k = k->op_next) {
6362 if (k->op_next == kid)
6363 k->op_next = 0;
71a29c3c
GS		 6364 /* don't descend into loops */
6365 else if (k->op_type == OP_ENTERLOOP
6366 || k->op_type == OP_ENTERITER)
6367 {
6368 k = cLOOPx(k)->op_lastop;
6369 }
748a9306 6370 }
463ee0b2 6371 }
748a9306
LW		 6372 else
6373 kid->op_next = 0; /* just disconnect the leave */
a0d0e21e 6374 k = kLISTOP->op_first;
463ee0b2 6375 }
a2efc822 6376 CALL_PEEP(k);
a0d0e21e 6377
8e3f9bdf
GS		 6378 kid = firstkid;
6379 if (o->op_type == OP_SORT) {
6380 /* provide scalar context for comparison function/block */
6381 kid = scalar(kid);
a0d0e21e 6382 kid->op_next = kid;
8e3f9bdf 6383 }
a0d0e21e
LW		 6384 else
6385 kid->op_next = k;
11343788 6386 o->op_flags |= OPf_SPECIAL;
79072805 6387 }
c6e96bcb 6388 else if (kid->op_type == OP_RV2SV || kid->op_type == OP_PADSV)
93c66552 6389 op_null(firstkid);
8e3f9bdf
GS		 6390
6391 firstkid = firstkid->op_sibling;
79072805 6392 }
bbce6d69 6393
8e3f9bdf
GS		 6394 /* provide list context for arguments */
6395 if (o->op_type == OP_SORT)
6396 list(firstkid);
6397
11343788 6398 return o;
79072805 6399}
bda4119b
GS		 6400
6401STATIC void
cea2e8a9 6402S_simplify_sort(pTHX_ OP *o)
9c007264
JH		 6403{
6404 register OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6405 OP *k;
6406 int reversed;
350de78d 6407 GV *gv;
9c007264
JH		 6408 if (!(o->op_flags & OPf_STACKED))
6409 return;
1c846c1f
NIS		 6410 GvMULTI_on(gv_fetchpv("a", TRUE, SVt_PV));
6411 GvMULTI_on(gv_fetchpv("b", TRUE, SVt_PV));
82092f1d 6412 kid = kUNOP->op_first; /* get past null */
9c007264
JH		 6413 if (kid->op_type != OP_SCOPE)
6414 return;
6415 kid = kLISTOP->op_last; /* get past scope */
6416 switch(kid->op_type) {
6417 case OP_NCMP:
6418 case OP_I_NCMP:
6419 case OP_SCMP:
6420 break;
6421 default:
6422 return;
6423 }
6424 k = kid; /* remember this node*/
6425 if (kBINOP->op_first->op_type != OP_RV2SV)
6426 return;
6427 kid = kBINOP->op_first; /* get past cmp */
6428 if (kUNOP->op_first->op_type != OP_GV)
6429 return;
6430 kid = kUNOP->op_first; /* get past rv2sv */
638eceb6 6431 gv = kGVOP_gv;
350de78d 6432 if (GvSTASH(gv) != PL_curstash)
9c007264 6433 return;
350de78d 6434 if (strEQ(GvNAME(gv), "a"))
9c007264 6435 reversed = 0;
0f79a09d 6436 else if (strEQ(GvNAME(gv), "b"))
9c007264
JH		 6437 reversed = 1;
6438 else
6439 return;
6440 kid = k; /* back to cmp */
6441 if (kBINOP->op_last->op_type != OP_RV2SV)
6442 return;
6443 kid = kBINOP->op_last; /* down to 2nd arg */
6444 if (kUNOP->op_first->op_type != OP_GV)
6445 return;
6446 kid = kUNOP->op_first; /* get past rv2sv */
638eceb6 6447 gv = kGVOP_gv;
350de78d 6448 if (GvSTASH(gv) != PL_curstash
9c007264 6449 || ( reversed
350de78d
GS		 6450 ? strNE(GvNAME(gv), "a")
6451 : strNE(GvNAME(gv), "b")))
9c007264
JH		 6452 return;
6453 o->op_flags &= ~(OPf_STACKED | OPf_SPECIAL);
6454 if (reversed)
6455 o->op_private |= OPpSORT_REVERSE;
6456 if (k->op_type == OP_NCMP)
6457 o->op_private |= OPpSORT_NUMERIC;
6458 if (k->op_type == OP_I_NCMP)
6459 o->op_private |= OPpSORT_NUMERIC | OPpSORT_INTEGER;
e507f050
SM		 6460 kid = cLISTOPo->op_first->op_sibling;
6461 cLISTOPo->op_first->op_sibling = kid->op_sibling; /* bypass old block */
6462 op_free(kid); /* then delete it */
9c007264 6463}
79072805
LW		 6464
6465OP *
cea2e8a9 6466Perl_ck_split(pTHX_ OP *o)
79072805
LW		 6467{
6468 register OP *kid;
aeea060c 6469
11343788
MB		 6470 if (o->op_flags & OPf_STACKED)
6471 return no_fh_allowed(o);
79072805 6472
11343788 6473 kid = cLISTOPo->op_first;
8990e307 6474 if (kid->op_type != OP_NULL)
cea2e8a9 6475 Perl_croak(aTHX_ "panic: ck_split");
8990e307 6476 kid = kid->op_sibling;
11343788
MB		 6477 op_free(cLISTOPo->op_first);
6478 cLISTOPo->op_first = kid;
85e6fe83 6479 if (!kid) {
79cb57f6 6480 cLISTOPo->op_first = kid = newSVOP(OP_CONST, 0, newSVpvn(" ", 1));
11343788 6481 cLISTOPo->op_last = kid; /* There was only one element previously */
85e6fe83 6482 }
79072805 6483
de4bf5b3 6484 if (kid->op_type != OP_MATCH || kid->op_flags & OPf_STACKED) {
79072805 6485 OP *sibl = kid->op_sibling;
463ee0b2 6486 kid->op_sibling = 0;
79072805 6487 kid = pmruntime( newPMOP(OP_MATCH, OPf_SPECIAL), kid, Nullop);
11343788
MB		 6488 if (cLISTOPo->op_first == cLISTOPo->op_last)
6489 cLISTOPo->op_last = kid;
6490 cLISTOPo->op_first = kid;
79072805
LW		 6491 kid->op_sibling = sibl;
6492 }
6493
6494 kid->op_type = OP_PUSHRE;
22c35a8c 6495 kid->op_ppaddr = PL_ppaddr[OP_PUSHRE];
79072805
LW		 6496 scalar(kid);
6497
6498 if (!kid->op_sibling)
54b9620d 6499 append_elem(OP_SPLIT, o, newDEFSVOP());
79072805
LW		 6500
6501 kid = kid->op_sibling;
6502 scalar(kid);
6503
6504 if (!kid->op_sibling)
11343788 6505 append_elem(OP_SPLIT, o, newSVOP(OP_CONST, 0, newSViv(0)));
79072805
LW		 6506
6507 kid = kid->op_sibling;
6508 scalar(kid);
6509
6510 if (kid->op_sibling)
53e06cf0 6511 return too_many_arguments(o,OP_DESC(o));
79072805 6512
11343788 6513 return o;
79072805
LW		 6514}
6515
6516OP *
1c846c1f 6517Perl_ck_join(pTHX_ OP *o)
eb6e2d6f
GS		 6518{
6519 if (ckWARN(WARN_SYNTAX)) {
6520 OP *kid = cLISTOPo->op_first->op_sibling;
6521 if (kid && kid->op_type == OP_MATCH) {
6522 char *pmstr = "STRING";
aaa362c4
RS		 6523 if (PM_GETRE(kPMOP))
6524 pmstr = PM_GETRE(kPMOP)->precomp;
eb6e2d6f
GS		 6525 Perl_warner(aTHX_ WARN_SYNTAX,
6526 "/%s/ should probably be written as \"%s\"",
6527 pmstr, pmstr);
6528 }
6529 }
6530 return ck_fun(o);
6531}
6532
6533OP *
cea2e8a9 6534Perl_ck_subr(pTHX_ OP *o)
79072805 6535{
11343788
MB		 6536 OP *prev = ((cUNOPo->op_first->op_sibling)
6537 ? cUNOPo : ((UNOP*)cUNOPo->op_first))->op_first;
6538 OP *o2 = prev->op_sibling;
4633a7c4
LW		 6539 OP *cvop;
6540 char *proto = 0;
6541 CV *cv = 0;
46fc3d4c 6542 GV *namegv = 0;
4633a7c4
LW		 6543 int optional = 0;
6544 I32 arg = 0;
5b794e05 6545 I32 contextclass = 0;
90b7f708 6546 char *e = 0;
2d8e6c8d 6547 STRLEN n_a;
4633a7c4 6548
d3011074 6549 o->op_private |= OPpENTERSUB_HASTARG;
11343788 6550 for (cvop = o2; cvop->op_sibling; cvop = cvop->op_sibling) ;
4633a7c4
LW		 6551 if (cvop->op_type == OP_RV2CV) {
6552 SVOP* tmpop;
11343788 6553 o->op_private |= (cvop->op_private & OPpENTERSUB_AMPER);
93c66552 6554 op_null(cvop); /* disable rv2cv */
4633a7c4 6555 tmpop = (SVOP*)((UNOP*)cvop)->op_first;
76cd736e 6556 if (tmpop->op_type == OP_GV && !(o->op_private & OPpENTERSUB_AMPER)) {
638eceb6 6557 GV *gv = cGVOPx_gv(tmpop);
350de78d 6558 cv = GvCVu(gv);
76cd736e
GS		 6559 if (!cv)
6560 tmpop->op_private |= OPpEARLY_CV;
6561 else if (SvPOK(cv)) {
350de78d 6562 namegv = CvANON(cv) ? gv : CvGV(cv);
2d8e6c8d 6563 proto = SvPV((SV*)cv, n_a);
46fc3d4c 6564 }
4633a7c4
LW		 6565 }
6566 }
f5d5a27c 6567 else if (cvop->op_type == OP_METHOD || cvop->op_type == OP_METHOD_NAMED) {
7a52d87a
GS		 6568 if (o2->op_type == OP_CONST)
6569 o2->op_private &= ~OPpCONST_STRICT;
58a40671
GS		 6570 else if (o2->op_type == OP_LIST) {
6571 OP *o = ((UNOP*)o2)->op_first->op_sibling;
6572 if (o && o->op_type == OP_CONST)
6573 o->op_private &= ~OPpCONST_STRICT;
6574 }
7a52d87a 6575 }
3280af22
NIS		 6576 o->op_private |= (PL_hints & HINT_STRICT_REFS);
6577 if (PERLDB_SUB && PL_curstash != PL_debstash)
11343788
MB		 6578 o->op_private |= OPpENTERSUB_DB;
6579 while (o2 != cvop) {
4633a7c4
LW		 6580 if (proto) {
6581 switch (*proto) {
6582 case '\0':
5dc0d613 6583 return too_many_arguments(o, gv_ename(namegv));
4633a7c4
LW		 6584 case ';':
6585 optional = 1;
6586 proto++;
6587 continue;
6588 case '$':
6589 proto++;
6590 arg++;
11343788 6591 scalar(o2);
4633a7c4
LW		 6592 break;
6593 case '%':
6594 case '@':
11343788 6595 list(o2);
4633a7c4
LW		 6596 arg++;
6597 break;
6598 case '&':
6599 proto++;
6600 arg++;
11343788 6601 if (o2->op_type != OP_REFGEN && o2->op_type != OP_UNDEF)
75fc29ea
GS		 6602 bad_type(arg,
6603 arg == 1 ? "block or sub {}" : "sub {}",
6604 gv_ename(namegv), o2);
4633a7c4
LW		 6605 break;
6606 case '*':
2ba6ecf4 6607 /* '*' allows any scalar type, including bareword */
4633a7c4
LW		 6608 proto++;
6609 arg++;
11343788 6610 if (o2->op_type == OP_RV2GV)
2ba6ecf4 6611 goto wrapref; /* autoconvert GLOB -> GLOBref */
7a52d87a
GS		 6612 else if (o2->op_type == OP_CONST)
6613 o2->op_private &= ~OPpCONST_STRICT;
9675f7ac
GS		 6614 else if (o2->op_type == OP_ENTERSUB) {
6615 /* accidental subroutine, revert to bareword */
6616 OP *gvop = ((UNOP*)o2)->op_first;
6617 if (gvop && gvop->op_type == OP_NULL) {
6618 gvop = ((UNOP*)gvop)->op_first;
6619 if (gvop) {
6620 for (; gvop->op_sibling; gvop = gvop->op_sibling)
6621 ;
6622 if (gvop &&
6623 (gvop->op_private & OPpENTERSUB_NOPAREN) &&
6624 (gvop = ((UNOP*)gvop)->op_first) &&
6625 gvop->op_type == OP_GV)
6626 {
638eceb6 6627 GV *gv = cGVOPx_gv(gvop);
9675f7ac 6628 OP *sibling = o2->op_sibling;
2692f720 6629 SV *n = newSVpvn("",0);
9675f7ac 6630 op_free(o2);
2692f720
GS		 6631 gv_fullname3(n, gv, "");
6632 if (SvCUR(n)>6 && strnEQ(SvPVX(n),"main::",6))
6633 sv_chop(n, SvPVX(n)+6);
6634 o2 = newSVOP(OP_CONST, 0, n);
9675f7ac
GS		 6635 prev->op_sibling = o2;
6636 o2->op_sibling = sibling;
6637 }
6638 }
6639 }
6640 }
2ba6ecf4
GS		 6641 scalar(o2);
6642 break;
5b794e05
JH		 6643 case '[': case ']':
6644 goto oops;
6645 break;
4633a7c4
LW		 6646 case '\\':
6647 proto++;
6648 arg++;
5b794e05 6649 again:
4633a7c4 6650 switch (*proto++) {
5b794e05
JH		 6651 case '[':
6652 if (contextclass++ == 0) {
841d93c8 6653 e = strchr(proto, ']');
5b794e05
JH		 6654 if (!e || e == proto)
6655 goto oops;
6656 }
6657 else
6658 goto oops;
6659 goto again;
6660 break;
6661 case ']':
6662 if (contextclass)
6663 contextclass = 0;
6664 else
6665 goto oops;
6666 break;
4633a7c4 6667 case '*':
5b794e05
JH		 6668 if (o2->op_type == OP_RV2GV)
6669 goto wrapref;
6670 if (!contextclass)
6671 bad_type(arg, "symbol", gv_ename(namegv), o2);
6672 break;
4633a7c4 6673 case '&':
5b794e05
JH		 6674 if (o2->op_type == OP_ENTERSUB)
6675 goto wrapref;
6676 if (!contextclass)
6677 bad_type(arg, "subroutine entry", gv_ename(namegv), o2);
6678 break;
4633a7c4 6679 case '$':
5b794e05
JH		 6680 if (o2->op_type == OP_RV2SV ||
6681 o2->op_type == OP_PADSV ||
6682 o2->op_type == OP_HELEM ||
6683 o2->op_type == OP_AELEM ||
6684 o2->op_type == OP_THREADSV)
6685 goto wrapref;
6686 if (!contextclass)
5dc0d613 6687 bad_type(arg, "scalar", gv_ename(namegv), o2);
5b794e05 6688 break;
4633a7c4 6689 case '@':
5b794e05
JH		 6690 if (o2->op_type == OP_RV2AV ||
6691 o2->op_type == OP_PADAV)
6692 goto wrapref;
6693 if (!contextclass)
5dc0d613 6694 bad_type(arg, "array", gv_ename(namegv), o2);
5b794e05 6695 break;
4633a7c4 6696 case '%':
5b794e05
JH		 6697 if (o2->op_type == OP_RV2HV ||
6698 o2->op_type == OP_PADHV)
6699 goto wrapref;
6700 if (!contextclass)
6701 bad_type(arg, "hash", gv_ename(namegv), o2);
6702 break;
6703 wrapref:
4633a7c4 6704 {
11343788 6705 OP* kid = o2;
6fa846a0 6706 OP* sib = kid->op_sibling;
4633a7c4 6707 kid->op_sibling = 0;
6fa846a0
GS		 6708 o2 = newUNOP(OP_REFGEN, 0, kid);
6709 o2->op_sibling = sib;
e858de61 6710 prev->op_sibling = o2;
4633a7c4 6711 }
841d93c8 6712 if (contextclass && e) {
5b794e05
JH		 6713 proto = e + 1;
6714 contextclass = 0;
6715 }
4633a7c4
LW		 6716 break;
6717 default: goto oops;
6718 }
5b794e05
JH		 6719 if (contextclass)
6720 goto again;
4633a7c4 6721 break;
b1cb66bf 6722 case ' ':
6723 proto++;
6724 continue;
4633a7c4
LW		 6725 default:
6726 oops:
cea2e8a9 6727 Perl_croak(aTHX_ "Malformed prototype for %s: %s",
5b794e05 6728 gv_ename(namegv), SvPV((SV*)cv, n_a));
4633a7c4
LW		 6729 }
6730 }
6731 else
11343788
MB		 6732 list(o2);
6733 mod(o2, OP_ENTERSUB);
6734 prev = o2;
6735 o2 = o2->op_sibling;
4633a7c4 6736 }
fb73857a 6737 if (proto && !optional &&
6738 (*proto && *proto != '@' && *proto != '%' && *proto != ';'))
5dc0d613 6739 return too_few_arguments(o, gv_ename(namegv));
11343788 6740 return o;
79072805
LW		 6741}
6742
6743OP *
cea2e8a9 6744Perl_ck_svconst(pTHX_ OP *o)
8990e307 6745{
11343788
MB		 6746 SvREADONLY_on(cSVOPo->op_sv);
6747 return o;
8990e307
LW		 6748}
6749
6750OP *
cea2e8a9 6751Perl_ck_trunc(pTHX_ OP *o)
79072805 6752{
11343788
MB		 6753 if (o->op_flags & OPf_KIDS) {
6754 SVOP *kid = (SVOP*)cUNOPo->op_first;
79072805 6755
a0d0e21e
LW		 6756 if (kid->op_type == OP_NULL)
6757 kid = (SVOP*)kid->op_sibling;
bb53490d
GS		 6758 if (kid && kid->op_type == OP_CONST &&
6759 (kid->op_private & OPpCONST_BARE))
6760 {
11343788 6761 o->op_flags |= OPf_SPECIAL;
bb53490d
GS		 6762 kid->op_private &= ~OPpCONST_STRICT;
6763 }
79072805 6764 }
11343788 6765 return ck_fun(o);
79072805
LW		 6766}
6767
35fba0d9
RG		 6768OP *
6769Perl_ck_substr(pTHX_ OP *o)
6770{
6771 o = ck_fun(o);
6772 if ((o->op_flags & OPf_KIDS) && o->op_private == 4) {
6773 OP *kid = cLISTOPo->op_first;
6774
6775 if (kid->op_type == OP_NULL)
6776 kid = kid->op_sibling;
6777 if (kid)
6778 kid->op_flags |= OPf_MOD;
6779
6780 }
6781 return o;
6782}
6783
463ee0b2
LW		 6784/* A peephole optimizer. We visit the ops in the order they're to execute. */
6785
79072805 6786void
864dbfa3 6787Perl_peep(pTHX_ register OP *o)
79072805
LW		 6788{
6789 register OP* oldop = 0;
2d8e6c8d
GS		 6790 STRLEN n_a;
6791
a0d0e21e 6792 if (!o || o->op_seq)
79072805 6793 return;
a0d0e21e 6794 ENTER;
462e5cf6 6795 SAVEOP();
7766f137 6796 SAVEVPTR(PL_curcop);
a0d0e21e
LW		 6797 for (; o; o = o->op_next) {
6798 if (o->op_seq)
6799 break;
3280af22
NIS		 6800 if (!PL_op_seqmax)
6801 PL_op_seqmax++;
533c011a 6802 PL_op = o;
a0d0e21e 6803 switch (o->op_type) {
acb36ea4 6804 case OP_SETSTATE:
a0d0e21e
LW		 6805 case OP_NEXTSTATE:
6806 case OP_DBSTATE:
3280af22
NIS		 6807 PL_curcop = ((COP*)o); /* for warnings */
6808 o->op_seq = PL_op_seqmax++;
a0d0e21e
LW		 6809 break;
6810
a0d0e21e 6811 case OP_CONST:
7a52d87a
GS		 6812 if (cSVOPo->op_private & OPpCONST_STRICT)
6813 no_bareword_allowed(o);
7766f137
GS		 6814#ifdef USE_ITHREADS
6815 /* Relocate sv to the pad for thread safety.
6816 * Despite being a "constant", the SV is written to,
6817 * for reference counts, sv_upgrade() etc. */
6818 if (cSVOP->op_sv) {
6819 PADOFFSET ix = pad_alloc(OP_CONST, SVs_PADTMP);
6a7129a1
GS		 6820 if (SvPADTMP(cSVOPo->op_sv)) {
6821 /* If op_sv is already a PADTMP then it is being used by
9a049f1c 6822 * some pad, so make a copy. */
6a7129a1
GS		 6823 sv_setsv(PL_curpad[ix],cSVOPo->op_sv);
6824 SvREADONLY_on(PL_curpad[ix]);
6825 SvREFCNT_dec(cSVOPo->op_sv);
6826 }
6827 else {
6828 SvREFCNT_dec(PL_curpad[ix]);
6829 SvPADTMP_on(cSVOPo->op_sv);
6830 PL_curpad[ix] = cSVOPo->op_sv;
9a049f1c
JT		 6831 /* XXX I don't know how this isn't readonly already. */
6832 SvREADONLY_on(PL_curpad[ix]);
6a7129a1 6833 }
7766f137
GS		 6834 cSVOPo->op_sv = Nullsv;
6835 o->op_targ = ix;
6836 }
6837#endif
07447971
GS		 6838 o->op_seq = PL_op_seqmax++;
6839 break;
6840
ed7ab888 6841 case OP_CONCAT:
b162f9ea
IZ		 6842 if (o->op_next && o->op_next->op_type == OP_STRINGIFY) {
6843 if (o->op_next->op_private & OPpTARGET_MY) {
69b47968 6844 if (o->op_flags & OPf_STACKED) /* chained concats */
b162f9ea 6845 goto ignore_optimization;
cd06dffe 6846 else {
07447971 6847 /* assert(PL_opargs[o->op_type] & OA_TARGLEX); */
b162f9ea 6848 o->op_targ = o->op_next->op_targ;
743e66e6 6849 o->op_next->op_targ = 0;
2c2d71f5 6850 o->op_private |= OPpTARGET_MY;
b162f9ea
IZ		 6851 }
6852 }
93c66552 6853 op_null(o->op_next);
b162f9ea
IZ		 6854 }
6855 ignore_optimization:
3280af22 6856 o->op_seq = PL_op_seqmax++;
a0d0e21e 6857 break;
8990e307 6858 case OP_STUB:
54310121 6859 if ((o->op_flags & OPf_WANT) != OPf_WANT_LIST) {
3280af22 6860 o->op_seq = PL_op_seqmax++;
54310121 6861 break; /* Scalar stub must produce undef. List stub is noop */
8990e307 6862 }
748a9306 6863 goto nothin;
79072805 6864 case OP_NULL:
acb36ea4
GS		 6865 if (o->op_targ == OP_NEXTSTATE
6866 || o->op_targ == OP_DBSTATE
6867 || o->op_targ == OP_SETSTATE)
6868 {
3280af22 6869 PL_curcop = ((COP*)o);
acb36ea4 6870 }
dad75012
AMS		 6871 /* XXX: We avoid setting op_seq here to prevent later calls
6872 to peep() from mistakenly concluding that optimisation
6873 has already occurred. This doesn't fix the real problem,
6874 though (See 20010220.007). AMS 20010719 */
6875 if (oldop && o->op_next) {
6876 oldop->op_next = o->op_next;
6877 continue;
6878 }
6879 break;
79072805 6880 case OP_SCALAR:
93a17b20 6881 case OP_LINESEQ:
463ee0b2 6882 case OP_SCOPE:
748a9306 6883 nothin:
a0d0e21e
LW		 6884 if (oldop && o->op_next) {
6885 oldop->op_next = o->op_next;
79072805
LW		 6886 continue;
6887 }
3280af22 6888 o->op_seq = PL_op_seqmax++;
79072805
LW		 6889 break;
6890
6891 case OP_GV:
a0d0e21e 6892 if (o->op_next->op_type == OP_RV2SV) {
64aac5a9 6893 if (!(o->op_next->op_private & OPpDEREF)) {
93c66552 6894 op_null(o->op_next);
64aac5a9
GS		 6895 o->op_private |= o->op_next->op_private & (OPpLVAL_INTRO
6896 | OPpOUR_INTRO);
a0d0e21e
LW		 6897 o->op_next = o->op_next->op_next;
6898 o->op_type = OP_GVSV;
22c35a8c 6899 o->op_ppaddr = PL_ppaddr[OP_GVSV];
8990e307
LW		 6900 }
6901 }
a0d0e21e
LW		 6902 else if (o->op_next->op_type == OP_RV2AV) {
6903 OP* pop = o->op_next->op_next;
6904 IV i;
8990e307 6905 if (pop->op_type == OP_CONST &&
533c011a 6906 (PL_op = pop->op_next) &&
8990e307 6907 pop->op_next->op_type == OP_AELEM &&
a0d0e21e 6908 !(pop->op_next->op_private &
78f9721b 6909 (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB)) &&
b0840a2a 6910 (i = SvIV(((SVOP*)pop)->op_sv) - PL_curcop->cop_arybase)
a0d0e21e 6911 <= 255 &&
8990e307
LW		 6912 i >= 0)
6913 {
350de78d 6914 GV *gv;
93c66552
DM		 6915 op_null(o->op_next);
6916 op_null(pop->op_next);
6917 op_null(pop);
a0d0e21e
LW		 6918 o->op_flags |= pop->op_next->op_flags & OPf_MOD;
6919 o->op_next = pop->op_next->op_next;
6920 o->op_type = OP_AELEMFAST;
22c35a8c 6921 o->op_ppaddr = PL_ppaddr[OP_AELEMFAST];
a0d0e21e 6922 o->op_private = (U8)i;
638eceb6 6923 gv = cGVOPo_gv;
350de78d 6924 GvAVn(gv);
8990e307 6925 }
79072805 6926 }
e476b1b5 6927 else if ((o->op_private & OPpEARLY_CV) && ckWARN(WARN_PROTOTYPE)) {
638eceb6 6928 GV *gv = cGVOPo_gv;
76cd736e
GS		 6929 if (SvTYPE(gv) == SVt_PVGV && GvCV(gv) && SvPVX(GvCV(gv))) {
6930 /* XXX could check prototype here instead of just carping */
6931 SV *sv = sv_newmortal();
6932 gv_efullname3(sv, gv, Nullch);
e476b1b5 6933 Perl_warner(aTHX_ WARN_PROTOTYPE,
76cd736e
GS		 6934 "%s() called too early to check prototype",
6935 SvPV_nolen(sv));
6936 }
6937 }
89de2904
AMS		 6938 else if (o->op_next->op_type == OP_READLINE
6939 && o->op_next->op_next->op_type == OP_CONCAT
6940 && (o->op_next->op_next->op_flags & OPf_STACKED))
6941 {
d2c45030
AMS		 6942 /* Turn "$a .= <FH>" into an OP_RCATLINE. AMS 20010917 */
6943 o->op_type = OP_RCATLINE;
6944 o->op_flags |= OPf_STACKED;
6945 o->op_ppaddr = PL_ppaddr[OP_RCATLINE];
89de2904 6946 op_null(o->op_next->op_next);
d2c45030 6947 op_null(o->op_next);
89de2904 6948 }
76cd736e 6949
3280af22 6950 o->op_seq = PL_op_seqmax++;
79072805
LW		 6951 break;
6952
a0d0e21e 6953 case OP_MAPWHILE:
79072805
LW		 6954 case OP_GREPWHILE:
6955 case OP_AND:
6956 case OP_OR:
2c2d71f5
JH		 6957 case OP_ANDASSIGN:
6958 case OP_ORASSIGN:
1a67a97c
SM		 6959 case OP_COND_EXPR:
6960 case OP_RANGE:
3280af22 6961 o->op_seq = PL_op_seqmax++;
fd4d1407
IZ		 6962 while (cLOGOP->op_other->op_type == OP_NULL)
6963 cLOGOP->op_other = cLOGOP->op_other->op_next;
a2efc822 6964 peep(cLOGOP->op_other); /* Recursive calls are not replaced by fptr calls */
79072805
LW		 6965 break;
6966
79072805 6967 case OP_ENTERLOOP:
9c2ca71a 6968 case OP_ENTERITER:
3280af22 6969 o->op_seq = PL_op_seqmax++;
58cccf98
SM		 6970 while (cLOOP->op_redoop->op_type == OP_NULL)
6971 cLOOP->op_redoop = cLOOP->op_redoop->op_next;
79072805 6972 peep(cLOOP->op_redoop);
58cccf98
SM		 6973 while (cLOOP->op_nextop->op_type == OP_NULL)
6974 cLOOP->op_nextop = cLOOP->op_nextop->op_next;
79072805 6975 peep(cLOOP->op_nextop);
58cccf98
SM		 6976 while (cLOOP->op_lastop->op_type == OP_NULL)
6977 cLOOP->op_lastop = cLOOP->op_lastop->op_next;
79072805
LW		 6978 peep(cLOOP->op_lastop);
6979 break;
6980
8782bef2 6981 case OP_QR:
79072805
LW		 6982 case OP_MATCH:
6983 case OP_SUBST:
3280af22 6984 o->op_seq = PL_op_seqmax++;
9041c2e3 6985 while (cPMOP->op_pmreplstart &&
58cccf98
SM		 6986 cPMOP->op_pmreplstart->op_type == OP_NULL)
6987 cPMOP->op_pmreplstart = cPMOP->op_pmreplstart->op_next;
a0d0e21e 6988 peep(cPMOP->op_pmreplstart);
79072805
LW		 6989 break;
6990
a0d0e21e 6991 case OP_EXEC:
3280af22 6992 o->op_seq = PL_op_seqmax++;
1c846c1f 6993 if (ckWARN(WARN_SYNTAX) && o->op_next
599cee73 6994 && o->op_next->op_type == OP_NEXTSTATE) {
a0d0e21e 6995 if (o->op_next->op_sibling &&
20408e3c
GS		 6996 o->op_next->op_sibling->op_type != OP_EXIT &&
6997 o->op_next->op_sibling->op_type != OP_WARN &&
a0d0e21e 6998 o->op_next->op_sibling->op_type != OP_DIE) {
57843af0 6999 line_t oldline = CopLINE(PL_curcop);
a0d0e21e 7000
57843af0 7001 CopLINE_set(PL_curcop, CopLINE((COP*)o->op_next));
eeb6a2c9
GS		 7002 Perl_warner(aTHX_ WARN_EXEC,
7003 "Statement unlikely to be reached");
7004 Perl_warner(aTHX_ WARN_EXEC,
cc507455 7005 "\t(Maybe you meant system() when you said exec()?)\n");
57843af0 7006 CopLINE_set(PL_curcop, oldline);
a0d0e21e
LW		 7007 }
7008 }
7009 break;
aeea060c 7010
c750a3ec
MB		 7011 case OP_HELEM: {
7012 UNOP *rop;
7013 SV *lexname;
7014 GV **fields;
9615e741 7015 SV **svp, **indsvp, *sv;
c750a3ec 7016 I32 ind;
1c846c1f 7017 char *key = NULL;
c750a3ec 7018 STRLEN keylen;
aeea060c 7019
9615e741 7020 o->op_seq = PL_op_seqmax++;
1c846c1f
NIS		 7021
7022 if (((BINOP*)o)->op_last->op_type != OP_CONST)
c750a3ec 7023 break;
1c846c1f
NIS		 7024
7025 /* Make the CONST have a shared SV */
7026 svp = cSVOPx_svp(((BINOP*)o)->op_last);
3049cdab 7027 if ((!SvFAKE(sv = *svp) || !SvREADONLY(sv)) && !IS_PADCONST(sv)) {
1c846c1f 7028 key = SvPV(sv, keylen);
25716404
GS		 7029 lexname = newSVpvn_share(key,
7030 SvUTF8(sv) ? -(I32)keylen : keylen,
7031 0);
1c846c1f
NIS		 7032 SvREFCNT_dec(sv);
7033 *svp = lexname;
7034 }
7035
7036 if ((o->op_private & (OPpLVAL_INTRO)))
7037 break;
7038
c750a3ec
MB		 7039 rop = (UNOP*)((BINOP*)o)->op_first;
7040 if (rop->op_type != OP_RV2HV || rop->op_first->op_type != OP_PADSV)
7041 break;
3280af22 7042 lexname = *av_fetch(PL_comppad_name, rop->op_first->op_targ, TRUE);
524189f1 7043 if (!(SvFLAGS(lexname) & SVpad_TYPED))
c750a3ec 7044 break;
5196be3e 7045 fields = (GV**)hv_fetch(SvSTASH(lexname), "FIELDS", 6, FALSE);
c750a3ec
MB		 7046 if (!fields || !GvHV(*fields))
7047 break;
c750a3ec 7048 key = SvPV(*svp, keylen);
25716404
GS		 7049 indsvp = hv_fetch(GvHV(*fields), key,
7050 SvUTF8(*svp) ? -(I32)keylen : keylen, FALSE);
c750a3ec 7051 if (!indsvp) {
88e9b055 7052 Perl_croak(aTHX_ "No such pseudo-hash field \"%s\" in variable %s of type %s",
2d8e6c8d 7053 key, SvPV(lexname, n_a), HvNAME(SvSTASH(lexname)));
c750a3ec
MB		 7054 }
7055 ind = SvIV(*indsvp);
7056 if (ind < 1)
cea2e8a9 7057 Perl_croak(aTHX_ "Bad index while coercing array into hash");
c750a3ec 7058 rop->op_type = OP_RV2AV;
22c35a8c 7059 rop->op_ppaddr = PL_ppaddr[OP_RV2AV];
c750a3ec 7060 o->op_type = OP_AELEM;
22c35a8c 7061 o->op_ppaddr = PL_ppaddr[OP_AELEM];
9615e741
GS		 7062 sv = newSViv(ind);
7063 if (SvREADONLY(*svp))
7064 SvREADONLY_on(sv);
7065 SvFLAGS(sv) |= (SvFLAGS(*svp)
7066 & (SVs_PADBUSY|SVs_PADTMP|SVs_PADMY));
c750a3ec 7067 SvREFCNT_dec(*svp);
9615e741 7068 *svp = sv;
c750a3ec
MB		 7069 break;
7070 }
345599ca
GS		 7071
7072 case OP_HSLICE: {
7073 UNOP *rop;
7074 SV *lexname;
7075 GV **fields;
9615e741 7076 SV **svp, **indsvp, *sv;
345599ca
GS		 7077 I32 ind;
7078 char *key;
7079 STRLEN keylen;
7080 SVOP *first_key_op, *key_op;
9615e741
GS		 7081
7082 o->op_seq = PL_op_seqmax++;
345599ca
GS		 7083 if ((o->op_private & (OPpLVAL_INTRO))
7084 /* I bet there's always a pushmark... */
7085 || ((LISTOP*)o)->op_first->op_sibling->op_type != OP_LIST)
7086 /* hmmm, no optimization if list contains only one key. */
7087 break;
7088 rop = (UNOP*)((LISTOP*)o)->op_last;
7089 if (rop->op_type != OP_RV2HV || rop->op_first->op_type != OP_PADSV)
7090 break;
7091 lexname = *av_fetch(PL_comppad_name, rop->op_first->op_targ, TRUE);
524189f1 7092 if (!(SvFLAGS(lexname) & SVpad_TYPED))
345599ca
GS		 7093 break;
7094 fields = (GV**)hv_fetch(SvSTASH(lexname), "FIELDS", 6, FALSE);
7095 if (!fields || !GvHV(*fields))
7096 break;
7097 /* Again guessing that the pushmark can be jumped over.... */
7098 first_key_op = (SVOP*)((LISTOP*)((LISTOP*)o)->op_first->op_sibling)
7099 ->op_first->op_sibling;
7100 /* Check that the key list contains only constants. */
7101 for (key_op = first_key_op; key_op;
7102 key_op = (SVOP*)key_op->op_sibling)
7103 if (key_op->op_type != OP_CONST)
7104 break;
7105 if (key_op)
7106 break;
7107 rop->op_type = OP_RV2AV;
7108 rop->op_ppaddr = PL_ppaddr[OP_RV2AV];
7109 o->op_type = OP_ASLICE;
7110 o->op_ppaddr = PL_ppaddr[OP_ASLICE];
7111 for (key_op = first_key_op; key_op;
7112 key_op = (SVOP*)key_op->op_sibling) {
7113 svp = cSVOPx_svp(key_op);
7114 key = SvPV(*svp, keylen);
25716404
GS		 7115 indsvp = hv_fetch(GvHV(*fields), key,
7116 SvUTF8(*svp) ? -(I32)keylen : keylen, FALSE);
345599ca 7117 if (!indsvp) {
9615e741
GS		 7118 Perl_croak(aTHX_ "No such pseudo-hash field \"%s\" "
7119 "in variable %s of type %s",
345599ca
GS		 7120 key, SvPV(lexname, n_a), HvNAME(SvSTASH(lexname)));
7121 }
7122 ind = SvIV(*indsvp);
7123 if (ind < 1)
7124 Perl_croak(aTHX_ "Bad index while coercing array into hash");
9615e741
GS		 7125 sv = newSViv(ind);
7126 if (SvREADONLY(*svp))
7127 SvREADONLY_on(sv);
7128 SvFLAGS(sv) |= (SvFLAGS(*svp)
7129 & (SVs_PADBUSY|SVs_PADTMP|SVs_PADMY));
345599ca 7130 SvREFCNT_dec(*svp);
9615e741 7131 *svp = sv;
345599ca
GS		 7132 }
7133 break;
7134 }
c750a3ec 7135
79072805 7136 default:
3280af22 7137 o->op_seq = PL_op_seqmax++;
79072805
LW		 7138 break;
7139 }
a0d0e21e 7140 oldop = o;
79072805 7141 }
a0d0e21e 7142 LEAVE;
79072805 7143}
beab0874 7144
19e8ce8e
AB		 7145
7146
7147char* Perl_custom_op_name(pTHX_ OP* o)
53e06cf0
SC		 7148{
7149 IV index = PTR2IV(o->op_ppaddr);
7150 SV* keysv;
7151 HE* he;
7152
7153 if (!PL_custom_op_names) /* This probably shouldn't happen */
7154 return PL_op_name[OP_CUSTOM];
7155
7156 keysv = sv_2mortal(newSViv(index));
7157
7158 he = hv_fetch_ent(PL_custom_op_names, keysv, 0, 0);
7159 if (!he)
7160 return PL_op_name[OP_CUSTOM]; /* Don't know who you are */
7161
7162 return SvPV_nolen(HeVAL(he));
7163}
7164
19e8ce8e 7165char* Perl_custom_op_desc(pTHX_ OP* o)
53e06cf0
SC		 7166{
7167 IV index = PTR2IV(o->op_ppaddr);
7168 SV* keysv;
7169 HE* he;
7170
7171 if (!PL_custom_op_descs)
7172 return PL_op_desc[OP_CUSTOM];
7173
7174 keysv = sv_2mortal(newSViv(index));
7175
7176 he = hv_fetch_ent(PL_custom_op_descs, keysv, 0, 0);
7177 if (!he)
7178 return PL_op_desc[OP_CUSTOM];
7179
7180 return SvPV_nolen(HeVAL(he));
7181}
19e8ce8e 7182
53e06cf0 7183
beab0874
JT		 7184#include "XSUB.h"
7185
7186/* Efficient sub that returns a constant scalar value. */
7187static void
acfe0abc 7188const_sv_xsub(pTHX_ CV* cv)
beab0874
JT		 7189{
7190 dXSARGS;
9cbac4c7
DM		 7191 if (items != 0) {
7192#if 0
7193 Perl_croak(aTHX_ "usage: %s::%s()",
7194 HvNAME(GvSTASH(CvGV(cv))), GvNAME(CvGV(cv)));
7195#endif
7196 }
9a049f1c 7197 EXTEND(sp, 1);
0768512c 7198 ST(0) = (SV*)XSANY.any_ptr;
beab0874
JT		 7199 XSRETURN(1);
7200}
2b9d42f0 7201
Unnamed repository; edit this file 'description' to name the repository.