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