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