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