This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
https://perl5.git.perl.org / perl5.git / blame
? search:
summary | shortlog | log | commit | commitdiff | tree
blob | blame (incremental) | history | HEAD
Integrate Memoize 0.64. Few tweaks were required in
[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 */
93a17b20 381 continue;
93a17b20 382 }
2680586e 383 return pad_findlex(name, newoff, seq, cv, i-1, saweval,FINDLEX_NOSEARCH);
93a17b20
LW		 384 }
385 }
386
748a9306
LW		 387 return 0;
388}
a0d0e21e 389
748a9306 390PADOFFSET
864dbfa3 391Perl_pad_findmy(pTHX_ char *name)
748a9306
LW		 392{
393 I32 off;
54310121 394 I32 pendoff = 0;
748a9306 395 SV *sv;
3280af22
NIS		 396 SV **svp = AvARRAY(PL_comppad_name);
397 U32 seq = PL_cop_seqmax;
6b35e009 398 PERL_CONTEXT *cx;
33b8ce05 399 CV *outside;
748a9306 400
11343788
MB		 401#ifdef USE_THREADS
402 /*
403 * Special case to get lexical (and hence per-thread) @_.
404 * XXX I need to find out how to tell at parse-time whether use
405 * of @_ should refer to a lexical (from a sub) or defgv (global
406 * scope and maybe weird sub-ish things like formats). See
407 * startsub in perly.y. It's possible that @_ could be lexical
408 * (at least from subs) even in non-threaded perl.
409 */
410 if (strEQ(name, "@_"))
411 return 0; /* success. (NOT_IN_PAD indicates failure) */
412#endif /* USE_THREADS */
413
748a9306 414 /* The one we're looking for is probably just before comppad_name_fill. */
3280af22 415 for (off = AvFILLp(PL_comppad_name); off > 0; off--) {
a0d0e21e 416 if ((sv = svp[off]) &&
3280af22 417 sv != &PL_sv_undef &&
54310121 418 (!SvIVX(sv) ||
419 (seq <= SvIVX(sv) &&
420 seq > I_32(SvNVX(sv)))) &&
a0d0e21e
LW		 421 strEQ(SvPVX(sv), name))
422 {
77ca0c92 423 if (SvIVX(sv) || SvFLAGS(sv) & SVpad_OUR)
54310121 424 return (PADOFFSET)off;
425 pendoff = off; /* this pending def. will override import */
a0d0e21e
LW		 426 }
427 }
748a9306 428
33b8ce05
GS		 429 outside = CvOUTSIDE(PL_compcv);
430
431 /* Check if if we're compiling an eval'', and adjust seq to be the
432 * eval's seq number. This depends on eval'' having a non-null
433 * CvOUTSIDE() while it is being compiled. The eval'' itself is
1aff0e91
GS		 434 * identified by CvEVAL being true and CvGV being null. */
435 if (outside && CvEVAL(PL_compcv) && !CvGV(PL_compcv) && cxstack_ix >= 0) {
6b35e009
GS		 436 cx = &cxstack[cxstack_ix];
437 if (CxREALEVAL(cx))
438 seq = cx->blk_oldcop->cop_seq;
439 }
440
748a9306 441 /* See if it's in a nested scope */
2680586e 442 off = pad_findlex(name, 0, seq, outside, cxstack_ix, 0, 0);
54310121 443 if (off) {
444 /* If there is a pending local definition, this new alias must die */
445 if (pendoff)
3280af22 446 SvIVX(AvARRAY(PL_comppad_name)[off]) = seq;
11343788 447 return off; /* pad_findlex returns 0 for failure...*/
54310121 448 }
11343788 449 return NOT_IN_PAD; /* ...but we return NOT_IN_PAD for failure */
93a17b20
LW		 450}
451
452void
864dbfa3 453Perl_pad_leavemy(pTHX_ I32 fill)
93a17b20
LW		 454{
455 I32 off;
3280af22 456 SV **svp = AvARRAY(PL_comppad_name);
93a17b20 457 SV *sv;
3280af22
NIS		 458 if (PL_min_intro_pending && fill < PL_min_intro_pending) {
459 for (off = PL_max_intro_pending; off >= PL_min_intro_pending; off--) {
0453d815
PM		 460 if ((sv = svp[off]) && sv != &PL_sv_undef && ckWARN_d(WARN_INTERNAL))
461 Perl_warner(aTHX_ WARN_INTERNAL, "%s never introduced", SvPVX(sv));
8990e307
LW		 462 }
463 }
464 /* "Deintroduce" my variables that are leaving with this scope. */
3280af22 465 for (off = AvFILLp(PL_comppad_name); off > fill; off--) {
c53d7c7d 466 if ((sv = svp[off]) && sv != &PL_sv_undef && SvIVX(sv) == PAD_MAX)
3280af22 467 SvIVX(sv) = PL_cop_seqmax;
93a17b20
LW		 468 }
469}
470
471PADOFFSET
864dbfa3 472Perl_pad_alloc(pTHX_ I32 optype, U32 tmptype)
79072805
LW		 473{
474 SV *sv;
475 I32 retval;
476
3280af22 477 if (AvARRAY(PL_comppad) != PL_curpad)
cea2e8a9 478 Perl_croak(aTHX_ "panic: pad_alloc");
3280af22 479 if (PL_pad_reset_pending)
a0d0e21e 480 pad_reset();
ed6116ce 481 if (tmptype & SVs_PADMY) {
79072805 482 do {
3280af22 483 sv = *av_fetch(PL_comppad, AvFILLp(PL_comppad) + 1, TRUE);
ed6116ce 484 } while (SvPADBUSY(sv)); /* need a fresh one */
3280af22 485 retval = AvFILLp(PL_comppad);
79072805
LW		 486 }
487 else {
3280af22
NIS		 488 SV **names = AvARRAY(PL_comppad_name);
489 SSize_t names_fill = AvFILLp(PL_comppad_name);
bbce6d69 490 for (;;) {
491 /*
492 * "foreach" index vars temporarily become aliases to non-"my"
493 * values. Thus we must skip, not just pad values that are
494 * marked as current pad values, but also those with names.
495 */
3280af22
NIS		 496 if (++PL_padix <= names_fill &&
497 (sv = names[PL_padix]) && sv != &PL_sv_undef)
bbce6d69 498 continue;
3280af22 499 sv = *av_fetch(PL_comppad, PL_padix, TRUE);
3049cdab
SB		 500 if (!(SvFLAGS(sv) & (SVs_PADTMP|SVs_PADMY)) &&
501 !IS_PADGV(sv) && !IS_PADCONST(sv))
bbce6d69 502 break;
503 }
3280af22 504 retval = PL_padix;
79072805 505 }
8990e307 506 SvFLAGS(sv) |= tmptype;
3280af22 507 PL_curpad = AvARRAY(PL_comppad);
11343788 508#ifdef USE_THREADS
b900a521
JH		 509 DEBUG_X(PerlIO_printf(Perl_debug_log,
510 "0x%"UVxf" Pad 0x%"UVxf" alloc %ld for %s\n",
511 PTR2UV(thr), PTR2UV(PL_curpad),
22c35a8c 512 (long) retval, PL_op_name[optype]));
11343788 513#else
b900a521
JH		 514 DEBUG_X(PerlIO_printf(Perl_debug_log,
515 "Pad 0x%"UVxf" alloc %ld for %s\n",
516 PTR2UV(PL_curpad),
22c35a8c 517 (long) retval, PL_op_name[optype]));
11343788 518#endif /* USE_THREADS */
79072805
LW		 519 return (PADOFFSET)retval;
520}
521
522SV *
864dbfa3 523Perl_pad_sv(pTHX_ PADOFFSET po)
79072805 524{
11343788 525#ifdef USE_THREADS
b900a521 526 DEBUG_X(PerlIO_printf(Perl_debug_log,
f1dbda3d
JH		 527 "0x%"UVxf" Pad 0x%"UVxf" sv %"IVdf"\n",
528 PTR2UV(thr), PTR2UV(PL_curpad), (IV)po));
11343788 529#else
79072805 530 if (!po)
cea2e8a9 531 Perl_croak(aTHX_ "panic: pad_sv po");
97835f67
JH		 532 DEBUG_X(PerlIO_printf(Perl_debug_log, "Pad 0x%"UVxf" sv %"IVdf"\n",
533 PTR2UV(PL_curpad), (IV)po));
11343788 534#endif /* USE_THREADS */
3280af22 535 return PL_curpad[po]; /* eventually we'll turn this into a macro */
79072805
LW		 536}
537
538void
864dbfa3 539Perl_pad_free(pTHX_ PADOFFSET po)
79072805 540{
3280af22 541 if (!PL_curpad)
a0d0e21e 542 return;
3280af22 543 if (AvARRAY(PL_comppad) != PL_curpad)
cea2e8a9 544 Perl_croak(aTHX_ "panic: pad_free curpad");
79072805 545 if (!po)
cea2e8a9 546 Perl_croak(aTHX_ "panic: pad_free po");
11343788 547#ifdef USE_THREADS
b900a521 548 DEBUG_X(PerlIO_printf(Perl_debug_log,
7766f137 549 "0x%"UVxf" Pad 0x%"UVxf" free %"IVdf"\n",
f1dbda3d 550 PTR2UV(thr), PTR2UV(PL_curpad), (IV)po));
11343788 551#else
97835f67
JH		 552 DEBUG_X(PerlIO_printf(Perl_debug_log, "Pad 0x%"UVxf" free %"IVdf"\n",
553 PTR2UV(PL_curpad), (IV)po));
11343788 554#endif /* USE_THREADS */
2aa1bedc 555 if (PL_curpad[po] && PL_curpad[po] != &PL_sv_undef) {
3280af22 556 SvPADTMP_off(PL_curpad[po]);
2aa1bedc
GS		 557#ifdef USE_ITHREADS
558 SvREADONLY_off(PL_curpad[po]); /* could be a freed constant */
559#endif
560 }
3280af22
NIS		 561 if ((I32)po < PL_padix)
562 PL_padix = po - 1;
79072805
LW		 563}
564
565void
864dbfa3 566Perl_pad_swipe(pTHX_ PADOFFSET po)
79072805 567{
3280af22 568 if (AvARRAY(PL_comppad) != PL_curpad)
cea2e8a9 569 Perl_croak(aTHX_ "panic: pad_swipe curpad");
79072805 570 if (!po)
cea2e8a9 571 Perl_croak(aTHX_ "panic: pad_swipe po");
11343788 572#ifdef USE_THREADS
b900a521 573 DEBUG_X(PerlIO_printf(Perl_debug_log,
f1dbda3d
JH		 574 "0x%"UVxf" Pad 0x%"UVxf" swipe %"IVdf"\n",
575 PTR2UV(thr), PTR2UV(PL_curpad), (IV)po));
11343788 576#else
97835f67
JH		 577 DEBUG_X(PerlIO_printf(Perl_debug_log, "Pad 0x%"UVxf" swipe %"IVdf"\n",
578 PTR2UV(PL_curpad), (IV)po));
11343788 579#endif /* USE_THREADS */
3280af22
NIS		 580 SvPADTMP_off(PL_curpad[po]);
581 PL_curpad[po] = NEWSV(1107,0);
582 SvPADTMP_on(PL_curpad[po]);
583 if ((I32)po < PL_padix)
584 PL_padix = po - 1;
79072805
LW		 585}
586
d9bb4600
GS		 587/* XXX pad_reset() is currently disabled because it results in serious bugs.
588 * It causes pad temp TARGs to be shared between OPs. Since TARGs are pushed
589 * on the stack by OPs that use them, there are several ways to get an alias
590 * to a shared TARG. Such an alias will change randomly and unpredictably.
591 * We avoid doing this until we can think of a Better Way.
592 * GSAR 97-10-29 */
79072805 593void
864dbfa3 594Perl_pad_reset(pTHX)
79072805 595{
d9bb4600 596#ifdef USE_BROKEN_PAD_RESET
79072805
LW		 597 register I32 po;
598
6b88bc9c 599 if (AvARRAY(PL_comppad) != PL_curpad)
cea2e8a9 600 Perl_croak(aTHX_ "panic: pad_reset curpad");
11343788 601#ifdef USE_THREADS
b900a521
JH		 602 DEBUG_X(PerlIO_printf(Perl_debug_log,
603 "0x%"UVxf" Pad 0x%"UVxf" reset\n",
604 PTR2UV(thr), PTR2UV(PL_curpad)));
11343788 605#else
b900a521
JH		 606 DEBUG_X(PerlIO_printf(Perl_debug_log, "Pad 0x%"UVxf" reset\n",
607 PTR2UV(PL_curpad)));
11343788 608#endif /* USE_THREADS */
6b88bc9c
GS		 609 if (!PL_tainting) { /* Can't mix tainted and non-tainted temporaries. */
610 for (po = AvMAX(PL_comppad); po > PL_padix_floor; po--) {
611 if (PL_curpad[po] && !SvIMMORTAL(PL_curpad[po]))
612 SvPADTMP_off(PL_curpad[po]);
748a9306 613 }
6b88bc9c 614 PL_padix = PL_padix_floor;
79072805 615 }
d9bb4600 616#endif
3280af22 617 PL_pad_reset_pending = FALSE;
79072805
LW		 618}
619
a863c7d1 620#ifdef USE_THREADS
54b9620d 621/* find_threadsv is not reentrant */
a863c7d1 622PADOFFSET
864dbfa3 623Perl_find_threadsv(pTHX_ const char *name)
a863c7d1 624{
a863c7d1
MB		 625 char *p;
626 PADOFFSET key;
554b3eca 627 SV **svp;
54b9620d 628 /* We currently only handle names of a single character */
533c011a 629 p = strchr(PL_threadsv_names, *name);
a863c7d1
MB		 630 if (!p)
631 return NOT_IN_PAD;
533c011a 632 key = p - PL_threadsv_names;
2d8e6c8d 633 MUTEX_LOCK(&thr->mutex);
54b9620d 634 svp = av_fetch(thr->threadsv, key, FALSE);
2d8e6c8d
GS		 635 if (svp)
636 MUTEX_UNLOCK(&thr->mutex);
637 else {
554b3eca 638 SV *sv = NEWSV(0, 0);
54b9620d 639 av_store(thr->threadsv, key, sv);
940cb80d 640 thr->threadsvp = AvARRAY(thr->threadsv);
2d8e6c8d 641 MUTEX_UNLOCK(&thr->mutex);
554b3eca
MB		 642 /*
643 * Some magic variables used to be automagically initialised
644 * in gv_fetchpv. Those which are now per-thread magicals get
645 * initialised here instead.
646 */
647 switch (*name) {
54b9620d
MB		 648 case '_':
649 break;
554b3eca
MB		 650 case ';':
651 sv_setpv(sv, "\034");
14befaf4 652 sv_magic(sv, 0, PERL_MAGIC_sv, name, 1);
554b3eca 653 break;
c277df42
IZ		 654 case '&':
655 case '`':
656 case '\'':
533c011a 657 PL_sawampersand = TRUE;
a3f914c5
GS		 658 /* FALL THROUGH */
659 case '1':
660 case '2':
661 case '3':
662 case '4':
663 case '5':
664 case '6':
665 case '7':
666 case '8':
667 case '9':
c277df42 668 SvREADONLY_on(sv);
d8b5173a 669 /* FALL THROUGH */
067391ea
GS		 670
671 /* XXX %! tied to Errno.pm needs to be added here.
672 * See gv_fetchpv(). */
673 /* case '!': */
674
54b9620d 675 default:
14befaf4 676 sv_magic(sv, 0, PERL_MAGIC_sv, name, 1);
554b3eca 677 }
bf49b057 678 DEBUG_S(PerlIO_printf(Perl_error_log,
54b9620d 679 "find_threadsv: new SV %p for $%s%c\n",
554b3eca
MB		 680 sv, (*name < 32) ? "^" : "",
681 (*name < 32) ? toCTRL(*name) : *name));
a863c7d1
MB		 682 }
683 return key;
684}
685#endif /* USE_THREADS */
686
79072805
LW		 687/* Destructor */
688
689void
864dbfa3 690Perl_op_free(pTHX_ OP *o)
79072805 691{
85e6fe83 692 register OP *kid, *nextkid;
acb36ea4 693 OPCODE type;
79072805 694
5dc0d613 695 if (!o || o->op_seq == (U16)-1)
79072805
LW		 696 return;
697
7934575e
GS		 698 if (o->op_private & OPpREFCOUNTED) {
699 switch (o->op_type) {
700 case OP_LEAVESUB:
701 case OP_LEAVESUBLV:
702 case OP_LEAVEEVAL:
703 case OP_LEAVE:
704 case OP_SCOPE:
705 case OP_LEAVEWRITE:
706 OP_REFCNT_LOCK;
707 if (OpREFCNT_dec(o)) {
708 OP_REFCNT_UNLOCK;
709 return;
710 }
711 OP_REFCNT_UNLOCK;
712 break;
713 default:
714 break;
715 }
716 }
717
11343788
MB		 718 if (o->op_flags & OPf_KIDS) {
719 for (kid = cUNOPo->op_first; kid; kid = nextkid) {
85e6fe83 720 nextkid = kid->op_sibling; /* Get before next freeing kid */
79072805 721 op_free(kid);
85e6fe83 722 }
79072805 723 }
acb36ea4
GS		 724 type = o->op_type;
725 if (type == OP_NULL)
726 type = o->op_targ;
727
728 /* COP* is not cleared by op_clear() so that we may track line
729 * numbers etc even after null() */
730 if (type == OP_NEXTSTATE || type == OP_SETSTATE || type == OP_DBSTATE)
731 cop_free((COP*)o);
732
733 op_clear(o);
734
735#ifdef PL_OP_SLAB_ALLOC
736 if ((char *) o == PL_OpPtr)
737 {
738 }
739#else
740 Safefree(o);
741#endif
742}
79072805 743
93c66552
DM		 744void
745Perl_op_clear(pTHX_ OP *o)
acb36ea4 746{
11343788 747 switch (o->op_type) {
acb36ea4
GS		 748 case OP_NULL: /* Was holding old type, if any. */
749 case OP_ENTEREVAL: /* Was holding hints. */
750#ifdef USE_THREADS
751 case OP_THREADSV: /* Was holding index into thr->threadsv AV. */
752#endif
753 o->op_targ = 0;
a0d0e21e 754 break;
554b3eca 755#ifdef USE_THREADS
8dd3ba40
SM		 756 case OP_ENTERITER:
757 if (!(o->op_flags & OPf_SPECIAL))
758 break;
759 /* FALL THROUGH */
554b3eca 760#endif /* USE_THREADS */
a6006777 761 default:
ac4c12e7 762 if (!(o->op_flags & OPf_REF)
0b94c7bb 763 || (PL_check[o->op_type] != MEMBER_TO_FPTR(Perl_ck_ftst)))
a6006777 764 break;
765 /* FALL THROUGH */
463ee0b2 766 case OP_GVSV:
79072805 767 case OP_GV:
a6006777 768 case OP_AELEMFAST:
350de78d 769#ifdef USE_ITHREADS
971a9dd3
GS		 770 if (cPADOPo->op_padix > 0) {
771 if (PL_curpad) {
638eceb6 772 GV *gv = cGVOPo_gv;
971a9dd3
GS		 773 pad_swipe(cPADOPo->op_padix);
774 /* No GvIN_PAD_off(gv) here, because other references may still
775 * exist on the pad */
776 SvREFCNT_dec(gv);
777 }
778 cPADOPo->op_padix = 0;
779 }
350de78d 780#else
971a9dd3 781 SvREFCNT_dec(cSVOPo->op_sv);
7934575e 782 cSVOPo->op_sv = Nullsv;
350de78d 783#endif
79072805 784 break;
a1ae71d2 785 case OP_METHOD_NAMED:
79072805 786 case OP_CONST:
11343788 787 SvREFCNT_dec(cSVOPo->op_sv);
acb36ea4 788 cSVOPo->op_sv = Nullsv;
79072805 789 break;
748a9306
LW		 790 case OP_GOTO:
791 case OP_NEXT:
792 case OP_LAST:
793 case OP_REDO:
11343788 794 if (o->op_flags & (OPf_SPECIAL|OPf_STACKED|OPf_KIDS))
748a9306
LW		 795 break;
796 /* FALL THROUGH */
a0d0e21e 797 case OP_TRANS:
acb36ea4 798 if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
a0ed51b3 799 SvREFCNT_dec(cSVOPo->op_sv);
acb36ea4
GS		 800 cSVOPo->op_sv = Nullsv;
801 }
802 else {
a0ed51b3 803 Safefree(cPVOPo->op_pv);
acb36ea4
GS		 804 cPVOPo->op_pv = Nullch;
805 }
a0d0e21e
LW		 806 break;
807 case OP_SUBST:
11343788 808 op_free(cPMOPo->op_pmreplroot);
971a9dd3 809 goto clear_pmop;
748a9306 810 case OP_PUSHRE:
971a9dd3
GS		 811#ifdef USE_ITHREADS
812 if ((PADOFFSET)cPMOPo->op_pmreplroot) {
813 if (PL_curpad) {
814 GV *gv = (GV*)PL_curpad[(PADOFFSET)cPMOPo->op_pmreplroot];
815 pad_swipe((PADOFFSET)cPMOPo->op_pmreplroot);
816 /* No GvIN_PAD_off(gv) here, because other references may still
817 * exist on the pad */
818 SvREFCNT_dec(gv);
819 }
820 }
821#else
822 SvREFCNT_dec((SV*)cPMOPo->op_pmreplroot);
823#endif
824 /* FALL THROUGH */
a0d0e21e 825 case OP_MATCH:
8782bef2 826 case OP_QR:
971a9dd3 827clear_pmop:
cb55de95
JH		 828 {
829 HV *pmstash = PmopSTASH(cPMOPo);
830 if (pmstash && SvREFCNT(pmstash)) {
831 PMOP *pmop = HvPMROOT(pmstash);
832 PMOP *lastpmop = NULL;
833 while (pmop) {
834 if (cPMOPo == pmop) {
835 if (lastpmop)
836 lastpmop->op_pmnext = pmop->op_pmnext;
837 else
838 HvPMROOT(pmstash) = pmop->op_pmnext;
839 break;
840 }
841 lastpmop = pmop;
842 pmop = pmop->op_pmnext;
843 }
844#ifdef USE_ITHREADS
845 Safefree(PmopSTASHPV(cPMOPo));
846#else
847 /* NOTE: PMOP.op_pmstash is not refcounted */
848#endif
849 }
850 }
971a9dd3 851 cPMOPo->op_pmreplroot = Nullop;
c277df42 852 ReREFCNT_dec(cPMOPo->op_pmregexp);
acb36ea4 853 cPMOPo->op_pmregexp = (REGEXP*)NULL;
a0d0e21e 854 break;
79072805
LW		 855 }
856
743e66e6 857 if (o->op_targ > 0) {
11343788 858 pad_free(o->op_targ);
743e66e6
GS		 859 o->op_targ = 0;
860 }
79072805
LW		 861}
862
76e3520e 863STATIC void
3eb57f73
HS		 864S_cop_free(pTHX_ COP* cop)
865{
866 Safefree(cop->cop_label);
57843af0 867#ifdef USE_ITHREADS
f4dd75d9
GS		 868 Safefree(CopFILE(cop)); /* XXX share in a pvtable? */
869 Safefree(CopSTASHPV(cop)); /* XXX share in a pvtable? */
57843af0 870#else
11faa288 871 /* NOTE: COP.cop_stash is not refcounted */
cc49e20b 872 SvREFCNT_dec(CopFILEGV(cop));
57843af0 873#endif
0453d815 874 if (! specialWARN(cop->cop_warnings))
3eb57f73 875 SvREFCNT_dec(cop->cop_warnings);
ac27b0f5
NIS		 876 if (! specialCopIO(cop->cop_io))
877 SvREFCNT_dec(cop->cop_io);
3eb57f73
HS		 878}
879
93c66552
DM		 880void
881Perl_op_null(pTHX_ OP *o)
8990e307 882{
acb36ea4
GS		 883 if (o->op_type == OP_NULL)
884 return;
885 op_clear(o);
11343788
MB		 886 o->op_targ = o->op_type;
887 o->op_type = OP_NULL;
22c35a8c 888 o->op_ppaddr = PL_ppaddr[OP_NULL];
8990e307
LW		 889}
890
79072805
LW		 891/* Contextualizers */
892
463ee0b2 893#define LINKLIST(o) ((o)->op_next ? (o)->op_next : linklist((OP*)o))
79072805
LW		 894
895OP *
864dbfa3 896Perl_linklist(pTHX_ OP *o)
79072805
LW		 897{
898 register OP *kid;
899
11343788
MB		 900 if (o->op_next)
901 return o->op_next;
79072805
LW		 902
903 /* establish postfix order */
11343788
MB		 904 if (cUNOPo->op_first) {
905 o->op_next = LINKLIST(cUNOPo->op_first);
906 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
79072805
LW		 907 if (kid->op_sibling)
908 kid->op_next = LINKLIST(kid->op_sibling);
909 else
11343788 910 kid->op_next = o;
79072805
LW		 911 }
912 }
913 else
11343788 914 o->op_next = o;
79072805 915
11343788 916 return o->op_next;
79072805
LW		 917}
918
919OP *
864dbfa3 920Perl_scalarkids(pTHX_ OP *o)
79072805
LW		 921{
922 OP *kid;
11343788
MB		 923 if (o && o->op_flags & OPf_KIDS) {
924 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
79072805
LW		 925 scalar(kid);
926 }
11343788 927 return o;
79072805
LW		 928}
929
76e3520e 930STATIC OP *
cea2e8a9 931S_scalarboolean(pTHX_ OP *o)
8990e307 932{
d008e5eb 933 if (o->op_type == OP_SASSIGN && cBINOPo->op_first->op_type == OP_CONST) {
d008e5eb 934 if (ckWARN(WARN_SYNTAX)) {
57843af0 935 line_t oldline = CopLINE(PL_curcop);
a0d0e21e 936
d008e5eb 937 if (PL_copline != NOLINE)
57843af0 938 CopLINE_set(PL_curcop, PL_copline);
cea2e8a9 939 Perl_warner(aTHX_ WARN_SYNTAX, "Found = in conditional, should be ==");
57843af0 940 CopLINE_set(PL_curcop, oldline);
d008e5eb 941 }
a0d0e21e 942 }
11343788 943 return scalar(o);
8990e307
LW		 944}
945
946OP *
864dbfa3 947Perl_scalar(pTHX_ OP *o)
79072805
LW		 948{
949 OP *kid;
950
a0d0e21e 951 /* assumes no premature commitment */
3280af22 952 if (!o || (o->op_flags & OPf_WANT) || PL_error_count
5dc0d613 953 || o->op_type == OP_RETURN)
7e363e51 954 {
11343788 955 return o;
7e363e51 956 }
79072805 957
5dc0d613 958 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_SCALAR;
79072805 959
11343788 960 switch (o->op_type) {
79072805 961 case OP_REPEAT:
11343788 962 scalar(cBINOPo->op_first);
8990e307 963 break;
79072805
LW		 964 case OP_OR:
965 case OP_AND:
966 case OP_COND_EXPR:
11343788 967 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
8990e307 968 scalar(kid);
79072805 969 break;
a0d0e21e 970 case OP_SPLIT:
11343788 971 if ((kid = cLISTOPo->op_first) && kid->op_type == OP_PUSHRE) {
a0d0e21e
LW		 972 if (!kPMOP->op_pmreplroot)
973 deprecate("implicit split to @_");
974 }
975 /* FALL THROUGH */
79072805 976 case OP_MATCH:
8782bef2 977 case OP_QR:
79072805
LW		 978 case OP_SUBST:
979 case OP_NULL:
8990e307 980 default:
11343788
MB		 981 if (o->op_flags & OPf_KIDS) {
982 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling)
8990e307
LW		 983 scalar(kid);
984 }
79072805
LW		 985 break;
986 case OP_LEAVE:
987 case OP_LEAVETRY:
5dc0d613 988 kid = cLISTOPo->op_first;
54310121 989 scalar(kid);
155aba94 990 while ((kid = kid->op_sibling)) {
54310121 991 if (kid->op_sibling)
992 scalarvoid(kid);
993 else
994 scalar(kid);
995 }
3280af22 996 WITH_THR(PL_curcop = &PL_compiling);
54310121 997 break;
748a9306 998 case OP_SCOPE:
79072805 999 case OP_LINESEQ:
8990e307 1000 case OP_LIST:
11343788 1001 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
79072805
LW		 1002 if (kid->op_sibling)
1003 scalarvoid(kid);
1004 else
1005 scalar(kid);
1006 }
3280af22 1007 WITH_THR(PL_curcop = &PL_compiling);
79072805
LW		 1008 break;
1009 }
11343788 1010 return o;
79072805
LW		 1011}
1012
1013OP *
864dbfa3 1014Perl_scalarvoid(pTHX_ OP *o)
79072805
LW		 1015{
1016 OP *kid;
8990e307
LW		 1017 char* useless = 0;
1018 SV* sv;
2ebea0a1
GS		 1019 U8 want;
1020
acb36ea4
GS		 1021 if (o->op_type == OP_NEXTSTATE
1022 || o->op_type == OP_SETSTATE
1023 || o->op_type == OP_DBSTATE
1024 || (o->op_type == OP_NULL && (o->op_targ == OP_NEXTSTATE
1025 || o->op_targ == OP_SETSTATE
1026 || o->op_targ == OP_DBSTATE)))
2ebea0a1 1027 PL_curcop = (COP*)o; /* for warning below */
79072805 1028
54310121 1029 /* assumes no premature commitment */
2ebea0a1
GS		 1030 want = o->op_flags & OPf_WANT;
1031 if ((want && want != OPf_WANT_SCALAR) || PL_error_count
5dc0d613 1032 || o->op_type == OP_RETURN)
7e363e51 1033 {
11343788 1034 return o;
7e363e51 1035 }
79072805 1036
b162f9ea 1037 if ((o->op_private & OPpTARGET_MY)
7e363e51
GS		 1038 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1039 {
b162f9ea 1040 return scalar(o); /* As if inside SASSIGN */
7e363e51 1041 }
1c846c1f 1042
5dc0d613 1043 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
79072805 1044
11343788 1045 switch (o->op_type) {
79072805 1046 default:
22c35a8c 1047 if (!(PL_opargs[o->op_type] & OA_FOLDCONST))
8990e307 1048 break;
36477c24 1049 /* FALL THROUGH */
1050 case OP_REPEAT:
11343788 1051 if (o->op_flags & OPf_STACKED)
8990e307 1052 break;
5d82c453
GA		 1053 goto func_ops;
1054 case OP_SUBSTR:
1055 if (o->op_private == 4)
1056 break;
8990e307
LW		 1057 /* FALL THROUGH */
1058 case OP_GVSV:
1059 case OP_WANTARRAY:
1060 case OP_GV:
1061 case OP_PADSV:
1062 case OP_PADAV:
1063 case OP_PADHV:
1064 case OP_PADANY:
1065 case OP_AV2ARYLEN:
8990e307 1066 case OP_REF:
a0d0e21e
LW		 1067 case OP_REFGEN:
1068 case OP_SREFGEN:
8990e307
LW		 1069 case OP_DEFINED:
1070 case OP_HEX:
1071 case OP_OCT:
1072 case OP_LENGTH:
8990e307
LW		 1073 case OP_VEC:
1074 case OP_INDEX:
1075 case OP_RINDEX:
1076 case OP_SPRINTF:
1077 case OP_AELEM:
1078 case OP_AELEMFAST:
1079 case OP_ASLICE:
8990e307
LW		 1080 case OP_HELEM:
1081 case OP_HSLICE:
1082 case OP_UNPACK:
1083 case OP_PACK:
8990e307
LW		 1084 case OP_JOIN:
1085 case OP_LSLICE:
1086 case OP_ANONLIST:
1087 case OP_ANONHASH:
1088 case OP_SORT:
1089 case OP_REVERSE:
1090 case OP_RANGE:
1091 case OP_FLIP:
1092 case OP_FLOP:
1093 case OP_CALLER:
1094 case OP_FILENO:
1095 case OP_EOF:
1096 case OP_TELL:
1097 case OP_GETSOCKNAME:
1098 case OP_GETPEERNAME:
1099 case OP_READLINK:
1100 case OP_TELLDIR:
1101 case OP_GETPPID:
1102 case OP_GETPGRP:
1103 case OP_GETPRIORITY:
1104 case OP_TIME:
1105 case OP_TMS:
1106 case OP_LOCALTIME:
1107 case OP_GMTIME:
1108 case OP_GHBYNAME:
1109 case OP_GHBYADDR:
1110 case OP_GHOSTENT:
1111 case OP_GNBYNAME:
1112 case OP_GNBYADDR:
1113 case OP_GNETENT:
1114 case OP_GPBYNAME:
1115 case OP_GPBYNUMBER:
1116 case OP_GPROTOENT:
1117 case OP_GSBYNAME:
1118 case OP_GSBYPORT:
1119 case OP_GSERVENT:
1120 case OP_GPWNAM:
1121 case OP_GPWUID:
1122 case OP_GGRNAM:
1123 case OP_GGRGID:
1124 case OP_GETLOGIN:
5d82c453 1125 func_ops:
64aac5a9 1126 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)))
22c35a8c 1127 useless = PL_op_desc[o->op_type];
8990e307
LW		 1128 break;
1129
1130 case OP_RV2GV:
1131 case OP_RV2SV:
1132 case OP_RV2AV:
1133 case OP_RV2HV:
192587c2 1134 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)) &&
11343788 1135 (!o->op_sibling || o->op_sibling->op_type != OP_READLINE))
8990e307
LW		 1136 useless = "a variable";
1137 break;
79072805
LW		 1138
1139 case OP_CONST:
7766f137 1140 sv = cSVOPo_sv;
7a52d87a
GS		 1141 if (cSVOPo->op_private & OPpCONST_STRICT)
1142 no_bareword_allowed(o);
1143 else {
d008e5eb
GS		 1144 if (ckWARN(WARN_VOID)) {
1145 useless = "a constant";
960b4253
MG		 1146 /* the constants 0 and 1 are permitted as they are
1147 conventionally used as dummies in constructs like
1148 1 while some_condition_with_side_effects; */
d008e5eb
GS		 1149 if (SvNIOK(sv) && (SvNV(sv) == 0.0 || SvNV(sv) == 1.0))
1150 useless = 0;
1151 else if (SvPOK(sv)) {
a52fe3ac
A		 1152 /* perl4's way of mixing documentation and code
1153 (before the invention of POD) was based on a
1154 trick to mix nroff and perl code. The trick was
1155 built upon these three nroff macros being used in
1156 void context. The pink camel has the details in
1157 the script wrapman near page 319. */
d008e5eb
GS		 1158 if (strnEQ(SvPVX(sv), "di", 2) ||
1159 strnEQ(SvPVX(sv), "ds", 2) ||
1160 strnEQ(SvPVX(sv), "ig", 2))
1161 useless = 0;
1162 }
8990e307
LW		 1163 }
1164 }
93c66552 1165 op_null(o); /* don't execute or even remember it */
79072805
LW		 1166 break;
1167
1168 case OP_POSTINC:
11343788 1169 o->op_type = OP_PREINC; /* pre-increment is faster */
22c35a8c 1170 o->op_ppaddr = PL_ppaddr[OP_PREINC];
79072805
LW		 1171 break;
1172
1173 case OP_POSTDEC:
11343788 1174 o->op_type = OP_PREDEC; /* pre-decrement is faster */
22c35a8c 1175 o->op_ppaddr = PL_ppaddr[OP_PREDEC];
79072805
LW		 1176 break;
1177
79072805
LW		 1178 case OP_OR:
1179 case OP_AND:
1180 case OP_COND_EXPR:
11343788 1181 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
79072805
LW		 1182 scalarvoid(kid);
1183 break;
5aabfad6 1184
a0d0e21e 1185 case OP_NULL:
11343788 1186 if (o->op_flags & OPf_STACKED)
a0d0e21e 1187 break;
5aabfad6 1188 /* FALL THROUGH */
2ebea0a1
GS		 1189 case OP_NEXTSTATE:
1190 case OP_DBSTATE:
79072805
LW		 1191 case OP_ENTERTRY:
1192 case OP_ENTER:
11343788 1193 if (!(o->op_flags & OPf_KIDS))
79072805 1194 break;
54310121 1195 /* FALL THROUGH */
463ee0b2 1196 case OP_SCOPE:
79072805
LW		 1197 case OP_LEAVE:
1198 case OP_LEAVETRY:
a0d0e21e 1199 case OP_LEAVELOOP:
79072805 1200 case OP_LINESEQ:
79072805 1201 case OP_LIST:
11343788 1202 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
79072805
LW		 1203 scalarvoid(kid);
1204 break;
c90c0ff4 1205 case OP_ENTEREVAL:
5196be3e 1206 scalarkids(o);
c90c0ff4 1207 break;
5aabfad6 1208 case OP_REQUIRE:
c90c0ff4 1209 /* all requires must return a boolean value */
5196be3e 1210 o->op_flags &= ~OPf_WANT;
d6483035
GS		 1211 /* FALL THROUGH */
1212 case OP_SCALAR:
5196be3e 1213 return scalar(o);
a0d0e21e 1214 case OP_SPLIT:
11343788 1215 if ((kid = cLISTOPo->op_first) && kid->op_type == OP_PUSHRE) {
a0d0e21e
LW		 1216 if (!kPMOP->op_pmreplroot)
1217 deprecate("implicit split to @_");
1218 }
1219 break;
79072805 1220 }
411caa50
JH		 1221 if (useless && ckWARN(WARN_VOID))
1222 Perl_warner(aTHX_ WARN_VOID, "Useless use of %s in void context", useless);
11343788 1223 return o;
79072805
LW		 1224}
1225
1226OP *
864dbfa3 1227Perl_listkids(pTHX_ OP *o)
79072805
LW		 1228{
1229 OP *kid;
11343788
MB		 1230 if (o && o->op_flags & OPf_KIDS) {
1231 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
79072805
LW		 1232 list(kid);
1233 }
11343788 1234 return o;
79072805
LW		 1235}
1236
1237OP *
864dbfa3 1238Perl_list(pTHX_ OP *o)
79072805
LW		 1239{
1240 OP *kid;
1241
a0d0e21e 1242 /* assumes no premature commitment */
3280af22 1243 if (!o || (o->op_flags & OPf_WANT) || PL_error_count
5dc0d613 1244 || o->op_type == OP_RETURN)
7e363e51 1245 {
11343788 1246 return o;
7e363e51 1247 }
79072805 1248
b162f9ea 1249 if ((o->op_private & OPpTARGET_MY)
7e363e51
GS		 1250 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1251 {
b162f9ea 1252 return o; /* As if inside SASSIGN */
7e363e51 1253 }
1c846c1f 1254
5dc0d613 1255 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_LIST;
79072805 1256
11343788 1257 switch (o->op_type) {
79072805
LW		 1258 case OP_FLOP:
1259 case OP_REPEAT:
11343788 1260 list(cBINOPo->op_first);
79072805
LW		 1261 break;
1262 case OP_OR:
1263 case OP_AND:
1264 case OP_COND_EXPR:
11343788 1265 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
79072805
LW		 1266 list(kid);
1267 break;
1268 default:
1269 case OP_MATCH:
8782bef2 1270 case OP_QR:
79072805
LW		 1271 case OP_SUBST:
1272 case OP_NULL:
11343788 1273 if (!(o->op_flags & OPf_KIDS))
79072805 1274 break;
11343788
MB		 1275 if (!o->op_next && cUNOPo->op_first->op_type == OP_FLOP) {
1276 list(cBINOPo->op_first);
1277 return gen_constant_list(o);
79072805
LW		 1278 }
1279 case OP_LIST:
11343788 1280 listkids(o);
79072805
LW		 1281 break;
1282 case OP_LEAVE:
1283 case OP_LEAVETRY:
5dc0d613 1284 kid = cLISTOPo->op_first;
54310121 1285 list(kid);
155aba94 1286 while ((kid = kid->op_sibling)) {
54310121 1287 if (kid->op_sibling)
1288 scalarvoid(kid);
1289 else
1290 list(kid);
1291 }
3280af22 1292 WITH_THR(PL_curcop = &PL_compiling);
54310121 1293 break;
748a9306 1294 case OP_SCOPE:
79072805 1295 case OP_LINESEQ:
11343788 1296 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
79072805
LW		 1297 if (kid->op_sibling)
1298 scalarvoid(kid);
1299 else
1300 list(kid);
1301 }
3280af22 1302 WITH_THR(PL_curcop = &PL_compiling);
79072805 1303 break;
c90c0ff4 1304 case OP_REQUIRE:
1305 /* all requires must return a boolean value */
5196be3e
MB		 1306 o->op_flags &= ~OPf_WANT;
1307 return scalar(o);
79072805 1308 }
11343788 1309 return o;
79072805
LW		 1310}
1311
1312OP *
864dbfa3 1313Perl_scalarseq(pTHX_ OP *o)
79072805
LW		 1314{
1315 OP *kid;
1316
11343788
MB		 1317 if (o) {
1318 if (o->op_type == OP_LINESEQ ||
1319 o->op_type == OP_SCOPE ||
1320 o->op_type == OP_LEAVE ||
1321 o->op_type == OP_LEAVETRY)
463ee0b2 1322 {
11343788 1323 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
ed6116ce 1324 if (kid->op_sibling) {
463ee0b2 1325 scalarvoid(kid);
ed6116ce 1326 }
463ee0b2 1327 }
3280af22 1328 PL_curcop = &PL_compiling;
79072805 1329 }
11343788 1330 o->op_flags &= ~OPf_PARENS;
3280af22 1331 if (PL_hints & HINT_BLOCK_SCOPE)
11343788 1332 o->op_flags |= OPf_PARENS;
79072805 1333 }
8990e307 1334 else
11343788
MB		 1335 o = newOP(OP_STUB, 0);
1336 return o;
79072805
LW		 1337}
1338
76e3520e 1339STATIC OP *
cea2e8a9 1340S_modkids(pTHX_ OP *o, I32 type)
79072805
LW		 1341{
1342 OP *kid;
11343788
MB		 1343 if (o && o->op_flags & OPf_KIDS) {
1344 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
463ee0b2 1345 mod(kid, type);
79072805 1346 }
11343788 1347 return o;
79072805
LW		 1348}
1349
79072805 1350OP *
864dbfa3 1351Perl_mod(pTHX_ OP *o, I32 type)
79072805
LW		 1352{
1353 OP *kid;
2d8e6c8d 1354 STRLEN n_a;
79072805 1355
3280af22 1356 if (!o || PL_error_count)
11343788 1357 return o;
79072805 1358
b162f9ea 1359 if ((o->op_private & OPpTARGET_MY)
7e363e51
GS		 1360 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1361 {
b162f9ea 1362 return o;
7e363e51 1363 }
1c846c1f 1364
11343788 1365 switch (o->op_type) {
68dc0745 1366 case OP_UNDEF:
3280af22 1367 PL_modcount++;
5dc0d613 1368 return o;
a0d0e21e 1369 case OP_CONST:
11343788 1370 if (!(o->op_private & (OPpCONST_ARYBASE)))
a0d0e21e 1371 goto nomod;
3280af22 1372 if (PL_eval_start && PL_eval_start->op_type == OP_CONST) {
7766f137 1373 PL_compiling.cop_arybase = (I32)SvIV(cSVOPx(PL_eval_start)->op_sv);
3280af22 1374 PL_eval_start = 0;
a0d0e21e
LW		 1375 }
1376 else if (!type) {
3280af22
NIS		 1377 SAVEI32(PL_compiling.cop_arybase);
1378 PL_compiling.cop_arybase = 0;
a0d0e21e
LW		 1379 }
1380 else if (type == OP_REFGEN)
1381 goto nomod;
1382 else
cea2e8a9 1383 Perl_croak(aTHX_ "That use of $[ is unsupported");
a0d0e21e 1384 break;
5f05dabc 1385 case OP_STUB:
5196be3e 1386 if (o->op_flags & OPf_PARENS)
5f05dabc 1387 break;
1388 goto nomod;
a0d0e21e
LW		 1389 case OP_ENTERSUB:
1390 if ((type == OP_UNDEF || type == OP_REFGEN) &&
11343788
MB		 1391 !(o->op_flags & OPf_STACKED)) {
1392 o->op_type = OP_RV2CV; /* entersub => rv2cv */
22c35a8c 1393 o->op_ppaddr = PL_ppaddr[OP_RV2CV];
11343788 1394 assert(cUNOPo->op_first->op_type == OP_NULL);
93c66552 1395 op_null(((LISTOP*)cUNOPo->op_first)->op_first);/* disable pushmark */
79072805
LW		 1396 break;
1397 }
cd06dffe
GS		 1398 else { /* lvalue subroutine call */
1399 o->op_private |= OPpLVAL_INTRO;
e6438c1a 1400 PL_modcount = RETURN_UNLIMITED_NUMBER;
4978d6d9 1401 if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN) {
cd06dffe
GS		 1402 /* Backward compatibility mode: */
1403 o->op_private |= OPpENTERSUB_INARGS;
1404 break;
1405 }
1406 else { /* Compile-time error message: */
1407 OP *kid = cUNOPo->op_first;
1408 CV *cv;
1409 OP *okid;
1410
1411 if (kid->op_type == OP_PUSHMARK)
1412 goto skip_kids;
1413 if (kid->op_type != OP_NULL || kid->op_targ != OP_LIST)
1414 Perl_croak(aTHX_
1415 "panic: unexpected lvalue entersub "
1416 "args: type/targ %ld:%ld",
1417 (long)kid->op_type,kid->op_targ);
1418 kid = kLISTOP->op_first;
1419 skip_kids:
1420 while (kid->op_sibling)
1421 kid = kid->op_sibling;
1422 if (!(kid->op_type == OP_NULL && kid->op_targ == OP_RV2CV)) {
1423 /* Indirect call */
1424 if (kid->op_type == OP_METHOD_NAMED
1425 || kid->op_type == OP_METHOD)
1426 {
87d7fd28 1427 UNOP *newop;
cd06dffe
GS		 1428
1429 if (kid->op_sibling || kid->op_next != kid) {
1430 yyerror("panic: unexpected optree near method call");
1431 break;
1432 }
1433
87d7fd28 1434 NewOp(1101, newop, 1, UNOP);
349fd7b7
GS		 1435 newop->op_type = OP_RV2CV;
1436 newop->op_ppaddr = PL_ppaddr[OP_RV2CV];
87d7fd28
GS		 1437 newop->op_first = Nullop;
1438 newop->op_next = (OP*)newop;
1439 kid->op_sibling = (OP*)newop;
349fd7b7 1440 newop->op_private |= OPpLVAL_INTRO;
cd06dffe
GS		 1441 break;
1442 }
1c846c1f 1443
cd06dffe
GS		 1444 if (kid->op_type != OP_RV2CV)
1445 Perl_croak(aTHX_
1446 "panic: unexpected lvalue entersub "
1447 "entry via type/targ %ld:%ld",
1448 (long)kid->op_type,kid->op_targ);
1449 kid->op_private |= OPpLVAL_INTRO;
1450 break; /* Postpone until runtime */
1451 }
1452
1453 okid = kid;
1454 kid = kUNOP->op_first;
1455 if (kid->op_type == OP_NULL && kid->op_targ == OP_RV2SV)
1456 kid = kUNOP->op_first;
1457 if (kid->op_type == OP_NULL)
1458 Perl_croak(aTHX_
1459 "Unexpected constant lvalue entersub "
1460 "entry via type/targ %ld:%ld",
1461 (long)kid->op_type,kid->op_targ);
1462 if (kid->op_type != OP_GV) {
1463 /* Restore RV2CV to check lvalueness */
1464 restore_2cv:
1465 if (kid->op_next && kid->op_next != kid) { /* Happens? */
1466 okid->op_next = kid->op_next;
1467 kid->op_next = okid;
1468 }
1469 else
1470 okid->op_next = Nullop;
1471 okid->op_type = OP_RV2CV;
1472 okid->op_targ = 0;
1473 okid->op_ppaddr = PL_ppaddr[OP_RV2CV];
1474 okid->op_private |= OPpLVAL_INTRO;
1475 break;
1476 }
1477
638eceb6 1478 cv = GvCV(kGVOP_gv);
1c846c1f 1479 if (!cv)
cd06dffe
GS		 1480 goto restore_2cv;
1481 if (CvLVALUE(cv))
1482 break;
1483 }
1484 }
79072805
LW		 1485 /* FALL THROUGH */
1486 default:
a0d0e21e
LW		 1487 nomod:
1488 /* grep, foreach, subcalls, refgen */
1489 if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN)
1490 break;
cea2e8a9 1491 yyerror(Perl_form(aTHX_ "Can't modify %s in %s",
638bc118 1492 (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)
cd06dffe
GS		 1493 ? "do block"
1494 : (o->op_type == OP_ENTERSUB
1495 ? "non-lvalue subroutine call"
1496 : PL_op_desc[o->op_type])),
22c35a8c 1497 type ? PL_op_desc[type] : "local"));
11343788 1498 return o;
79072805 1499
a0d0e21e
LW		 1500 case OP_PREINC:
1501 case OP_PREDEC:
1502 case OP_POW:
1503 case OP_MULTIPLY:
1504 case OP_DIVIDE:
1505 case OP_MODULO:
1506 case OP_REPEAT:
1507 case OP_ADD:
1508 case OP_SUBTRACT:
1509 case OP_CONCAT:
1510 case OP_LEFT_SHIFT:
1511 case OP_RIGHT_SHIFT:
1512 case OP_BIT_AND:
1513 case OP_BIT_XOR:
1514 case OP_BIT_OR:
1515 case OP_I_MULTIPLY:
1516 case OP_I_DIVIDE:
1517 case OP_I_MODULO:
1518 case OP_I_ADD:
1519 case OP_I_SUBTRACT:
11343788 1520 if (!(o->op_flags & OPf_STACKED))
a0d0e21e 1521 goto nomod;
3280af22 1522 PL_modcount++;
a0d0e21e
LW		 1523 break;
1524
79072805 1525 case OP_COND_EXPR:
11343788 1526 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
463ee0b2 1527 mod(kid, type);
79072805
LW		 1528 break;
1529
1530 case OP_RV2AV:
1531 case OP_RV2HV:
93af7a87 1532 if (!type && cUNOPo->op_first->op_type != OP_GV)
cea2e8a9 1533 Perl_croak(aTHX_ "Can't localize through a reference");
11343788 1534 if (type == OP_REFGEN && o->op_flags & OPf_PARENS) {
e6438c1a 1535 PL_modcount = RETURN_UNLIMITED_NUMBER;
11343788 1536 return o; /* Treat \(@foo) like ordinary list. */
748a9306
LW		 1537 }
1538 /* FALL THROUGH */
79072805 1539 case OP_RV2GV:
5dc0d613 1540 if (scalar_mod_type(o, type))
3fe9a6f1 1541 goto nomod;
11343788 1542 ref(cUNOPo->op_first, o->op_type);
79072805 1543 /* FALL THROUGH */
79072805
LW		 1544 case OP_ASLICE:
1545 case OP_HSLICE:
78f9721b
SM		 1546 if (type == OP_LEAVESUBLV)
1547 o->op_private |= OPpMAYBE_LVSUB;
1548 /* FALL THROUGH */
1549 case OP_AASSIGN:
93a17b20
LW		 1550 case OP_NEXTSTATE:
1551 case OP_DBSTATE:
a0d0e21e 1552 case OP_CHOMP:
e6438c1a 1553 PL_modcount = RETURN_UNLIMITED_NUMBER;
79072805 1554 break;
463ee0b2 1555 case OP_RV2SV:
11343788 1556 if (!type && cUNOPo->op_first->op_type != OP_GV)
cea2e8a9 1557 Perl_croak(aTHX_ "Can't localize through a reference");
aeea060c 1558 ref(cUNOPo->op_first, o->op_type);
463ee0b2 1559 /* FALL THROUGH */
79072805 1560 case OP_GV:
463ee0b2 1561 case OP_AV2ARYLEN:
3280af22 1562 PL_hints |= HINT_BLOCK_SCOPE;
463ee0b2 1563 case OP_SASSIGN:
bf4b1e52
GS		 1564 case OP_ANDASSIGN:
1565 case OP_ORASSIGN:
8990e307 1566 case OP_AELEMFAST:
3280af22 1567 PL_modcount++;
8990e307
LW		 1568 break;
1569
748a9306
LW		 1570 case OP_PADAV:
1571 case OP_PADHV:
e6438c1a 1572 PL_modcount = RETURN_UNLIMITED_NUMBER;
5196be3e
MB		 1573 if (type == OP_REFGEN && o->op_flags & OPf_PARENS)
1574 return o; /* Treat \(@foo) like ordinary list. */
1575 if (scalar_mod_type(o, type))
3fe9a6f1 1576 goto nomod;
78f9721b
SM		 1577 if (type == OP_LEAVESUBLV)
1578 o->op_private |= OPpMAYBE_LVSUB;
748a9306
LW		 1579 /* FALL THROUGH */
1580 case OP_PADSV:
3280af22 1581 PL_modcount++;
748a9306 1582 if (!type)
cea2e8a9 1583 Perl_croak(aTHX_ "Can't localize lexical variable %s",
2d8e6c8d 1584 SvPV(*av_fetch(PL_comppad_name, o->op_targ, 4), n_a));
463ee0b2
LW		 1585 break;
1586
554b3eca 1587#ifdef USE_THREADS
2faa37cc 1588 case OP_THREADSV:
533c011a 1589 PL_modcount++; /* XXX ??? */
554b3eca
MB		 1590 break;
1591#endif /* USE_THREADS */
1592
748a9306
LW		 1593 case OP_PUSHMARK:
1594 break;
a0d0e21e 1595
69969c6f
SB		 1596 case OP_KEYS:
1597 if (type != OP_SASSIGN)
1598 goto nomod;
5d82c453
GA		 1599 goto lvalue_func;
1600 case OP_SUBSTR:
1601 if (o->op_private == 4) /* don't allow 4 arg substr as lvalue */
1602 goto nomod;
5f05dabc 1603 /* FALL THROUGH */
a0d0e21e 1604 case OP_POS:
463ee0b2 1605 case OP_VEC:
78f9721b
SM		 1606 if (type == OP_LEAVESUBLV)
1607 o->op_private |= OPpMAYBE_LVSUB;
5d82c453 1608 lvalue_func:
11343788
MB		 1609 pad_free(o->op_targ);
1610 o->op_targ = pad_alloc(o->op_type, SVs_PADMY);
5dc0d613 1611 assert(SvTYPE(PAD_SV(o->op_targ)) == SVt_NULL);
11343788
MB		 1612 if (o->op_flags & OPf_KIDS)
1613 mod(cBINOPo->op_first->op_sibling, type);
463ee0b2 1614 break;
a0d0e21e 1615
463ee0b2
LW		 1616 case OP_AELEM:
1617 case OP_HELEM:
11343788 1618 ref(cBINOPo->op_first, o->op_type);
68dc0745 1619 if (type == OP_ENTERSUB &&
5dc0d613
MB		 1620 !(o->op_private & (OPpLVAL_INTRO | OPpDEREF)))
1621 o->op_private |= OPpLVAL_DEFER;
78f9721b
SM		 1622 if (type == OP_LEAVESUBLV)
1623 o->op_private |= OPpMAYBE_LVSUB;
3280af22 1624 PL_modcount++;
463ee0b2
LW		 1625 break;
1626
1627 case OP_SCOPE:
1628 case OP_LEAVE:
1629 case OP_ENTER:
78f9721b 1630 case OP_LINESEQ:
11343788
MB		 1631 if (o->op_flags & OPf_KIDS)
1632 mod(cLISTOPo->op_last, type);
a0d0e21e
LW		 1633 break;
1634
1635 case OP_NULL:
638bc118
GS		 1636 if (o->op_flags & OPf_SPECIAL) /* do BLOCK */
1637 goto nomod;
1638 else if (!(o->op_flags & OPf_KIDS))
463ee0b2 1639 break;
11343788
MB		 1640 if (o->op_targ != OP_LIST) {
1641 mod(cBINOPo->op_first, type);
a0d0e21e
LW		 1642 break;
1643 }
1644 /* FALL THROUGH */
463ee0b2 1645 case OP_LIST:
11343788 1646 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
463ee0b2
LW		 1647 mod(kid, type);
1648 break;
78f9721b
SM		 1649
1650 case OP_RETURN:
1651 if (type != OP_LEAVESUBLV)
1652 goto nomod;
1653 break; /* mod()ing was handled by ck_return() */
463ee0b2 1654 }
78f9721b
SM		 1655 if (type != OP_LEAVESUBLV)
1656 o->op_flags |= OPf_MOD;
a0d0e21e
LW		 1657
1658 if (type == OP_AASSIGN || type == OP_SASSIGN)
11343788 1659 o->op_flags |= OPf_SPECIAL|OPf_REF;
a0d0e21e 1660 else if (!type) {
11343788
MB		 1661 o->op_private |= OPpLVAL_INTRO;
1662 o->op_flags &= ~OPf_SPECIAL;
3280af22 1663 PL_hints |= HINT_BLOCK_SCOPE;
463ee0b2 1664 }
78f9721b
SM		 1665 else if (type != OP_GREPSTART && type != OP_ENTERSUB
1666 && type != OP_LEAVESUBLV)
11343788
MB		 1667 o->op_flags |= OPf_REF;
1668 return o;
463ee0b2
LW		 1669}
1670
864dbfa3 1671STATIC bool
cea2e8a9 1672S_scalar_mod_type(pTHX_ OP *o, I32 type)
3fe9a6f1 1673{
1674 switch (type) {
1675 case OP_SASSIGN:
5196be3e 1676 if (o->op_type == OP_RV2GV)
3fe9a6f1 1677 return FALSE;
1678 /* FALL THROUGH */
1679 case OP_PREINC:
1680 case OP_PREDEC:
1681 case OP_POSTINC:
1682 case OP_POSTDEC:
1683 case OP_I_PREINC:
1684 case OP_I_PREDEC:
1685 case OP_I_POSTINC:
1686 case OP_I_POSTDEC:
1687 case OP_POW:
1688 case OP_MULTIPLY:
1689 case OP_DIVIDE:
1690 case OP_MODULO:
1691 case OP_REPEAT:
1692 case OP_ADD:
1693 case OP_SUBTRACT:
1694 case OP_I_MULTIPLY:
1695 case OP_I_DIVIDE:
1696 case OP_I_MODULO:
1697 case OP_I_ADD:
1698 case OP_I_SUBTRACT:
1699 case OP_LEFT_SHIFT:
1700 case OP_RIGHT_SHIFT:
1701 case OP_BIT_AND:
1702 case OP_BIT_XOR:
1703 case OP_BIT_OR:
1704 case OP_CONCAT:
1705 case OP_SUBST:
1706 case OP_TRANS:
49e9fbe6
GS		 1707 case OP_READ:
1708 case OP_SYSREAD:
1709 case OP_RECV:
bf4b1e52
GS		 1710 case OP_ANDASSIGN:
1711 case OP_ORASSIGN:
3fe9a6f1 1712 return TRUE;
1713 default:
1714 return FALSE;
1715 }
1716}
1717
35cd451c 1718STATIC bool
cea2e8a9 1719S_is_handle_constructor(pTHX_ OP *o, I32 argnum)
35cd451c
GS		 1720{
1721 switch (o->op_type) {
1722 case OP_PIPE_OP:
1723 case OP_SOCKPAIR:
1724 if (argnum == 2)
1725 return TRUE;
1726 /* FALL THROUGH */
1727 case OP_SYSOPEN:
1728 case OP_OPEN:
ded8aa31 1729 case OP_SELECT: /* XXX c.f. SelectSaver.pm */
35cd451c
GS		 1730 case OP_SOCKET:
1731 case OP_OPEN_DIR:
1732 case OP_ACCEPT:
1733 if (argnum == 1)
1734 return TRUE;
1735 /* FALL THROUGH */
1736 default:
1737 return FALSE;
1738 }
1739}
1740
463ee0b2 1741OP *
864dbfa3 1742Perl_refkids(pTHX_ OP *o, I32 type)
463ee0b2
LW		 1743{
1744 OP *kid;
11343788
MB		 1745 if (o && o->op_flags & OPf_KIDS) {
1746 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
463ee0b2
LW		 1747 ref(kid, type);
1748 }
11343788 1749 return o;
463ee0b2
LW		 1750}
1751
1752OP *
864dbfa3 1753Perl_ref(pTHX_ OP *o, I32 type)
463ee0b2
LW		 1754{
1755 OP *kid;
463ee0b2 1756
3280af22 1757 if (!o || PL_error_count)
11343788 1758 return o;
463ee0b2 1759
11343788 1760 switch (o->op_type) {
a0d0e21e 1761 case OP_ENTERSUB:
afebc493 1762 if ((type == OP_EXISTS || type == OP_DEFINED || type == OP_LOCK) &&
11343788
MB		 1763 !(o->op_flags & OPf_STACKED)) {
1764 o->op_type = OP_RV2CV; /* entersub => rv2cv */
22c35a8c 1765 o->op_ppaddr = PL_ppaddr[OP_RV2CV];
11343788 1766 assert(cUNOPo->op_first->op_type == OP_NULL);
93c66552 1767 op_null(((LISTOP*)cUNOPo->op_first)->op_first); /* disable pushmark */
11343788 1768 o->op_flags |= OPf_SPECIAL;
8990e307
LW		 1769 }
1770 break;
aeea060c 1771
463ee0b2 1772 case OP_COND_EXPR:
11343788 1773 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
463ee0b2
LW		 1774 ref(kid, type);
1775 break;
8990e307 1776 case OP_RV2SV:
35cd451c
GS		 1777 if (type == OP_DEFINED)
1778 o->op_flags |= OPf_SPECIAL; /* don't create GV */
11343788 1779 ref(cUNOPo->op_first, o->op_type);
4633a7c4
LW		 1780 /* FALL THROUGH */
1781 case OP_PADSV:
5f05dabc 1782 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
5dc0d613
MB		 1783 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
1784 : type == OP_RV2HV ? OPpDEREF_HV
1785 : OPpDEREF_SV);
11343788 1786 o->op_flags |= OPf_MOD;
a0d0e21e 1787 }
8990e307 1788 break;
1c846c1f 1789
2faa37cc 1790 case OP_THREADSV:
a863c7d1
MB		 1791 o->op_flags |= OPf_MOD; /* XXX ??? */
1792 break;
1793
463ee0b2
LW		 1794 case OP_RV2AV:
1795 case OP_RV2HV:
aeea060c 1796 o->op_flags |= OPf_REF;
8990e307 1797 /* FALL THROUGH */
463ee0b2 1798 case OP_RV2GV:
35cd451c
GS		 1799 if (type == OP_DEFINED)
1800 o->op_flags |= OPf_SPECIAL; /* don't create GV */
11343788 1801 ref(cUNOPo->op_first, o->op_type);
463ee0b2 1802 break;
8990e307 1803
463ee0b2
LW		 1804 case OP_PADAV:
1805 case OP_PADHV:
aeea060c 1806 o->op_flags |= OPf_REF;
79072805 1807 break;
aeea060c 1808
8990e307 1809 case OP_SCALAR:
79072805 1810 case OP_NULL:
11343788 1811 if (!(o->op_flags & OPf_KIDS))
463ee0b2 1812 break;
11343788 1813 ref(cBINOPo->op_first, type);
79072805
LW		 1814 break;
1815 case OP_AELEM:
1816 case OP_HELEM:
11343788 1817 ref(cBINOPo->op_first, o->op_type);
5f05dabc 1818 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
5dc0d613
MB		 1819 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
1820 : type == OP_RV2HV ? OPpDEREF_HV
1821 : OPpDEREF_SV);
11343788 1822 o->op_flags |= OPf_MOD;
8990e307 1823 }
79072805
LW		 1824 break;
1825
463ee0b2 1826 case OP_SCOPE:
79072805
LW		 1827 case OP_LEAVE:
1828 case OP_ENTER:
8990e307 1829 case OP_LIST:
11343788 1830 if (!(o->op_flags & OPf_KIDS))
79072805 1831 break;
11343788 1832 ref(cLISTOPo->op_last, type);
79072805 1833 break;
a0d0e21e
LW		 1834 default:
1835 break;
79072805 1836 }
11343788 1837 return scalar(o);
8990e307 1838
79072805
LW		 1839}
1840
09bef843
SB		 1841STATIC OP *
1842S_dup_attrlist(pTHX_ OP *o)
1843{
1844 OP *rop = Nullop;
1845
1846 /* An attrlist is either a simple OP_CONST or an OP_LIST with kids,
1847 * where the first kid is OP_PUSHMARK and the remaining ones
1848 * are OP_CONST. We need to push the OP_CONST values.
1849 */
1850 if (o->op_type == OP_CONST)
1851 rop = newSVOP(OP_CONST, o->op_flags, SvREFCNT_inc(cSVOPo->op_sv));
1852 else {
1853 assert((o->op_type == OP_LIST) && (o->op_flags & OPf_KIDS));
1854 for (o = cLISTOPo->op_first; o; o=o->op_sibling) {
1855 if (o->op_type == OP_CONST)
1856 rop = append_elem(OP_LIST, rop,
1857 newSVOP(OP_CONST, o->op_flags,
1858 SvREFCNT_inc(cSVOPo->op_sv)));
1859 }
1860 }
1861 return rop;
1862}
1863
1864STATIC void
1865S_apply_attrs(pTHX_ HV *stash, SV *target, OP *attrs)
1866{
09bef843
SB		 1867 SV *stashsv;
1868
1869 /* fake up C<use attributes $pkg,$rv,@attrs> */
1870 ENTER; /* need to protect against side-effects of 'use' */
1871 SAVEINT(PL_expect);
1872 if (stash && HvNAME(stash))
1873 stashsv = newSVpv(HvNAME(stash), 0);
1874 else
1875 stashsv = &PL_sv_no;
e4783991 1876
09bef843 1877#define ATTRSMODULE "attributes"
e4783991
GS		 1878
1879 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
1880 newSVpvn(ATTRSMODULE, sizeof(ATTRSMODULE)-1),
1881 Nullsv,
1882 prepend_elem(OP_LIST,
1883 newSVOP(OP_CONST, 0, stashsv),
1884 prepend_elem(OP_LIST,
1885 newSVOP(OP_CONST, 0,
1886 newRV(target)),
1887 dup_attrlist(attrs))));
09bef843
SB		 1888 LEAVE;
1889}
1890
be3174d2
GS		 1891void
1892Perl_apply_attrs_string(pTHX_ char *stashpv, CV *cv,
1893 char *attrstr, STRLEN len)
1894{
1895 OP *attrs = Nullop;
1896
1897 if (!len) {
1898 len = strlen(attrstr);
1899 }
1900
1901 while (len) {
1902 for (; isSPACE(*attrstr) && len; --len, ++attrstr) ;
1903 if (len) {
1904 char *sstr = attrstr;
1905 for (; !isSPACE(*attrstr) && len; --len, ++attrstr) ;
1906 attrs = append_elem(OP_LIST, attrs,
1907 newSVOP(OP_CONST, 0,
1908 newSVpvn(sstr, attrstr-sstr)));
1909 }
1910 }
1911
1912 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
1913 newSVpvn(ATTRSMODULE, sizeof(ATTRSMODULE)-1),
1914 Nullsv, prepend_elem(OP_LIST,
1915 newSVOP(OP_CONST, 0, newSVpv(stashpv,0)),
1916 prepend_elem(OP_LIST,
1917 newSVOP(OP_CONST, 0,
1918 newRV((SV*)cv)),
1919 attrs)));
1920}
1921
09bef843
SB		 1922STATIC OP *
1923S_my_kid(pTHX_ OP *o, OP *attrs)
93a17b20
LW		 1924{
1925 OP *kid;
93a17b20
LW		 1926 I32 type;
1927
3280af22 1928 if (!o || PL_error_count)
11343788 1929 return o;
93a17b20 1930
11343788 1931 type = o->op_type;
93a17b20 1932 if (type == OP_LIST) {
11343788 1933 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
09bef843 1934 my_kid(kid, attrs);
dab48698 1935 } else if (type == OP_UNDEF) {
7766148a 1936 return o;
77ca0c92
LW		 1937 } else if (type == OP_RV2SV || /* "our" declaration */
1938 type == OP_RV2AV ||
1939 type == OP_RV2HV) { /* XXX does this let anything illegal in? */
0256094b
DM		 1940 if (attrs) {
1941 GV *gv = cGVOPx_gv(cUNOPo->op_first);
1942 PL_in_my = FALSE;
1943 PL_in_my_stash = Nullhv;
1944 apply_attrs(GvSTASH(gv),
1945 (type == OP_RV2SV ? GvSV(gv) :
1946 type == OP_RV2AV ? (SV*)GvAV(gv) :
1947 type == OP_RV2HV ? (SV*)GvHV(gv) : (SV*)gv),
1948 attrs);
1949 }
192587c2 1950 o->op_private |= OPpOUR_INTRO;
77ca0c92 1951 return o;
dab48698 1952 } else if (type != OP_PADSV &&
93a17b20
LW		 1953 type != OP_PADAV &&
1954 type != OP_PADHV &&
1955 type != OP_PUSHMARK)
1956 {
eb64745e
GS		 1957 yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"",
1958 PL_op_desc[o->op_type],
1959 PL_in_my == KEY_our ? "our" : "my"));
11343788 1960 return o;
93a17b20 1961 }
09bef843
SB		 1962 else if (attrs && type != OP_PUSHMARK) {
1963 HV *stash;
1964 SV *padsv;
1965 SV **namesvp;
1966
eb64745e
GS		 1967 PL_in_my = FALSE;
1968 PL_in_my_stash = Nullhv;
1969
09bef843
SB		 1970 /* check for C<my Dog $spot> when deciding package */
1971 namesvp = av_fetch(PL_comppad_name, o->op_targ, FALSE);
524189f1
JH		 1972 if (namesvp && *namesvp && (SvFLAGS(*namesvp) & SVpad_TYPED)
1973 && HvNAME(SvSTASH(*namesvp)))
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;
cea2e8a9 2979 pm->op_pmregexp = CALLREGCOMP(aTHX_ p, p + plen, pm);
aeea060c 2980 if (strEQ("\\s+", pm->op_pmregexp->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
NIS		 3075 && !(repl_has_vars
3076 && (!pm->op_pmregexp
ce862d02 3077 || pm->op_pmregexp->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 {
ce862d02
IZ		 3083 if (curop == repl && !pm->op_pmregexp) { /* Has variables. */
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
a0d0e21e 4156 if (!CvXSUB(cv) && CvROOT(cv)) {
11343788
MB		 4157#ifdef USE_THREADS
4158 if (CvDEPTH(cv) || (CvOWNER(cv) && CvOWNER(cv) != thr))
cea2e8a9 4159 Perl_croak(aTHX_ "Can't undef active subroutine");
11343788 4160#else
a0d0e21e 4161 if (CvDEPTH(cv))
cea2e8a9 4162 Perl_croak(aTHX_ "Can't undef active subroutine");
11343788 4163#endif /* USE_THREADS */
8990e307 4164 ENTER;
a0d0e21e 4165
7766f137 4166 SAVEVPTR(PL_curpad);
3280af22 4167 PL_curpad = 0;
a0d0e21e 4168
282f25c9 4169 op_free(CvROOT(cv));
79072805 4170 CvROOT(cv) = Nullop;
8990e307 4171 LEAVE;
79072805 4172 }
1d5db326 4173 SvPOK_off((SV*)cv); /* forget prototype */
8e07c86e 4174 CvGV(cv) = Nullgv;
282f25c9
JH		 4175 /* Since closure prototypes have the same lifetime as the containing
4176 * CV, they don't hold a refcount on the outside CV. This avoids
4177 * the refcount loop between the outer CV (which keeps a refcount to
4178 * the closure prototype in the pad entry for pp_anoncode()) and the
c975facc
JH		 4179 * closure prototype, and the ensuing memory leak. This does not
4180 * apply to closures generated within eval"", since eval"" CVs are
4181 * ephemeral. --GSAR */
4182 if (!CvANON(cv) || CvCLONED(cv)
f58d1073
GS		 4183 || (CvOUTSIDE(cv) && SvTYPE(CvOUTSIDE(cv)) == SVt_PVCV
4184 && CvEVAL(CvOUTSIDE(cv)) && !CvGV(CvOUTSIDE(cv))))
c975facc 4185 {
282f25c9 4186 SvREFCNT_dec(CvOUTSIDE(cv));
c975facc 4187 }
8e07c86e 4188 CvOUTSIDE(cv) = Nullcv;
beab0874
JT		 4189 if (CvCONST(cv)) {
4190 SvREFCNT_dec((SV*)CvXSUBANY(cv).any_ptr);
4191 CvCONST_off(cv);
4192 }
8e07c86e 4193 if (CvPADLIST(cv)) {
8ebc5c01 4194 /* may be during global destruction */
4195 if (SvREFCNT(CvPADLIST(cv))) {
93965878 4196 I32 i = AvFILLp(CvPADLIST(cv));
8ebc5c01 4197 while (i >= 0) {
4198 SV** svp = av_fetch(CvPADLIST(cv), i--, FALSE);
46fc3d4c 4199 SV* sv = svp ? *svp : Nullsv;
4200 if (!sv)
4201 continue;
3280af22
NIS		 4202 if (sv == (SV*)PL_comppad_name)
4203 PL_comppad_name = Nullav;
4204 else if (sv == (SV*)PL_comppad) {
4205 PL_comppad = Nullav;
4206 PL_curpad = Null(SV**);
46fc3d4c 4207 }
4208 SvREFCNT_dec(sv);
8ebc5c01 4209 }
4210 SvREFCNT_dec((SV*)CvPADLIST(cv));
8e07c86e 4211 }
8e07c86e
AD		 4212 CvPADLIST(cv) = Nullav;
4213 }
50762d59
DM		 4214 if (CvXSUB(cv)) {
4215 CvXSUB(cv) = 0;
4216 }
a2c090b3 4217 CvFLAGS(cv) = 0;
79072805
LW		 4218}
4219
9cbac4c7 4220#ifdef DEBUG_CLOSURES
76e3520e 4221STATIC void
743e66e6 4222S_cv_dump(pTHX_ CV *cv)
5f05dabc 4223{
62fde642 4224#ifdef DEBUGGING
5f05dabc 4225 CV *outside = CvOUTSIDE(cv);
4226 AV* padlist = CvPADLIST(cv);
4fdae800 4227 AV* pad_name;
4228 AV* pad;
4229 SV** pname;
4230 SV** ppad;
5f05dabc 4231 I32 ix;
4232
b900a521
JH		 4233 PerlIO_printf(Perl_debug_log,
4234 "\tCV=0x%"UVxf" (%s), OUTSIDE=0x%"UVxf" (%s)\n",
4235 PTR2UV(cv),
ab50184a 4236 (CvANON(cv) ? "ANON"
6b88bc9c 4237 : (cv == PL_main_cv) ? "MAIN"
33b8ce05 4238 : CvUNIQUE(cv) ? "UNIQUE"
44a8e56a 4239 : CvGV(cv) ? GvNAME(CvGV(cv)) : "UNDEFINED"),
b900a521 4240 PTR2UV(outside),
ab50184a
CS		 4241 (!outside ? "null"
4242 : CvANON(outside) ? "ANON"
6b88bc9c 4243 : (outside == PL_main_cv) ? "MAIN"
07055b4c 4244 : CvUNIQUE(outside) ? "UNIQUE"
44a8e56a 4245 : CvGV(outside) ? GvNAME(CvGV(outside)) : "UNDEFINED"));
5f05dabc 4246
4fdae800 4247 if (!padlist)
4248 return;
4249
4250 pad_name = (AV*)*av_fetch(padlist, 0, FALSE);
4251 pad = (AV*)*av_fetch(padlist, 1, FALSE);
4252 pname = AvARRAY(pad_name);
4253 ppad = AvARRAY(pad);
4254
93965878 4255 for (ix = 1; ix <= AvFILLp(pad_name); ix++) {
5f05dabc 4256 if (SvPOK(pname[ix]))
b900a521
JH		 4257 PerlIO_printf(Perl_debug_log,
4258 "\t%4d. 0x%"UVxf" (%s\"%s\" %"IVdf"-%"IVdf")\n",
894356b3 4259 (int)ix, PTR2UV(ppad[ix]),
4fdae800 4260 SvFAKE(pname[ix]) ? "FAKE " : "",
4261 SvPVX(pname[ix]),
b900a521
JH		 4262 (IV)I_32(SvNVX(pname[ix])),
4263 SvIVX(pname[ix]));
5f05dabc 4264 }
743e66e6 4265#endif /* DEBUGGING */
62fde642 4266}
9cbac4c7 4267#endif /* DEBUG_CLOSURES */
5f05dabc 4268
76e3520e 4269STATIC CV *
cea2e8a9 4270S_cv_clone2(pTHX_ CV *proto, CV *outside)
748a9306
LW		 4271{
4272 AV* av;
4273 I32 ix;
4274 AV* protopadlist = CvPADLIST(proto);
4275 AV* protopad_name = (AV*)*av_fetch(protopadlist, 0, FALSE);
4276 AV* protopad = (AV*)*av_fetch(protopadlist, 1, FALSE);
5f05dabc 4277 SV** pname = AvARRAY(protopad_name);
4278 SV** ppad = AvARRAY(protopad);
93965878
NIS		 4279 I32 fname = AvFILLp(protopad_name);
4280 I32 fpad = AvFILLp(protopad);
748a9306
LW		 4281 AV* comppadlist;
4282 CV* cv;
4283
07055b4c
CS		 4284 assert(!CvUNIQUE(proto));
4285
748a9306 4286 ENTER;
354992b1 4287 SAVECOMPPAD();
3280af22
NIS		 4288 SAVESPTR(PL_comppad_name);
4289 SAVESPTR(PL_compcv);
748a9306 4290
3280af22 4291 cv = PL_compcv = (CV*)NEWSV(1104,0);
fa83b5b6 4292 sv_upgrade((SV *)cv, SvTYPE(proto));
a57ec3bd 4293 CvFLAGS(cv) = CvFLAGS(proto) & ~CVf_CLONE;
a5f75d66 4294 CvCLONED_on(cv);
748a9306 4295
11343788 4296#ifdef USE_THREADS
12ca11f6 4297 New(666, CvMUTEXP(cv), 1, perl_mutex);
11343788 4298 MUTEX_INIT(CvMUTEXP(cv));
11343788
MB		 4299 CvOWNER(cv) = 0;
4300#endif /* USE_THREADS */
57843af0 4301 CvFILE(cv) = CvFILE(proto);
65c50114 4302 CvGV(cv) = CvGV(proto);
748a9306 4303 CvSTASH(cv) = CvSTASH(proto);
282f25c9 4304 CvROOT(cv) = OpREFCNT_inc(CvROOT(proto));
748a9306 4305 CvSTART(cv) = CvSTART(proto);
5f05dabc 4306 if (outside)
4307 CvOUTSIDE(cv) = (CV*)SvREFCNT_inc(outside);
748a9306 4308
68dc0745 4309 if (SvPOK(proto))
4310 sv_setpvn((SV*)cv, SvPVX(proto), SvCUR(proto));
4311
3280af22 4312 PL_comppad_name = newAV();
46fc3d4c 4313 for (ix = fname; ix >= 0; ix--)
3280af22 4314 av_store(PL_comppad_name, ix, SvREFCNT_inc(pname[ix]));
748a9306 4315
3280af22 4316 PL_comppad = newAV();
748a9306
LW		 4317
4318 comppadlist = newAV();
4319 AvREAL_off(comppadlist);
3280af22
NIS		 4320 av_store(comppadlist, 0, (SV*)PL_comppad_name);
4321 av_store(comppadlist, 1, (SV*)PL_comppad);
748a9306 4322 CvPADLIST(cv) = comppadlist;
3280af22
NIS		 4323 av_fill(PL_comppad, AvFILLp(protopad));
4324 PL_curpad = AvARRAY(PL_comppad);
748a9306
LW		 4325
4326 av = newAV(); /* will be @_ */
4327 av_extend(av, 0);
3280af22 4328 av_store(PL_comppad, 0, (SV*)av);
748a9306
LW		 4329 AvFLAGS(av) = AVf_REIFY;
4330
9607fc9c 4331 for (ix = fpad; ix > 0; ix--) {
4332 SV* namesv = (ix <= fname) ? pname[ix] : Nullsv;
3280af22 4333 if (namesv && namesv != &PL_sv_undef) {
aa689395 4334 char *name = SvPVX(namesv); /* XXX */
4335 if (SvFLAGS(namesv) & SVf_FAKE) { /* lexical from outside? */
4336 I32 off = pad_findlex(name, ix, SvIVX(namesv),
2680586e 4337 CvOUTSIDE(cv), cxstack_ix, 0, 0);
5f05dabc 4338 if (!off)
3280af22 4339 PL_curpad[ix] = SvREFCNT_inc(ppad[ix]);
5f05dabc 4340 else if (off != ix)
cea2e8a9 4341 Perl_croak(aTHX_ "panic: cv_clone: %s", name);
748a9306
LW		 4342 }
4343 else { /* our own lexical */
aa689395 4344 SV* sv;
5f05dabc 4345 if (*name == '&') {
4346 /* anon code -- we'll come back for it */
4347 sv = SvREFCNT_inc(ppad[ix]);
4348 }
4349 else if (*name == '@')
4350 sv = (SV*)newAV();
748a9306 4351 else if (*name == '%')
5f05dabc 4352 sv = (SV*)newHV();
748a9306 4353 else
5f05dabc 4354 sv = NEWSV(0,0);
4355 if (!SvPADBUSY(sv))
4356 SvPADMY_on(sv);
3280af22 4357 PL_curpad[ix] = sv;
748a9306
LW		 4358 }
4359 }
7766f137 4360 else if (IS_PADGV(ppad[ix]) || IS_PADCONST(ppad[ix])) {
743e66e6
GS		 4361 PL_curpad[ix] = SvREFCNT_inc(ppad[ix]);
4362 }
748a9306 4363 else {
aa689395 4364 SV* sv = NEWSV(0,0);
748a9306 4365 SvPADTMP_on(sv);
3280af22 4366 PL_curpad[ix] = sv;
748a9306
LW		 4367 }
4368 }
4369
5f05dabc 4370 /* Now that vars are all in place, clone nested closures. */
4371
9607fc9c 4372 for (ix = fpad; ix > 0; ix--) {
4373 SV* namesv = (ix <= fname) ? pname[ix] : Nullsv;
aa689395 4374 if (namesv
3280af22 4375 && namesv != &PL_sv_undef
aa689395 4376 && !(SvFLAGS(namesv) & SVf_FAKE)
4377 && *SvPVX(namesv) == '&'
5f05dabc 4378 && CvCLONE(ppad[ix]))
4379 {
4380 CV *kid = cv_clone2((CV*)ppad[ix], cv);
4381 SvREFCNT_dec(ppad[ix]);
4382 CvCLONE_on(kid);
4383 SvPADMY_on(kid);
3280af22 4384 PL_curpad[ix] = (SV*)kid;
748a9306
LW		 4385 }
4386 }
4387
5f05dabc 4388#ifdef DEBUG_CLOSURES
ab50184a
CS		 4389 PerlIO_printf(Perl_debug_log, "Cloned inside:\n");
4390 cv_dump(outside);
4391 PerlIO_printf(Perl_debug_log, " from:\n");
5f05dabc 4392 cv_dump(proto);
ab50184a 4393 PerlIO_printf(Perl_debug_log, " to:\n");
5f05dabc 4394 cv_dump(cv);
4395#endif
4396
748a9306 4397 LEAVE;
beab0874
JT		 4398
4399 if (CvCONST(cv)) {
4400 SV* const_sv = op_const_sv(CvSTART(cv), cv);
4401 assert(const_sv);
4402 /* constant sub () { $x } closing over $x - see lib/constant.pm */
4403 SvREFCNT_dec(cv);
4404 cv = newCONSTSUB(CvSTASH(proto), 0, const_sv);
4405 }
4406
748a9306
LW		 4407 return cv;
4408}
4409
4410CV *
864dbfa3 4411Perl_cv_clone(pTHX_ CV *proto)
5f05dabc 4412{
b099ddc0 4413 CV *cv;
1feb2720 4414 LOCK_CRED_MUTEX; /* XXX create separate mutex */
b099ddc0 4415 cv = cv_clone2(proto, CvOUTSIDE(proto));
1feb2720 4416 UNLOCK_CRED_MUTEX; /* XXX create separate mutex */
b099ddc0 4417 return cv;
5f05dabc 4418}
4419
3fe9a6f1 4420void
864dbfa3 4421Perl_cv_ckproto(pTHX_ CV *cv, GV *gv, char *p)
3fe9a6f1 4422{
e476b1b5 4423 if (((!p != !SvPOK(cv)) || (p && strNE(p, SvPVX(cv)))) && ckWARN_d(WARN_PROTOTYPE)) {
46fc3d4c 4424 SV* msg = sv_newmortal();
3fe9a6f1 4425 SV* name = Nullsv;
4426
4427 if (gv)
46fc3d4c 4428 gv_efullname3(name = sv_newmortal(), gv, Nullch);
4429 sv_setpv(msg, "Prototype mismatch:");
4430 if (name)
894356b3 4431 Perl_sv_catpvf(aTHX_ msg, " sub %"SVf, name);
3fe9a6f1 4432 if (SvPOK(cv))
cea2e8a9 4433 Perl_sv_catpvf(aTHX_ msg, " (%s)", SvPVX(cv));
46fc3d4c 4434 sv_catpv(msg, " vs ");
4435 if (p)
cea2e8a9 4436 Perl_sv_catpvf(aTHX_ msg, "(%s)", p);
46fc3d4c 4437 else
4438 sv_catpv(msg, "none");
e476b1b5 4439 Perl_warner(aTHX_ WARN_PROTOTYPE, "%"SVf, msg);
3fe9a6f1 4440 }
4441}
4442
beab0874
JT		 4443static void const_sv_xsub(pTHXo_ CV* cv);
4444
4445/*
4446=for apidoc cv_const_sv
4447
4448If C<cv> is a constant sub eligible for inlining. returns the constant
4449value returned by the sub. Otherwise, returns NULL.
4450
4451Constant subs can be created with C<newCONSTSUB> or as described in
4452L<perlsub/"Constant Functions">.
4453
4454=cut
4455*/
760ac839 4456SV *
864dbfa3 4457Perl_cv_const_sv(pTHX_ CV *cv)
760ac839 4458{
beab0874 4459 if (!cv || !CvCONST(cv))
54310121 4460 return Nullsv;
beab0874 4461 return (SV*)CvXSUBANY(cv).any_ptr;
fe5e78ed 4462}
760ac839 4463
fe5e78ed 4464SV *
864dbfa3 4465Perl_op_const_sv(pTHX_ OP *o, CV *cv)
fe5e78ed
GS		 4466{
4467 SV *sv = Nullsv;
4468
0f79a09d 4469 if (!o)
fe5e78ed 4470 return Nullsv;
1c846c1f
NIS		 4471
4472 if (o->op_type == OP_LINESEQ && cLISTOPo->op_first)
fe5e78ed
GS		 4473 o = cLISTOPo->op_first->op_sibling;
4474
4475 for (; o; o = o->op_next) {
54310121 4476 OPCODE type = o->op_type;
fe5e78ed 4477
1c846c1f 4478 if (sv && o->op_next == o)
fe5e78ed 4479 return sv;
e576b457
JT		 4480 if (o->op_next != o) {
4481 if (type == OP_NEXTSTATE || type == OP_NULL || type == OP_PUSHMARK)
4482 continue;
4483 if (type == OP_DBSTATE)
4484 continue;
4485 }
54310121 4486 if (type == OP_LEAVESUB || type == OP_RETURN)
4487 break;
4488 if (sv)
4489 return Nullsv;
7766f137 4490 if (type == OP_CONST && cSVOPo->op_sv)
5dc0d613 4491 sv = cSVOPo->op_sv;
7766f137 4492 else if ((type == OP_PADSV || type == OP_CONST) && cv) {
e858de61
MB		 4493 AV* padav = (AV*)(AvARRAY(CvPADLIST(cv))[1]);
4494 sv = padav ? AvARRAY(padav)[o->op_targ] : Nullsv;
beab0874
JT		 4495 if (!sv)
4496 return Nullsv;
4497 if (CvCONST(cv)) {
4498 /* We get here only from cv_clone2() while creating a closure.
4499 Copy the const value here instead of in cv_clone2 so that
4500 SvREADONLY_on doesn't lead to problems when leaving
4501 scope.
4502 */
4503 sv = newSVsv(sv);
4504 }
4505 if (!SvREADONLY(sv) && SvREFCNT(sv) > 1)
54310121 4506 return Nullsv;
760ac839 4507 }
54310121 4508 else
4509 return Nullsv;
760ac839 4510 }
5aabfad6 4511 if (sv)
4512 SvREADONLY_on(sv);
760ac839
LW		 4513 return sv;
4514}
4515
09bef843
SB		 4516void
4517Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
4518{
4519 if (o)
4520 SAVEFREEOP(o);
4521 if (proto)
4522 SAVEFREEOP(proto);
4523 if (attrs)
4524 SAVEFREEOP(attrs);
4525 if (block)
4526 SAVEFREEOP(block);
4527 Perl_croak(aTHX_ "\"my sub\" not yet implemented");
4528}
4529
748a9306 4530CV *
864dbfa3 4531Perl_newSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *block)
79072805 4532{
09bef843
SB		 4533 return Perl_newATTRSUB(aTHX_ floor, o, proto, Nullop, block);
4534}
4535
4536CV *
4537Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
4538{
2d8e6c8d 4539 STRLEN n_a;
83ee9e09
GS		 4540 char *name;
4541 char *aname;
4542 GV *gv;
2d8e6c8d 4543 char *ps = proto ? SvPVx(((SVOP*)proto)->op_sv, n_a) : Nullch;
a2008d6d 4544 register CV *cv=0;
a0d0e21e 4545 I32 ix;
beab0874 4546 SV *const_sv;
79072805 4547
83ee9e09
GS		 4548 name = o ? SvPVx(cSVOPo->op_sv, n_a) : Nullch;
4549 if (!name && PERLDB_NAMEANON && CopLINE(PL_curcop)) {
4550 SV *sv = sv_newmortal();
4551 Perl_sv_setpvf(aTHX_ sv, "__ANON__[%s:%"IVdf"]",
4552 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
4553 aname = SvPVX(sv);
4554 }
4555 else
4556 aname = Nullch;
4557 gv = gv_fetchpv(name ? name : (aname ? aname : "__ANON__"),
4558 GV_ADDMULTI | ((block || attrs) ? 0 : GV_NOINIT),
4559 SVt_PVCV);
4560
11343788 4561 if (o)
5dc0d613 4562 SAVEFREEOP(o);
3fe9a6f1 4563 if (proto)
4564 SAVEFREEOP(proto);
09bef843
SB		 4565 if (attrs)
4566 SAVEFREEOP(attrs);
3fe9a6f1 4567
09bef843 4568 if (SvTYPE(gv) != SVt_PVGV) { /* Maybe prototype now, and had at
55d729e4
GS		 4569 maximum a prototype before. */
4570 if (SvTYPE(gv) > SVt_NULL) {
0453d815 4571 if (!SvPOK((SV*)gv) && !(SvIOK((SV*)gv) && SvIVX((SV*)gv) == -1)
e476b1b5 4572 && ckWARN_d(WARN_PROTOTYPE))
f248d071 4573 {
e476b1b5 4574 Perl_warner(aTHX_ WARN_PROTOTYPE, "Runaway prototype");
f248d071 4575 }
55d729e4
GS		 4576 cv_ckproto((CV*)gv, NULL, ps);
4577 }
4578 if (ps)
4579 sv_setpv((SV*)gv, ps);
4580 else
4581 sv_setiv((SV*)gv, -1);
3280af22
NIS		 4582 SvREFCNT_dec(PL_compcv);
4583 cv = PL_compcv = NULL;
4584 PL_sub_generation++;
beab0874 4585 goto done;
55d729e4
GS		 4586 }
4587
beab0874
JT		 4588 cv = (!name || GvCVGEN(gv)) ? Nullcv : GvCV(gv);
4589
5bd07a3d
DM		 4590#ifdef GV_SHARED_CHECK
4591 if (cv && GvSHARED(gv) && SvREADONLY(cv)) {
4592 Perl_croak(aTHX_ "Can't define subroutine %s (GV is shared)", name);
4593 }
4594#endif
4595
beab0874
JT		 4596 if (!block || !ps || *ps || attrs)
4597 const_sv = Nullsv;
4598 else
4599 const_sv = op_const_sv(block, Nullcv);
4600
4601 if (cv) {
60ed1d8c 4602 bool exists = CvROOT(cv) || CvXSUB(cv);
5bd07a3d
DM		 4603
4604#ifdef GV_SHARED_CHECK
4605 if (exists && GvSHARED(gv)) {
4606 Perl_croak(aTHX_ "Can't redefine shared subroutine %s", name);
4607 }
4608#endif
4609
60ed1d8c
GS		 4610 /* if the subroutine doesn't exist and wasn't pre-declared
4611 * with a prototype, assume it will be AUTOLOADed,
4612 * skipping the prototype check
4613 */
4614 if (exists || SvPOK(cv))
01ec43d0 4615 cv_ckproto(cv, gv, ps);
68dc0745 4616 /* already defined (or promised)? */
60ed1d8c 4617 if (exists || GvASSUMECV(gv)) {
09bef843 4618 if (!block && !attrs) {
aa689395 4619 /* just a "sub foo;" when &foo is already defined */
3280af22 4620 SAVEFREESV(PL_compcv);
aa689395 4621 goto done;
4622 }
7bac28a0 4623 /* ahem, death to those who redefine active sort subs */
3280af22 4624 if (PL_curstackinfo->si_type == PERLSI_SORT && PL_sortcop == CvSTART(cv))
cea2e8a9 4625 Perl_croak(aTHX_ "Can't redefine active sort subroutine %s", name);
beab0874
JT		 4626 if (block) {
4627 if (ckWARN(WARN_REDEFINE)
4628 || (CvCONST(cv)
4629 && (!const_sv || sv_cmp(cv_const_sv(cv), const_sv))))
4630 {
4631 line_t oldline = CopLINE(PL_curcop);
4632 CopLINE_set(PL_curcop, PL_copline);
4633 Perl_warner(aTHX_ WARN_REDEFINE,
4634 CvCONST(cv) ? "Constant subroutine %s redefined"
4635 : "Subroutine %s redefined", name);
4636 CopLINE_set(PL_curcop, oldline);
4637 }
4638 SvREFCNT_dec(cv);
4639 cv = Nullcv;
79072805 4640 }
79072805
LW		 4641 }
4642 }
beab0874
JT		 4643 if (const_sv) {
4644 SvREFCNT_inc(const_sv);
4645 if (cv) {
0768512c 4646 assert(!CvROOT(cv) && !CvCONST(cv));
beab0874
JT		 4647 sv_setpv((SV*)cv, ""); /* prototype is "" */
4648 CvXSUBANY(cv).any_ptr = const_sv;
4649 CvXSUB(cv) = const_sv_xsub;
4650 CvCONST_on(cv);
beab0874
JT		 4651 }
4652 else {
4653 GvCV(gv) = Nullcv;
4654 cv = newCONSTSUB(NULL, name, const_sv);
4655 }
4656 op_free(block);
4657 SvREFCNT_dec(PL_compcv);
4658 PL_compcv = NULL;
4659 PL_sub_generation++;
4660 goto done;
4661 }
09bef843
SB		 4662 if (attrs) {
4663 HV *stash;
4664 SV *rcv;
4665
4666 /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>
4667 * before we clobber PL_compcv.
4668 */
4669 if (cv && !block) {
4670 rcv = (SV*)cv;
4671 if (CvGV(cv) && GvSTASH(CvGV(cv)) && HvNAME(GvSTASH(CvGV(cv))))
4672 stash = GvSTASH(CvGV(cv));
4673 else if (CvSTASH(cv) && HvNAME(CvSTASH(cv)))
4674 stash = CvSTASH(cv);
4675 else
4676 stash = PL_curstash;
4677 }
4678 else {
4679 /* possibly about to re-define existing subr -- ignore old cv */
4680 rcv = (SV*)PL_compcv;
4681 if (name && GvSTASH(gv) && HvNAME(GvSTASH(gv)))
4682 stash = GvSTASH(gv);
4683 else
4684 stash = PL_curstash;
4685 }
4686 apply_attrs(stash, rcv, attrs);
4687 }
a0d0e21e 4688 if (cv) { /* must reuse cv if autoloaded */
09bef843
SB		 4689 if (!block) {
4690 /* got here with just attrs -- work done, so bug out */
4691 SAVEFREESV(PL_compcv);
4692 goto done;
4693 }
4633a7c4 4694 cv_undef(cv);
3280af22
NIS		 4695 CvFLAGS(cv) = CvFLAGS(PL_compcv);
4696 CvOUTSIDE(cv) = CvOUTSIDE(PL_compcv);
4697 CvOUTSIDE(PL_compcv) = 0;
4698 CvPADLIST(cv) = CvPADLIST(PL_compcv);
4699 CvPADLIST(PL_compcv) = 0;
282f25c9
JH		 4700 /* inner references to PL_compcv must be fixed up ... */
4701 {
4702 AV *padlist = CvPADLIST(cv);
4703 AV *comppad_name = (AV*)AvARRAY(padlist)[0];
4704 AV *comppad = (AV*)AvARRAY(padlist)[1];
4705 SV **namepad = AvARRAY(comppad_name);
4706 SV **curpad = AvARRAY(comppad);
4707 for (ix = AvFILLp(comppad_name); ix > 0; ix--) {
4708 SV *namesv = namepad[ix];
4709 if (namesv && namesv != &PL_sv_undef
4710 && *SvPVX(namesv) == '&')
4711 {
4712 CV *innercv = (CV*)curpad[ix];
4713 if (CvOUTSIDE(innercv) == PL_compcv) {
4714 CvOUTSIDE(innercv) = cv;
4715 if (!CvANON(innercv) || CvCLONED(innercv)) {
4716 (void)SvREFCNT_inc(cv);
4717 SvREFCNT_dec(PL_compcv);
4718 }
4719 }
4720 }
4721 }
4722 }
4723 /* ... before we throw it away */
3280af22 4724 SvREFCNT_dec(PL_compcv);
a0d0e21e
LW		 4725 }
4726 else {
3280af22 4727 cv = PL_compcv;
44a8e56a 4728 if (name) {
4729 GvCV(gv) = cv;
4730 GvCVGEN(gv) = 0;
3280af22 4731 PL_sub_generation++;
44a8e56a 4732 }
a0d0e21e 4733 }
65c50114 4734 CvGV(cv) = gv;
57843af0 4735 CvFILE(cv) = CopFILE(PL_curcop);
3280af22 4736 CvSTASH(cv) = PL_curstash;
11343788
MB		 4737#ifdef USE_THREADS
4738 CvOWNER(cv) = 0;
1cfa4ec7 4739 if (!CvMUTEXP(cv)) {
f6aaf501 4740 New(666, CvMUTEXP(cv), 1, perl_mutex);
1cfa4ec7
GS		 4741 MUTEX_INIT(CvMUTEXP(cv));
4742 }
11343788 4743#endif /* USE_THREADS */
8990e307 4744
3fe9a6f1 4745 if (ps)
4746 sv_setpv((SV*)cv, ps);
4633a7c4 4747
3280af22 4748 if (PL_error_count) {
c07a80fd 4749 op_free(block);
4750 block = Nullop;
68dc0745 4751 if (name) {
4752 char *s = strrchr(name, ':');
4753 s = s ? s+1 : name;
6d4c2119
CS		 4754 if (strEQ(s, "BEGIN")) {
4755 char *not_safe =
4756 "BEGIN not safe after errors--compilation aborted";
faef0170 4757 if (PL_in_eval & EVAL_KEEPERR)
cea2e8a9 4758 Perl_croak(aTHX_ not_safe);
6d4c2119
CS		 4759 else {
4760 /* force display of errors found but not reported */
38a03e6e 4761 sv_catpv(ERRSV, not_safe);
cea2e8a9 4762 Perl_croak(aTHX_ "%s", SvPVx(ERRSV, n_a));
6d4c2119
CS		 4763 }
4764 }
68dc0745 4765 }
c07a80fd 4766 }
beab0874
JT		 4767 if (!block)
4768 goto done;
a0d0e21e 4769
3280af22
NIS		 4770 if (AvFILLp(PL_comppad_name) < AvFILLp(PL_comppad))
4771 av_store(PL_comppad_name, AvFILLp(PL_comppad), Nullsv);
a0d0e21e 4772
7766f137 4773 if (CvLVALUE(cv)) {
78f9721b
SM		 4774 CvROOT(cv) = newUNOP(OP_LEAVESUBLV, 0,
4775 mod(scalarseq(block), OP_LEAVESUBLV));
7766f137
GS		 4776 }
4777 else {
4778 CvROOT(cv) = newUNOP(OP_LEAVESUB, 0, scalarseq(block));
4779 }
4780 CvROOT(cv)->op_private |= OPpREFCOUNTED;
4781 OpREFCNT_set(CvROOT(cv), 1);
4782 CvSTART(cv) = LINKLIST(CvROOT(cv));
4783 CvROOT(cv)->op_next = 0;
4784 peep(CvSTART(cv));
4785
4786 /* now that optimizer has done its work, adjust pad values */
54310121 4787 if (CvCLONE(cv)) {
3280af22
NIS		 4788 SV **namep = AvARRAY(PL_comppad_name);
4789 for (ix = AvFILLp(PL_comppad); ix > 0; ix--) {
54310121 4790 SV *namesv;
4791
7766f137 4792 if (SvIMMORTAL(PL_curpad[ix]) || IS_PADGV(PL_curpad[ix]) || IS_PADCONST(PL_curpad[ix]))
54310121 4793 continue;
4794 /*
4795 * The only things that a clonable function needs in its
4796 * pad are references to outer lexicals and anonymous subs.
4797 * The rest are created anew during cloning.
4798 */
4799 if (!((namesv = namep[ix]) != Nullsv &&
3280af22 4800 namesv != &PL_sv_undef &&
54310121 4801 (SvFAKE(namesv) ||
4802 *SvPVX(namesv) == '&')))
4803 {
3280af22
NIS		 4804 SvREFCNT_dec(PL_curpad[ix]);
4805 PL_curpad[ix] = Nullsv;
54310121 4806 }
4807 }
beab0874
JT		 4808 assert(!CvCONST(cv));
4809 if (ps && !*ps && op_const_sv(block, cv))
4810 CvCONST_on(cv);
a0d0e21e 4811 }
54310121 4812 else {
4813 AV *av = newAV(); /* Will be @_ */
4814 av_extend(av, 0);
3280af22 4815 av_store(PL_comppad, 0, (SV*)av);
54310121 4816 AvFLAGS(av) = AVf_REIFY;
79072805 4817
3280af22 4818 for (ix = AvFILLp(PL_comppad); ix > 0; ix--) {
7766f137 4819 if (SvIMMORTAL(PL_curpad[ix]) || IS_PADGV(PL_curpad[ix]) || IS_PADCONST(PL_curpad[ix]))
54310121 4820 continue;
3280af22
NIS		 4821 if (!SvPADMY(PL_curpad[ix]))
4822 SvPADTMP_on(PL_curpad[ix]);
54310121 4823 }
4824 }
79072805 4825
c975facc
JH		 4826 /* If a potential closure prototype, don't keep a refcount on
4827 * outer CV, unless the latter happens to be a passing eval"".
282f25c9
JH		 4828 * This is okay as the lifetime of the prototype is tied to the
4829 * lifetime of the outer CV. Avoids memory leak due to reference
4830 * loop. --GSAR */
c975facc 4831 if (!name && CvOUTSIDE(cv)
f58d1073
GS		 4832 && !(SvTYPE(CvOUTSIDE(cv)) == SVt_PVCV
4833 && CvEVAL(CvOUTSIDE(cv)) && !CvGV(CvOUTSIDE(cv))))
c975facc 4834 {
282f25c9 4835 SvREFCNT_dec(CvOUTSIDE(cv));
c975facc 4836 }
282f25c9 4837
83ee9e09 4838 if (name || aname) {
44a8e56a 4839 char *s;
83ee9e09 4840 char *tname = (name ? name : aname);
44a8e56a 4841
3280af22 4842 if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
46fc3d4c 4843 SV *sv = NEWSV(0,0);
44a8e56a 4844 SV *tmpstr = sv_newmortal();
549bb64a 4845 GV *db_postponed = gv_fetchpv("DB::postponed", GV_ADDMULTI, SVt_PVHV);
83ee9e09 4846 CV *pcv;
44a8e56a 4847 HV *hv;
4848
ed094faf
GS		 4849 Perl_sv_setpvf(aTHX_ sv, "%s:%ld-%ld",
4850 CopFILE(PL_curcop),
cc49e20b 4851 (long)PL_subline, (long)CopLINE(PL_curcop));
44a8e56a 4852 gv_efullname3(tmpstr, gv, Nullch);
3280af22 4853 hv_store(GvHV(PL_DBsub), SvPVX(tmpstr), SvCUR(tmpstr), sv, 0);
44a8e56a 4854 hv = GvHVn(db_postponed);
9607fc9c 4855 if (HvFILL(hv) > 0 && hv_exists(hv, SvPVX(tmpstr), SvCUR(tmpstr))
83ee9e09
GS		 4856 && (pcv = GvCV(db_postponed)))
4857 {
44a8e56a 4858 dSP;
924508f0 4859 PUSHMARK(SP);
44a8e56a 4860 XPUSHs(tmpstr);
4861 PUTBACK;
83ee9e09 4862 call_sv((SV*)pcv, G_DISCARD);
44a8e56a 4863 }
4864 }
79072805 4865
83ee9e09 4866 if ((s = strrchr(tname,':')))
28757baa 4867 s++;
4868 else
83ee9e09 4869 s = tname;
ed094faf 4870
7d30b5c4 4871 if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I')
ed094faf
GS		 4872 goto done;
4873
68dc0745 4874 if (strEQ(s, "BEGIN")) {
3280af22 4875 I32 oldscope = PL_scopestack_ix;
28757baa 4876 ENTER;
57843af0
GS		 4877 SAVECOPFILE(&PL_compiling);
4878 SAVECOPLINE(&PL_compiling);
3280af22
NIS		 4879 save_svref(&PL_rs);
4880 sv_setsv(PL_rs, PL_nrs);
28757baa 4881
3280af22
NIS		 4882 if (!PL_beginav)
4883 PL_beginav = newAV();
28757baa 4884 DEBUG_x( dump_sub(gv) );
ea2f84a3
GS		 4885 av_push(PL_beginav, (SV*)cv);
4886 GvCV(gv) = 0; /* cv has been hijacked */
3280af22 4887 call_list(oldscope, PL_beginav);
a6006777 4888
3280af22 4889 PL_curcop = &PL_compiling;
a0ed51b3 4890 PL_compiling.op_private = PL_hints;
28757baa 4891 LEAVE;
4892 }
3280af22
NIS		 4893 else if (strEQ(s, "END") && !PL_error_count) {
4894 if (!PL_endav)
4895 PL_endav = newAV();
ed094faf 4896 DEBUG_x( dump_sub(gv) );
3280af22 4897 av_unshift(PL_endav, 1);
ea2f84a3
GS		 4898 av_store(PL_endav, 0, (SV*)cv);
4899 GvCV(gv) = 0; /* cv has been hijacked */
28757baa 4900 }
7d30b5c4
GS		 4901 else if (strEQ(s, "CHECK") && !PL_error_count) {
4902 if (!PL_checkav)
4903 PL_checkav = newAV();
ed094faf 4904 DEBUG_x( dump_sub(gv) );
ddda08b7
GS		 4905 if (PL_main_start && ckWARN(WARN_VOID))
4906 Perl_warner(aTHX_ WARN_VOID, "Too late to run CHECK block");
7d30b5c4 4907 av_unshift(PL_checkav, 1);
ea2f84a3
GS		 4908 av_store(PL_checkav, 0, (SV*)cv);
4909 GvCV(gv) = 0; /* cv has been hijacked */
4f25aa18 4910 }
3280af22
NIS		 4911 else if (strEQ(s, "INIT") && !PL_error_count) {
4912 if (!PL_initav)
4913 PL_initav = newAV();
ed094faf 4914 DEBUG_x( dump_sub(gv) );
ddda08b7
GS		 4915 if (PL_main_start && ckWARN(WARN_VOID))
4916 Perl_warner(aTHX_ WARN_VOID, "Too late to run INIT block");
ea2f84a3
GS		 4917 av_push(PL_initav, (SV*)cv);
4918 GvCV(gv) = 0; /* cv has been hijacked */
ae77835f 4919 }
79072805 4920 }
a6006777 4921
aa689395 4922 done:
3280af22 4923 PL_copline = NOLINE;
8990e307 4924 LEAVE_SCOPE(floor);
a0d0e21e 4925 return cv;
79072805
LW		 4926}
4927
b099ddc0 4928/* XXX unsafe for threads if eval_owner isn't held */
954c1994
GS		 4929/*
4930=for apidoc newCONSTSUB
4931
4932Creates a constant sub equivalent to Perl C<sub FOO () { 123 }> which is
4933eligible for inlining at compile-time.
4934
4935=cut
4936*/
4937
beab0874 4938CV *
864dbfa3 4939Perl_newCONSTSUB(pTHX_ HV *stash, char *name, SV *sv)
5476c433 4940{
beab0874 4941 CV* cv;
5476c433 4942
11faa288 4943 ENTER;
11faa288 4944
f4dd75d9 4945 SAVECOPLINE(PL_curcop);
11faa288 4946 CopLINE_set(PL_curcop, PL_copline);
f4dd75d9
GS		 4947
4948 SAVEHINTS();
3280af22 4949 PL_hints &= ~HINT_BLOCK_SCOPE;
11faa288
GS		 4950
4951 if (stash) {
4952 SAVESPTR(PL_curstash);
4953 SAVECOPSTASH(PL_curcop);
4954 PL_curstash = stash;
4955#ifdef USE_ITHREADS
4956 CopSTASHPV(PL_curcop) = stash ? HvNAME(stash) : Nullch;
4957#else
4958 CopSTASH(PL_curcop) = stash;
4959#endif
4960 }
5476c433 4961
beab0874
JT		 4962 cv = newXS(name, const_sv_xsub, __FILE__);
4963 CvXSUBANY(cv).any_ptr = sv;
4964 CvCONST_on(cv);
4965 sv_setpv((SV*)cv, ""); /* prototype is "" */
5476c433 4966
11faa288 4967 LEAVE;
beab0874
JT		 4968
4969 return cv;
5476c433
JD		 4970}
4971
954c1994
GS		 4972/*
4973=for apidoc U||newXS
4974
4975Used by C<xsubpp> to hook up XSUBs as Perl subs.
4976
4977=cut
4978*/
4979
57d3b86d 4980CV *
864dbfa3 4981Perl_newXS(pTHX_ char *name, XSUBADDR_t subaddr, char *filename)
a0d0e21e 4982{
44a8e56a 4983 GV *gv = gv_fetchpv(name ? name : "__ANON__", GV_ADDMULTI, SVt_PVCV);
79072805 4984 register CV *cv;
44a8e56a 4985
155aba94 4986 if ((cv = (name ? GvCV(gv) : Nullcv))) {
44a8e56a 4987 if (GvCVGEN(gv)) {
4988 /* just a cached method */
4989 SvREFCNT_dec(cv);
4990 cv = 0;
4991 }
4992 else if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) {
4993 /* already defined (or promised) */
599cee73 4994 if (ckWARN(WARN_REDEFINE) && !(CvGV(cv) && GvSTASH(CvGV(cv))
2f34f9d4
IZ		 4995 && HvNAME(GvSTASH(CvGV(cv)))
4996 && strEQ(HvNAME(GvSTASH(CvGV(cv))), "autouse"))) {
57843af0 4997 line_t oldline = CopLINE(PL_curcop);
51f6edd3 4998 if (PL_copline != NOLINE)
57843af0 4999 CopLINE_set(PL_curcop, PL_copline);
beab0874
JT		 5000 Perl_warner(aTHX_ WARN_REDEFINE,
5001 CvCONST(cv) ? "Constant subroutine %s redefined"
5002 : "Subroutine %s redefined"
5003 ,name);
57843af0 5004 CopLINE_set(PL_curcop, oldline);
a0d0e21e
LW		 5005 }
5006 SvREFCNT_dec(cv);
5007 cv = 0;
79072805 5008 }
79072805 5009 }
44a8e56a 5010
5011 if (cv) /* must reuse cv if autoloaded */
5012 cv_undef(cv);
a0d0e21e
LW		 5013 else {
5014 cv = (CV*)NEWSV(1105,0);
5015 sv_upgrade((SV *)cv, SVt_PVCV);
44a8e56a 5016 if (name) {
5017 GvCV(gv) = cv;
5018 GvCVGEN(gv) = 0;
3280af22 5019 PL_sub_generation++;
44a8e56a 5020 }
a0d0e21e 5021 }
65c50114 5022 CvGV(cv) = gv;
11343788 5023#ifdef USE_THREADS
12ca11f6 5024 New(666, CvMUTEXP(cv), 1, perl_mutex);
11343788 5025 MUTEX_INIT(CvMUTEXP(cv));
11343788
MB		 5026 CvOWNER(cv) = 0;
5027#endif /* USE_THREADS */
b195d487 5028 (void)gv_fetchfile(filename);
57843af0
GS		 5029 CvFILE(cv) = filename; /* NOTE: not copied, as it is expected to be
5030 an external constant string */
a0d0e21e 5031 CvXSUB(cv) = subaddr;
44a8e56a 5032
28757baa 5033 if (name) {
5034 char *s = strrchr(name,':');
5035 if (s)
5036 s++;
5037 else
5038 s = name;
ed094faf 5039
7d30b5c4 5040 if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I')
ed094faf
GS		 5041 goto done;
5042
28757baa 5043 if (strEQ(s, "BEGIN")) {
3280af22
NIS		 5044 if (!PL_beginav)
5045 PL_beginav = newAV();
ea2f84a3
GS		 5046 av_push(PL_beginav, (SV*)cv);
5047 GvCV(gv) = 0; /* cv has been hijacked */
28757baa 5048 }
5049 else if (strEQ(s, "END")) {
3280af22
NIS		 5050 if (!PL_endav)
5051 PL_endav = newAV();
5052 av_unshift(PL_endav, 1);
ea2f84a3
GS		 5053 av_store(PL_endav, 0, (SV*)cv);
5054 GvCV(gv) = 0; /* cv has been hijacked */
28757baa 5055 }
7d30b5c4
GS		 5056 else if (strEQ(s, "CHECK")) {
5057 if (!PL_checkav)
5058 PL_checkav = newAV();
ddda08b7
GS		 5059 if (PL_main_start && ckWARN(WARN_VOID))
5060 Perl_warner(aTHX_ WARN_VOID, "Too late to run CHECK block");
7d30b5c4 5061 av_unshift(PL_checkav, 1);
ea2f84a3
GS		 5062 av_store(PL_checkav, 0, (SV*)cv);
5063 GvCV(gv) = 0; /* cv has been hijacked */
4f25aa18 5064 }
7d07dbc2 5065 else if (strEQ(s, "INIT")) {
3280af22
NIS		 5066 if (!PL_initav)
5067 PL_initav = newAV();
ddda08b7
GS		 5068 if (PL_main_start && ckWARN(WARN_VOID))
5069 Perl_warner(aTHX_ WARN_VOID, "Too late to run INIT block");
ea2f84a3
GS		 5070 av_push(PL_initav, (SV*)cv);
5071 GvCV(gv) = 0; /* cv has been hijacked */
ae77835f 5072 }
28757baa 5073 }
8990e307 5074 else
a5f75d66 5075 CvANON_on(cv);
44a8e56a 5076
ed094faf 5077done:
a0d0e21e 5078 return cv;
79072805
LW		 5079}
5080
5081void
864dbfa3 5082Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block)
79072805
LW		 5083{
5084 register CV *cv;
5085 char *name;
5086 GV *gv;
a0d0e21e 5087 I32 ix;
2d8e6c8d 5088 STRLEN n_a;
79072805 5089
11343788 5090 if (o)
2d8e6c8d 5091 name = SvPVx(cSVOPo->op_sv, n_a);
79072805
LW		 5092 else
5093 name = "STDOUT";
85e6fe83 5094 gv = gv_fetchpv(name,TRUE, SVt_PVFM);
5bd07a3d
DM		 5095#ifdef GV_SHARED_CHECK
5096 if (GvSHARED(gv)) {
5097 Perl_croak(aTHX_ "Bad symbol for form (GV is shared)");
5098 }
5099#endif
a5f75d66 5100 GvMULTI_on(gv);
155aba94 5101 if ((cv = GvFORM(gv))) {
599cee73 5102 if (ckWARN(WARN_REDEFINE)) {
57843af0 5103 line_t oldline = CopLINE(PL_curcop);
79072805 5104
57843af0 5105 CopLINE_set(PL_curcop, PL_copline);
cea2e8a9 5106 Perl_warner(aTHX_ WARN_REDEFINE, "Format %s redefined",name);
57843af0 5107 CopLINE_set(PL_curcop, oldline);
79072805 5108 }
8990e307 5109 SvREFCNT_dec(cv);
79072805 5110 }
3280af22 5111 cv = PL_compcv;
79072805 5112 GvFORM(gv) = cv;
65c50114 5113 CvGV(cv) = gv;
57843af0 5114 CvFILE(cv) = CopFILE(PL_curcop);
79072805 5115
3280af22
NIS		 5116 for (ix = AvFILLp(PL_comppad); ix > 0; ix--) {
5117 if (!SvPADMY(PL_curpad[ix]) && !SvIMMORTAL(PL_curpad[ix]))
5118 SvPADTMP_on(PL_curpad[ix]);
a0d0e21e
LW		 5119 }
5120
79072805 5121 CvROOT(cv) = newUNOP(OP_LEAVEWRITE, 0, scalarseq(block));
7934575e
GS		 5122 CvROOT(cv)->op_private |= OPpREFCOUNTED;
5123 OpREFCNT_set(CvROOT(cv), 1);
79072805
LW		 5124 CvSTART(cv) = LINKLIST(CvROOT(cv));
5125 CvROOT(cv)->op_next = 0;
5126 peep(CvSTART(cv));
11343788 5127 op_free(o);
3280af22 5128 PL_copline = NOLINE;
8990e307 5129 LEAVE_SCOPE(floor);
79072805
LW		 5130}
5131
5132OP *
864dbfa3 5133Perl_newANONLIST(pTHX_ OP *o)
79072805 5134{
93a17b20 5135 return newUNOP(OP_REFGEN, 0,
11343788 5136 mod(list(convert(OP_ANONLIST, 0, o)), OP_REFGEN));
79072805
LW		 5137}
5138
5139OP *
864dbfa3 5140Perl_newANONHASH(pTHX_ OP *o)
79072805 5141{
93a17b20 5142 return newUNOP(OP_REFGEN, 0,
11343788 5143 mod(list(convert(OP_ANONHASH, 0, o)), OP_REFGEN));
a0d0e21e
LW		 5144}
5145
5146OP *
864dbfa3 5147Perl_newANONSUB(pTHX_ I32 floor, OP *proto, OP *block)
a0d0e21e 5148{
09bef843
SB		 5149 return newANONATTRSUB(floor, proto, Nullop, block);
5150}
5151
5152OP *
5153Perl_newANONATTRSUB(pTHX_ I32 floor, OP *proto, OP *attrs, OP *block)
5154{
a0d0e21e 5155 return newUNOP(OP_REFGEN, 0,
09bef843
SB		 5156 newSVOP(OP_ANONCODE, 0,
5157 (SV*)newATTRSUB(floor, 0, proto, attrs, block)));
79072805
LW		 5158}
5159
5160OP *
864dbfa3 5161Perl_oopsAV(pTHX_ OP *o)
79072805 5162{
ed6116ce
LW		 5163 switch (o->op_type) {
5164 case OP_PADSV:
5165 o->op_type = OP_PADAV;
22c35a8c 5166 o->op_ppaddr = PL_ppaddr[OP_PADAV];
51e247a3 5167 return ref(o, OP_RV2AV);
ed6116ce
LW		 5168
5169 case OP_RV2SV:
79072805 5170 o->op_type = OP_RV2AV;
22c35a8c 5171 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
79072805 5172 ref(o, OP_RV2AV);
ed6116ce
LW		 5173 break;
5174
5175 default:
0453d815
PM		 5176 if (ckWARN_d(WARN_INTERNAL))
5177 Perl_warner(aTHX_ WARN_INTERNAL, "oops: oopsAV");
ed6116ce
LW		 5178 break;
5179 }
79072805
LW		 5180 return o;
5181}
5182
5183OP *
864dbfa3 5184Perl_oopsHV(pTHX_ OP *o)
79072805 5185{
ed6116ce
LW		 5186 switch (o->op_type) {
5187 case OP_PADSV:
5188 case OP_PADAV:
5189 o->op_type = OP_PADHV;
22c35a8c 5190 o->op_ppaddr = PL_ppaddr[OP_PADHV];
51e247a3 5191 return ref(o, OP_RV2HV);
ed6116ce
LW		 5192
5193 case OP_RV2SV:
5194 case OP_RV2AV:
79072805 5195 o->op_type = OP_RV2HV;
22c35a8c 5196 o->op_ppaddr = PL_ppaddr[OP_RV2HV];
79072805 5197 ref(o, OP_RV2HV);
ed6116ce
LW		 5198 break;
5199
5200 default:
0453d815
PM		 5201 if (ckWARN_d(WARN_INTERNAL))
5202 Perl_warner(aTHX_ WARN_INTERNAL, "oops: oopsHV");
ed6116ce
LW		 5203 break;
5204 }
79072805
LW		 5205 return o;
5206}
5207
5208OP *
864dbfa3 5209Perl_newAVREF(pTHX_ OP *o)
79072805 5210{
ed6116ce
LW		 5211 if (o->op_type == OP_PADANY) {
5212 o->op_type = OP_PADAV;
22c35a8c 5213 o->op_ppaddr = PL_ppaddr[OP_PADAV];
93a17b20 5214 return o;
ed6116ce 5215 }
a1063b2d
RH		 5216 else if ((o->op_type == OP_RV2AV || o->op_type == OP_PADAV)
5217 && ckWARN(WARN_DEPRECATED)) {
5218 Perl_warner(aTHX_ WARN_DEPRECATED,
5219 "Using an array as a reference is deprecated");
5220 }
79072805
LW		 5221 return newUNOP(OP_RV2AV, 0, scalar(o));
5222}
5223
5224OP *
864dbfa3 5225Perl_newGVREF(pTHX_ I32 type, OP *o)
79072805 5226{
82092f1d 5227 if (type == OP_MAPSTART || type == OP_GREPSTART || type == OP_SORT)
a0d0e21e 5228 return newUNOP(OP_NULL, 0, o);
748a9306 5229 return ref(newUNOP(OP_RV2GV, OPf_REF, o), type);
79072805
LW		 5230}
5231
5232OP *
864dbfa3 5233Perl_newHVREF(pTHX_ OP *o)
79072805 5234{
ed6116ce
LW		 5235 if (o->op_type == OP_PADANY) {
5236 o->op_type = OP_PADHV;
22c35a8c 5237 o->op_ppaddr = PL_ppaddr[OP_PADHV];
93a17b20 5238 return o;
ed6116ce 5239 }
a1063b2d
RH		 5240 else if ((o->op_type == OP_RV2HV || o->op_type == OP_PADHV)
5241 && ckWARN(WARN_DEPRECATED)) {
5242 Perl_warner(aTHX_ WARN_DEPRECATED,
5243 "Using a hash as a reference is deprecated");
5244 }
79072805
LW		 5245 return newUNOP(OP_RV2HV, 0, scalar(o));
5246}
5247
5248OP *
864dbfa3 5249Perl_oopsCV(pTHX_ OP *o)
79072805 5250{
cea2e8a9 5251 Perl_croak(aTHX_ "NOT IMPL LINE %d",__LINE__);
79072805
LW		 5252 /* STUB */
5253 return o;
5254}
5255
5256OP *
864dbfa3 5257Perl_newCVREF(pTHX_ I32 flags, OP *o)
79072805 5258{
c07a80fd 5259 return newUNOP(OP_RV2CV, flags, scalar(o));
79072805
LW		 5260}
5261
5262OP *
864dbfa3 5263Perl_newSVREF(pTHX_ OP *o)
79072805 5264{
ed6116ce
LW		 5265 if (o->op_type == OP_PADANY) {
5266 o->op_type = OP_PADSV;
22c35a8c 5267 o->op_ppaddr = PL_ppaddr[OP_PADSV];
93a17b20 5268 return o;
ed6116ce 5269 }
224a4551
MB		 5270 else if (o->op_type == OP_THREADSV && !(o->op_flags & OPpDONE_SVREF)) {
5271 o->op_flags |= OPpDONE_SVREF;
a863c7d1 5272 return o;
224a4551 5273 }
79072805
LW		 5274 return newUNOP(OP_RV2SV, 0, scalar(o));
5275}
5276
5277/* Check routines. */
5278
5279OP *
cea2e8a9 5280Perl_ck_anoncode(pTHX_ OP *o)
5f05dabc 5281{
178c6305
CS		 5282 PADOFFSET ix;
5283 SV* name;
5284
5285 name = NEWSV(1106,0);
5286 sv_upgrade(name, SVt_PVNV);
5287 sv_setpvn(name, "&", 1);
5288 SvIVX(name) = -1;
5289 SvNVX(name) = 1;
5dc0d613 5290 ix = pad_alloc(o->op_type, SVs_PADMY);
3280af22
NIS		 5291 av_store(PL_comppad_name, ix, name);
5292 av_store(PL_comppad, ix, cSVOPo->op_sv);
5dc0d613
MB		 5293 SvPADMY_on(cSVOPo->op_sv);
5294 cSVOPo->op_sv = Nullsv;
5295 cSVOPo->op_targ = ix;
5296 return o;
5f05dabc 5297}
5298
5299OP *
cea2e8a9 5300Perl_ck_bitop(pTHX_ OP *o)
55497cff 5301{
3280af22 5302 o->op_private = PL_hints;
5dc0d613 5303 return o;
55497cff 5304}
5305
5306OP *
cea2e8a9 5307Perl_ck_concat(pTHX_ OP *o)
79072805 5308{
11343788
MB		 5309 if (cUNOPo->op_first->op_type == OP_CONCAT)
5310 o->op_flags |= OPf_STACKED;
5311 return o;
79072805
LW		 5312}
5313
5314OP *
cea2e8a9 5315Perl_ck_spair(pTHX_ OP *o)
79072805 5316{
11343788 5317 if (o->op_flags & OPf_KIDS) {
79072805 5318 OP* newop;
a0d0e21e 5319 OP* kid;
5dc0d613
MB		 5320 OPCODE type = o->op_type;
5321 o = modkids(ck_fun(o), type);
11343788 5322 kid = cUNOPo->op_first;
a0d0e21e
LW		 5323 newop = kUNOP->op_first->op_sibling;
5324 if (newop &&
5325 (newop->op_sibling ||
22c35a8c 5326 !(PL_opargs[newop->op_type] & OA_RETSCALAR) ||
a0d0e21e
LW		 5327 newop->op_type == OP_PADAV || newop->op_type == OP_PADHV ||
5328 newop->op_type == OP_RV2AV || newop->op_type == OP_RV2HV)) {
aeea060c 5329
11343788 5330 return o;
a0d0e21e
LW		 5331 }
5332 op_free(kUNOP->op_first);
5333 kUNOP->op_first = newop;
5334 }
22c35a8c 5335 o->op_ppaddr = PL_ppaddr[++o->op_type];
11343788 5336 return ck_fun(o);
a0d0e21e
LW		 5337}
5338
5339OP *
cea2e8a9 5340Perl_ck_delete(pTHX_ OP *o)
a0d0e21e 5341{
11343788 5342 o = ck_fun(o);
5dc0d613 5343 o->op_private = 0;
11343788
MB		 5344 if (o->op_flags & OPf_KIDS) {
5345 OP *kid = cUNOPo->op_first;
01020589
GS		 5346 switch (kid->op_type) {
5347 case OP_ASLICE:
5348 o->op_flags |= OPf_SPECIAL;
5349 /* FALL THROUGH */
5350 case OP_HSLICE:
5dc0d613 5351 o->op_private |= OPpSLICE;
01020589
GS		 5352 break;
5353 case OP_AELEM:
5354 o->op_flags |= OPf_SPECIAL;
5355 /* FALL THROUGH */
5356 case OP_HELEM:
5357 break;
5358 default:
5359 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element or slice",
22c35a8c 5360 PL_op_desc[o->op_type]);
01020589 5361 }
93c66552 5362 op_null(kid);
79072805 5363 }
11343788 5364 return o;
79072805
LW		 5365}
5366
5367OP *
cea2e8a9 5368Perl_ck_eof(pTHX_ OP *o)
79072805 5369{
11343788 5370 I32 type = o->op_type;
79072805 5371
11343788
MB		 5372 if (o->op_flags & OPf_KIDS) {
5373 if (cLISTOPo->op_first->op_type == OP_STUB) {
5374 op_free(o);
5375 o = newUNOP(type, OPf_SPECIAL,
d58bf5aa 5376 newGVOP(OP_GV, 0, gv_fetchpv("main::ARGV", TRUE, SVt_PVAV)));
8990e307 5377 }
11343788 5378 return ck_fun(o);
79072805 5379 }
11343788 5380 return o;
79072805
LW		 5381}
5382
5383OP *
cea2e8a9 5384Perl_ck_eval(pTHX_ OP *o)
79072805 5385{
3280af22 5386 PL_hints |= HINT_BLOCK_SCOPE;
11343788
MB		 5387 if (o->op_flags & OPf_KIDS) {
5388 SVOP *kid = (SVOP*)cUNOPo->op_first;
79072805 5389
93a17b20 5390 if (!kid) {
11343788 5391 o->op_flags &= ~OPf_KIDS;
93c66552 5392 op_null(o);
79072805
LW		 5393 }
5394 else if (kid->op_type == OP_LINESEQ) {
5395 LOGOP *enter;
5396
11343788
MB		 5397 kid->op_next = o->op_next;
5398 cUNOPo->op_first = 0;
5399 op_free(o);
79072805 5400
b7dc083c 5401 NewOp(1101, enter, 1, LOGOP);
79072805 5402 enter->op_type = OP_ENTERTRY;
22c35a8c 5403 enter->op_ppaddr = PL_ppaddr[OP_ENTERTRY];
79072805
LW		 5404 enter->op_private = 0;
5405
5406 /* establish postfix order */
5407 enter->op_next = (OP*)enter;
5408
11343788
MB		 5409 o = prepend_elem(OP_LINESEQ, (OP*)enter, (OP*)kid);
5410 o->op_type = OP_LEAVETRY;
22c35a8c 5411 o->op_ppaddr = PL_ppaddr[OP_LEAVETRY];
11343788
MB		 5412 enter->op_other = o;
5413 return o;
79072805 5414 }
c7cc6f1c 5415 else
473986ff 5416 scalar((OP*)kid);
79072805
LW		 5417 }
5418 else {
11343788 5419 op_free(o);
54b9620d 5420 o = newUNOP(OP_ENTEREVAL, 0, newDEFSVOP());
79072805 5421 }
3280af22 5422 o->op_targ = (PADOFFSET)PL_hints;
11343788 5423 return o;
79072805
LW		 5424}
5425
5426OP *
d98f61e7
GS		 5427Perl_ck_exit(pTHX_ OP *o)
5428{
5429#ifdef VMS
5430 HV *table = GvHV(PL_hintgv);
5431 if (table) {
5432 SV **svp = hv_fetch(table, "vmsish_exit", 11, FALSE);
5433 if (svp && *svp && SvTRUE(*svp))
5434 o->op_private |= OPpEXIT_VMSISH;
5435 }
5436#endif
5437 return ck_fun(o);
5438}
5439
5440OP *
cea2e8a9 5441Perl_ck_exec(pTHX_ OP *o)
79072805
LW		 5442{
5443 OP *kid;
11343788
MB		 5444 if (o->op_flags & OPf_STACKED) {
5445 o = ck_fun(o);
5446 kid = cUNOPo->op_first->op_sibling;
8990e307 5447 if (kid->op_type == OP_RV2GV)
93c66552 5448 op_null(kid);
79072805 5449 }
463ee0b2 5450 else
11343788
MB		 5451 o = listkids(o);
5452 return o;
79072805
LW		 5453}
5454
5455OP *
cea2e8a9 5456Perl_ck_exists(pTHX_ OP *o)
5f05dabc 5457{
5196be3e
MB		 5458 o = ck_fun(o);
5459 if (o->op_flags & OPf_KIDS) {
5460 OP *kid = cUNOPo->op_first;
afebc493
GS		 5461 if (kid->op_type == OP_ENTERSUB) {
5462 (void) ref(kid, o->op_type);
5463 if (kid->op_type != OP_RV2CV && !PL_error_count)
5464 Perl_croak(aTHX_ "%s argument is not a subroutine name",
5465 PL_op_desc[o->op_type]);
5466 o->op_private |= OPpEXISTS_SUB;
5467 }
5468 else if (kid->op_type == OP_AELEM)
01020589
GS		 5469 o->op_flags |= OPf_SPECIAL;
5470 else if (kid->op_type != OP_HELEM)
5471 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element",
5472 PL_op_desc[o->op_type]);
93c66552 5473 op_null(kid);
5f05dabc 5474 }
5196be3e 5475 return o;
5f05dabc 5476}
5477
22c35a8c 5478#if 0
5f05dabc 5479OP *
cea2e8a9 5480Perl_ck_gvconst(pTHX_ register OP *o)
79072805
LW		 5481{
5482 o = fold_constants(o);
5483 if (o->op_type == OP_CONST)
5484 o->op_type = OP_GV;
5485 return o;
5486}
22c35a8c 5487#endif
79072805
LW		 5488
5489OP *
cea2e8a9 5490Perl_ck_rvconst(pTHX_ register OP *o)
79072805 5491{
11343788 5492 SVOP *kid = (SVOP*)cUNOPo->op_first;
85e6fe83 5493
3280af22 5494 o->op_private |= (PL_hints & HINT_STRICT_REFS);
79072805 5495 if (kid->op_type == OP_CONST) {
44a8e56a 5496 char *name;
5497 int iscv;
5498 GV *gv;
779c5bc9 5499 SV *kidsv = kid->op_sv;
2d8e6c8d 5500 STRLEN n_a;
44a8e56a 5501
779c5bc9
GS		 5502 /* Is it a constant from cv_const_sv()? */
5503 if (SvROK(kidsv) && SvREADONLY(kidsv)) {
5504 SV *rsv = SvRV(kidsv);
5505 int svtype = SvTYPE(rsv);
5506 char *badtype = Nullch;
5507
5508 switch (o->op_type) {
5509 case OP_RV2SV:
5510 if (svtype > SVt_PVMG)
5511 badtype = "a SCALAR";
5512 break;
5513 case OP_RV2AV:
5514 if (svtype != SVt_PVAV)
5515 badtype = "an ARRAY";
5516 break;
5517 case OP_RV2HV:
5518 if (svtype != SVt_PVHV) {
5519 if (svtype == SVt_PVAV) { /* pseudohash? */
5520 SV **ksv = av_fetch((AV*)rsv, 0, FALSE);
5521 if (ksv && SvROK(*ksv)
5522 && SvTYPE(SvRV(*ksv)) == SVt_PVHV)
5523 {
5524 break;
5525 }
5526 }
5527 badtype = "a HASH";
5528 }
5529 break;
5530 case OP_RV2CV:
5531 if (svtype != SVt_PVCV)
5532 badtype = "a CODE";
5533 break;
5534 }
5535 if (badtype)
cea2e8a9 5536 Perl_croak(aTHX_ "Constant is not %s reference", badtype);
779c5bc9
GS		 5537 return o;
5538 }
2d8e6c8d 5539 name = SvPV(kidsv, n_a);
3280af22 5540 if ((PL_hints & HINT_STRICT_REFS) && (kid->op_private & OPpCONST_BARE)) {
44a8e56a 5541 char *badthing = Nullch;
5dc0d613 5542 switch (o->op_type) {
44a8e56a 5543 case OP_RV2SV:
5544 badthing = "a SCALAR";
5545 break;
5546 case OP_RV2AV:
5547 badthing = "an ARRAY";
5548 break;
5549 case OP_RV2HV:
5550 badthing = "a HASH";
5551 break;
5552 }
5553 if (badthing)
1c846c1f 5554 Perl_croak(aTHX_
44a8e56a 5555 "Can't use bareword (\"%s\") as %s ref while \"strict refs\" in use",
5556 name, badthing);
5557 }
93233ece
CS		 5558 /*
5559 * This is a little tricky. We only want to add the symbol if we
5560 * didn't add it in the lexer. Otherwise we get duplicate strict
5561 * warnings. But if we didn't add it in the lexer, we must at
5562 * least pretend like we wanted to add it even if it existed before,
5563 * or we get possible typo warnings. OPpCONST_ENTERED says
5564 * whether the lexer already added THIS instance of this symbol.
5565 */
5196be3e 5566 iscv = (o->op_type == OP_RV2CV) * 2;
93233ece 5567 do {
44a8e56a 5568 gv = gv_fetchpv(name,
748a9306 5569 iscv | !(kid->op_private & OPpCONST_ENTERED),
a0d0e21e
LW		 5570 iscv
5571 ? SVt_PVCV
11343788 5572 : o->op_type == OP_RV2SV
a0d0e21e 5573 ? SVt_PV
11343788 5574 : o->op_type == OP_RV2AV
a0d0e21e 5575 ? SVt_PVAV
11343788 5576 : o->op_type == OP_RV2HV
a0d0e21e
LW		 5577 ? SVt_PVHV
5578 : SVt_PVGV);
93233ece
CS		 5579 } while (!gv && !(kid->op_private & OPpCONST_ENTERED) && !iscv++);
5580 if (gv) {
5581 kid->op_type = OP_GV;
5582 SvREFCNT_dec(kid->op_sv);
350de78d 5583#ifdef USE_ITHREADS
638eceb6 5584 /* XXX hack: dependence on sizeof(PADOP) <= sizeof(SVOP) */
350de78d 5585 kPADOP->op_padix = pad_alloc(OP_GV, SVs_PADTMP);
63caf608 5586 SvREFCNT_dec(PL_curpad[kPADOP->op_padix]);
743e66e6 5587 GvIN_PAD_on(gv);
350de78d
GS		 5588 PL_curpad[kPADOP->op_padix] = SvREFCNT_inc(gv);
5589#else
93233ece 5590 kid->op_sv = SvREFCNT_inc(gv);
350de78d 5591#endif
23f1ca44 5592 kid->op_private = 0;
76cd736e 5593 kid->op_ppaddr = PL_ppaddr[OP_GV];
a0d0e21e 5594 }
79072805 5595 }
11343788 5596 return o;
79072805
LW		 5597}
5598
5599OP *
cea2e8a9 5600Perl_ck_ftst(pTHX_ OP *o)
79072805 5601{
11343788 5602 I32 type = o->op_type;
79072805 5603
d0dca557
JD		 5604 if (o->op_flags & OPf_REF) {
5605 /* nothing */
5606 }
5607 else if (o->op_flags & OPf_KIDS && cUNOPo->op_first->op_type != OP_STUB) {
11343788 5608 SVOP *kid = (SVOP*)cUNOPo->op_first;
79072805
LW		 5609
5610 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
2d8e6c8d 5611 STRLEN n_a;
a0d0e21e 5612 OP *newop = newGVOP(type, OPf_REF,
2d8e6c8d 5613 gv_fetchpv(SvPVx(kid->op_sv, n_a), TRUE, SVt_PVIO));
11343788 5614 op_free(o);
d0dca557 5615 o = newop;
79072805
LW		 5616 }
5617 }
5618 else {
11343788 5619 op_free(o);
79072805 5620 if (type == OP_FTTTY)
d0dca557 5621 o = newGVOP(type, OPf_REF, gv_fetchpv("main::STDIN", TRUE,
85e6fe83 5622 SVt_PVIO));
79072805 5623 else
d0dca557 5624 o = newUNOP(type, 0, newDEFSVOP());
79072805 5625 }
11343788 5626 return o;
79072805
LW		 5627}
5628
5629OP *
cea2e8a9 5630Perl_ck_fun(pTHX_ OP *o)
79072805
LW		 5631{
5632 register OP *kid;
5633 OP **tokid;
5634 OP *sibl;
5635 I32 numargs = 0;
11343788 5636 int type = o->op_type;
22c35a8c 5637 register I32 oa = PL_opargs[type] >> OASHIFT;
aeea060c 5638
11343788 5639 if (o->op_flags & OPf_STACKED) {
79072805
LW		 5640 if ((oa & OA_OPTIONAL) && (oa >> 4) && !((oa >> 4) & OA_OPTIONAL))
5641 oa &= ~OA_OPTIONAL;
5642 else
11343788 5643 return no_fh_allowed(o);
79072805
LW		 5644 }
5645
11343788 5646 if (o->op_flags & OPf_KIDS) {
2d8e6c8d 5647 STRLEN n_a;
11343788
MB		 5648 tokid = &cLISTOPo->op_first;
5649 kid = cLISTOPo->op_first;
8990e307 5650 if (kid->op_type == OP_PUSHMARK ||
155aba94 5651 (kid->op_type == OP_NULL && kid->op_targ == OP_PUSHMARK))
8990e307 5652 {
79072805
LW		 5653 tokid = &kid->op_sibling;
5654 kid = kid->op_sibling;
5655 }
22c35a8c 5656 if (!kid && PL_opargs[type] & OA_DEFGV)
54b9620d 5657 *tokid = kid = newDEFSVOP();
79072805
LW		 5658
5659 while (oa && kid) {
5660 numargs++;
5661 sibl = kid->op_sibling;
5662 switch (oa & 7) {
5663 case OA_SCALAR:
62c18ce2
GS		 5664 /* list seen where single (scalar) arg expected? */
5665 if (numargs == 1 && !(oa >> 4)
5666 && kid->op_type == OP_LIST && type != OP_SCALAR)
5667 {
5668 return too_many_arguments(o,PL_op_desc[type]);
5669 }
79072805
LW		 5670 scalar(kid);
5671 break;
5672 case OA_LIST:
5673 if (oa < 16) {
5674 kid = 0;
5675 continue;
5676 }
5677 else
5678 list(kid);
5679 break;
5680 case OA_AVREF:
936edb8b 5681 if ((type == OP_PUSH || type == OP_UNSHIFT)
f87c3213
JH		 5682 && !kid->op_sibling && ckWARN(WARN_SYNTAX))
5683 Perl_warner(aTHX_ WARN_SYNTAX,
de4864e4 5684 "Useless use of %s with no values",
936edb8b
RH		 5685 PL_op_desc[type]);
5686
79072805 5687 if (kid->op_type == OP_CONST &&
62c18ce2
GS		 5688 (kid->op_private & OPpCONST_BARE))
5689 {
2d8e6c8d 5690 char *name = SvPVx(((SVOP*)kid)->op_sv, n_a);
79072805 5691 OP *newop = newAVREF(newGVOP(OP_GV, 0,
85e6fe83 5692 gv_fetchpv(name, TRUE, SVt_PVAV) ));
e476b1b5
GS		 5693 if (ckWARN(WARN_DEPRECATED))
5694 Perl_warner(aTHX_ WARN_DEPRECATED,
57def98f 5695 "Array @%s missing the @ in argument %"IVdf" of %s()",
cf2093f6 5696 name, (IV)numargs, PL_op_desc[type]);
79072805
LW		 5697 op_free(kid);
5698 kid = newop;
5699 kid->op_sibling = sibl;
5700 *tokid = kid;
5701 }
8990e307 5702 else if (kid->op_type != OP_RV2AV && kid->op_type != OP_PADAV)
35cd451c 5703 bad_type(numargs, "array", PL_op_desc[type], kid);
a0d0e21e 5704 mod(kid, type);
79072805
LW		 5705 break;
5706 case OA_HVREF:
5707 if (kid->op_type == OP_CONST &&
62c18ce2
GS		 5708 (kid->op_private & OPpCONST_BARE))
5709 {
2d8e6c8d 5710 char *name = SvPVx(((SVOP*)kid)->op_sv, n_a);
79072805 5711 OP *newop = newHVREF(newGVOP(OP_GV, 0,
85e6fe83 5712 gv_fetchpv(name, TRUE, SVt_PVHV) ));
e476b1b5
GS		 5713 if (ckWARN(WARN_DEPRECATED))
5714 Perl_warner(aTHX_ WARN_DEPRECATED,
57def98f 5715 "Hash %%%s missing the %% in argument %"IVdf" of %s()",
cf2093f6 5716 name, (IV)numargs, PL_op_desc[type]);
79072805
LW		 5717 op_free(kid);
5718 kid = newop;
5719 kid->op_sibling = sibl;
5720 *tokid = kid;
5721 }
8990e307 5722 else if (kid->op_type != OP_RV2HV && kid->op_type != OP_PADHV)
35cd451c 5723 bad_type(numargs, "hash", PL_op_desc[type], kid);
a0d0e21e 5724 mod(kid, type);
79072805
LW		 5725 break;
5726 case OA_CVREF:
5727 {
a0d0e21e 5728 OP *newop = newUNOP(OP_NULL, 0, kid);
79072805
LW		 5729 kid->op_sibling = 0;
5730 linklist(kid);
5731 newop->op_next = newop;
5732 kid = newop;
5733 kid->op_sibling = sibl;
5734 *tokid = kid;
5735 }
5736 break;
5737 case OA_FILEREF:
c340be78 5738 if (kid->op_type != OP_GV && kid->op_type != OP_RV2GV) {
79072805 5739 if (kid->op_type == OP_CONST &&
62c18ce2
GS		 5740 (kid->op_private & OPpCONST_BARE))
5741 {
79072805 5742 OP *newop = newGVOP(OP_GV, 0,
2d8e6c8d 5743 gv_fetchpv(SvPVx(((SVOP*)kid)->op_sv, n_a), TRUE,
85e6fe83 5744 SVt_PVIO) );
79072805
LW		 5745 op_free(kid);
5746 kid = newop;
5747 }
1ea32a52
GS		 5748 else if (kid->op_type == OP_READLINE) {
5749 /* neophyte patrol: open(<FH>), close(<FH>) etc. */
5750 bad_type(numargs, "HANDLE", PL_op_desc[o->op_type], kid);
5751 }
79072805 5752 else {
35cd451c 5753 I32 flags = OPf_SPECIAL;
a6c40364 5754 I32 priv = 0;
2c8ac474
GS		 5755 PADOFFSET targ = 0;
5756
35cd451c 5757 /* is this op a FH constructor? */
853846ea 5758 if (is_handle_constructor(o,numargs)) {
2c8ac474
GS		 5759 char *name = Nullch;
5760 STRLEN len;
5761
5762 flags = 0;
5763 /* Set a flag to tell rv2gv to vivify
853846ea
NIS		 5764 * need to "prove" flag does not mean something
5765 * else already - NI-S 1999/05/07
2c8ac474
GS		 5766 */
5767 priv = OPpDEREF;
5768 if (kid->op_type == OP_PADSV) {
5769 SV **namep = av_fetch(PL_comppad_name,
5770 kid->op_targ, 4);
5771 if (namep && *namep)
5772 name = SvPV(*namep, len);
5773 }
5774 else if (kid->op_type == OP_RV2SV
5775 && kUNOP->op_first->op_type == OP_GV)
5776 {
5777 GV *gv = cGVOPx_gv(kUNOP->op_first);
5778 name = GvNAME(gv);
5779 len = GvNAMELEN(gv);
5780 }
afd1915d
GS		 5781 else if (kid->op_type == OP_AELEM
5782 || kid->op_type == OP_HELEM)
5783 {
5784 name = "__ANONIO__";
5785 len = 10;
5786 mod(kid,type);
5787 }
2c8ac474
GS		 5788 if (name) {
5789 SV *namesv;
5790 targ = pad_alloc(OP_RV2GV, SVs_PADTMP);
5791 namesv = PL_curpad[targ];
155aba94 5792 (void)SvUPGRADE(namesv, SVt_PV);
2c8ac474
GS		 5793 if (*name != '$')
5794 sv_setpvn(namesv, "$", 1);
5795 sv_catpvn(namesv, name, len);
5796 }
853846ea 5797 }
79072805 5798 kid->op_sibling = 0;
35cd451c 5799 kid = newUNOP(OP_RV2GV, flags, scalar(kid));
2c8ac474
GS		 5800 kid->op_targ = targ;
5801 kid->op_private |= priv;
79072805
LW		 5802 }
5803 kid->op_sibling = sibl;
5804 *tokid = kid;
5805 }
5806 scalar(kid);
5807 break;
5808 case OA_SCALARREF:
a0d0e21e 5809 mod(scalar(kid), type);
79072805
LW		 5810 break;
5811 }
5812 oa >>= 4;
5813 tokid = &kid->op_sibling;
5814 kid = kid->op_sibling;
5815 }
11343788 5816 o->op_private |= numargs;
79072805 5817 if (kid)
22c35a8c 5818 return too_many_arguments(o,PL_op_desc[o->op_type]);
11343788 5819 listkids(o);
79072805 5820 }
22c35a8c 5821 else if (PL_opargs[type] & OA_DEFGV) {
11343788 5822 op_free(o);
54b9620d 5823 return newUNOP(type, 0, newDEFSVOP());
a0d0e21e
LW		 5824 }
5825
79072805
LW		 5826 if (oa) {
5827 while (oa & OA_OPTIONAL)
5828 oa >>= 4;
5829 if (oa && oa != OA_LIST)
22c35a8c 5830 return too_few_arguments(o,PL_op_desc[o->op_type]);
79072805 5831 }
11343788 5832 return o;
79072805
LW		 5833}
5834
5835OP *
cea2e8a9 5836Perl_ck_glob(pTHX_ OP *o)
79072805 5837{
fb73857a 5838 GV *gv;
5839
649da076 5840 o = ck_fun(o);
1f2bfc8a 5841 if ((o->op_flags & OPf_KIDS) && !cLISTOPo->op_first->op_sibling)
54b9620d 5842 append_elem(OP_GLOB, o, newDEFSVOP());
fb73857a 5843
5844 if (!((gv = gv_fetchpv("glob", FALSE, SVt_PVCV)) && GvIMPORTED_CV(gv)))
5845 gv = gv_fetchpv("CORE::GLOBAL::glob", FALSE, SVt_PVCV);
b1cb66bf 5846
52bb0670 5847#if !defined(PERL_EXTERNAL_GLOB)
72b16652
GS		 5848 /* XXX this can be tightened up and made more failsafe. */
5849 if (!gv) {
7d3fb230 5850 GV *glob_gv;
72b16652 5851 ENTER;
7d3fb230
BS		 5852 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT, newSVpvn("File::Glob", 10), Nullsv,
5853 Nullsv, Nullsv);
72b16652 5854 gv = gv_fetchpv("CORE::GLOBAL::glob", FALSE, SVt_PVCV);
7d3fb230
BS		 5855 glob_gv = gv_fetchpv("File::Glob::csh_glob", FALSE, SVt_PVCV);
5856 GvCV(gv) = GvCV(glob_gv);
445266f0 5857 SvREFCNT_inc((SV*)GvCV(gv));
7d3fb230 5858 GvIMPORTED_CV_on(gv);
72b16652
GS		 5859 LEAVE;
5860 }
52bb0670 5861#endif /* PERL_EXTERNAL_GLOB */
72b16652 5862
b1cb66bf 5863 if (gv && GvIMPORTED_CV(gv)) {
5196be3e 5864 append_elem(OP_GLOB, o,
80252599 5865 newSVOP(OP_CONST, 0, newSViv(PL_glob_index++)));
1f2bfc8a 5866 o->op_type = OP_LIST;
22c35a8c 5867 o->op_ppaddr = PL_ppaddr[OP_LIST];
1f2bfc8a 5868 cLISTOPo->op_first->op_type = OP_PUSHMARK;
22c35a8c 5869 cLISTOPo->op_first->op_ppaddr = PL_ppaddr[OP_PUSHMARK];
1f2bfc8a 5870 o = newUNOP(OP_ENTERSUB, OPf_STACKED,
aeea060c 5871 append_elem(OP_LIST, o,
1f2bfc8a
MB		 5872 scalar(newUNOP(OP_RV2CV, 0,
5873 newGVOP(OP_GV, 0, gv)))));
d58bf5aa
MB		 5874 o = newUNOP(OP_NULL, 0, ck_subr(o));
5875 o->op_targ = OP_GLOB; /* hint at what it used to be */
5876 return o;
b1cb66bf 5877 }
5878 gv = newGVgen("main");
a0d0e21e 5879 gv_IOadd(gv);
11343788
MB		 5880 append_elem(OP_GLOB, o, newGVOP(OP_GV, 0, gv));
5881 scalarkids(o);
649da076 5882 return o;
79072805
LW		 5883}
5884
5885OP *
cea2e8a9 5886Perl_ck_grep(pTHX_ OP *o)
79072805
LW		 5887{
5888 LOGOP *gwop;
5889 OP *kid;
11343788 5890 OPCODE type = o->op_type == OP_GREPSTART ? OP_GREPWHILE : OP_MAPWHILE;
79072805 5891
22c35a8c 5892 o->op_ppaddr = PL_ppaddr[OP_GREPSTART];
b7dc083c 5893 NewOp(1101, gwop, 1, LOGOP);
aeea060c 5894
11343788 5895 if (o->op_flags & OPf_STACKED) {
a0d0e21e 5896 OP* k;
11343788
MB		 5897 o = ck_sort(o);
5898 kid = cLISTOPo->op_first->op_sibling;
5899 for (k = cLISTOPo->op_first->op_sibling->op_next; k; k = k->op_next) {
a0d0e21e
LW		 5900 kid = k;
5901 }
5902 kid->op_next = (OP*)gwop;
11343788 5903 o->op_flags &= ~OPf_STACKED;
93a17b20 5904 }
11343788 5905 kid = cLISTOPo->op_first->op_sibling;
a0d0e21e
LW		 5906 if (type == OP_MAPWHILE)
5907 list(kid);
5908 else
5909 scalar(kid);
11343788 5910 o = ck_fun(o);
3280af22 5911 if (PL_error_count)
11343788 5912 return o;
aeea060c 5913 kid = cLISTOPo->op_first->op_sibling;
79072805 5914 if (kid->op_type != OP_NULL)
cea2e8a9 5915 Perl_croak(aTHX_ "panic: ck_grep");
79072805
LW		 5916 kid = kUNOP->op_first;
5917
a0d0e21e 5918 gwop->op_type = type;
22c35a8c 5919 gwop->op_ppaddr = PL_ppaddr[type];
11343788 5920 gwop->op_first = listkids(o);
79072805
LW		 5921 gwop->op_flags |= OPf_KIDS;
5922 gwop->op_private = 1;
5923 gwop->op_other = LINKLIST(kid);
a0d0e21e 5924 gwop->op_targ = pad_alloc(type, SVs_PADTMP);
79072805
LW		 5925 kid->op_next = (OP*)gwop;
5926
11343788 5927 kid = cLISTOPo->op_first->op_sibling;
a0d0e21e 5928 if (!kid || !kid->op_sibling)
22c35a8c 5929 return too_few_arguments(o,PL_op_desc[o->op_type]);
a0d0e21e
LW		 5930 for (kid = kid->op_sibling; kid; kid = kid->op_sibling)
5931 mod(kid, OP_GREPSTART);
5932
79072805
LW		 5933 return (OP*)gwop;
5934}
5935
5936OP *
cea2e8a9 5937Perl_ck_index(pTHX_ OP *o)
79072805 5938{
11343788
MB		 5939 if (o->op_flags & OPf_KIDS) {
5940 OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
0b71040e
LW		 5941 if (kid)
5942 kid = kid->op_sibling; /* get past "big" */
79072805 5943 if (kid && kid->op_type == OP_CONST)
2779dcf1 5944 fbm_compile(((SVOP*)kid)->op_sv, 0);
79072805 5945 }
11343788 5946 return ck_fun(o);
79072805
LW		 5947}
5948
5949OP *
cea2e8a9 5950Perl_ck_lengthconst(pTHX_ OP *o)
79072805
LW		 5951{
5952 /* XXX length optimization goes here */
11343788 5953 return ck_fun(o);
79072805
LW		 5954}
5955
5956OP *
cea2e8a9 5957Perl_ck_lfun(pTHX_ OP *o)
79072805 5958{
5dc0d613
MB		 5959 OPCODE type = o->op_type;
5960 return modkids(ck_fun(o), type);
79072805
LW		 5961}
5962
5963OP *
cea2e8a9 5964Perl_ck_defined(pTHX_ OP *o) /* 19990527 MJD */
69794302 5965{
d0334bed
GS		 5966 if ((o->op_flags & OPf_KIDS) && ckWARN(WARN_DEPRECATED)) {
5967 switch (cUNOPo->op_first->op_type) {
5968 case OP_RV2AV:
a8739d98
JH		 5969 /* This is needed for
5970 if (defined %stash::)
5971 to work. Do not break Tk.
5972 */
1c846c1f 5973 break; /* Globals via GV can be undef */
d0334bed
GS		 5974 case OP_PADAV:
5975 case OP_AASSIGN: /* Is this a good idea? */
5976 Perl_warner(aTHX_ WARN_DEPRECATED,
f10b0346 5977 "defined(@array) is deprecated");
d0334bed 5978 Perl_warner(aTHX_ WARN_DEPRECATED,
cc507455 5979 "\t(Maybe you should just omit the defined()?)\n");
69794302 5980 break;
d0334bed 5981 case OP_RV2HV:
a8739d98
JH		 5982 /* This is needed for
5983 if (defined %stash::)
5984 to work. Do not break Tk.
5985 */
1c846c1f 5986 break; /* Globals via GV can be undef */
d0334bed
GS		 5987 case OP_PADHV:
5988 Perl_warner(aTHX_ WARN_DEPRECATED,
894356b3 5989 "defined(%%hash) is deprecated");
d0334bed 5990 Perl_warner(aTHX_ WARN_DEPRECATED,
cc507455 5991 "\t(Maybe you should just omit the defined()?)\n");
d0334bed
GS		 5992 break;
5993 default:
5994 /* no warning */
5995 break;
5996 }
69794302
MJD		 5997 }
5998 return ck_rfun(o);
5999}
6000
6001OP *
cea2e8a9 6002Perl_ck_rfun(pTHX_ OP *o)
8990e307 6003{
5dc0d613
MB		 6004 OPCODE type = o->op_type;
6005 return refkids(ck_fun(o), type);
8990e307
LW		 6006}
6007
6008OP *
cea2e8a9 6009Perl_ck_listiob(pTHX_ OP *o)
79072805
LW		 6010{
6011 register OP *kid;
aeea060c 6012
11343788 6013 kid = cLISTOPo->op_first;
79072805 6014 if (!kid) {
11343788
MB		 6015 o = force_list(o);
6016 kid = cLISTOPo->op_first;
79072805
LW		 6017 }
6018 if (kid->op_type == OP_PUSHMARK)
6019 kid = kid->op_sibling;
11343788 6020 if (kid && o->op_flags & OPf_STACKED)
79072805
LW		 6021 kid = kid->op_sibling;
6022 else if (kid && !kid->op_sibling) { /* print HANDLE; */
6023 if (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE) {
11343788 6024 o->op_flags |= OPf_STACKED; /* make it a filehandle */
748a9306 6025 kid = newUNOP(OP_RV2GV, OPf_REF, scalar(kid));
11343788
MB		 6026 cLISTOPo->op_first->op_sibling = kid;
6027 cLISTOPo->op_last = kid;
79072805
LW		 6028 kid = kid->op_sibling;
6029 }
6030 }
6031
6032 if (!kid)
54b9620d 6033 append_elem(o->op_type, o, newDEFSVOP());
79072805 6034
2de3dbcc 6035 return listkids(o);
bbce6d69 6036}
6037
6038OP *
b162f9ea
IZ		 6039Perl_ck_sassign(pTHX_ OP *o)
6040{
6041 OP *kid = cLISTOPo->op_first;
6042 /* has a disposable target? */
6043 if ((PL_opargs[kid->op_type] & OA_TARGLEX)
6b66af17
GS		 6044 && !(kid->op_flags & OPf_STACKED)
6045 /* Cannot steal the second time! */
6046 && !(kid->op_private & OPpTARGET_MY))
b162f9ea
IZ		 6047 {
6048 OP *kkid = kid->op_sibling;
6049
6050 /* Can just relocate the target. */
2c2d71f5
JH		 6051 if (kkid && kkid->op_type == OP_PADSV
6052 && !(kkid->op_private & OPpLVAL_INTRO))
6053 {
b162f9ea 6054 kid->op_targ = kkid->op_targ;
743e66e6 6055 kkid->op_targ = 0;
b162f9ea
IZ		 6056 /* Now we do not need PADSV and SASSIGN. */
6057 kid->op_sibling = o->op_sibling; /* NULL */
6058 cLISTOPo->op_first = NULL;
6059 op_free(o);
6060 op_free(kkid);
6061 kid->op_private |= OPpTARGET_MY; /* Used for context settings */
6062 return kid;
6063 }
6064 }
6065 return o;
6066}
6067
6068OP *
cea2e8a9 6069Perl_ck_match(pTHX_ OP *o)
79072805 6070{
5dc0d613 6071 o->op_private |= OPpRUNTIME;
11343788 6072 return o;
79072805
LW		 6073}
6074
6075OP *
f5d5a27c
CS		 6076Perl_ck_method(pTHX_ OP *o)
6077{
6078 OP *kid = cUNOPo->op_first;
6079 if (kid->op_type == OP_CONST) {
6080 SV* sv = kSVOP->op_sv;
6081 if (!(strchr(SvPVX(sv), ':') || strchr(SvPVX(sv), '\''))) {
6082 OP *cmop;
1c846c1f
NIS		 6083 if (!SvREADONLY(sv) || !SvFAKE(sv)) {
6084 sv = newSVpvn_share(SvPVX(sv), SvCUR(sv), 0);
6085 }
6086 else {
6087 kSVOP->op_sv = Nullsv;
6088 }
f5d5a27c 6089 cmop = newSVOP(OP_METHOD_NAMED, 0, sv);
f5d5a27c
CS		 6090 op_free(o);
6091 return cmop;
6092 }
6093 }
6094 return o;
6095}
6096
6097OP *
cea2e8a9 6098Perl_ck_null(pTHX_ OP *o)
79072805 6099{
11343788 6100 return o;
79072805
LW		 6101}
6102
6103OP *
16fe6d59
GS		 6104Perl_ck_open(pTHX_ OP *o)
6105{
6106 HV *table = GvHV(PL_hintgv);
6107 if (table) {
6108 SV **svp;
6109 I32 mode;
6110 svp = hv_fetch(table, "open_IN", 7, FALSE);
6111 if (svp && *svp) {
6112 mode = mode_from_discipline(*svp);
6113 if (mode & O_BINARY)
6114 o->op_private |= OPpOPEN_IN_RAW;
6115 else if (mode & O_TEXT)
6116 o->op_private |= OPpOPEN_IN_CRLF;
6117 }
6118
6119 svp = hv_fetch(table, "open_OUT", 8, FALSE);
6120 if (svp && *svp) {
6121 mode = mode_from_discipline(*svp);
6122 if (mode & O_BINARY)
6123 o->op_private |= OPpOPEN_OUT_RAW;
6124 else if (mode & O_TEXT)
6125 o->op_private |= OPpOPEN_OUT_CRLF;
6126 }
6127 }
6128 if (o->op_type == OP_BACKTICK)
6129 return o;
6130 return ck_fun(o);
6131}
6132
6133OP *
cea2e8a9 6134Perl_ck_repeat(pTHX_ OP *o)
79072805 6135{
11343788
MB		 6136 if (cBINOPo->op_first->op_flags & OPf_PARENS) {
6137 o->op_private |= OPpREPEAT_DOLIST;
6138 cBINOPo->op_first = force_list(cBINOPo->op_first);
79072805
LW		 6139 }
6140 else
11343788
MB		 6141 scalar(o);
6142 return o;
79072805
LW		 6143}
6144
6145OP *
cea2e8a9 6146Perl_ck_require(pTHX_ OP *o)
8990e307 6147{
ec4ab249
GA		 6148 GV* gv;
6149
11343788
MB		 6150 if (o->op_flags & OPf_KIDS) { /* Shall we supply missing .pm? */
6151 SVOP *kid = (SVOP*)cUNOPo->op_first;
8990e307
LW		 6152
6153 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
8990e307 6154 char *s;
a0d0e21e
LW		 6155 for (s = SvPVX(kid->op_sv); *s; s++) {
6156 if (*s == ':' && s[1] == ':') {
6157 *s = '/';
1aef975c 6158 Move(s+2, s+1, strlen(s+2)+1, char);
a0d0e21e
LW		 6159 --SvCUR(kid->op_sv);
6160 }
8990e307 6161 }
ce3b816e
GS		 6162 if (SvREADONLY(kid->op_sv)) {
6163 SvREADONLY_off(kid->op_sv);
6164 sv_catpvn(kid->op_sv, ".pm", 3);
6165 SvREADONLY_on(kid->op_sv);
6166 }
6167 else
6168 sv_catpvn(kid->op_sv, ".pm", 3);
8990e307
LW		 6169 }
6170 }
ec4ab249
GA		 6171
6172 /* handle override, if any */
6173 gv = gv_fetchpv("require", FALSE, SVt_PVCV);
6174 if (!(gv && GvIMPORTED_CV(gv)))
6175 gv = gv_fetchpv("CORE::GLOBAL::require", FALSE, SVt_PVCV);
6176
6177 if (gv && GvIMPORTED_CV(gv)) {
6178 OP *kid = cUNOPo->op_first;
6179 cUNOPo->op_first = 0;
6180 op_free(o);
6181 return ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
6182 append_elem(OP_LIST, kid,
6183 scalar(newUNOP(OP_RV2CV, 0,
6184 newGVOP(OP_GV, 0,
6185 gv))))));
6186 }
6187
11343788 6188 return ck_fun(o);
8990e307
LW		 6189}
6190
78f9721b
SM		 6191OP *
6192Perl_ck_return(pTHX_ OP *o)
6193{
6194 OP *kid;
6195 if (CvLVALUE(PL_compcv)) {
6196 for (kid = cLISTOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
6197 mod(kid, OP_LEAVESUBLV);
6198 }
6199 return o;
6200}
6201
22c35a8c 6202#if 0
8990e307 6203OP *
cea2e8a9 6204Perl_ck_retarget(pTHX_ OP *o)
79072805 6205{
cea2e8a9 6206 Perl_croak(aTHX_ "NOT IMPL LINE %d",__LINE__);
79072805 6207 /* STUB */
11343788 6208 return o;
79072805 6209}
22c35a8c 6210#endif
79072805
LW		 6211
6212OP *
cea2e8a9 6213Perl_ck_select(pTHX_ OP *o)
79072805 6214{
c07a80fd 6215 OP* kid;
11343788
MB		 6216 if (o->op_flags & OPf_KIDS) {
6217 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
2304df62 6218 if (kid && kid->op_sibling) {
11343788 6219 o->op_type = OP_SSELECT;
22c35a8c 6220 o->op_ppaddr = PL_ppaddr[OP_SSELECT];
11343788
MB		 6221 o = ck_fun(o);
6222 return fold_constants(o);
79072805
LW		 6223 }
6224 }
11343788
MB		 6225 o = ck_fun(o);
6226 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
c07a80fd 6227 if (kid && kid->op_type == OP_RV2GV)
6228 kid->op_private &= ~HINT_STRICT_REFS;
11343788 6229 return o;
79072805
LW		 6230}
6231
6232OP *
cea2e8a9 6233Perl_ck_shift(pTHX_ OP *o)
79072805 6234{
11343788 6235 I32 type = o->op_type;
79072805 6236
11343788 6237 if (!(o->op_flags & OPf_KIDS)) {
6d4ff0d2
MB		 6238 OP *argop;
6239
11343788 6240 op_free(o);
6d4ff0d2 6241#ifdef USE_THREADS
533c011a 6242 if (!CvUNIQUE(PL_compcv)) {
6d4ff0d2 6243 argop = newOP(OP_PADAV, OPf_REF);
6b88bc9c 6244 argop->op_targ = 0; /* PL_curpad[0] is @_ */
6d4ff0d2
MB		 6245 }
6246 else {
6247 argop = newUNOP(OP_RV2AV, 0,
6248 scalar(newGVOP(OP_GV, 0,
6249 gv_fetchpv("ARGV", TRUE, SVt_PVAV))));
6250 }
6251#else
6252 argop = newUNOP(OP_RV2AV, 0,
3280af22
NIS		 6253 scalar(newGVOP(OP_GV, 0, !CvUNIQUE(PL_compcv) ?
6254 PL_defgv : gv_fetchpv("ARGV", TRUE, SVt_PVAV))));
6d4ff0d2
MB		 6255#endif /* USE_THREADS */
6256 return newUNOP(type, 0, scalar(argop));
79072805 6257 }
11343788 6258 return scalar(modkids(ck_fun(o), type));
79072805
LW		 6259}
6260
6261OP *
cea2e8a9 6262Perl_ck_sort(pTHX_ OP *o)
79072805 6263{
8e3f9bdf 6264 OP *firstkid;
bbce6d69 6265
9ea6e965 6266 if (o->op_type == OP_SORT && o->op_flags & OPf_STACKED)
51a19bc0 6267 simplify_sort(o);
8e3f9bdf
GS		 6268 firstkid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6269 if (o->op_flags & OPf_STACKED) { /* may have been cleared */
9c5ffd7c 6270 OP *k = NULL;
8e3f9bdf 6271 OP *kid = cUNOPx(firstkid)->op_first; /* get past null */
79072805 6272
463ee0b2 6273 if (kid->op_type == OP_SCOPE || kid->op_type == OP_LEAVE) {
79072805 6274 linklist(kid);
463ee0b2
LW		 6275 if (kid->op_type == OP_SCOPE) {
6276 k = kid->op_next;
6277 kid->op_next = 0;
79072805 6278 }
463ee0b2 6279 else if (kid->op_type == OP_LEAVE) {
11343788 6280 if (o->op_type == OP_SORT) {
93c66552 6281 op_null(kid); /* wipe out leave */
748a9306 6282 kid->op_next = kid;
463ee0b2 6283
748a9306
LW		 6284 for (k = kLISTOP->op_first->op_next; k; k = k->op_next) {
6285 if (k->op_next == kid)
6286 k->op_next = 0;
71a29c3c
GS		 6287 /* don't descend into loops */
6288 else if (k->op_type == OP_ENTERLOOP
6289 || k->op_type == OP_ENTERITER)
6290 {
6291 k = cLOOPx(k)->op_lastop;
6292 }
748a9306 6293 }
463ee0b2 6294 }
748a9306
LW		 6295 else
6296 kid->op_next = 0; /* just disconnect the leave */
a0d0e21e 6297 k = kLISTOP->op_first;
463ee0b2 6298 }
a0d0e21e
LW		 6299 peep(k);
6300
8e3f9bdf
GS		 6301 kid = firstkid;
6302 if (o->op_type == OP_SORT) {
6303 /* provide scalar context for comparison function/block */
6304 kid = scalar(kid);
a0d0e21e 6305 kid->op_next = kid;
8e3f9bdf 6306 }
a0d0e21e
LW		 6307 else
6308 kid->op_next = k;
11343788 6309 o->op_flags |= OPf_SPECIAL;
79072805 6310 }
c6e96bcb 6311 else if (kid->op_type == OP_RV2SV || kid->op_type == OP_PADSV)
93c66552 6312 op_null(firstkid);
8e3f9bdf
GS		 6313
6314 firstkid = firstkid->op_sibling;
79072805 6315 }
bbce6d69 6316
8e3f9bdf
GS		 6317 /* provide list context for arguments */
6318 if (o->op_type == OP_SORT)
6319 list(firstkid);
6320
11343788 6321 return o;
79072805 6322}
bda4119b
GS		 6323
6324STATIC void
cea2e8a9 6325S_simplify_sort(pTHX_ OP *o)
9c007264
JH		 6326{
6327 register OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6328 OP *k;
6329 int reversed;
350de78d 6330 GV *gv;
9c007264
JH		 6331 if (!(o->op_flags & OPf_STACKED))
6332 return;
1c846c1f
NIS		 6333 GvMULTI_on(gv_fetchpv("a", TRUE, SVt_PV));
6334 GvMULTI_on(gv_fetchpv("b", TRUE, SVt_PV));
82092f1d 6335 kid = kUNOP->op_first; /* get past null */
9c007264
JH		 6336 if (kid->op_type != OP_SCOPE)
6337 return;
6338 kid = kLISTOP->op_last; /* get past scope */
6339 switch(kid->op_type) {
6340 case OP_NCMP:
6341 case OP_I_NCMP:
6342 case OP_SCMP:
6343 break;
6344 default:
6345 return;
6346 }
6347 k = kid; /* remember this node*/
6348 if (kBINOP->op_first->op_type != OP_RV2SV)
6349 return;
6350 kid = kBINOP->op_first; /* get past cmp */
6351 if (kUNOP->op_first->op_type != OP_GV)
6352 return;
6353 kid = kUNOP->op_first; /* get past rv2sv */
638eceb6 6354 gv = kGVOP_gv;
350de78d 6355 if (GvSTASH(gv) != PL_curstash)
9c007264 6356 return;
350de78d 6357 if (strEQ(GvNAME(gv), "a"))
9c007264 6358 reversed = 0;
0f79a09d 6359 else if (strEQ(GvNAME(gv), "b"))
9c007264
JH		 6360 reversed = 1;
6361 else
6362 return;
6363 kid = k; /* back to cmp */
6364 if (kBINOP->op_last->op_type != OP_RV2SV)
6365 return;
6366 kid = kBINOP->op_last; /* down to 2nd arg */
6367 if (kUNOP->op_first->op_type != OP_GV)
6368 return;
6369 kid = kUNOP->op_first; /* get past rv2sv */
638eceb6 6370 gv = kGVOP_gv;
350de78d 6371 if (GvSTASH(gv) != PL_curstash
9c007264 6372 || ( reversed
350de78d
GS		 6373 ? strNE(GvNAME(gv), "a")
6374 : strNE(GvNAME(gv), "b")))
9c007264
JH		 6375 return;
6376 o->op_flags &= ~(OPf_STACKED | OPf_SPECIAL);
6377 if (reversed)
6378 o->op_private |= OPpSORT_REVERSE;
6379 if (k->op_type == OP_NCMP)
6380 o->op_private |= OPpSORT_NUMERIC;
6381 if (k->op_type == OP_I_NCMP)
6382 o->op_private |= OPpSORT_NUMERIC | OPpSORT_INTEGER;
e507f050
SM		 6383 kid = cLISTOPo->op_first->op_sibling;
6384 cLISTOPo->op_first->op_sibling = kid->op_sibling; /* bypass old block */
6385 op_free(kid); /* then delete it */
9c007264 6386}
79072805
LW		 6387
6388OP *
cea2e8a9 6389Perl_ck_split(pTHX_ OP *o)
79072805
LW		 6390{
6391 register OP *kid;
aeea060c 6392
11343788
MB		 6393 if (o->op_flags & OPf_STACKED)
6394 return no_fh_allowed(o);
79072805 6395
11343788 6396 kid = cLISTOPo->op_first;
8990e307 6397 if (kid->op_type != OP_NULL)
cea2e8a9 6398 Perl_croak(aTHX_ "panic: ck_split");
8990e307 6399 kid = kid->op_sibling;
11343788
MB		 6400 op_free(cLISTOPo->op_first);
6401 cLISTOPo->op_first = kid;
85e6fe83 6402 if (!kid) {
79cb57f6 6403 cLISTOPo->op_first = kid = newSVOP(OP_CONST, 0, newSVpvn(" ", 1));
11343788 6404 cLISTOPo->op_last = kid; /* There was only one element previously */
85e6fe83 6405 }
79072805 6406
de4bf5b3 6407 if (kid->op_type != OP_MATCH || kid->op_flags & OPf_STACKED) {
79072805 6408 OP *sibl = kid->op_sibling;
463ee0b2 6409 kid->op_sibling = 0;
79072805 6410 kid = pmruntime( newPMOP(OP_MATCH, OPf_SPECIAL), kid, Nullop);
11343788
MB		 6411 if (cLISTOPo->op_first == cLISTOPo->op_last)
6412 cLISTOPo->op_last = kid;
6413 cLISTOPo->op_first = kid;
79072805
LW		 6414 kid->op_sibling = sibl;
6415 }
6416
6417 kid->op_type = OP_PUSHRE;
22c35a8c 6418 kid->op_ppaddr = PL_ppaddr[OP_PUSHRE];
79072805
LW		 6419 scalar(kid);
6420
6421 if (!kid->op_sibling)
54b9620d 6422 append_elem(OP_SPLIT, o, newDEFSVOP());
79072805
LW		 6423
6424 kid = kid->op_sibling;
6425 scalar(kid);
6426
6427 if (!kid->op_sibling)
11343788 6428 append_elem(OP_SPLIT, o, newSVOP(OP_CONST, 0, newSViv(0)));
79072805
LW		 6429
6430 kid = kid->op_sibling;
6431 scalar(kid);
6432
6433 if (kid->op_sibling)
22c35a8c 6434 return too_many_arguments(o,PL_op_desc[o->op_type]);
79072805 6435
11343788 6436 return o;
79072805
LW		 6437}
6438
6439OP *
1c846c1f 6440Perl_ck_join(pTHX_ OP *o)
eb6e2d6f
GS		 6441{
6442 if (ckWARN(WARN_SYNTAX)) {
6443 OP *kid = cLISTOPo->op_first->op_sibling;
6444 if (kid && kid->op_type == OP_MATCH) {
6445 char *pmstr = "STRING";
6446 if (kPMOP->op_pmregexp)
6447 pmstr = kPMOP->op_pmregexp->precomp;
6448 Perl_warner(aTHX_ WARN_SYNTAX,
6449 "/%s/ should probably be written as \"%s\"",
6450 pmstr, pmstr);
6451 }
6452 }
6453 return ck_fun(o);
6454}
6455
6456OP *
cea2e8a9 6457Perl_ck_subr(pTHX_ OP *o)
79072805 6458{
11343788
MB		 6459 OP *prev = ((cUNOPo->op_first->op_sibling)
6460 ? cUNOPo : ((UNOP*)cUNOPo->op_first))->op_first;
6461 OP *o2 = prev->op_sibling;
4633a7c4
LW		 6462 OP *cvop;
6463 char *proto = 0;
6464 CV *cv = 0;
46fc3d4c 6465 GV *namegv = 0;
4633a7c4
LW		 6466 int optional = 0;
6467 I32 arg = 0;
2d8e6c8d 6468 STRLEN n_a;
4633a7c4 6469
d3011074 6470 o->op_private |= OPpENTERSUB_HASTARG;
11343788 6471 for (cvop = o2; cvop->op_sibling; cvop = cvop->op_sibling) ;
4633a7c4
LW		 6472 if (cvop->op_type == OP_RV2CV) {
6473 SVOP* tmpop;
11343788 6474 o->op_private |= (cvop->op_private & OPpENTERSUB_AMPER);
93c66552 6475 op_null(cvop); /* disable rv2cv */
4633a7c4 6476 tmpop = (SVOP*)((UNOP*)cvop)->op_first;
76cd736e 6477 if (tmpop->op_type == OP_GV && !(o->op_private & OPpENTERSUB_AMPER)) {
638eceb6 6478 GV *gv = cGVOPx_gv(tmpop);
350de78d 6479 cv = GvCVu(gv);
76cd736e
GS		 6480 if (!cv)
6481 tmpop->op_private |= OPpEARLY_CV;
6482 else if (SvPOK(cv)) {
350de78d 6483 namegv = CvANON(cv) ? gv : CvGV(cv);
2d8e6c8d 6484 proto = SvPV((SV*)cv, n_a);
46fc3d4c 6485 }
4633a7c4
LW		 6486 }
6487 }
f5d5a27c 6488 else if (cvop->op_type == OP_METHOD || cvop->op_type == OP_METHOD_NAMED) {
7a52d87a
GS		 6489 if (o2->op_type == OP_CONST)
6490 o2->op_private &= ~OPpCONST_STRICT;
58a40671
GS		 6491 else if (o2->op_type == OP_LIST) {
6492 OP *o = ((UNOP*)o2)->op_first->op_sibling;
6493 if (o && o->op_type == OP_CONST)
6494 o->op_private &= ~OPpCONST_STRICT;
6495 }
7a52d87a 6496 }
3280af22
NIS		 6497 o->op_private |= (PL_hints & HINT_STRICT_REFS);
6498 if (PERLDB_SUB && PL_curstash != PL_debstash)
11343788
MB		 6499 o->op_private |= OPpENTERSUB_DB;
6500 while (o2 != cvop) {
4633a7c4
LW		 6501 if (proto) {
6502 switch (*proto) {
6503 case '\0':
5dc0d613 6504 return too_many_arguments(o, gv_ename(namegv));
4633a7c4
LW		 6505 case ';':
6506 optional = 1;
6507 proto++;
6508 continue;
6509 case '$':
6510 proto++;
6511 arg++;
11343788 6512 scalar(o2);
4633a7c4
LW		 6513 break;
6514 case '%':
6515 case '@':
11343788 6516 list(o2);
4633a7c4
LW		 6517 arg++;
6518 break;
6519 case '&':
6520 proto++;
6521 arg++;
11343788 6522 if (o2->op_type != OP_REFGEN && o2->op_type != OP_UNDEF)
75fc29ea
GS		 6523 bad_type(arg,
6524 arg == 1 ? "block or sub {}" : "sub {}",
6525 gv_ename(namegv), o2);
4633a7c4
LW		 6526 break;
6527 case '*':
2ba6ecf4 6528 /* '*' allows any scalar type, including bareword */
4633a7c4
LW		 6529 proto++;
6530 arg++;
11343788 6531 if (o2->op_type == OP_RV2GV)
2ba6ecf4 6532 goto wrapref; /* autoconvert GLOB -> GLOBref */
7a52d87a
GS		 6533 else if (o2->op_type == OP_CONST)
6534 o2->op_private &= ~OPpCONST_STRICT;
9675f7ac
GS		 6535 else if (o2->op_type == OP_ENTERSUB) {
6536 /* accidental subroutine, revert to bareword */
6537 OP *gvop = ((UNOP*)o2)->op_first;
6538 if (gvop && gvop->op_type == OP_NULL) {
6539 gvop = ((UNOP*)gvop)->op_first;
6540 if (gvop) {
6541 for (; gvop->op_sibling; gvop = gvop->op_sibling)
6542 ;
6543 if (gvop &&
6544 (gvop->op_private & OPpENTERSUB_NOPAREN) &&
6545 (gvop = ((UNOP*)gvop)->op_first) &&
6546 gvop->op_type == OP_GV)
6547 {
638eceb6 6548 GV *gv = cGVOPx_gv(gvop);
9675f7ac 6549 OP *sibling = o2->op_sibling;
2692f720 6550 SV *n = newSVpvn("",0);
9675f7ac 6551 op_free(o2);
2692f720
GS		 6552 gv_fullname3(n, gv, "");
6553 if (SvCUR(n)>6 && strnEQ(SvPVX(n),"main::",6))
6554 sv_chop(n, SvPVX(n)+6);
6555 o2 = newSVOP(OP_CONST, 0, n);
9675f7ac
GS		 6556 prev->op_sibling = o2;
6557 o2->op_sibling = sibling;
6558 }
6559 }
6560 }
6561 }
2ba6ecf4
GS		 6562 scalar(o2);
6563 break;
4633a7c4
LW		 6564 case '\\':
6565 proto++;
6566 arg++;
6567 switch (*proto++) {
6568 case '*':
11343788 6569 if (o2->op_type != OP_RV2GV)
5dc0d613 6570 bad_type(arg, "symbol", gv_ename(namegv), o2);
4633a7c4
LW		 6571 goto wrapref;
6572 case '&':
75fc29ea
GS		 6573 if (o2->op_type != OP_ENTERSUB)
6574 bad_type(arg, "subroutine entry", gv_ename(namegv), o2);
4633a7c4
LW		 6575 goto wrapref;
6576 case '$':
386acf99
GS		 6577 if (o2->op_type != OP_RV2SV
6578 && o2->op_type != OP_PADSV
1c01eb51
GS		 6579 && o2->op_type != OP_HELEM
6580 && o2->op_type != OP_AELEM
386acf99
GS		 6581 && o2->op_type != OP_THREADSV)
6582 {
5dc0d613 6583 bad_type(arg, "scalar", gv_ename(namegv), o2);
386acf99 6584 }
4633a7c4
LW		 6585 goto wrapref;
6586 case '@':
11343788 6587 if (o2->op_type != OP_RV2AV && o2->op_type != OP_PADAV)
5dc0d613 6588 bad_type(arg, "array", gv_ename(namegv), o2);
4633a7c4
LW		 6589 goto wrapref;
6590 case '%':
11343788 6591 if (o2->op_type != OP_RV2HV && o2->op_type != OP_PADHV)
5dc0d613 6592 bad_type(arg, "hash", gv_ename(namegv), o2);
4633a7c4
LW		 6593 wrapref:
6594 {
11343788 6595 OP* kid = o2;
6fa846a0 6596 OP* sib = kid->op_sibling;
4633a7c4 6597 kid->op_sibling = 0;
6fa846a0
GS		 6598 o2 = newUNOP(OP_REFGEN, 0, kid);
6599 o2->op_sibling = sib;
e858de61 6600 prev->op_sibling = o2;
4633a7c4
LW		 6601 }
6602 break;
6603 default: goto oops;
6604 }
6605 break;
b1cb66bf 6606 case ' ':
6607 proto++;
6608 continue;
4633a7c4
LW		 6609 default:
6610 oops:
cea2e8a9 6611 Perl_croak(aTHX_ "Malformed prototype for %s: %s",
2d8e6c8d 6612 gv_ename(namegv), SvPV((SV*)cv, n_a));
4633a7c4
LW		 6613 }
6614 }
6615 else
11343788
MB		 6616 list(o2);
6617 mod(o2, OP_ENTERSUB);
6618 prev = o2;
6619 o2 = o2->op_sibling;
4633a7c4 6620 }
fb73857a 6621 if (proto && !optional &&
6622 (*proto && *proto != '@' && *proto != '%' && *proto != ';'))
5dc0d613 6623 return too_few_arguments(o, gv_ename(namegv));
11343788 6624 return o;
79072805
LW		 6625}
6626
6627OP *
cea2e8a9 6628Perl_ck_svconst(pTHX_ OP *o)
8990e307 6629{
11343788
MB		 6630 SvREADONLY_on(cSVOPo->op_sv);
6631 return o;
8990e307
LW		 6632}
6633
6634OP *
cea2e8a9 6635Perl_ck_trunc(pTHX_ OP *o)
79072805 6636{
11343788
MB		 6637 if (o->op_flags & OPf_KIDS) {
6638 SVOP *kid = (SVOP*)cUNOPo->op_first;
79072805 6639
a0d0e21e
LW		 6640 if (kid->op_type == OP_NULL)
6641 kid = (SVOP*)kid->op_sibling;
bb53490d
GS		 6642 if (kid && kid->op_type == OP_CONST &&
6643 (kid->op_private & OPpCONST_BARE))
6644 {
11343788 6645 o->op_flags |= OPf_SPECIAL;
bb53490d
GS		 6646 kid->op_private &= ~OPpCONST_STRICT;
6647 }
79072805 6648 }
11343788 6649 return ck_fun(o);
79072805
LW		 6650}
6651
35fba0d9
RG		 6652OP *
6653Perl_ck_substr(pTHX_ OP *o)
6654{
6655 o = ck_fun(o);
6656 if ((o->op_flags & OPf_KIDS) && o->op_private == 4) {
6657 OP *kid = cLISTOPo->op_first;
6658
6659 if (kid->op_type == OP_NULL)
6660 kid = kid->op_sibling;
6661 if (kid)
6662 kid->op_flags |= OPf_MOD;
6663
6664 }
6665 return o;
6666}
6667
463ee0b2
LW		 6668/* A peephole optimizer. We visit the ops in the order they're to execute. */
6669
79072805 6670void
864dbfa3 6671Perl_peep(pTHX_ register OP *o)
79072805
LW		 6672{
6673 register OP* oldop = 0;
2d8e6c8d
GS		 6674 STRLEN n_a;
6675
a0d0e21e 6676 if (!o || o->op_seq)
79072805 6677 return;
a0d0e21e 6678 ENTER;
462e5cf6 6679 SAVEOP();
7766f137 6680 SAVEVPTR(PL_curcop);
a0d0e21e
LW		 6681 for (; o; o = o->op_next) {
6682 if (o->op_seq)
6683 break;
3280af22
NIS		 6684 if (!PL_op_seqmax)
6685 PL_op_seqmax++;
533c011a 6686 PL_op = o;
a0d0e21e 6687 switch (o->op_type) {
acb36ea4 6688 case OP_SETSTATE:
a0d0e21e
LW		 6689 case OP_NEXTSTATE:
6690 case OP_DBSTATE:
3280af22
NIS		 6691 PL_curcop = ((COP*)o); /* for warnings */
6692 o->op_seq = PL_op_seqmax++;
a0d0e21e
LW		 6693 break;
6694
a0d0e21e 6695 case OP_CONST:
7a52d87a
GS		 6696 if (cSVOPo->op_private & OPpCONST_STRICT)
6697 no_bareword_allowed(o);
7766f137
GS		 6698#ifdef USE_ITHREADS
6699 /* Relocate sv to the pad for thread safety.
6700 * Despite being a "constant", the SV is written to,
6701 * for reference counts, sv_upgrade() etc. */
6702 if (cSVOP->op_sv) {
6703 PADOFFSET ix = pad_alloc(OP_CONST, SVs_PADTMP);
6a7129a1
GS		 6704 if (SvPADTMP(cSVOPo->op_sv)) {
6705 /* If op_sv is already a PADTMP then it is being used by
9a049f1c 6706 * some pad, so make a copy. */
6a7129a1
GS		 6707 sv_setsv(PL_curpad[ix],cSVOPo->op_sv);
6708 SvREADONLY_on(PL_curpad[ix]);
6709 SvREFCNT_dec(cSVOPo->op_sv);
6710 }
6711 else {
6712 SvREFCNT_dec(PL_curpad[ix]);
6713 SvPADTMP_on(cSVOPo->op_sv);
6714 PL_curpad[ix] = cSVOPo->op_sv;
9a049f1c
JT		 6715 /* XXX I don't know how this isn't readonly already. */
6716 SvREADONLY_on(PL_curpad[ix]);
6a7129a1 6717 }
7766f137
GS		 6718 cSVOPo->op_sv = Nullsv;
6719 o->op_targ = ix;
6720 }
6721#endif
07447971
GS		 6722 o->op_seq = PL_op_seqmax++;
6723 break;
6724
ed7ab888 6725 case OP_CONCAT:
b162f9ea
IZ		 6726 if (o->op_next && o->op_next->op_type == OP_STRINGIFY) {
6727 if (o->op_next->op_private & OPpTARGET_MY) {
69b47968 6728 if (o->op_flags & OPf_STACKED) /* chained concats */
b162f9ea 6729 goto ignore_optimization;
cd06dffe 6730 else {
07447971 6731 /* assert(PL_opargs[o->op_type] & OA_TARGLEX); */
b162f9ea 6732 o->op_targ = o->op_next->op_targ;
743e66e6 6733 o->op_next->op_targ = 0;
2c2d71f5 6734 o->op_private |= OPpTARGET_MY;
b162f9ea
IZ		 6735 }
6736 }
93c66552 6737 op_null(o->op_next);
b162f9ea
IZ		 6738 }
6739 ignore_optimization:
3280af22 6740 o->op_seq = PL_op_seqmax++;
a0d0e21e 6741 break;
8990e307 6742 case OP_STUB:
54310121 6743 if ((o->op_flags & OPf_WANT) != OPf_WANT_LIST) {
3280af22 6744 o->op_seq = PL_op_seqmax++;
54310121 6745 break; /* Scalar stub must produce undef. List stub is noop */
8990e307 6746 }
748a9306 6747 goto nothin;
79072805 6748 case OP_NULL:
acb36ea4
GS		 6749 if (o->op_targ == OP_NEXTSTATE
6750 || o->op_targ == OP_DBSTATE
6751 || o->op_targ == OP_SETSTATE)
6752 {
3280af22 6753 PL_curcop = ((COP*)o);
acb36ea4 6754 }
748a9306 6755 goto nothin;
79072805 6756 case OP_SCALAR:
93a17b20 6757 case OP_LINESEQ:
463ee0b2 6758 case OP_SCOPE:
748a9306 6759 nothin:
a0d0e21e
LW		 6760 if (oldop && o->op_next) {
6761 oldop->op_next = o->op_next;
79072805
LW		 6762 continue;
6763 }
3280af22 6764 o->op_seq = PL_op_seqmax++;
79072805
LW		 6765 break;
6766
6767 case OP_GV:
a0d0e21e 6768 if (o->op_next->op_type == OP_RV2SV) {
64aac5a9 6769 if (!(o->op_next->op_private & OPpDEREF)) {
93c66552 6770 op_null(o->op_next);
64aac5a9
GS		 6771 o->op_private |= o->op_next->op_private & (OPpLVAL_INTRO
6772 | OPpOUR_INTRO);
a0d0e21e
LW		 6773 o->op_next = o->op_next->op_next;
6774 o->op_type = OP_GVSV;
22c35a8c 6775 o->op_ppaddr = PL_ppaddr[OP_GVSV];
8990e307
LW		 6776 }
6777 }
a0d0e21e
LW		 6778 else if (o->op_next->op_type == OP_RV2AV) {
6779 OP* pop = o->op_next->op_next;
6780 IV i;
8990e307 6781 if (pop->op_type == OP_CONST &&
533c011a 6782 (PL_op = pop->op_next) &&
8990e307 6783 pop->op_next->op_type == OP_AELEM &&
a0d0e21e 6784 !(pop->op_next->op_private &
78f9721b 6785 (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB)) &&
b0840a2a 6786 (i = SvIV(((SVOP*)pop)->op_sv) - PL_curcop->cop_arybase)
a0d0e21e 6787 <= 255 &&
8990e307
LW		 6788 i >= 0)
6789 {
350de78d 6790 GV *gv;
93c66552
DM		 6791 op_null(o->op_next);
6792 op_null(pop->op_next);
6793 op_null(pop);
a0d0e21e
LW		 6794 o->op_flags |= pop->op_next->op_flags & OPf_MOD;
6795 o->op_next = pop->op_next->op_next;
6796 o->op_type = OP_AELEMFAST;
22c35a8c 6797 o->op_ppaddr = PL_ppaddr[OP_AELEMFAST];
a0d0e21e 6798 o->op_private = (U8)i;
638eceb6 6799 gv = cGVOPo_gv;
350de78d 6800 GvAVn(gv);
8990e307 6801 }
79072805 6802 }
e476b1b5 6803 else if ((o->op_private & OPpEARLY_CV) && ckWARN(WARN_PROTOTYPE)) {
638eceb6 6804 GV *gv = cGVOPo_gv;
76cd736e
GS		 6805 if (SvTYPE(gv) == SVt_PVGV && GvCV(gv) && SvPVX(GvCV(gv))) {
6806 /* XXX could check prototype here instead of just carping */
6807 SV *sv = sv_newmortal();
6808 gv_efullname3(sv, gv, Nullch);
e476b1b5 6809 Perl_warner(aTHX_ WARN_PROTOTYPE,
76cd736e
GS		 6810 "%s() called too early to check prototype",
6811 SvPV_nolen(sv));
6812 }
6813 }
6814
3280af22 6815 o->op_seq = PL_op_seqmax++;
79072805
LW		 6816 break;
6817
a0d0e21e 6818 case OP_MAPWHILE:
79072805
LW		 6819 case OP_GREPWHILE:
6820 case OP_AND:
6821 case OP_OR:
2c2d71f5
JH		 6822 case OP_ANDASSIGN:
6823 case OP_ORASSIGN:
1a67a97c
SM		 6824 case OP_COND_EXPR:
6825 case OP_RANGE:
3280af22 6826 o->op_seq = PL_op_seqmax++;
fd4d1407
IZ		 6827 while (cLOGOP->op_other->op_type == OP_NULL)
6828 cLOGOP->op_other = cLOGOP->op_other->op_next;
79072805
LW		 6829 peep(cLOGOP->op_other);
6830 break;
6831
79072805 6832 case OP_ENTERLOOP:
9c2ca71a 6833 case OP_ENTERITER:
3280af22 6834 o->op_seq = PL_op_seqmax++;
58cccf98
SM		 6835 while (cLOOP->op_redoop->op_type == OP_NULL)
6836 cLOOP->op_redoop = cLOOP->op_redoop->op_next;
79072805 6837 peep(cLOOP->op_redoop);
58cccf98
SM		 6838 while (cLOOP->op_nextop->op_type == OP_NULL)
6839 cLOOP->op_nextop = cLOOP->op_nextop->op_next;
79072805 6840 peep(cLOOP->op_nextop);
58cccf98
SM		 6841 while (cLOOP->op_lastop->op_type == OP_NULL)
6842 cLOOP->op_lastop = cLOOP->op_lastop->op_next;
79072805
LW		 6843 peep(cLOOP->op_lastop);
6844 break;
6845
8782bef2 6846 case OP_QR:
79072805
LW		 6847 case OP_MATCH:
6848 case OP_SUBST:
3280af22 6849 o->op_seq = PL_op_seqmax++;
9041c2e3 6850 while (cPMOP->op_pmreplstart &&
58cccf98
SM		 6851 cPMOP->op_pmreplstart->op_type == OP_NULL)
6852 cPMOP->op_pmreplstart = cPMOP->op_pmreplstart->op_next;
a0d0e21e 6853 peep(cPMOP->op_pmreplstart);
79072805
LW		 6854 break;
6855
a0d0e21e 6856 case OP_EXEC:
3280af22 6857 o->op_seq = PL_op_seqmax++;
1c846c1f 6858 if (ckWARN(WARN_SYNTAX) && o->op_next
599cee73 6859 && o->op_next->op_type == OP_NEXTSTATE) {
a0d0e21e 6860 if (o->op_next->op_sibling &&
20408e3c
GS		 6861 o->op_next->op_sibling->op_type != OP_EXIT &&
6862 o->op_next->op_sibling->op_type != OP_WARN &&
a0d0e21e 6863 o->op_next->op_sibling->op_type != OP_DIE) {
57843af0 6864 line_t oldline = CopLINE(PL_curcop);
a0d0e21e 6865
57843af0 6866 CopLINE_set(PL_curcop, CopLINE((COP*)o->op_next));
eeb6a2c9
GS		 6867 Perl_warner(aTHX_ WARN_EXEC,
6868 "Statement unlikely to be reached");
6869 Perl_warner(aTHX_ WARN_EXEC,
cc507455 6870 "\t(Maybe you meant system() when you said exec()?)\n");
57843af0 6871 CopLINE_set(PL_curcop, oldline);
a0d0e21e
LW		 6872 }
6873 }
6874 break;
aeea060c 6875
c750a3ec
MB		 6876 case OP_HELEM: {
6877 UNOP *rop;
6878 SV *lexname;
6879 GV **fields;
9615e741 6880 SV **svp, **indsvp, *sv;
c750a3ec 6881 I32 ind;
1c846c1f 6882 char *key = NULL;
c750a3ec 6883 STRLEN keylen;
aeea060c 6884
9615e741 6885 o->op_seq = PL_op_seqmax++;
1c846c1f
NIS		 6886
6887 if (((BINOP*)o)->op_last->op_type != OP_CONST)
c750a3ec 6888 break;
1c846c1f
NIS		 6889
6890 /* Make the CONST have a shared SV */
6891 svp = cSVOPx_svp(((BINOP*)o)->op_last);
3049cdab 6892 if ((!SvFAKE(sv = *svp) || !SvREADONLY(sv)) && !IS_PADCONST(sv)) {
1c846c1f 6893 key = SvPV(sv, keylen);
8fed10cd 6894 if (SvUTF8(sv))
c3654f1a
IH		 6895 keylen = -keylen;
6896 lexname = newSVpvn_share(key, keylen, 0);
1c846c1f
NIS		 6897 SvREFCNT_dec(sv);
6898 *svp = lexname;
6899 }
6900
6901 if ((o->op_private & (OPpLVAL_INTRO)))
6902 break;
6903
c750a3ec
MB		 6904 rop = (UNOP*)((BINOP*)o)->op_first;
6905 if (rop->op_type != OP_RV2HV || rop->op_first->op_type != OP_PADSV)
6906 break;
3280af22 6907 lexname = *av_fetch(PL_comppad_name, rop->op_first->op_targ, TRUE);
524189f1 6908 if (!(SvFLAGS(lexname) & SVpad_TYPED))
c750a3ec 6909 break;
5196be3e 6910 fields = (GV**)hv_fetch(SvSTASH(lexname), "FIELDS", 6, FALSE);
c750a3ec
MB		 6911 if (!fields || !GvHV(*fields))
6912 break;
c750a3ec 6913 key = SvPV(*svp, keylen);
1aa99e6b
IH		 6914 if (SvUTF8(*svp))
6915 keylen = -keylen;
c750a3ec
MB		 6916 indsvp = hv_fetch(GvHV(*fields), key, keylen, FALSE);
6917 if (!indsvp) {
88e9b055 6918 Perl_croak(aTHX_ "No such pseudo-hash field \"%s\" in variable %s of type %s",
2d8e6c8d 6919 key, SvPV(lexname, n_a), HvNAME(SvSTASH(lexname)));
c750a3ec
MB		 6920 }
6921 ind = SvIV(*indsvp);
6922 if (ind < 1)
cea2e8a9 6923 Perl_croak(aTHX_ "Bad index while coercing array into hash");
c750a3ec 6924 rop->op_type = OP_RV2AV;
22c35a8c 6925 rop->op_ppaddr = PL_ppaddr[OP_RV2AV];
c750a3ec 6926 o->op_type = OP_AELEM;
22c35a8c 6927 o->op_ppaddr = PL_ppaddr[OP_AELEM];
9615e741
GS		 6928 sv = newSViv(ind);
6929 if (SvREADONLY(*svp))
6930 SvREADONLY_on(sv);
6931 SvFLAGS(sv) |= (SvFLAGS(*svp)
6932 & (SVs_PADBUSY|SVs_PADTMP|SVs_PADMY));
c750a3ec 6933 SvREFCNT_dec(*svp);
9615e741 6934 *svp = sv;
c750a3ec
MB		 6935 break;
6936 }
345599ca
GS		 6937
6938 case OP_HSLICE: {
6939 UNOP *rop;
6940 SV *lexname;
6941 GV **fields;
9615e741 6942 SV **svp, **indsvp, *sv;
345599ca
GS		 6943 I32 ind;
6944 char *key;
6945 STRLEN keylen;
6946 SVOP *first_key_op, *key_op;
9615e741
GS		 6947
6948 o->op_seq = PL_op_seqmax++;
345599ca
GS		 6949 if ((o->op_private & (OPpLVAL_INTRO))
6950 /* I bet there's always a pushmark... */
6951 || ((LISTOP*)o)->op_first->op_sibling->op_type != OP_LIST)
6952 /* hmmm, no optimization if list contains only one key. */
6953 break;
6954 rop = (UNOP*)((LISTOP*)o)->op_last;
6955 if (rop->op_type != OP_RV2HV || rop->op_first->op_type != OP_PADSV)
6956 break;
6957 lexname = *av_fetch(PL_comppad_name, rop->op_first->op_targ, TRUE);
524189f1 6958 if (!(SvFLAGS(lexname) & SVpad_TYPED))
345599ca
GS		 6959 break;
6960 fields = (GV**)hv_fetch(SvSTASH(lexname), "FIELDS", 6, FALSE);
6961 if (!fields || !GvHV(*fields))
6962 break;
6963 /* Again guessing that the pushmark can be jumped over.... */
6964 first_key_op = (SVOP*)((LISTOP*)((LISTOP*)o)->op_first->op_sibling)
6965 ->op_first->op_sibling;
6966 /* Check that the key list contains only constants. */
6967 for (key_op = first_key_op; key_op;
6968 key_op = (SVOP*)key_op->op_sibling)
6969 if (key_op->op_type != OP_CONST)
6970 break;
6971 if (key_op)
6972 break;
6973 rop->op_type = OP_RV2AV;
6974 rop->op_ppaddr = PL_ppaddr[OP_RV2AV];
6975 o->op_type = OP_ASLICE;
6976 o->op_ppaddr = PL_ppaddr[OP_ASLICE];
6977 for (key_op = first_key_op; key_op;
6978 key_op = (SVOP*)key_op->op_sibling) {
6979 svp = cSVOPx_svp(key_op);
6980 key = SvPV(*svp, keylen);
1aa99e6b
IH		 6981 if (SvUTF8(*svp))
6982 keylen = -keylen;
345599ca
GS		 6983 indsvp = hv_fetch(GvHV(*fields), key, keylen, FALSE);
6984 if (!indsvp) {
9615e741
GS		 6985 Perl_croak(aTHX_ "No such pseudo-hash field \"%s\" "
6986 "in variable %s of type %s",
345599ca
GS		 6987 key, SvPV(lexname, n_a), HvNAME(SvSTASH(lexname)));
6988 }
6989 ind = SvIV(*indsvp);
6990 if (ind < 1)
6991 Perl_croak(aTHX_ "Bad index while coercing array into hash");
9615e741
GS		 6992 sv = newSViv(ind);
6993 if (SvREADONLY(*svp))
6994 SvREADONLY_on(sv);
6995 SvFLAGS(sv) |= (SvFLAGS(*svp)
6996 & (SVs_PADBUSY|SVs_PADTMP|SVs_PADMY));
345599ca 6997 SvREFCNT_dec(*svp);
9615e741 6998 *svp = sv;
345599ca
GS		 6999 }
7000 break;
7001 }
c750a3ec 7002
79072805 7003 default:
3280af22 7004 o->op_seq = PL_op_seqmax++;
79072805
LW		 7005 break;
7006 }
a0d0e21e 7007 oldop = o;
79072805 7008 }
a0d0e21e 7009 LEAVE;
79072805 7010}
beab0874
JT		 7011
7012#include "XSUB.h"
7013
7014/* Efficient sub that returns a constant scalar value. */
7015static void
7016const_sv_xsub(pTHXo_ CV* cv)
7017{
7018 dXSARGS;
9cbac4c7
DM		 7019 if (items != 0) {
7020#if 0
7021 Perl_croak(aTHX_ "usage: %s::%s()",
7022 HvNAME(GvSTASH(CvGV(cv))), GvNAME(CvGV(cv)));
7023#endif
7024 }
9a049f1c 7025 EXTEND(sp, 1);
0768512c 7026 ST(0) = (SV*)XSANY.any_ptr;
beab0874
JT		 7027 XSRETURN(1);
7028}
2b9d42f0 7029
Unnamed repository; edit this file 'description' to name the repository.