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