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