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