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