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