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