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