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
Update Changes.
[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);
198 for (off = top; 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 &&
748a9306 311 seq <= SvIVX(sv) &&
13826f2c 312 seq > 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) ||
474 (seq <= SvIVX(sv) &&
475 seq > 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)
781 type = o->op_targ;
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;
e24b16f9 2313 PL_compiling.op_private = PL_hints;
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
11343788 2550 o->op_type = 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
LW		 2666
2667 listop->op_type = type;
22c35a8c 2668 listop->op_ppaddr = PL_ppaddr[type];
117dada2
SM		 2669 if (first || last)
2670 flags |= OPf_KIDS;
79072805 2671 listop->op_flags = 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);
11343788 2699 o->op_type = type;
22c35a8c 2700 o->op_ppaddr = PL_ppaddr[type];
11343788 2701 o->op_flags = flags;
79072805 2702
11343788
MB		 2703 o->op_next = o;
2704 o->op_private = 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);
79072805 2723 unop->op_type = type;
22c35a8c 2724 unop->op_ppaddr = PL_ppaddr[type];
79072805
LW		 2725 unop->op_first = first;
2726 unop->op_flags = flags | OPf_KIDS;
c07a80fd 2727 unop->op_private = 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
2744 binop->op_type = 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;
c07a80fd 2750 binop->op_private = 1 | (flags >> 8);
79072805
LW		 2751 }
2752 else {
c07a80fd 2753 binop->op_private = 2 | (flags >> 8);
79072805
LW		 2754 first->op_sibling = last;
2755 }
2756
e50aee73 2757 binop = (BINOP*)CHECKOP(type, binop);
b162f9ea 2758 if (binop->op_next || binop->op_type != 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);
3018 for (i = 0; i < tlen; i++)
ec49126f 3019 tbl[t[i]] = -1;
79072805
LW		 3020 for (i = 0, j = 0; i < 256; i++) {
3021 if (!tbl[i]) {
3022 if (j >= rlen) {
a0ed51b3 3023 if (del)
79072805
LW		 3024 tbl[i] = -2;
3025 else if (rlen)
ec49126f 3026 tbl[i] = r[j-1];
79072805
LW		 3027 else
3028 tbl[i] = i;
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 }
3043 else if (j >= rlen)
3044 j = rlen - 1;
3045 else
3046 cPVOPo->op_pv = (char*)Renew(tbl, 0x101+rlen-j, short);
8973db79
JH		 3047 tbl[0x100] = rlen - j;
3048 for (i=0; i < rlen - j; i++)
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;
3063 for (i = 0, j = 0; i < tlen; i++,j++) {
3064 if (j >= 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);
79072805 3093 pmop->op_type = type;
22c35a8c 3094 pmop->op_ppaddr = PL_ppaddr[type];
79072805 3095 pmop->op_flags = flags;
c07a80fd 3096 pmop->op_private = 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
GS		 3194 if (CopLINE(PL_curcop) < PL_multi_end)
3195 CopLINE_set(PL_curcop, 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);
79072805 3287 svop->op_type = type;
22c35a8c 3288 svop->op_ppaddr = PL_ppaddr[type];
79072805
LW		 3289 svop->op_sv = sv;
3290 svop->op_next = (OP*)svop;
3291 svop->op_flags = 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);
3304 padop->op_type = type;
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
GS		 3310 padop->op_next = (OP*)padop;
3311 padop->op_flags = flags;
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);
79072805 3335 pvop->op_type = type;
22c35a8c 3336 pvop->op_ppaddr = PL_ppaddr[type];
79072805
LW		 3337 pvop->op_pv = pv;
3338 pvop->op_next = (OP*)pvop;
3339 pvop->op_flags = 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;
18fc9488 3379 char *packname = Nullch;
c4e33207 3380 STRLEN packlen = 0;
18fc9488 3381 SV *packsv;
85e6fe83 3382
a0d0e21e 3383 if (id->op_type != OP_CONST)
cea2e8a9 3384 Perl_croak(aTHX_ "Module name must be constant");
85e6fe83 3385
b1cb66bf 3386 veop = Nullop;
3387
0f79a09d 3388 if (version != Nullop) {
b1cb66bf 3389 SV *vesv = ((SVOP*)version)->op_sv;
3390
44dcb63b 3391 if (arg == Nullop && !SvNIOKp(vesv)) {
b1cb66bf 3392 arg = version;
3393 }
3394 else {
3395 OP *pack;
0f79a09d 3396 SV *meth;
b1cb66bf 3397
44dcb63b 3398 if (version->op_type != OP_CONST || !SvNIOKp(vesv))
cea2e8a9 3399 Perl_croak(aTHX_ "Version number must be constant number");
b1cb66bf 3400
3401 /* Make copy of id so we don't free it twice */
3402 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)id)->op_sv));
3403
3404 /* Fake up a method call to VERSION */
0f79a09d
GS		 3405 meth = newSVpvn("VERSION",7);
3406 sv_upgrade(meth, SVt_PVIV);
155aba94 3407 (void)SvIOK_on(meth);
0f79a09d 3408 PERL_HASH(SvUVX(meth), SvPVX(meth), SvCUR(meth));
b1cb66bf 3409 veop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
3410 append_elem(OP_LIST,
0f79a09d
GS		 3411 prepend_elem(OP_LIST, pack, list(version)),
3412 newSVOP(OP_METHOD_NAMED, 0, meth)));
b1cb66bf 3413 }
3414 }
aeea060c 3415
a0d0e21e 3416 /* Fake up an import/unimport */
4633a7c4
LW		 3417 if (arg && arg->op_type == OP_STUB)
3418 imop = arg; /* no import on explicit () */
44dcb63b 3419 else if (SvNIOKp(((SVOP*)id)->op_sv)) {
b1cb66bf 3420 imop = Nullop; /* use 5.0; */
3421 }
4633a7c4 3422 else {
0f79a09d
GS		 3423 SV *meth;
3424
4633a7c4
LW		 3425 /* Make copy of id so we don't free it twice */
3426 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)id)->op_sv));
0f79a09d
GS		 3427
3428 /* Fake up a method call to import/unimport */
3429 meth = aver ? newSVpvn("import",6) : newSVpvn("unimport", 8);;
ad4c42df 3430 (void)SvUPGRADE(meth, SVt_PVIV);
155aba94 3431 (void)SvIOK_on(meth);
0f79a09d 3432 PERL_HASH(SvUVX(meth), SvPVX(meth), SvCUR(meth));
4633a7c4 3433 imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
0f79a09d
GS		 3434 append_elem(OP_LIST,
3435 prepend_elem(OP_LIST, pack, list(arg)),
3436 newSVOP(OP_METHOD_NAMED, 0, meth)));
4633a7c4
LW		 3437 }
3438
d04f2e46
DM		 3439 if (ckWARN(WARN_MISC) &&
3440 imop && (imop != arg) && /* no warning on use 5.0; or explicit () */
3441 SvPOK(packsv = ((SVOP*)id)->op_sv))
3442 {
18fc9488
DM		 3443 /* BEGIN will free the ops, so we need to make a copy */
3444 packlen = SvCUR(packsv);
3445 packname = savepvn(SvPVX(packsv), packlen);
3446 }
3447
a0d0e21e 3448 /* Fake up the BEGIN {}, which does its thing immediately. */
09bef843 3449 newATTRSUB(floor,
79cb57f6 3450 newSVOP(OP_CONST, 0, newSVpvn("BEGIN", 5)),
4633a7c4 3451 Nullop,
09bef843 3452 Nullop,
a0d0e21e 3453 append_elem(OP_LINESEQ,
b1cb66bf 3454 append_elem(OP_LINESEQ,
ec4ab249 3455 newSTATEOP(0, Nullch, newUNOP(OP_REQUIRE, 0, id)),
b1cb66bf 3456 newSTATEOP(0, Nullch, veop)),
a0d0e21e 3457 newSTATEOP(0, Nullch, imop) ));
85e6fe83 3458
18fc9488 3459 if (packname) {
bfc3ae4f
JH		 3460 /* The "did you use incorrect case?" warning used to be here.
3461 * The problem is that on case-insensitive filesystems one
3462 * might get false positives for "use" (and "require"):
3463 * "use Strict" or "require CARP" will work. This causes
3464 * portability problems for the script: in case-strict
3465 * filesystems the script will stop working.
3466 *
3467 * The "incorrect case" warning checked whether "use Foo"
3468 * imported "Foo" to your namespace, but that is wrong, too:
3469 * there is no requirement nor promise in the language that
3470 * a Foo.pm should or would contain anything in package "Foo".
3471 *
3472 * There is very little Configure-wise that can be done, either:
3473 * the case-sensitivity of the build filesystem of Perl does not
3474 * help in guessing the case-sensitivity of the runtime environment.
3475 */
18fc9488
DM		 3476 safefree(packname);
3477 }
3478
c305c6a0 3479 PL_hints |= HINT_BLOCK_SCOPE;
3280af22
NIS		 3480 PL_copline = NOLINE;
3481 PL_expect = XSTATE;
85e6fe83
LW		 3482}
3483
7d3fb230 3484/*
ccfc67b7
JH		 3485=head1 Embedding Functions
3486
7d3fb230
BS		 3487=for apidoc load_module
3488
3489Loads the module whose name is pointed to by the string part of name.
3490Note that the actual module name, not its filename, should be given.
3491Eg, "Foo::Bar" instead of "Foo/Bar.pm". flags can be any of
3492PERL_LOADMOD_DENY, PERL_LOADMOD_NOIMPORT, or PERL_LOADMOD_IMPORT_OPS
3493(or 0 for no flags). ver, if specified, provides version semantics
3494similar to C<use Foo::Bar VERSION>. The optional trailing SV*
3495arguments can be used to specify arguments to the module's import()
3496method, similar to C<use Foo::Bar VERSION LIST>.
3497
3498=cut */
3499
e4783991
GS		 3500void
3501Perl_load_module(pTHX_ U32 flags, SV *name, SV *ver, ...)
3502{
3503 va_list args;
3504 va_start(args, ver);
3505 vload_module(flags, name, ver, &args);
3506 va_end(args);
3507}
3508
3509#ifdef PERL_IMPLICIT_CONTEXT
3510void
3511Perl_load_module_nocontext(U32 flags, SV *name, SV *ver, ...)
3512{
3513 dTHX;
3514 va_list args;
3515 va_start(args, ver);
3516 vload_module(flags, name, ver, &args);
3517 va_end(args);
3518}
3519#endif
3520
3521void
3522Perl_vload_module(pTHX_ U32 flags, SV *name, SV *ver, va_list *args)
3523{
3524 OP *modname, *veop, *imop;
3525
3526 modname = newSVOP(OP_CONST, 0, name);
3527 modname->op_private |= OPpCONST_BARE;
3528 if (ver) {
3529 veop = newSVOP(OP_CONST, 0, ver);
3530 }
3531 else
3532 veop = Nullop;
3533 if (flags & PERL_LOADMOD_NOIMPORT) {
3534 imop = sawparens(newNULLLIST());
3535 }
3536 else if (flags & PERL_LOADMOD_IMPORT_OPS) {
3537 imop = va_arg(*args, OP*);
3538 }
3539 else {
3540 SV *sv;
3541 imop = Nullop;
3542 sv = va_arg(*args, SV*);
3543 while (sv) {
3544 imop = append_elem(OP_LIST, imop, newSVOP(OP_CONST, 0, sv));
3545 sv = va_arg(*args, SV*);
3546 }
3547 }
81885997
GS		 3548 {
3549 line_t ocopline = PL_copline;
3550 int oexpect = PL_expect;
3551
3552 utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(FALSE, 0),
3553 veop, modname, imop);
3554 PL_expect = oexpect;
3555 PL_copline = ocopline;
3556 }
e4783991
GS		 3557}
3558
79072805 3559OP *
864dbfa3 3560Perl_dofile(pTHX_ OP *term)
78ca652e
GS		 3561{
3562 OP *doop;
3563 GV *gv;
3564
3565 gv = gv_fetchpv("do", FALSE, SVt_PVCV);
b9f751c0 3566 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv)))
78ca652e
GS		 3567 gv = gv_fetchpv("CORE::GLOBAL::do", FALSE, SVt_PVCV);
3568
b9f751c0 3569 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
78ca652e
GS		 3570 doop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
3571 append_elem(OP_LIST, term,
3572 scalar(newUNOP(OP_RV2CV, 0,
3573 newGVOP(OP_GV, 0,
3574 gv))))));
3575 }
3576 else {
3577 doop = newUNOP(OP_DOFILE, 0, scalar(term));
3578 }
3579 return doop;
3580}
3581
3582OP *
864dbfa3 3583Perl_newSLICEOP(pTHX_ I32 flags, OP *subscript, OP *listval)
79072805
LW		 3584{
3585 return newBINOP(OP_LSLICE, flags,
8990e307
LW		 3586 list(force_list(subscript)),
3587 list(force_list(listval)) );
79072805
LW		 3588}
3589
76e3520e 3590STATIC I32
cea2e8a9 3591S_list_assignment(pTHX_ register OP *o)
79072805 3592{
11343788 3593 if (!o)
79072805
LW		 3594 return TRUE;
3595
11343788
MB		 3596 if (o->op_type == OP_NULL && o->op_flags & OPf_KIDS)
3597 o = cUNOPo->op_first;
79072805 3598
11343788 3599 if (o->op_type == OP_COND_EXPR) {
1a67a97c
SM		 3600 I32 t = list_assignment(cLOGOPo->op_first->op_sibling);
3601 I32 f = list_assignment(cLOGOPo->op_first->op_sibling->op_sibling);
79072805
LW		 3602
3603 if (t && f)
3604 return TRUE;
3605 if (t || f)
3606 yyerror("Assignment to both a list and a scalar");
3607 return FALSE;
3608 }
3609
95f0a2f1
SB		 3610 if (o->op_type == OP_LIST &&
3611 (o->op_flags & OPf_WANT) == OPf_WANT_SCALAR &&
3612 o->op_private & OPpLVAL_INTRO)
3613 return FALSE;
3614
11343788
MB		 3615 if (o->op_type == OP_LIST || o->op_flags & OPf_PARENS ||
3616 o->op_type == OP_RV2AV || o->op_type == OP_RV2HV ||
3617 o->op_type == OP_ASLICE || o->op_type == OP_HSLICE)
79072805
LW		 3618 return TRUE;
3619
11343788 3620 if (o->op_type == OP_PADAV || o->op_type == OP_PADHV)
93a17b20
LW		 3621 return TRUE;
3622
11343788 3623 if (o->op_type == OP_RV2SV)
79072805
LW		 3624 return FALSE;
3625
3626 return FALSE;
3627}
3628
3629OP *
864dbfa3 3630Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right)
79072805 3631{
11343788 3632 OP *o;
79072805 3633
a0d0e21e
LW		 3634 if (optype) {
3635 if (optype == OP_ANDASSIGN || optype == OP_ORASSIGN) {
3636 return newLOGOP(optype, 0,
3637 mod(scalar(left), optype),
3638 newUNOP(OP_SASSIGN, 0, scalar(right)));
3639 }
3640 else {
3641 return newBINOP(optype, OPf_STACKED,
3642 mod(scalar(left), optype), scalar(right));
3643 }
3644 }
3645
79072805 3646 if (list_assignment(left)) {
10c8fecd
GS		 3647 OP *curop;
3648
3280af22
NIS		 3649 PL_modcount = 0;
3650 PL_eval_start = right; /* Grandfathering $[ assignment here. Bletch.*/
463ee0b2 3651 left = mod(left, OP_AASSIGN);
3280af22
NIS		 3652 if (PL_eval_start)
3653 PL_eval_start = 0;
748a9306 3654 else {
a0d0e21e
LW		 3655 op_free(left);
3656 op_free(right);
3657 return Nullop;
3658 }
10c8fecd
GS		 3659 curop = list(force_list(left));
3660 o = newBINOP(OP_AASSIGN, flags, list(force_list(right)), curop);
11343788 3661 o->op_private = 0 | (flags >> 8);
10c8fecd
GS		 3662 for (curop = ((LISTOP*)curop)->op_first;
3663 curop; curop = curop->op_sibling)
3664 {
3665 if (curop->op_type == OP_RV2HV &&
3666 ((UNOP*)curop)->op_first->op_type != OP_GV) {
3667 o->op_private |= OPpASSIGN_HASH;
3668 break;
3669 }
3670 }
a0d0e21e 3671 if (!(left->op_private & OPpLVAL_INTRO)) {
11343788 3672 OP *lastop = o;
3280af22 3673 PL_generation++;
11343788 3674 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
22c35a8c 3675 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
79072805 3676 if (curop->op_type == OP_GV) {
638eceb6 3677 GV *gv = cGVOPx_gv(curop);
3280af22 3678 if (gv == PL_defgv || SvCUR(gv) == PL_generation)
79072805 3679 break;
3280af22 3680 SvCUR(gv) = PL_generation;
79072805 3681 }
748a9306
LW		 3682 else if (curop->op_type == OP_PADSV ||
3683 curop->op_type == OP_PADAV ||
3684 curop->op_type == OP_PADHV ||
3685 curop->op_type == OP_PADANY) {
3280af22 3686 SV **svp = AvARRAY(PL_comppad_name);
8e07c86e 3687 SV *sv = svp[curop->op_targ];
3280af22 3688 if (SvCUR(sv) == PL_generation)
748a9306 3689 break;
3280af22 3690 SvCUR(sv) = PL_generation; /* (SvCUR not used any more) */
748a9306 3691 }
79072805
LW		 3692 else if (curop->op_type == OP_RV2CV)
3693 break;
3694 else if (curop->op_type == OP_RV2SV ||
3695 curop->op_type == OP_RV2AV ||
3696 curop->op_type == OP_RV2HV ||
3697 curop->op_type == OP_RV2GV) {
3698 if (lastop->op_type != OP_GV) /* funny deref? */
3699 break;
3700 }
1167e5da
SM		 3701 else if (curop->op_type == OP_PUSHRE) {
3702 if (((PMOP*)curop)->op_pmreplroot) {
b3f5893f 3703#ifdef USE_ITHREADS
ba89bb6e 3704 GV *gv = (GV*)PL_curpad[INT2PTR(PADOFFSET,((PMOP*)curop)->op_pmreplroot)];
b3f5893f 3705#else
1167e5da 3706 GV *gv = (GV*)((PMOP*)curop)->op_pmreplroot;
b3f5893f 3707#endif
3280af22 3708 if (gv == PL_defgv || SvCUR(gv) == PL_generation)
1167e5da 3709 break;
3280af22 3710 SvCUR(gv) = PL_generation;
b2ffa427 3711 }
1167e5da 3712 }
79072805
LW		 3713 else
3714 break;
3715 }
3716 lastop = curop;
3717 }
11343788 3718 if (curop != o)
10c8fecd 3719 o->op_private |= OPpASSIGN_COMMON;
79072805 3720 }
c07a80fd 3721 if (right && right->op_type == OP_SPLIT) {
3722 OP* tmpop;
3723 if ((tmpop = ((LISTOP*)right)->op_first) &&
3724 tmpop->op_type == OP_PUSHRE)
3725 {
3726 PMOP *pm = (PMOP*)tmpop;
3727 if (left->op_type == OP_RV2AV &&
3728 !(left->op_private & OPpLVAL_INTRO) &&
11343788 3729 !(o->op_private & OPpASSIGN_COMMON) )
c07a80fd 3730 {
3731 tmpop = ((UNOP*)left)->op_first;
3732 if (tmpop->op_type == OP_GV && !pm->op_pmreplroot) {
971a9dd3 3733#ifdef USE_ITHREADS
ba89bb6e 3734 pm->op_pmreplroot = INT2PTR(OP*, cPADOPx(tmpop)->op_padix);
971a9dd3
GS		 3735 cPADOPx(tmpop)->op_padix = 0; /* steal it */
3736#else
3737 pm->op_pmreplroot = (OP*)cSVOPx(tmpop)->op_sv;
3738 cSVOPx(tmpop)->op_sv = Nullsv; /* steal it */
3739#endif
c07a80fd 3740 pm->op_pmflags |= PMf_ONCE;
11343788 3741 tmpop = cUNOPo->op_first; /* to list (nulled) */
c07a80fd 3742 tmpop = ((UNOP*)tmpop)->op_first; /* to pushmark */
3743 tmpop->op_sibling = Nullop; /* don't free split */
3744 right->op_next = tmpop->op_next; /* fix starting loc */
11343788 3745 op_free(o); /* blow off assign */
54310121 3746 right->op_flags &= ~OPf_WANT;
a5f75d66 3747 /* "I don't know and I don't care." */
c07a80fd 3748 return right;
3749 }
3750 }
3751 else {
e6438c1a 3752 if (PL_modcount < RETURN_UNLIMITED_NUMBER &&
c07a80fd 3753 ((LISTOP*)right)->op_last->op_type == OP_CONST)
3754 {
3755 SV *sv = ((SVOP*)((LISTOP*)right)->op_last)->op_sv;
3756 if (SvIVX(sv) == 0)
3280af22 3757 sv_setiv(sv, PL_modcount+1);
c07a80fd 3758 }
3759 }
3760 }
3761 }
11343788 3762 return o;
79072805
LW		 3763 }
3764 if (!right)
3765 right = newOP(OP_UNDEF, 0);
3766 if (right->op_type == OP_READLINE) {
3767 right->op_flags |= OPf_STACKED;
463ee0b2 3768 return newBINOP(OP_NULL, flags, mod(scalar(left), OP_SASSIGN), scalar(right));
79072805 3769 }
a0d0e21e 3770 else {
3280af22 3771 PL_eval_start = right; /* Grandfathering $[ assignment here. Bletch.*/
11343788 3772 o = newBINOP(OP_SASSIGN, flags,
463ee0b2 3773 scalar(right), mod(scalar(left), OP_SASSIGN) );
3280af22
NIS		 3774 if (PL_eval_start)
3775 PL_eval_start = 0;
748a9306 3776 else {
11343788 3777 op_free(o);
a0d0e21e
LW		 3778 return Nullop;
3779 }
3780 }
11343788 3781 return o;
79072805
LW		 3782}
3783
3784OP *
864dbfa3 3785Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o)
79072805 3786{
bbce6d69 3787 U32 seq = intro_my();
79072805
LW		 3788 register COP *cop;
3789
b7dc083c 3790 NewOp(1101, cop, 1, COP);
57843af0 3791 if (PERLDB_LINE && CopLINE(PL_curcop) && PL_curstash != PL_debstash) {
8990e307 3792 cop->op_type = OP_DBSTATE;
22c35a8c 3793 cop->op_ppaddr = PL_ppaddr[ OP_DBSTATE ];
8990e307
LW		 3794 }
3795 else {
3796 cop->op_type = OP_NEXTSTATE;
22c35a8c 3797 cop->op_ppaddr = PL_ppaddr[ OP_NEXTSTATE ];
8990e307 3798 }
79072805 3799 cop->op_flags = flags;
9d43a755 3800 cop->op_private = (PL_hints & HINT_PRIVATE_MASK);
ff0cee69 3801#ifdef NATIVE_HINTS
3802 cop->op_private |= NATIVE_HINTS;
3803#endif
e24b16f9 3804 PL_compiling.op_private = cop->op_private;
79072805
LW		 3805 cop->op_next = (OP*)cop;
3806
463ee0b2
LW		 3807 if (label) {
3808 cop->cop_label = label;
3280af22 3809 PL_hints |= HINT_BLOCK_SCOPE;
463ee0b2 3810 }
bbce6d69 3811 cop->cop_seq = seq;
3280af22 3812 cop->cop_arybase = PL_curcop->cop_arybase;
0453d815 3813 if (specialWARN(PL_curcop->cop_warnings))
599cee73 3814 cop->cop_warnings = PL_curcop->cop_warnings ;
1c846c1f 3815 else
599cee73 3816 cop->cop_warnings = newSVsv(PL_curcop->cop_warnings) ;
ac27b0f5
NIS		 3817 if (specialCopIO(PL_curcop->cop_io))
3818 cop->cop_io = PL_curcop->cop_io;
3819 else
3820 cop->cop_io = newSVsv(PL_curcop->cop_io) ;
599cee73 3821
79072805 3822
3280af22 3823 if (PL_copline == NOLINE)
57843af0 3824 CopLINE_set(cop, CopLINE(PL_curcop));
79072805 3825 else {
57843af0 3826 CopLINE_set(cop, PL_copline);
3280af22 3827 PL_copline = NOLINE;
79072805 3828 }
57843af0 3829#ifdef USE_ITHREADS
f4dd75d9 3830 CopFILE_set(cop, CopFILE(PL_curcop)); /* XXX share in a pvtable? */
57843af0 3831#else
f4dd75d9 3832 CopFILEGV_set(cop, CopFILEGV(PL_curcop));
57843af0 3833#endif
11faa288 3834 CopSTASH_set(cop, PL_curstash);
79072805 3835
3280af22 3836 if (PERLDB_LINE && PL_curstash != PL_debstash) {
cc49e20b 3837 SV **svp = av_fetch(CopFILEAV(PL_curcop), (I32)CopLINE(cop), FALSE);
1eb1540c 3838 if (svp && *svp != &PL_sv_undef ) {
0ac0412a 3839 (void)SvIOK_on(*svp);
57b2e452 3840 SvIVX(*svp) = PTR2IV(cop);
1eb1540c 3841 }
93a17b20
LW		 3842 }
3843
11343788 3844 return prepend_elem(OP_LINESEQ, (OP*)cop, o);
79072805
LW		 3845}
3846
bbce6d69 3847/* "Introduce" my variables to visible status. */
3848U32
864dbfa3 3849Perl_intro_my(pTHX)
bbce6d69 3850{
3851 SV **svp;
3852 SV *sv;
3853 I32 i;
3854
3280af22
NIS		 3855 if (! PL_min_intro_pending)
3856 return PL_cop_seqmax;
bbce6d69 3857
3280af22
NIS		 3858 svp = AvARRAY(PL_comppad_name);
3859 for (i = PL_min_intro_pending; i <= PL_max_intro_pending; i++) {
3860 if ((sv = svp[i]) && sv != &PL_sv_undef && !SvIVX(sv)) {
c53d7c7d 3861 SvIVX(sv) = PAD_MAX; /* Don't know scope end yet. */
65202027 3862 SvNVX(sv) = (NV)PL_cop_seqmax;
bbce6d69 3863 }
3864 }
3280af22
NIS		 3865 PL_min_intro_pending = 0;
3866 PL_comppad_name_fill = PL_max_intro_pending; /* Needn't search higher */
3867 return PL_cop_seqmax++;
bbce6d69 3868}
3869
79072805 3870OP *
864dbfa3 3871Perl_newLOGOP(pTHX_ I32 type, I32 flags, OP *first, OP *other)
79072805 3872{
883ffac3
CS		 3873 return new_logop(type, flags, &first, &other);
3874}
3875
3bd495df 3876STATIC OP *
cea2e8a9 3877S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp)
883ffac3 3878{
79072805 3879 LOGOP *logop;
11343788 3880 OP *o;
883ffac3
CS		 3881 OP *first = *firstp;
3882 OP *other = *otherp;
79072805 3883
a0d0e21e
LW		 3884 if (type == OP_XOR) /* Not short circuit, but here by precedence. */
3885 return newBINOP(type, flags, scalar(first), scalar(other));
3886
8990e307 3887 scalarboolean(first);
79072805
LW		 3888 /* optimize "!a && b" to "a || b", and "!a || b" to "a && b" */
3889 if (first->op_type == OP_NOT && (first->op_flags & OPf_SPECIAL)) {
3890 if (type == OP_AND || type == OP_OR) {
3891 if (type == OP_AND)
3892 type = OP_OR;
3893 else
3894 type = OP_AND;
11343788 3895 o = first;
883ffac3 3896 first = *firstp = cUNOPo->op_first;
11343788
MB		 3897 if (o->op_next)
3898 first->op_next = o->op_next;
3899 cUNOPo->op_first = Nullop;
3900 op_free(o);
79072805
LW		 3901 }
3902 }
3903 if (first->op_type == OP_CONST) {
4673fc70 3904 if (ckWARN(WARN_BAREWORD) && (first->op_private & OPpCONST_BARE))
9014280d 3905 Perl_warner(aTHX_ packWARN(WARN_BAREWORD), "Bareword found in conditional");
79072805
LW		 3906 if ((type == OP_AND) == (SvTRUE(((SVOP*)first)->op_sv))) {
3907 op_free(first);
883ffac3 3908 *firstp = Nullop;
79072805
LW		 3909 return other;
3910 }
3911 else {
3912 op_free(other);
883ffac3 3913 *otherp = Nullop;
79072805
LW		 3914 return first;
3915 }
3916 }
3917 else if (first->op_type == OP_WANTARRAY) {
3918 if (type == OP_AND)
3919 list(other);
3920 else
3921 scalar(other);
3922 }
e476b1b5 3923 else if (ckWARN(WARN_MISC) && (first->op_flags & OPf_KIDS)) {
a6006777 3924 OP *k1 = ((UNOP*)first)->op_first;
3925 OP *k2 = k1->op_sibling;
3926 OPCODE warnop = 0;
3927 switch (first->op_type)
3928 {
3929 case OP_NULL:
3930 if (k2 && k2->op_type == OP_READLINE
3931 && (k2->op_flags & OPf_STACKED)
1c846c1f 3932 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
72b16652 3933 {
a6006777 3934 warnop = k2->op_type;
72b16652 3935 }
a6006777 3936 break;
3937
3938 case OP_SASSIGN:
68dc0745 3939 if (k1->op_type == OP_READDIR
3940 || k1->op_type == OP_GLOB
72b16652 3941 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
68dc0745 3942 || k1->op_type == OP_EACH)
72b16652
GS		 3943 {
3944 warnop = ((k1->op_type == OP_NULL)
3945 ? k1->op_targ : k1->op_type);
3946 }
a6006777 3947 break;
3948 }
8ebc5c01 3949 if (warnop) {
57843af0
GS		 3950 line_t oldline = CopLINE(PL_curcop);
3951 CopLINE_set(PL_curcop, PL_copline);
9014280d 3952 Perl_warner(aTHX_ packWARN(WARN_MISC),
599cee73 3953 "Value of %s%s can be \"0\"; test with defined()",
22c35a8c 3954 PL_op_desc[warnop],
68dc0745 3955 ((warnop == OP_READLINE || warnop == OP_GLOB)
3956 ? " construct" : "() operator"));
57843af0 3957 CopLINE_set(PL_curcop, oldline);
8ebc5c01 3958 }
a6006777 3959 }
79072805
LW		 3960
3961 if (!other)
3962 return first;
3963
a0d0e21e
LW		 3964 if (type == OP_ANDASSIGN || type == OP_ORASSIGN)
3965 other->op_private |= OPpASSIGN_BACKWARDS; /* other is an OP_SASSIGN */
3966
b7dc083c 3967 NewOp(1101, logop, 1, LOGOP);
79072805
LW		 3968
3969 logop->op_type = type;
22c35a8c 3970 logop->op_ppaddr = PL_ppaddr[type];
79072805
LW		 3971 logop->op_first = first;
3972 logop->op_flags = flags | OPf_KIDS;
3973 logop->op_other = LINKLIST(other);
c07a80fd 3974 logop->op_private = 1 | (flags >> 8);
79072805
LW		 3975
3976 /* establish postfix order */
3977 logop->op_next = LINKLIST(first);
3978 first->op_next = (OP*)logop;
3979 first->op_sibling = other;
3980
11343788
MB		 3981 o = newUNOP(OP_NULL, 0, (OP*)logop);
3982 other->op_next = o;
79072805 3983
11343788 3984 return o;
79072805
LW		 3985}
3986
3987OP *
864dbfa3 3988Perl_newCONDOP(pTHX_ I32 flags, OP *first, OP *trueop, OP *falseop)
79072805 3989{
1a67a97c
SM		 3990 LOGOP *logop;
3991 OP *start;
11343788 3992 OP *o;
79072805 3993
b1cb66bf 3994 if (!falseop)
3995 return newLOGOP(OP_AND, 0, first, trueop);
3996 if (!trueop)
3997 return newLOGOP(OP_OR, 0, first, falseop);
79072805 3998
8990e307 3999 scalarboolean(first);
79072805
LW		 4000 if (first->op_type == OP_CONST) {
4001 if (SvTRUE(((SVOP*)first)->op_sv)) {
4002 op_free(first);
b1cb66bf 4003 op_free(falseop);
4004 return trueop;
79072805
LW		 4005 }
4006 else {
4007 op_free(first);
b1cb66bf 4008 op_free(trueop);
4009 return falseop;
79072805
LW		 4010 }
4011 }
4012 else if (first->op_type == OP_WANTARRAY) {
b1cb66bf 4013 list(trueop);
4014 scalar(falseop);
79072805 4015 }
1a67a97c
SM		 4016 NewOp(1101, logop, 1, LOGOP);
4017 logop->op_type = OP_COND_EXPR;
4018 logop->op_ppaddr = PL_ppaddr[OP_COND_EXPR];
4019 logop->op_first = first;
4020 logop->op_flags = flags | OPf_KIDS;
4021 logop->op_private = 1 | (flags >> 8);
4022 logop->op_other = LINKLIST(trueop);
4023 logop->op_next = LINKLIST(falseop);
79072805 4024
79072805
LW		 4025
4026 /* establish postfix order */
1a67a97c
SM		 4027 start = LINKLIST(first);
4028 first->op_next = (OP*)logop;
79072805 4029
b1cb66bf 4030 first->op_sibling = trueop;
4031 trueop->op_sibling = falseop;
1a67a97c 4032 o = newUNOP(OP_NULL, 0, (OP*)logop);
79072805 4033
1a67a97c 4034 trueop->op_next = falseop->op_next = o;
79072805 4035
1a67a97c 4036 o->op_next = start;
11343788 4037 return o;
79072805
LW		 4038}
4039
4040OP *
864dbfa3 4041Perl_newRANGE(pTHX_ I32 flags, OP *left, OP *right)
79072805 4042{
1a67a97c 4043 LOGOP *range;
79072805
LW		 4044 OP *flip;
4045 OP *flop;
1a67a97c 4046 OP *leftstart;
11343788 4047 OP *o;
79072805 4048
1a67a97c 4049 NewOp(1101, range, 1, LOGOP);
79072805 4050
1a67a97c
SM		 4051 range->op_type = OP_RANGE;
4052 range->op_ppaddr = PL_ppaddr[OP_RANGE];
4053 range->op_first = left;
4054 range->op_flags = OPf_KIDS;
4055 leftstart = LINKLIST(left);
4056 range->op_other = LINKLIST(right);
4057 range->op_private = 1 | (flags >> 8);
79072805
LW		 4058
4059 left->op_sibling = right;
4060
1a67a97c
SM		 4061 range->op_next = (OP*)range;
4062 flip = newUNOP(OP_FLIP, flags, (OP*)range);
79072805 4063 flop = newUNOP(OP_FLOP, 0, flip);
11343788 4064 o = newUNOP(OP_NULL, 0, flop);
79072805 4065 linklist(flop);
1a67a97c 4066 range->op_next = leftstart;
79072805
LW		 4067
4068 left->op_next = flip;
4069 right->op_next = flop;
4070
1a67a97c
SM		 4071 range->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
4072 sv_upgrade(PAD_SV(range->op_targ), SVt_PVNV);
ed6116ce 4073 flip->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
79072805
LW		 4074 sv_upgrade(PAD_SV(flip->op_targ), SVt_PVNV);
4075
4076 flip->op_private = left->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
4077 flop->op_private = right->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
4078
11343788 4079 flip->op_next = o;
79072805 4080 if (!flip->op_private || !flop->op_private)
11343788 4081 linklist(o); /* blow off optimizer unless constant */
79072805 4082
11343788 4083 return o;
79072805
LW		 4084}
4085
4086OP *
864dbfa3 4087Perl_newLOOPOP(pTHX_ I32 flags, I32 debuggable, OP *expr, OP *block)
79072805 4088{
463ee0b2 4089 OP* listop;
11343788 4090 OP* o;
463ee0b2 4091 int once = block && block->op_flags & OPf_SPECIAL &&
a0d0e21e 4092 (block->op_type == OP_ENTERSUB || block->op_type == OP_NULL);
93a17b20 4093
463ee0b2
LW		 4094 if (expr) {
4095 if (once && expr->op_type == OP_CONST && !SvTRUE(((SVOP*)expr)->op_sv))
4096 return block; /* do {} while 0 does once */
fb73857a 4097 if (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
4098 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
774d564b 4099 expr = newUNOP(OP_DEFINED, 0,
54b9620d 4100 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
55d729e4
GS		 4101 } else if (expr->op_flags & OPf_KIDS) {
4102 OP *k1 = ((UNOP*)expr)->op_first;
4103 OP *k2 = (k1) ? k1->op_sibling : NULL;
4104 switch (expr->op_type) {
1c846c1f 4105 case OP_NULL:
55d729e4
GS		 4106 if (k2 && k2->op_type == OP_READLINE
4107 && (k2->op_flags & OPf_STACKED)
1c846c1f 4108 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
55d729e4 4109 expr = newUNOP(OP_DEFINED, 0, expr);
1c846c1f 4110 break;
55d729e4
GS		 4111
4112 case OP_SASSIGN:
4113 if (k1->op_type == OP_READDIR
4114 || k1->op_type == OP_GLOB
6531c3e6 4115 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
55d729e4
GS		 4116 || k1->op_type == OP_EACH)
4117 expr = newUNOP(OP_DEFINED, 0, expr);
4118 break;
4119 }
774d564b 4120 }
463ee0b2 4121 }
93a17b20 4122
8990e307 4123 listop = append_elem(OP_LINESEQ, block, newOP(OP_UNSTACK, 0));
883ffac3 4124 o = new_logop(OP_AND, 0, &expr, &listop);
463ee0b2 4125
883ffac3
CS		 4126 if (listop)
4127 ((LISTOP*)listop)->op_last->op_next = LINKLIST(o);
79072805 4128
11343788
MB		 4129 if (once && o != listop)
4130 o->op_next = ((LOGOP*)cUNOPo->op_first)->op_other;
79072805 4131
11343788
MB		 4132 if (o == listop)
4133 o = newUNOP(OP_NULL, 0, o); /* or do {} while 1 loses outer block */
748a9306 4134
11343788
MB		 4135 o->op_flags |= flags;
4136 o = scope(o);
4137 o->op_flags |= OPf_SPECIAL; /* suppress POPBLOCK curpm restoration*/
4138 return o;
79072805
LW		 4139}
4140
4141OP *
864dbfa3 4142Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP *loop, I32 whileline, OP *expr, OP *block, OP *cont)
79072805
LW		 4143{
4144 OP *redo;
4145 OP *next = 0;
4146 OP *listop;
11343788 4147 OP *o;
1ba6ee2b 4148 U8 loopflags = 0;
79072805 4149
fb73857a 4150 if (expr && (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
4151 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB))) {
748a9306 4152 expr = newUNOP(OP_DEFINED, 0,
54b9620d 4153 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
55d729e4
GS		 4154 } else if (expr && (expr->op_flags & OPf_KIDS)) {
4155 OP *k1 = ((UNOP*)expr)->op_first;
4156 OP *k2 = (k1) ? k1->op_sibling : NULL;
4157 switch (expr->op_type) {
1c846c1f 4158 case OP_NULL:
55d729e4
GS		 4159 if (k2 && k2->op_type == OP_READLINE
4160 && (k2->op_flags & OPf_STACKED)
1c846c1f 4161 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
55d729e4 4162 expr = newUNOP(OP_DEFINED, 0, expr);
1c846c1f 4163 break;
55d729e4
GS		 4164
4165 case OP_SASSIGN:
4166 if (k1->op_type == OP_READDIR
4167 || k1->op_type == OP_GLOB
72b16652 4168 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
55d729e4
GS		 4169 || k1->op_type == OP_EACH)
4170 expr = newUNOP(OP_DEFINED, 0, expr);
4171 break;
4172 }
748a9306 4173 }
79072805
LW		 4174
4175 if (!block)
4176 block = newOP(OP_NULL, 0);
87246558
GS		 4177 else if (cont) {
4178 block = scope(block);
4179 }
79072805 4180
1ba6ee2b 4181 if (cont) {
79072805 4182 next = LINKLIST(cont);
1ba6ee2b 4183 }
fb73857a 4184 if (expr) {
85538317
GS		 4185 OP *unstack = newOP(OP_UNSTACK, 0);
4186 if (!next)
4187 next = unstack;
4188 cont = append_elem(OP_LINESEQ, cont, unstack);
fb73857a 4189 if ((line_t)whileline != NOLINE) {
3280af22 4190 PL_copline = whileline;
fb73857a 4191 cont = append_elem(OP_LINESEQ, cont,
4192 newSTATEOP(0, Nullch, Nullop));
4193 }
4194 }
79072805 4195
463ee0b2 4196 listop = append_list(OP_LINESEQ, (LISTOP*)block, (LISTOP*)cont);
79072805
LW		 4197 redo = LINKLIST(listop);
4198
4199 if (expr) {
3280af22 4200 PL_copline = whileline;
883ffac3
CS		 4201 scalar(listop);
4202 o = new_logop(OP_AND, 0, &expr, &listop);
11343788 4203 if (o == expr && o->op_type == OP_CONST && !SvTRUE(cSVOPo->op_sv)) {
85e6fe83 4204 op_free(expr); /* oops, it's a while (0) */
463ee0b2 4205 op_free((OP*)loop);
883ffac3 4206 return Nullop; /* listop already freed by new_logop */
463ee0b2 4207 }
883ffac3 4208 if (listop)
497b47a8 4209 ((LISTOP*)listop)->op_last->op_next =
883ffac3 4210 (o == listop ? redo : LINKLIST(o));
79072805
LW		 4211 }
4212 else
11343788 4213 o = listop;
79072805
LW		 4214
4215 if (!loop) {
b7dc083c 4216 NewOp(1101,loop,1,LOOP);
79072805 4217 loop->op_type = OP_ENTERLOOP;
22c35a8c 4218 loop->op_ppaddr = PL_ppaddr[OP_ENTERLOOP];
79072805
LW		 4219 loop->op_private = 0;
4220 loop->op_next = (OP*)loop;
4221 }
4222
11343788 4223 o = newBINOP(OP_LEAVELOOP, 0, (OP*)loop, o);
79072805
LW		 4224
4225 loop->op_redoop = redo;
11343788 4226 loop->op_lastop = o;
1ba6ee2b 4227 o->op_private |= loopflags;
79072805
LW		 4228
4229 if (next)
4230 loop->op_nextop = next;
4231 else
11343788 4232 loop->op_nextop = o;
79072805 4233
11343788
MB		 4234 o->op_flags |= flags;
4235 o->op_private |= (flags >> 8);
4236 return o;
79072805
LW		 4237}
4238
4239OP *
864dbfa3 4240Perl_newFOROP(pTHX_ I32 flags,char *label,line_t forline,OP *sv,OP *expr,OP *block,OP *cont)
79072805
LW		 4241{
4242 LOOP *loop;
fb73857a 4243 OP *wop;
85e6fe83 4244 int padoff = 0;
4633a7c4 4245 I32 iterflags = 0;
79072805 4246
79072805 4247 if (sv) {
85e6fe83 4248 if (sv->op_type == OP_RV2SV) { /* symbol table variable */
748a9306 4249 sv->op_type = OP_RV2GV;
22c35a8c 4250 sv->op_ppaddr = PL_ppaddr[OP_RV2GV];
79072805 4251 }
85e6fe83
LW		 4252 else if (sv->op_type == OP_PADSV) { /* private variable */
4253 padoff = sv->op_targ;
743e66e6 4254 sv->op_targ = 0;
85e6fe83
LW		 4255 op_free(sv);
4256 sv = Nullop;
4257 }
54b9620d
MB		 4258 else if (sv->op_type == OP_THREADSV) { /* per-thread variable */
4259 padoff = sv->op_targ;
743e66e6 4260 sv->op_targ = 0;
54b9620d
MB		 4261 iterflags |= OPf_SPECIAL;
4262 op_free(sv);
4263 sv = Nullop;
4264 }
79072805 4265 else
cea2e8a9 4266 Perl_croak(aTHX_ "Can't use %s for loop variable", PL_op_desc[sv->op_type]);
79072805
LW		 4267 }
4268 else {
4d1ff10f 4269#ifdef USE_5005THREADS
54b9620d
MB		 4270 padoff = find_threadsv("_");
4271 iterflags |= OPf_SPECIAL;
4272#else
3280af22 4273 sv = newGVOP(OP_GV, 0, PL_defgv);
54b9620d 4274#endif
79072805 4275 }
5f05dabc 4276 if (expr->op_type == OP_RV2AV || expr->op_type == OP_PADAV) {
89ea2908 4277 expr = mod(force_list(scalar(ref(expr, OP_ITER))), OP_GREPSTART);
4633a7c4
LW		 4278 iterflags |= OPf_STACKED;
4279 }
89ea2908
GA		 4280 else if (expr->op_type == OP_NULL &&
4281 (expr->op_flags & OPf_KIDS) &&
4282 ((BINOP*)expr)->op_first->op_type == OP_FLOP)
4283 {
4284 /* Basically turn for($x..$y) into the same as for($x,$y), but we
4285 * set the STACKED flag to indicate that these values are to be
4286 * treated as min/max values by 'pp_iterinit'.
4287 */
4288 UNOP* flip = (UNOP*)((UNOP*)((BINOP*)expr)->op_first)->op_first;
1a67a97c 4289 LOGOP* range = (LOGOP*) flip->op_first;
89ea2908
GA		 4290 OP* left = range->op_first;
4291 OP* right = left->op_sibling;
5152d7c7 4292 LISTOP* listop;
89ea2908
GA		 4293
4294 range->op_flags &= ~OPf_KIDS;
4295 range->op_first = Nullop;
4296
5152d7c7 4297 listop = (LISTOP*)newLISTOP(OP_LIST, 0, left, right);
1a67a97c
SM		 4298 listop->op_first->op_next = range->op_next;
4299 left->op_next = range->op_other;
5152d7c7
GS		 4300 right->op_next = (OP*)listop;
4301 listop->op_next = listop->op_first;
89ea2908
GA		 4302
4303 op_free(expr);
5152d7c7 4304 expr = (OP*)(listop);
93c66552 4305 op_null(expr);
89ea2908
GA		 4306 iterflags |= OPf_STACKED;
4307 }
4308 else {
4309 expr = mod(force_list(expr), OP_GREPSTART);
4310 }
4311
4312
4633a7c4 4313 loop = (LOOP*)list(convert(OP_ENTERITER, iterflags,
89ea2908 4314 append_elem(OP_LIST, expr, scalar(sv))));
85e6fe83 4315 assert(!loop->op_next);
b7dc083c 4316#ifdef PL_OP_SLAB_ALLOC
155aba94
GS		 4317 {
4318 LOOP *tmp;
4319 NewOp(1234,tmp,1,LOOP);
4320 Copy(loop,tmp,1,LOOP);
238a4c30 4321 FreeOp(loop);
155aba94
GS		 4322 loop = tmp;
4323 }
b7dc083c 4324#else
85e6fe83 4325 Renew(loop, 1, LOOP);
1c846c1f 4326#endif
85e6fe83 4327 loop->op_targ = padoff;
fb73857a 4328 wop = newWHILEOP(flags, 1, loop, forline, newOP(OP_ITER, 0), block, cont);
3280af22 4329 PL_copline = forline;
fb73857a 4330 return newSTATEOP(0, label, wop);
79072805
LW		 4331}
4332
8990e307 4333OP*
864dbfa3 4334Perl_newLOOPEX(pTHX_ I32 type, OP *label)
8990e307 4335{
11343788 4336 OP *o;
2d8e6c8d
GS		 4337 STRLEN n_a;
4338
8990e307 4339 if (type != OP_GOTO || label->op_type == OP_CONST) {
cdaebead
MB		 4340 /* "last()" means "last" */
4341 if (label->op_type == OP_STUB && (label->op_flags & OPf_PARENS))
4342 o = newOP(type, OPf_SPECIAL);
4343 else {
4344 o = newPVOP(type, 0, savepv(label->op_type == OP_CONST
2d8e6c8d 4345 ? SvPVx(((SVOP*)label)->op_sv, n_a)
cdaebead
MB		 4346 : ""));
4347 }
8990e307
LW		 4348 op_free(label);
4349 }
4350 else {
a0d0e21e
LW		 4351 if (label->op_type == OP_ENTERSUB)
4352 label = newUNOP(OP_REFGEN, 0, mod(label, OP_REFGEN));
11343788 4353 o = newUNOP(type, OPf_STACKED, label);
8990e307 4354 }
3280af22 4355 PL_hints |= HINT_BLOCK_SCOPE;
11343788 4356 return o;
8990e307
LW		 4357}
4358
79072805 4359void
864dbfa3 4360Perl_cv_undef(pTHX_ CV *cv)
79072805 4361{
4d1ff10f 4362#ifdef USE_5005THREADS
e858de61
MB		 4363 if (CvMUTEXP(cv)) {
4364 MUTEX_DESTROY(CvMUTEXP(cv));
4365 Safefree(CvMUTEXP(cv));
4366 CvMUTEXP(cv) = 0;
4367 }
4d1ff10f 4368#endif /* USE_5005THREADS */
11343788 4369
a636914a
RH		 4370#ifdef USE_ITHREADS
4371 if (CvFILE(cv) && !CvXSUB(cv)) {
f3e31eb5 4372 /* for XSUBs CvFILE point directly to static memory; __FILE__ */
a636914a 4373 Safefree(CvFILE(cv));
a636914a 4374 }
f3e31eb5 4375 CvFILE(cv) = 0;
a636914a
RH		 4376#endif
4377
a0d0e21e 4378 if (!CvXSUB(cv) && CvROOT(cv)) {
4d1ff10f 4379#ifdef USE_5005THREADS
11343788 4380 if (CvDEPTH(cv) || (CvOWNER(cv) && CvOWNER(cv) != thr))
cea2e8a9 4381 Perl_croak(aTHX_ "Can't undef active subroutine");
11343788 4382#else
a0d0e21e 4383 if (CvDEPTH(cv))
cea2e8a9 4384 Perl_croak(aTHX_ "Can't undef active subroutine");
4d1ff10f 4385#endif /* USE_5005THREADS */
8990e307 4386 ENTER;
a0d0e21e 4387
7766f137 4388 SAVEVPTR(PL_curpad);
3280af22 4389 PL_curpad = 0;
a0d0e21e 4390
282f25c9 4391 op_free(CvROOT(cv));
79072805 4392 CvROOT(cv) = Nullop;
8990e307 4393 LEAVE;
79072805 4394 }
1d5db326 4395 SvPOK_off((SV*)cv); /* forget prototype */
8e07c86e 4396 CvGV(cv) = Nullgv;
282f25c9
JH		 4397 /* Since closure prototypes have the same lifetime as the containing
4398 * CV, they don't hold a refcount on the outside CV. This avoids
4399 * the refcount loop between the outer CV (which keeps a refcount to
4400 * the closure prototype in the pad entry for pp_anoncode()) and the
afa38808
JH		 4401 * closure prototype, and the ensuing memory leak. --GSAR */
4402 if (!CvANON(cv) || CvCLONED(cv))
c64c7340 4403 SvREFCNT_dec(CvOUTSIDE(cv));
8e07c86e 4404 CvOUTSIDE(cv) = Nullcv;
beab0874
JT		 4405 if (CvCONST(cv)) {
4406 SvREFCNT_dec((SV*)CvXSUBANY(cv).any_ptr);
4407 CvCONST_off(cv);
4408 }
8e07c86e 4409 if (CvPADLIST(cv)) {
8ebc5c01 4410 /* may be during global destruction */
4411 if (SvREFCNT(CvPADLIST(cv))) {
c64c7340
JH		 4412 I32 i = AvFILLp(CvPADLIST(cv));
4413 while (i >= 0) {
4414 SV** svp = av_fetch(CvPADLIST(cv), i--, FALSE);
4415 SV* sv = svp ? *svp : Nullsv;
46fc3d4c 4416 if (!sv)
4417 continue;
3280af22
NIS		 4418 if (sv == (SV*)PL_comppad_name)
4419 PL_comppad_name = Nullav;
4420 else if (sv == (SV*)PL_comppad) {
4421 PL_comppad = Nullav;
4422 PL_curpad = Null(SV**);
46fc3d4c 4423 }
4424 SvREFCNT_dec(sv);
8ebc5c01 4425 }
4426 SvREFCNT_dec((SV*)CvPADLIST(cv));
8e07c86e 4427 }
8e07c86e
AD		 4428 CvPADLIST(cv) = Nullav;
4429 }
50762d59
DM		 4430 if (CvXSUB(cv)) {
4431 CvXSUB(cv) = 0;
4432 }
a2c090b3 4433 CvFLAGS(cv) = 0;
79072805
LW		 4434}
4435
9cbac4c7 4436#ifdef DEBUG_CLOSURES
76e3520e 4437STATIC void
743e66e6 4438S_cv_dump(pTHX_ CV *cv)
5f05dabc 4439{
62fde642 4440#ifdef DEBUGGING
5f05dabc 4441 CV *outside = CvOUTSIDE(cv);
4442 AV* padlist = CvPADLIST(cv);
4fdae800 4443 AV* pad_name;
4444 AV* pad;
4445 SV** pname;
4446 SV** ppad;
5f05dabc 4447 I32 ix;
4448
b900a521
JH		 4449 PerlIO_printf(Perl_debug_log,
4450 "\tCV=0x%"UVxf" (%s), OUTSIDE=0x%"UVxf" (%s)\n",
4451 PTR2UV(cv),
ab50184a 4452 (CvANON(cv) ? "ANON"
6b88bc9c 4453 : (cv == PL_main_cv) ? "MAIN"
33b8ce05 4454 : CvUNIQUE(cv) ? "UNIQUE"
44a8e56a 4455 : CvGV(cv) ? GvNAME(CvGV(cv)) : "UNDEFINED"),
b900a521 4456 PTR2UV(outside),
ab50184a
CS		 4457 (!outside ? "null"
4458 : CvANON(outside) ? "ANON"
6b88bc9c 4459 : (outside == PL_main_cv) ? "MAIN"
07055b4c 4460 : CvUNIQUE(outside) ? "UNIQUE"
44a8e56a 4461 : CvGV(outside) ? GvNAME(CvGV(outside)) : "UNDEFINED"));
5f05dabc 4462
4fdae800 4463 if (!padlist)
4464 return;
4465
4466 pad_name = (AV*)*av_fetch(padlist, 0, FALSE);
4467 pad = (AV*)*av_fetch(padlist, 1, FALSE);
4468 pname = AvARRAY(pad_name);
4469 ppad = AvARRAY(pad);
4470
93965878 4471 for (ix = 1; ix <= AvFILLp(pad_name); ix++) {
5f05dabc 4472 if (SvPOK(pname[ix]))
b900a521
JH		 4473 PerlIO_printf(Perl_debug_log,
4474 "\t%4d. 0x%"UVxf" (%s\"%s\" %"IVdf"-%"IVdf")\n",
894356b3 4475 (int)ix, PTR2UV(ppad[ix]),
4fdae800 4476 SvFAKE(pname[ix]) ? "FAKE " : "",
4477 SvPVX(pname[ix]),
b900a521
JH		 4478 (IV)I_32(SvNVX(pname[ix])),
4479 SvIVX(pname[ix]));
5f05dabc 4480 }
743e66e6 4481#endif /* DEBUGGING */
62fde642 4482}
9cbac4c7 4483#endif /* DEBUG_CLOSURES */
5f05dabc 4484
76e3520e 4485STATIC CV *
cea2e8a9 4486S_cv_clone2(pTHX_ CV *proto, CV *outside)
748a9306
LW		 4487{
4488 AV* av;
4489 I32 ix;
4490 AV* protopadlist = CvPADLIST(proto);
4491 AV* protopad_name = (AV*)*av_fetch(protopadlist, 0, FALSE);
4492 AV* protopad = (AV*)*av_fetch(protopadlist, 1, FALSE);
5f05dabc 4493 SV** pname = AvARRAY(protopad_name);
4494 SV** ppad = AvARRAY(protopad);
93965878
NIS		 4495 I32 fname = AvFILLp(protopad_name);
4496 I32 fpad = AvFILLp(protopad);
748a9306
LW		 4497 AV* comppadlist;
4498 CV* cv;
4499
07055b4c
CS		 4500 assert(!CvUNIQUE(proto));
4501
748a9306 4502 ENTER;
354992b1 4503 SAVECOMPPAD();
3280af22
NIS		 4504 SAVESPTR(PL_comppad_name);
4505 SAVESPTR(PL_compcv);
748a9306 4506
3280af22 4507 cv = PL_compcv = (CV*)NEWSV(1104,0);
fa83b5b6 4508 sv_upgrade((SV *)cv, SvTYPE(proto));
a57ec3bd 4509 CvFLAGS(cv) = CvFLAGS(proto) & ~CVf_CLONE;
a5f75d66 4510 CvCLONED_on(cv);
748a9306 4511
4d1ff10f 4512#ifdef USE_5005THREADS
12ca11f6 4513 New(666, CvMUTEXP(cv), 1, perl_mutex);
11343788 4514 MUTEX_INIT(CvMUTEXP(cv));
11343788 4515 CvOWNER(cv) = 0;
4d1ff10f 4516#endif /* USE_5005THREADS */
a636914a
RH		 4517#ifdef USE_ITHREADS
4518 CvFILE(cv) = CvXSUB(proto) ? CvFILE(proto)
4519 : savepv(CvFILE(proto));
4520#else
57843af0 4521 CvFILE(cv) = CvFILE(proto);
a636914a 4522#endif
65c50114 4523 CvGV(cv) = CvGV(proto);
748a9306 4524 CvSTASH(cv) = CvSTASH(proto);
282f25c9 4525 CvROOT(cv) = OpREFCNT_inc(CvROOT(proto));
748a9306 4526 CvSTART(cv) = CvSTART(proto);
5f05dabc 4527 if (outside)
4528 CvOUTSIDE(cv) = (CV*)SvREFCNT_inc(outside);
748a9306 4529
68dc0745 4530 if (SvPOK(proto))
4531 sv_setpvn((SV*)cv, SvPVX(proto), SvCUR(proto));
4532
3280af22 4533 PL_comppad_name = newAV();
46fc3d4c 4534 for (ix = fname; ix >= 0; ix--)
3280af22 4535 av_store(PL_comppad_name, ix, SvREFCNT_inc(pname[ix]));
748a9306 4536
3280af22 4537 PL_comppad = newAV();
748a9306
LW		 4538
4539 comppadlist = newAV();
4540 AvREAL_off(comppadlist);
3280af22
NIS		 4541 av_store(comppadlist, 0, (SV*)PL_comppad_name);
4542 av_store(comppadlist, 1, (SV*)PL_comppad);
748a9306 4543 CvPADLIST(cv) = comppadlist;
3280af22
NIS		 4544 av_fill(PL_comppad, AvFILLp(protopad));
4545 PL_curpad = AvARRAY(PL_comppad);
748a9306
LW		 4546
4547 av = newAV(); /* will be @_ */
4548 av_extend(av, 0);
3280af22 4549 av_store(PL_comppad, 0, (SV*)av);
748a9306
LW		 4550 AvFLAGS(av) = AVf_REIFY;
4551
9607fc9c 4552 for (ix = fpad; ix > 0; ix--) {
4553 SV* namesv = (ix <= fname) ? pname[ix] : Nullsv;
3280af22 4554 if (namesv && namesv != &PL_sv_undef) {
aa689395 4555 char *name = SvPVX(namesv); /* XXX */
4556 if (SvFLAGS(namesv) & SVf_FAKE) { /* lexical from outside? */
4557 I32 off = pad_findlex(name, ix, SvIVX(namesv),
2680586e 4558 CvOUTSIDE(cv), cxstack_ix, 0, 0);
5f05dabc 4559 if (!off)
3280af22 4560 PL_curpad[ix] = SvREFCNT_inc(ppad[ix]);
5f05dabc 4561 else if (off != ix)
cea2e8a9 4562 Perl_croak(aTHX_ "panic: cv_clone: %s", name);
748a9306
LW		 4563 }
4564 else { /* our own lexical */
aa689395 4565 SV* sv;
5f05dabc 4566 if (*name == '&') {
4567 /* anon code -- we'll come back for it */
4568 sv = SvREFCNT_inc(ppad[ix]);
4569 }
4570 else if (*name == '@')
4571 sv = (SV*)newAV();
748a9306 4572 else if (*name == '%')
5f05dabc 4573 sv = (SV*)newHV();
748a9306 4574 else
5f05dabc 4575 sv = NEWSV(0,0);
4576 if (!SvPADBUSY(sv))
4577 SvPADMY_on(sv);
3280af22 4578 PL_curpad[ix] = sv;
748a9306
LW		 4579 }
4580 }
7766f137 4581 else if (IS_PADGV(ppad[ix]) || IS_PADCONST(ppad[ix])) {
743e66e6
GS		 4582 PL_curpad[ix] = SvREFCNT_inc(ppad[ix]);
4583 }
748a9306 4584 else {
aa689395 4585 SV* sv = NEWSV(0,0);
748a9306 4586 SvPADTMP_on(sv);
3280af22 4587 PL_curpad[ix] = sv;
748a9306
LW		 4588 }
4589 }
4590
5f05dabc 4591 /* Now that vars are all in place, clone nested closures. */
4592
9607fc9c 4593 for (ix = fpad; ix > 0; ix--) {
4594 SV* namesv = (ix <= fname) ? pname[ix] : Nullsv;
aa689395 4595 if (namesv
3280af22 4596 && namesv != &PL_sv_undef
aa689395 4597 && !(SvFLAGS(namesv) & SVf_FAKE)
4598 && *SvPVX(namesv) == '&'
5f05dabc 4599 && CvCLONE(ppad[ix]))
4600 {
4601 CV *kid = cv_clone2((CV*)ppad[ix], cv);
4602 SvREFCNT_dec(ppad[ix]);
4603 CvCLONE_on(kid);
4604 SvPADMY_on(kid);
3280af22 4605 PL_curpad[ix] = (SV*)kid;
748a9306
LW		 4606 }
4607 }
4608
5f05dabc 4609#ifdef DEBUG_CLOSURES
ab50184a
CS		 4610 PerlIO_printf(Perl_debug_log, "Cloned inside:\n");
4611 cv_dump(outside);
4612 PerlIO_printf(Perl_debug_log, " from:\n");
5f05dabc 4613 cv_dump(proto);
ab50184a 4614 PerlIO_printf(Perl_debug_log, " to:\n");
5f05dabc 4615 cv_dump(cv);
4616#endif
4617
748a9306 4618 LEAVE;
beab0874
JT		 4619
4620 if (CvCONST(cv)) {
4621 SV* const_sv = op_const_sv(CvSTART(cv), cv);
4622 assert(const_sv);
4623 /* constant sub () { $x } closing over $x - see lib/constant.pm */
4624 SvREFCNT_dec(cv);
4625 cv = newCONSTSUB(CvSTASH(proto), 0, const_sv);
4626 }
4627
748a9306
LW		 4628 return cv;
4629}
4630
4631CV *
864dbfa3 4632Perl_cv_clone(pTHX_ CV *proto)
5f05dabc 4633{
b099ddc0 4634 CV *cv;
1feb2720 4635 LOCK_CRED_MUTEX; /* XXX create separate mutex */
b099ddc0 4636 cv = cv_clone2(proto, CvOUTSIDE(proto));
1feb2720 4637 UNLOCK_CRED_MUTEX; /* XXX create separate mutex */
b099ddc0 4638 return cv;
5f05dabc 4639}
4640
3fe9a6f1 4641void
864dbfa3 4642Perl_cv_ckproto(pTHX_ CV *cv, GV *gv, char *p)
3fe9a6f1 4643{
e476b1b5 4644 if (((!p != !SvPOK(cv)) || (p && strNE(p, SvPVX(cv)))) && ckWARN_d(WARN_PROTOTYPE)) {
46fc3d4c 4645 SV* msg = sv_newmortal();
3fe9a6f1 4646 SV* name = Nullsv;
4647
4648 if (gv)
46fc3d4c 4649 gv_efullname3(name = sv_newmortal(), gv, Nullch);
4650 sv_setpv(msg, "Prototype mismatch:");
4651 if (name)
894356b3 4652 Perl_sv_catpvf(aTHX_ msg, " sub %"SVf, name);
3fe9a6f1 4653 if (SvPOK(cv))
cea2e8a9 4654 Perl_sv_catpvf(aTHX_ msg, " (%s)", SvPVX(cv));
46fc3d4c 4655 sv_catpv(msg, " vs ");
4656 if (p)
cea2e8a9 4657 Perl_sv_catpvf(aTHX_ msg, "(%s)", p);
46fc3d4c 4658 else
4659 sv_catpv(msg, "none");
9014280d 4660 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "%"SVf, msg);
3fe9a6f1 4661 }
4662}
4663
acfe0abc 4664static void const_sv_xsub(pTHX_ CV* cv);
beab0874
JT		 4665
4666/*
ccfc67b7
JH		 4667
4668=head1 Optree Manipulation Functions
4669
beab0874
JT		 4670=for apidoc cv_const_sv
4671
4672If C<cv> is a constant sub eligible for inlining. returns the constant
4673value returned by the sub. Otherwise, returns NULL.
4674
4675Constant subs can be created with C<newCONSTSUB> or as described in
4676L<perlsub/"Constant Functions">.
4677
4678=cut
4679*/
760ac839 4680SV *
864dbfa3 4681Perl_cv_const_sv(pTHX_ CV *cv)
760ac839 4682{
beab0874 4683 if (!cv || !CvCONST(cv))
54310121 4684 return Nullsv;
beab0874 4685 return (SV*)CvXSUBANY(cv).any_ptr;
fe5e78ed 4686}
760ac839 4687
fe5e78ed 4688SV *
864dbfa3 4689Perl_op_const_sv(pTHX_ OP *o, CV *cv)
fe5e78ed
GS		 4690{
4691 SV *sv = Nullsv;
4692
0f79a09d 4693 if (!o)
fe5e78ed 4694 return Nullsv;
1c846c1f
NIS		 4695
4696 if (o->op_type == OP_LINESEQ && cLISTOPo->op_first)
fe5e78ed
GS		 4697 o = cLISTOPo->op_first->op_sibling;
4698
4699 for (; o; o = o->op_next) {
54310121 4700 OPCODE type = o->op_type;
fe5e78ed 4701
1c846c1f 4702 if (sv && o->op_next == o)
fe5e78ed 4703 return sv;
e576b457
JT		 4704 if (o->op_next != o) {
4705 if (type == OP_NEXTSTATE || type == OP_NULL || type == OP_PUSHMARK)
4706 continue;
4707 if (type == OP_DBSTATE)
4708 continue;
4709 }
54310121 4710 if (type == OP_LEAVESUB || type == OP_RETURN)
4711 break;
4712 if (sv)
4713 return Nullsv;
7766f137 4714 if (type == OP_CONST && cSVOPo->op_sv)
5dc0d613 4715 sv = cSVOPo->op_sv;
7766f137 4716 else if ((type == OP_PADSV || type == OP_CONST) && cv) {
e858de61
MB		 4717 AV* padav = (AV*)(AvARRAY(CvPADLIST(cv))[1]);
4718 sv = padav ? AvARRAY(padav)[o->op_targ] : Nullsv;
beab0874
JT		 4719 if (!sv)
4720 return Nullsv;
4721 if (CvCONST(cv)) {
4722 /* We get here only from cv_clone2() while creating a closure.
4723 Copy the const value here instead of in cv_clone2 so that
4724 SvREADONLY_on doesn't lead to problems when leaving
4725 scope.
4726 */
4727 sv = newSVsv(sv);
4728 }
4729 if (!SvREADONLY(sv) && SvREFCNT(sv) > 1)
54310121 4730 return Nullsv;
760ac839 4731 }
54310121 4732 else
4733 return Nullsv;
760ac839 4734 }
5aabfad6 4735 if (sv)
4736 SvREADONLY_on(sv);
760ac839
LW		 4737 return sv;
4738}
4739
09bef843
SB		 4740void
4741Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
4742{
4743 if (o)
4744 SAVEFREEOP(o);
4745 if (proto)
4746 SAVEFREEOP(proto);
4747 if (attrs)
4748 SAVEFREEOP(attrs);
4749 if (block)
4750 SAVEFREEOP(block);
4751 Perl_croak(aTHX_ "\"my sub\" not yet implemented");
4752}
4753
748a9306 4754CV *
864dbfa3 4755Perl_newSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *block)
79072805 4756{
09bef843
SB		 4757 return Perl_newATTRSUB(aTHX_ floor, o, proto, Nullop, block);
4758}
4759
4760CV *
4761Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
4762{
2d8e6c8d 4763 STRLEN n_a;
83ee9e09
GS		 4764 char *name;
4765 char *aname;
4766 GV *gv;
2d8e6c8d 4767 char *ps = proto ? SvPVx(((SVOP*)proto)->op_sv, n_a) : Nullch;
a2008d6d 4768 register CV *cv=0;
a0d0e21e 4769 I32 ix;
beab0874 4770 SV *const_sv;
79072805 4771
83ee9e09
GS		 4772 name = o ? SvPVx(cSVOPo->op_sv, n_a) : Nullch;
4773 if (!name && PERLDB_NAMEANON && CopLINE(PL_curcop)) {
4774 SV *sv = sv_newmortal();
c99da370
JH		 4775 Perl_sv_setpvf(aTHX_ sv, "%s[%s:%"IVdf"]",
4776 PL_curstash ? "__ANON__" : "__ANON__::__ANON__",
83ee9e09
GS		 4777 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
4778 aname = SvPVX(sv);
4779 }
4780 else
4781 aname = Nullch;
c99da370
JH		 4782 gv = gv_fetchpv(name ? name : (aname ? aname :
4783 (PL_curstash ? "__ANON__" : "__ANON__::__ANON__")),
83ee9e09
GS		 4784 GV_ADDMULTI | ((block || attrs) ? 0 : GV_NOINIT),
4785 SVt_PVCV);
4786
11343788 4787 if (o)
5dc0d613 4788 SAVEFREEOP(o);
3fe9a6f1 4789 if (proto)
4790 SAVEFREEOP(proto);
09bef843
SB		 4791 if (attrs)
4792 SAVEFREEOP(attrs);
3fe9a6f1 4793
09bef843 4794 if (SvTYPE(gv) != SVt_PVGV) { /* Maybe prototype now, and had at
55d729e4
GS		 4795 maximum a prototype before. */
4796 if (SvTYPE(gv) > SVt_NULL) {
0453d815 4797 if (!SvPOK((SV*)gv) && !(SvIOK((SV*)gv) && SvIVX((SV*)gv) == -1)
e476b1b5 4798 && ckWARN_d(WARN_PROTOTYPE))
f248d071 4799 {
9014280d 4800 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "Runaway prototype");
f248d071 4801 }
55d729e4
GS		 4802 cv_ckproto((CV*)gv, NULL, ps);
4803 }
4804 if (ps)
4805 sv_setpv((SV*)gv, ps);
4806 else
4807 sv_setiv((SV*)gv, -1);
3280af22
NIS		 4808 SvREFCNT_dec(PL_compcv);
4809 cv = PL_compcv = NULL;
4810 PL_sub_generation++;
beab0874 4811 goto done;
55d729e4
GS		 4812 }
4813
beab0874
JT		 4814 cv = (!name || GvCVGEN(gv)) ? Nullcv : GvCV(gv);
4815
7fb37951
AMS		 4816#ifdef GV_UNIQUE_CHECK
4817 if (cv && GvUNIQUE(gv) && SvREADONLY(cv)) {
4818 Perl_croak(aTHX_ "Can't define subroutine %s (GV is unique)", name);
5bd07a3d
DM		 4819 }
4820#endif
4821
beab0874
JT		 4822 if (!block || !ps || *ps || attrs)
4823 const_sv = Nullsv;
4824 else
4825 const_sv = op_const_sv(block, Nullcv);
4826
4827 if (cv) {
60ed1d8c 4828 bool exists = CvROOT(cv) || CvXSUB(cv);
5bd07a3d 4829
7fb37951
AMS		 4830#ifdef GV_UNIQUE_CHECK
4831 if (exists && GvUNIQUE(gv)) {
4832 Perl_croak(aTHX_ "Can't redefine unique subroutine %s", name);
5bd07a3d
DM		 4833 }
4834#endif
4835
60ed1d8c
GS		 4836 /* if the subroutine doesn't exist and wasn't pre-declared
4837 * with a prototype, assume it will be AUTOLOADed,
4838 * skipping the prototype check
4839 */
4840 if (exists || SvPOK(cv))
01ec43d0 4841 cv_ckproto(cv, gv, ps);
68dc0745 4842 /* already defined (or promised)? */
60ed1d8c 4843 if (exists || GvASSUMECV(gv)) {
09bef843 4844 if (!block && !attrs) {
d3cea301
SB		 4845 if (CvFLAGS(PL_compcv)) {
4846 /* might have had built-in attrs applied */
4847 CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
4848 }
aa689395 4849 /* just a "sub foo;" when &foo is already defined */
3280af22 4850 SAVEFREESV(PL_compcv);
aa689395 4851 goto done;
4852 }
7bac28a0 4853 /* ahem, death to those who redefine active sort subs */
3280af22 4854 if (PL_curstackinfo->si_type == PERLSI_SORT && PL_sortcop == CvSTART(cv))
cea2e8a9 4855 Perl_croak(aTHX_ "Can't redefine active sort subroutine %s", name);
beab0874
JT		 4856 if (block) {
4857 if (ckWARN(WARN_REDEFINE)
4858 || (CvCONST(cv)
4859 && (!const_sv || sv_cmp(cv_const_sv(cv), const_sv))))
4860 {
4861 line_t oldline = CopLINE(PL_curcop);
d8a34499
IK		 4862 if (PL_copline != NOLINE)
4863 CopLINE_set(PL_curcop, PL_copline);
9014280d 4864 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
beab0874
JT		 4865 CvCONST(cv) ? "Constant subroutine %s redefined"
4866 : "Subroutine %s redefined", name);
4867 CopLINE_set(PL_curcop, oldline);
4868 }
4869 SvREFCNT_dec(cv);
4870 cv = Nullcv;
79072805 4871 }
79072805
LW		 4872 }
4873 }
beab0874
JT		 4874 if (const_sv) {
4875 SvREFCNT_inc(const_sv);
4876 if (cv) {
0768512c 4877 assert(!CvROOT(cv) && !CvCONST(cv));
beab0874
JT		 4878 sv_setpv((SV*)cv, ""); /* prototype is "" */
4879 CvXSUBANY(cv).any_ptr = const_sv;
4880 CvXSUB(cv) = const_sv_xsub;
4881 CvCONST_on(cv);
beab0874
JT		 4882 }
4883 else {
4884 GvCV(gv) = Nullcv;
4885 cv = newCONSTSUB(NULL, name, const_sv);
4886 }
4887 op_free(block);
4888 SvREFCNT_dec(PL_compcv);
4889 PL_compcv = NULL;
4890 PL_sub_generation++;
4891 goto done;
4892 }
09bef843
SB		 4893 if (attrs) {
4894 HV *stash;
4895 SV *rcv;
4896
4897 /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>
4898 * before we clobber PL_compcv.
4899 */
4900 if (cv && !block) {
4901 rcv = (SV*)cv;
020f0e03
SB		 4902 /* Might have had built-in attributes applied -- propagate them. */
4903 CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
a9164de8 4904 if (CvGV(cv) && GvSTASH(CvGV(cv)))
09bef843 4905 stash = GvSTASH(CvGV(cv));
a9164de8 4906 else if (CvSTASH(cv))
09bef843
SB		 4907 stash = CvSTASH(cv);
4908 else
4909 stash = PL_curstash;
4910 }
4911 else {
4912 /* possibly about to re-define existing subr -- ignore old cv */
4913 rcv = (SV*)PL_compcv;
a9164de8 4914 if (name && GvSTASH(gv))
09bef843
SB		 4915 stash = GvSTASH(gv);
4916 else
4917 stash = PL_curstash;
4918 }
95f0a2f1 4919 apply_attrs(stash, rcv, attrs, FALSE);
09bef843 4920 }
a0d0e21e 4921 if (cv) { /* must reuse cv if autoloaded */
09bef843
SB		 4922 if (!block) {
4923 /* got here with just attrs -- work done, so bug out */
4924 SAVEFREESV(PL_compcv);
4925 goto done;
4926 }
4633a7c4 4927 cv_undef(cv);
3280af22
NIS		 4928 CvFLAGS(cv) = CvFLAGS(PL_compcv);
4929 CvOUTSIDE(cv) = CvOUTSIDE(PL_compcv);
4930 CvOUTSIDE(PL_compcv) = 0;
4931 CvPADLIST(cv) = CvPADLIST(PL_compcv);
4932 CvPADLIST(PL_compcv) = 0;
282f25c9
JH		 4933 /* inner references to PL_compcv must be fixed up ... */
4934 {
4935 AV *padlist = CvPADLIST(cv);
4936 AV *comppad_name = (AV*)AvARRAY(padlist)[0];
4937 AV *comppad = (AV*)AvARRAY(padlist)[1];
4938 SV **namepad = AvARRAY(comppad_name);
4939 SV **curpad = AvARRAY(comppad);
4940 for (ix = AvFILLp(comppad_name); ix > 0; ix--) {
4941 SV *namesv = namepad[ix];
4942 if (namesv && namesv != &PL_sv_undef
4943 && *SvPVX(namesv) == '&')
4944 {
4945 CV *innercv = (CV*)curpad[ix];
4946 if (CvOUTSIDE(innercv) == PL_compcv) {
4947 CvOUTSIDE(innercv) = cv;
4948 if (!CvANON(innercv) || CvCLONED(innercv)) {
4949 (void)SvREFCNT_inc(cv);
4950 SvREFCNT_dec(PL_compcv);
4951 }
4952 }
4953 }
4954 }
4955 }
4956 /* ... before we throw it away */
3280af22 4957 SvREFCNT_dec(PL_compcv);
a933f601
IZ		 4958 if (PERLDB_INTER)/* Advice debugger on the new sub. */
4959 ++PL_sub_generation;
a0d0e21e
LW		 4960 }
4961 else {
3280af22 4962 cv = PL_compcv;
44a8e56a 4963 if (name) {
4964 GvCV(gv) = cv;
4965 GvCVGEN(gv) = 0;
3280af22 4966 PL_sub_generation++;
44a8e56a 4967 }
a0d0e21e 4968 }
65c50114 4969 CvGV(cv) = gv;
a636914a 4970 CvFILE_set_from_cop(cv, PL_curcop);
3280af22 4971 CvSTASH(cv) = PL_curstash;
4d1ff10f 4972#ifdef USE_5005THREADS
11343788 4973 CvOWNER(cv) = 0;
1cfa4ec7 4974 if (!CvMUTEXP(cv)) {
f6aaf501 4975 New(666, CvMUTEXP(cv), 1, perl_mutex);
1cfa4ec7
GS		 4976 MUTEX_INIT(CvMUTEXP(cv));
4977 }
4d1ff10f 4978#endif /* USE_5005THREADS */
8990e307 4979
3fe9a6f1 4980 if (ps)
4981 sv_setpv((SV*)cv, ps);
4633a7c4 4982
3280af22 4983 if (PL_error_count) {
c07a80fd 4984 op_free(block);
4985 block = Nullop;
68dc0745 4986 if (name) {
4987 char *s = strrchr(name, ':');
4988 s = s ? s+1 : name;
6d4c2119
CS		 4989 if (strEQ(s, "BEGIN")) {
4990 char *not_safe =
4991 "BEGIN not safe after errors--compilation aborted";
faef0170 4992 if (PL_in_eval & EVAL_KEEPERR)
cea2e8a9 4993 Perl_croak(aTHX_ not_safe);
6d4c2119
CS		 4994 else {
4995 /* force display of errors found but not reported */
38a03e6e 4996 sv_catpv(ERRSV, not_safe);
cea2e8a9 4997 Perl_croak(aTHX_ "%s", SvPVx(ERRSV, n_a));
6d4c2119
CS		 4998 }
4999 }
68dc0745 5000 }
c07a80fd 5001 }
beab0874
JT		 5002 if (!block)
5003 goto done;
a0d0e21e 5004
3280af22
NIS		 5005 if (AvFILLp(PL_comppad_name) < AvFILLp(PL_comppad))
5006 av_store(PL_comppad_name, AvFILLp(PL_comppad), Nullsv);
a0d0e21e 5007
7766f137 5008 if (CvLVALUE(cv)) {
78f9721b
SM		 5009 CvROOT(cv) = newUNOP(OP_LEAVESUBLV, 0,
5010 mod(scalarseq(block), OP_LEAVESUBLV));
7766f137
GS		 5011 }
5012 else {
5013 CvROOT(cv) = newUNOP(OP_LEAVESUB, 0, scalarseq(block));
5014 }
5015 CvROOT(cv)->op_private |= OPpREFCOUNTED;
5016 OpREFCNT_set(CvROOT(cv), 1);
5017 CvSTART(cv) = LINKLIST(CvROOT(cv));
5018 CvROOT(cv)->op_next = 0;
a2efc822 5019 CALL_PEEP(CvSTART(cv));
7766f137
GS		 5020
5021 /* now that optimizer has done its work, adjust pad values */
54310121 5022 if (CvCLONE(cv)) {
3280af22
NIS		 5023 SV **namep = AvARRAY(PL_comppad_name);
5024 for (ix = AvFILLp(PL_comppad); ix > 0; ix--) {
54310121 5025 SV *namesv;
5026
7766f137 5027 if (SvIMMORTAL(PL_curpad[ix]) || IS_PADGV(PL_curpad[ix]) || IS_PADCONST(PL_curpad[ix]))
54310121 5028 continue;
5029 /*
5030 * The only things that a clonable function needs in its
5031 * pad are references to outer lexicals and anonymous subs.
5032 * The rest are created anew during cloning.
5033 */
5034 if (!((namesv = namep[ix]) != Nullsv &&
3280af22 5035 namesv != &PL_sv_undef &&
54310121 5036 (SvFAKE(namesv) ||
5037 *SvPVX(namesv) == '&')))
5038 {
3280af22
NIS		 5039 SvREFCNT_dec(PL_curpad[ix]);
5040 PL_curpad[ix] = Nullsv;
54310121 5041 }
5042 }
beab0874
JT		 5043 assert(!CvCONST(cv));
5044 if (ps && !*ps && op_const_sv(block, cv))
5045 CvCONST_on(cv);
a0d0e21e 5046 }
54310121 5047 else {
5048 AV *av = newAV(); /* Will be @_ */
5049 av_extend(av, 0);
3280af22 5050 av_store(PL_comppad, 0, (SV*)av);
54310121 5051 AvFLAGS(av) = AVf_REIFY;
79072805 5052
3280af22 5053 for (ix = AvFILLp(PL_comppad); ix > 0; ix--) {
7766f137 5054 if (SvIMMORTAL(PL_curpad[ix]) || IS_PADGV(PL_curpad[ix]) || IS_PADCONST(PL_curpad[ix]))
54310121 5055 continue;
3280af22
NIS		 5056 if (!SvPADMY(PL_curpad[ix]))
5057 SvPADTMP_on(PL_curpad[ix]);
54310121 5058 }
5059 }
79072805 5060
afa38808 5061 /* If a potential closure prototype, don't keep a refcount on outer CV.
282f25c9
JH		 5062 * This is okay as the lifetime of the prototype is tied to the
5063 * lifetime of the outer CV. Avoids memory leak due to reference
5064 * loop. --GSAR */
afa38808 5065 if (!name)
282f25c9
JH		 5066 SvREFCNT_dec(CvOUTSIDE(cv));
5067
83ee9e09 5068 if (name || aname) {
44a8e56a 5069 char *s;
83ee9e09 5070 char *tname = (name ? name : aname);
44a8e56a 5071
3280af22 5072 if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
46fc3d4c 5073 SV *sv = NEWSV(0,0);
44a8e56a 5074 SV *tmpstr = sv_newmortal();
549bb64a 5075 GV *db_postponed = gv_fetchpv("DB::postponed", GV_ADDMULTI, SVt_PVHV);
83ee9e09 5076 CV *pcv;
44a8e56a 5077 HV *hv;
5078
ed094faf
GS		 5079 Perl_sv_setpvf(aTHX_ sv, "%s:%ld-%ld",
5080 CopFILE(PL_curcop),
cc49e20b 5081 (long)PL_subline, (long)CopLINE(PL_curcop));
44a8e56a 5082 gv_efullname3(tmpstr, gv, Nullch);
3280af22 5083 hv_store(GvHV(PL_DBsub), SvPVX(tmpstr), SvCUR(tmpstr), sv, 0);
44a8e56a 5084 hv = GvHVn(db_postponed);
9607fc9c 5085 if (HvFILL(hv) > 0 && hv_exists(hv, SvPVX(tmpstr), SvCUR(tmpstr))
83ee9e09
GS		 5086 && (pcv = GvCV(db_postponed)))
5087 {
44a8e56a 5088 dSP;
924508f0 5089 PUSHMARK(SP);
44a8e56a 5090 XPUSHs(tmpstr);
5091 PUTBACK;
83ee9e09 5092 call_sv((SV*)pcv, G_DISCARD);
44a8e56a 5093 }
5094 }
79072805 5095
83ee9e09 5096 if ((s = strrchr(tname,':')))
28757baa 5097 s++;
5098 else
83ee9e09 5099 s = tname;
ed094faf 5100
7d30b5c4 5101 if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I')
ed094faf
GS		 5102 goto done;
5103
68dc0745 5104 if (strEQ(s, "BEGIN")) {
3280af22 5105 I32 oldscope = PL_scopestack_ix;
28757baa 5106 ENTER;
57843af0
GS		 5107 SAVECOPFILE(&PL_compiling);
5108 SAVECOPLINE(&PL_compiling);
28757baa 5109
3280af22
NIS		 5110 if (!PL_beginav)
5111 PL_beginav = newAV();
28757baa 5112 DEBUG_x( dump_sub(gv) );
ea2f84a3
GS		 5113 av_push(PL_beginav, (SV*)cv);
5114 GvCV(gv) = 0; /* cv has been hijacked */
3280af22 5115 call_list(oldscope, PL_beginav);
a6006777 5116
3280af22 5117 PL_curcop = &PL_compiling;
a0ed51b3 5118 PL_compiling.op_private = PL_hints;
28757baa 5119 LEAVE;
5120 }
3280af22
NIS		 5121 else if (strEQ(s, "END") && !PL_error_count) {
5122 if (!PL_endav)
5123 PL_endav = newAV();
ed094faf 5124 DEBUG_x( dump_sub(gv) );
3280af22 5125 av_unshift(PL_endav, 1);
ea2f84a3
GS		 5126 av_store(PL_endav, 0, (SV*)cv);
5127 GvCV(gv) = 0; /* cv has been hijacked */
28757baa 5128 }
7d30b5c4
GS		 5129 else if (strEQ(s, "CHECK") && !PL_error_count) {
5130 if (!PL_checkav)
5131 PL_checkav = newAV();
ed094faf 5132 DEBUG_x( dump_sub(gv) );
ddda08b7 5133 if (PL_main_start && ckWARN(WARN_VOID))
9014280d 5134 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run CHECK block");
7d30b5c4 5135 av_unshift(PL_checkav, 1);
ea2f84a3
GS		 5136 av_store(PL_checkav, 0, (SV*)cv);
5137 GvCV(gv) = 0; /* cv has been hijacked */
4f25aa18 5138 }
3280af22
NIS		 5139 else if (strEQ(s, "INIT") && !PL_error_count) {
5140 if (!PL_initav)
5141 PL_initav = newAV();
ed094faf 5142 DEBUG_x( dump_sub(gv) );
ddda08b7 5143 if (PL_main_start && ckWARN(WARN_VOID))
9014280d 5144 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run INIT block");
ea2f84a3
GS		 5145 av_push(PL_initav, (SV*)cv);
5146 GvCV(gv) = 0; /* cv has been hijacked */
ae77835f 5147 }
79072805 5148 }
a6006777 5149
aa689395 5150 done:
3280af22 5151 PL_copline = NOLINE;
8990e307 5152 LEAVE_SCOPE(floor);
a0d0e21e 5153 return cv;
79072805
LW		 5154}
5155
b099ddc0 5156/* XXX unsafe for threads if eval_owner isn't held */
954c1994
GS		 5157/*
5158=for apidoc newCONSTSUB
5159
5160Creates a constant sub equivalent to Perl C<sub FOO () { 123 }> which is
5161eligible for inlining at compile-time.
5162
5163=cut
5164*/
5165
beab0874 5166CV *
864dbfa3 5167Perl_newCONSTSUB(pTHX_ HV *stash, char *name, SV *sv)
5476c433 5168{
beab0874 5169 CV* cv;
5476c433 5170
11faa288 5171 ENTER;
11faa288 5172
f4dd75d9 5173 SAVECOPLINE(PL_curcop);
11faa288 5174 CopLINE_set(PL_curcop, PL_copline);
f4dd75d9
GS		 5175
5176 SAVEHINTS();
3280af22 5177 PL_hints &= ~HINT_BLOCK_SCOPE;
11faa288
GS		 5178
5179 if (stash) {
5180 SAVESPTR(PL_curstash);
5181 SAVECOPSTASH(PL_curcop);
5182 PL_curstash = stash;
05ec9bb3 5183 CopSTASH_set(PL_curcop,stash);
11faa288 5184 }
5476c433 5185
beab0874
JT		 5186 cv = newXS(name, const_sv_xsub, __FILE__);
5187 CvXSUBANY(cv).any_ptr = sv;
5188 CvCONST_on(cv);
5189 sv_setpv((SV*)cv, ""); /* prototype is "" */
5476c433 5190
11faa288 5191 LEAVE;
beab0874
JT		 5192
5193 return cv;
5476c433
JD		 5194}
5195
954c1994
GS		 5196/*
5197=for apidoc U||newXS
5198
5199Used by C<xsubpp> to hook up XSUBs as Perl subs.
5200
5201=cut
5202*/
5203
57d3b86d 5204CV *
864dbfa3 5205Perl_newXS(pTHX_ char *name, XSUBADDR_t subaddr, char *filename)
a0d0e21e 5206{
c99da370
JH		 5207 GV *gv = gv_fetchpv(name ? name :
5208 (PL_curstash ? "__ANON__" : "__ANON__::__ANON__"),
5209 GV_ADDMULTI, SVt_PVCV);
79072805 5210 register CV *cv;
44a8e56a 5211
155aba94 5212 if ((cv = (name ? GvCV(gv) : Nullcv))) {
44a8e56a 5213 if (GvCVGEN(gv)) {
5214 /* just a cached method */
5215 SvREFCNT_dec(cv);
5216 cv = 0;
5217 }
5218 else if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) {
5219 /* already defined (or promised) */
599cee73 5220 if (ckWARN(WARN_REDEFINE) && !(CvGV(cv) && GvSTASH(CvGV(cv))
2f34f9d4 5221 && strEQ(HvNAME(GvSTASH(CvGV(cv))), "autouse"))) {
57843af0 5222 line_t oldline = CopLINE(PL_curcop);
51f6edd3 5223 if (PL_copline != NOLINE)
57843af0 5224 CopLINE_set(PL_curcop, PL_copline);
9014280d 5225 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
beab0874
JT		 5226 CvCONST(cv) ? "Constant subroutine %s redefined"
5227 : "Subroutine %s redefined"
5228 ,name);
57843af0 5229 CopLINE_set(PL_curcop, oldline);
a0d0e21e
LW		 5230 }
5231 SvREFCNT_dec(cv);
5232 cv = 0;
79072805 5233 }
79072805 5234 }
44a8e56a 5235
5236 if (cv) /* must reuse cv if autoloaded */
5237 cv_undef(cv);
a0d0e21e
LW		 5238 else {
5239 cv = (CV*)NEWSV(1105,0);
5240 sv_upgrade((SV *)cv, SVt_PVCV);
44a8e56a 5241 if (name) {
5242 GvCV(gv) = cv;
5243 GvCVGEN(gv) = 0;
3280af22 5244 PL_sub_generation++;
44a8e56a 5245 }
a0d0e21e 5246 }
65c50114 5247 CvGV(cv) = gv;
4d1ff10f 5248#ifdef USE_5005THREADS
12ca11f6 5249 New(666, CvMUTEXP(cv), 1, perl_mutex);
11343788 5250 MUTEX_INIT(CvMUTEXP(cv));
11343788 5251 CvOWNER(cv) = 0;
4d1ff10f 5252#endif /* USE_5005THREADS */
b195d487 5253 (void)gv_fetchfile(filename);
57843af0
GS		 5254 CvFILE(cv) = filename; /* NOTE: not copied, as it is expected to be
5255 an external constant string */
a0d0e21e 5256 CvXSUB(cv) = subaddr;
44a8e56a 5257
28757baa 5258 if (name) {
5259 char *s = strrchr(name,':');
5260 if (s)
5261 s++;
5262 else
5263 s = name;
ed094faf 5264
7d30b5c4 5265 if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I')
ed094faf
GS		 5266 goto done;
5267
28757baa 5268 if (strEQ(s, "BEGIN")) {
3280af22
NIS		 5269 if (!PL_beginav)
5270 PL_beginav = newAV();
ea2f84a3
GS		 5271 av_push(PL_beginav, (SV*)cv);
5272 GvCV(gv) = 0; /* cv has been hijacked */
28757baa 5273 }
5274 else if (strEQ(s, "END")) {
3280af22
NIS		 5275 if (!PL_endav)
5276 PL_endav = newAV();
5277 av_unshift(PL_endav, 1);
ea2f84a3
GS		 5278 av_store(PL_endav, 0, (SV*)cv);
5279 GvCV(gv) = 0; /* cv has been hijacked */
28757baa 5280 }
7d30b5c4
GS		 5281 else if (strEQ(s, "CHECK")) {
5282 if (!PL_checkav)
5283 PL_checkav = newAV();
ddda08b7 5284 if (PL_main_start && ckWARN(WARN_VOID))
9014280d 5285 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run CHECK block");
7d30b5c4 5286 av_unshift(PL_checkav, 1);
ea2f84a3
GS		 5287 av_store(PL_checkav, 0, (SV*)cv);
5288 GvCV(gv) = 0; /* cv has been hijacked */
4f25aa18 5289 }
7d07dbc2 5290 else if (strEQ(s, "INIT")) {
3280af22
NIS		 5291 if (!PL_initav)
5292 PL_initav = newAV();
ddda08b7 5293 if (PL_main_start && ckWARN(WARN_VOID))
9014280d 5294 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run INIT block");
ea2f84a3
GS		 5295 av_push(PL_initav, (SV*)cv);
5296 GvCV(gv) = 0; /* cv has been hijacked */
ae77835f 5297 }
28757baa 5298 }
8990e307 5299 else
a5f75d66 5300 CvANON_on(cv);
44a8e56a 5301
ed094faf 5302done:
a0d0e21e 5303 return cv;
79072805
LW		 5304}
5305
5306void
864dbfa3 5307Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block)
79072805
LW		 5308{
5309 register CV *cv;
5310 char *name;
5311 GV *gv;
a0d0e21e 5312 I32 ix;
2d8e6c8d 5313 STRLEN n_a;
79072805 5314
11343788 5315 if (o)
2d8e6c8d 5316 name = SvPVx(cSVOPo->op_sv, n_a);
79072805
LW		 5317 else
5318 name = "STDOUT";
85e6fe83 5319 gv = gv_fetchpv(name,TRUE, SVt_PVFM);
7fb37951
AMS		 5320#ifdef GV_UNIQUE_CHECK
5321 if (GvUNIQUE(gv)) {
5322 Perl_croak(aTHX_ "Bad symbol for form (GV is unique)");
5bd07a3d
DM		 5323 }
5324#endif
a5f75d66 5325 GvMULTI_on(gv);
155aba94 5326 if ((cv = GvFORM(gv))) {
599cee73 5327 if (ckWARN(WARN_REDEFINE)) {
57843af0 5328 line_t oldline = CopLINE(PL_curcop);
d8a34499
IK		 5329 if (PL_copline != NOLINE)
5330 CopLINE_set(PL_curcop, PL_copline);
9014280d 5331 Perl_warner(aTHX_ packWARN(WARN_REDEFINE), "Format %s redefined",name);
57843af0 5332 CopLINE_set(PL_curcop, oldline);
79072805 5333 }
8990e307 5334 SvREFCNT_dec(cv);
79072805 5335 }
3280af22 5336 cv = PL_compcv;
79072805 5337 GvFORM(gv) = cv;
65c50114 5338 CvGV(cv) = gv;
a636914a 5339 CvFILE_set_from_cop(cv, PL_curcop);
79072805 5340
3280af22
NIS		 5341 for (ix = AvFILLp(PL_comppad); ix > 0; ix--) {
5342 if (!SvPADMY(PL_curpad[ix]) && !SvIMMORTAL(PL_curpad[ix]))
5343 SvPADTMP_on(PL_curpad[ix]);
a0d0e21e
LW		 5344 }
5345
79072805 5346 CvROOT(cv) = newUNOP(OP_LEAVEWRITE, 0, scalarseq(block));
7934575e
GS		 5347 CvROOT(cv)->op_private |= OPpREFCOUNTED;
5348 OpREFCNT_set(CvROOT(cv), 1);
79072805
LW		 5349 CvSTART(cv) = LINKLIST(CvROOT(cv));
5350 CvROOT(cv)->op_next = 0;
a2efc822 5351 CALL_PEEP(CvSTART(cv));
11343788 5352 op_free(o);
3280af22 5353 PL_copline = NOLINE;
8990e307 5354 LEAVE_SCOPE(floor);
79072805
LW		 5355}
5356
5357OP *
864dbfa3 5358Perl_newANONLIST(pTHX_ OP *o)
79072805 5359{
93a17b20 5360 return newUNOP(OP_REFGEN, 0,
11343788 5361 mod(list(convert(OP_ANONLIST, 0, o)), OP_REFGEN));
79072805
LW		 5362}
5363
5364OP *
864dbfa3 5365Perl_newANONHASH(pTHX_ OP *o)
79072805 5366{
93a17b20 5367 return newUNOP(OP_REFGEN, 0,
11343788 5368 mod(list(convert(OP_ANONHASH, 0, o)), OP_REFGEN));
a0d0e21e
LW		 5369}
5370
5371OP *
864dbfa3 5372Perl_newANONSUB(pTHX_ I32 floor, OP *proto, OP *block)
a0d0e21e 5373{
09bef843
SB		 5374 return newANONATTRSUB(floor, proto, Nullop, block);
5375}
5376
5377OP *
5378Perl_newANONATTRSUB(pTHX_ I32 floor, OP *proto, OP *attrs, OP *block)
5379{
a0d0e21e 5380 return newUNOP(OP_REFGEN, 0,
09bef843
SB		 5381 newSVOP(OP_ANONCODE, 0,
5382 (SV*)newATTRSUB(floor, 0, proto, attrs, block)));
79072805
LW		 5383}
5384
5385OP *
864dbfa3 5386Perl_oopsAV(pTHX_ OP *o)
79072805 5387{
ed6116ce
LW		 5388 switch (o->op_type) {
5389 case OP_PADSV:
5390 o->op_type = OP_PADAV;
22c35a8c 5391 o->op_ppaddr = PL_ppaddr[OP_PADAV];
51e247a3 5392 return ref(o, OP_RV2AV);
b2ffa427 5393
ed6116ce 5394 case OP_RV2SV:
79072805 5395 o->op_type = OP_RV2AV;
22c35a8c 5396 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
79072805 5397 ref(o, OP_RV2AV);
ed6116ce
LW		 5398 break;
5399
5400 default:
0453d815 5401 if (ckWARN_d(WARN_INTERNAL))
9014280d 5402 Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsAV");
ed6116ce
LW		 5403 break;
5404 }
79072805
LW		 5405 return o;
5406}
5407
5408OP *
864dbfa3 5409Perl_oopsHV(pTHX_ OP *o)
79072805 5410{
ed6116ce
LW		 5411 switch (o->op_type) {
5412 case OP_PADSV:
5413 case OP_PADAV:
5414 o->op_type = OP_PADHV;
22c35a8c 5415 o->op_ppaddr = PL_ppaddr[OP_PADHV];
51e247a3 5416 return ref(o, OP_RV2HV);
ed6116ce
LW		 5417
5418 case OP_RV2SV:
5419 case OP_RV2AV:
79072805 5420 o->op_type = OP_RV2HV;
22c35a8c 5421 o->op_ppaddr = PL_ppaddr[OP_RV2HV];
79072805 5422 ref(o, OP_RV2HV);
ed6116ce
LW		 5423 break;
5424
5425 default:
0453d815 5426 if (ckWARN_d(WARN_INTERNAL))
9014280d 5427 Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsHV");
ed6116ce
LW		 5428 break;
5429 }
79072805
LW		 5430 return o;
5431}
5432
5433OP *
864dbfa3 5434Perl_newAVREF(pTHX_ OP *o)
79072805 5435{
ed6116ce
LW		 5436 if (o->op_type == OP_PADANY) {
5437 o->op_type = OP_PADAV;
22c35a8c 5438 o->op_ppaddr = PL_ppaddr[OP_PADAV];
93a17b20 5439 return o;
ed6116ce 5440 }
a1063b2d 5441 else if ((o->op_type == OP_RV2AV || o->op_type == OP_PADAV)
9014280d
PM		 5442 && ckWARN(WARN_DEPRECATED)) {
5443 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
a1063b2d
RH		 5444 "Using an array as a reference is deprecated");
5445 }
79072805
LW		 5446 return newUNOP(OP_RV2AV, 0, scalar(o));
5447}
5448
5449OP *
864dbfa3 5450Perl_newGVREF(pTHX_ I32 type, OP *o)
79072805 5451{
82092f1d 5452 if (type == OP_MAPSTART || type == OP_GREPSTART || type == OP_SORT)
a0d0e21e 5453 return newUNOP(OP_NULL, 0, o);
748a9306 5454 return ref(newUNOP(OP_RV2GV, OPf_REF, o), type);
79072805
LW		 5455}
5456
5457OP *
864dbfa3 5458Perl_newHVREF(pTHX_ OP *o)
79072805 5459{
ed6116ce
LW		 5460 if (o->op_type == OP_PADANY) {
5461 o->op_type = OP_PADHV;
22c35a8c 5462 o->op_ppaddr = PL_ppaddr[OP_PADHV];
93a17b20 5463 return o;
ed6116ce 5464 }
a1063b2d 5465 else if ((o->op_type == OP_RV2HV || o->op_type == OP_PADHV)
9014280d
PM		 5466 && ckWARN(WARN_DEPRECATED)) {
5467 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
a1063b2d
RH		 5468 "Using a hash as a reference is deprecated");
5469 }
79072805
LW		 5470 return newUNOP(OP_RV2HV, 0, scalar(o));
5471}
5472
5473OP *
864dbfa3 5474Perl_oopsCV(pTHX_ OP *o)
79072805 5475{
cea2e8a9 5476 Perl_croak(aTHX_ "NOT IMPL LINE %d",__LINE__);
79072805
LW		 5477 /* STUB */
5478 return o;
5479}
5480
5481OP *
864dbfa3 5482Perl_newCVREF(pTHX_ I32 flags, OP *o)
79072805 5483{
c07a80fd 5484 return newUNOP(OP_RV2CV, flags, scalar(o));
79072805
LW		 5485}
5486
5487OP *
864dbfa3 5488Perl_newSVREF(pTHX_ OP *o)
79072805 5489{
ed6116ce
LW		 5490 if (o->op_type == OP_PADANY) {
5491 o->op_type = OP_PADSV;
22c35a8c 5492 o->op_ppaddr = PL_ppaddr[OP_PADSV];
93a17b20 5493 return o;
ed6116ce 5494 }
224a4551
MB		 5495 else if (o->op_type == OP_THREADSV && !(o->op_flags & OPpDONE_SVREF)) {
5496 o->op_flags |= OPpDONE_SVREF;
a863c7d1 5497 return o;
224a4551 5498 }
79072805
LW		 5499 return newUNOP(OP_RV2SV, 0, scalar(o));
5500}
5501
5502/* Check routines. */
5503
5504OP *
cea2e8a9 5505Perl_ck_anoncode(pTHX_ OP *o)
5f05dabc 5506{
178c6305
CS		 5507 PADOFFSET ix;
5508 SV* name;
5509
5510 name = NEWSV(1106,0);
5511 sv_upgrade(name, SVt_PVNV);
5512 sv_setpvn(name, "&", 1);
5513 SvIVX(name) = -1;
5514 SvNVX(name) = 1;
5dc0d613 5515 ix = pad_alloc(o->op_type, SVs_PADMY);
3280af22
NIS		 5516 av_store(PL_comppad_name, ix, name);
5517 av_store(PL_comppad, ix, cSVOPo->op_sv);
5dc0d613
MB		 5518 SvPADMY_on(cSVOPo->op_sv);
5519 cSVOPo->op_sv = Nullsv;
5520 cSVOPo->op_targ = ix;
5521 return o;
5f05dabc 5522}
5523
5524OP *
cea2e8a9 5525Perl_ck_bitop(pTHX_ OP *o)
55497cff 5526{
3280af22 5527 o->op_private = PL_hints;
5dc0d613 5528 return o;
55497cff 5529}
5530
5531OP *
cea2e8a9 5532Perl_ck_concat(pTHX_ OP *o)
79072805 5533{
11343788
MB		 5534 if (cUNOPo->op_first->op_type == OP_CONCAT)
5535 o->op_flags |= OPf_STACKED;
5536 return o;
79072805
LW		 5537}
5538
5539OP *
cea2e8a9 5540Perl_ck_spair(pTHX_ OP *o)
79072805 5541{
11343788 5542 if (o->op_flags & OPf_KIDS) {
79072805 5543 OP* newop;
a0d0e21e 5544 OP* kid;
5dc0d613
MB		 5545 OPCODE type = o->op_type;
5546 o = modkids(ck_fun(o), type);
11343788 5547 kid = cUNOPo->op_first;
a0d0e21e
LW		 5548 newop = kUNOP->op_first->op_sibling;
5549 if (newop &&
5550 (newop->op_sibling ||
22c35a8c 5551 !(PL_opargs[newop->op_type] & OA_RETSCALAR) ||
a0d0e21e
LW		 5552 newop->op_type == OP_PADAV || newop->op_type == OP_PADHV ||
5553 newop->op_type == OP_RV2AV || newop->op_type == OP_RV2HV)) {
b2ffa427 5554
11343788 5555 return o;
a0d0e21e
LW		 5556 }
5557 op_free(kUNOP->op_first);
5558 kUNOP->op_first = newop;
5559 }
22c35a8c 5560 o->op_ppaddr = PL_ppaddr[++o->op_type];
11343788 5561 return ck_fun(o);
a0d0e21e
LW		 5562}
5563
5564OP *
cea2e8a9 5565Perl_ck_delete(pTHX_ OP *o)
a0d0e21e 5566{
11343788 5567 o = ck_fun(o);
5dc0d613 5568 o->op_private = 0;
11343788
MB		 5569 if (o->op_flags & OPf_KIDS) {
5570 OP *kid = cUNOPo->op_first;
01020589
GS		 5571 switch (kid->op_type) {
5572 case OP_ASLICE:
5573 o->op_flags |= OPf_SPECIAL;
5574 /* FALL THROUGH */
5575 case OP_HSLICE:
5dc0d613 5576 o->op_private |= OPpSLICE;
01020589
GS		 5577 break;
5578 case OP_AELEM:
5579 o->op_flags |= OPf_SPECIAL;
5580 /* FALL THROUGH */
5581 case OP_HELEM:
5582 break;
5583 default:
5584 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element or slice",
53e06cf0 5585 OP_DESC(o));
01020589 5586 }
93c66552 5587 op_null(kid);
79072805 5588 }
11343788 5589 return o;
79072805
LW		 5590}
5591
5592OP *
96e176bf
CL		 5593Perl_ck_die(pTHX_ OP *o)
5594{
5595#ifdef VMS
5596 if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
5597#endif
5598 return ck_fun(o);
5599}
5600
5601OP *
cea2e8a9 5602Perl_ck_eof(pTHX_ OP *o)
79072805 5603{
11343788 5604 I32 type = o->op_type;
79072805 5605
11343788
MB		 5606 if (o->op_flags & OPf_KIDS) {
5607 if (cLISTOPo->op_first->op_type == OP_STUB) {
5608 op_free(o);
5609 o = newUNOP(type, OPf_SPECIAL,
d58bf5aa 5610 newGVOP(OP_GV, 0, gv_fetchpv("main::ARGV", TRUE, SVt_PVAV)));
8990e307 5611 }
11343788 5612 return ck_fun(o);
79072805 5613 }
11343788 5614 return o;
79072805
LW		 5615}
5616
5617OP *
cea2e8a9 5618Perl_ck_eval(pTHX_ OP *o)
79072805 5619{
3280af22 5620 PL_hints |= HINT_BLOCK_SCOPE;
11343788
MB		 5621 if (o->op_flags & OPf_KIDS) {
5622 SVOP *kid = (SVOP*)cUNOPo->op_first;
79072805 5623
93a17b20 5624 if (!kid) {
11343788 5625 o->op_flags &= ~OPf_KIDS;
93c66552 5626 op_null(o);
79072805
LW		 5627 }
5628 else if (kid->op_type == OP_LINESEQ) {
5629 LOGOP *enter;
5630
11343788
MB		 5631 kid->op_next = o->op_next;
5632 cUNOPo->op_first = 0;
5633 op_free(o);
79072805 5634
b7dc083c 5635 NewOp(1101, enter, 1, LOGOP);
79072805 5636 enter->op_type = OP_ENTERTRY;
22c35a8c 5637 enter->op_ppaddr = PL_ppaddr[OP_ENTERTRY];
79072805
LW		 5638 enter->op_private = 0;
5639
5640 /* establish postfix order */
5641 enter->op_next = (OP*)enter;
5642
11343788
MB		 5643 o = prepend_elem(OP_LINESEQ, (OP*)enter, (OP*)kid);
5644 o->op_type = OP_LEAVETRY;
22c35a8c 5645 o->op_ppaddr = PL_ppaddr[OP_LEAVETRY];
11343788
MB		 5646 enter->op_other = o;
5647 return o;
79072805 5648 }
c7cc6f1c 5649 else
473986ff 5650 scalar((OP*)kid);
79072805
LW		 5651 }
5652 else {
11343788 5653 op_free(o);
54b9620d 5654 o = newUNOP(OP_ENTEREVAL, 0, newDEFSVOP());
79072805 5655 }
3280af22 5656 o->op_targ = (PADOFFSET)PL_hints;
11343788 5657 return o;
79072805
LW		 5658}
5659
5660OP *
d98f61e7
GS		 5661Perl_ck_exit(pTHX_ OP *o)
5662{
5663#ifdef VMS
5664 HV *table = GvHV(PL_hintgv);
5665 if (table) {
5666 SV **svp = hv_fetch(table, "vmsish_exit", 11, FALSE);
5667 if (svp && *svp && SvTRUE(*svp))
5668 o->op_private |= OPpEXIT_VMSISH;
5669 }
96e176bf 5670 if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
d98f61e7
GS		 5671#endif
5672 return ck_fun(o);
5673}
5674
5675OP *
cea2e8a9 5676Perl_ck_exec(pTHX_ OP *o)
79072805
LW		 5677{
5678 OP *kid;
11343788
MB		 5679 if (o->op_flags & OPf_STACKED) {
5680 o = ck_fun(o);
5681 kid = cUNOPo->op_first->op_sibling;
8990e307 5682 if (kid->op_type == OP_RV2GV)
93c66552 5683 op_null(kid);
79072805 5684 }
463ee0b2 5685 else
11343788
MB		 5686 o = listkids(o);
5687 return o;
79072805
LW		 5688}
5689
5690OP *
cea2e8a9 5691Perl_ck_exists(pTHX_ OP *o)
5f05dabc 5692{
5196be3e
MB		 5693 o = ck_fun(o);
5694 if (o->op_flags & OPf_KIDS) {
5695 OP *kid = cUNOPo->op_first;
afebc493
GS		 5696 if (kid->op_type == OP_ENTERSUB) {
5697 (void) ref(kid, o->op_type);
5698 if (kid->op_type != OP_RV2CV && !PL_error_count)
5699 Perl_croak(aTHX_ "%s argument is not a subroutine name",
53e06cf0 5700 OP_DESC(o));
afebc493
GS		 5701 o->op_private |= OPpEXISTS_SUB;
5702 }
5703 else if (kid->op_type == OP_AELEM)
01020589
GS		 5704 o->op_flags |= OPf_SPECIAL;
5705 else if (kid->op_type != OP_HELEM)
5706 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element",
53e06cf0 5707 OP_DESC(o));
93c66552 5708 op_null(kid);
5f05dabc 5709 }
5196be3e 5710 return o;
5f05dabc 5711}
5712
22c35a8c 5713#if 0
5f05dabc 5714OP *
cea2e8a9 5715Perl_ck_gvconst(pTHX_ register OP *o)
79072805
LW		 5716{
5717 o = fold_constants(o);
5718 if (o->op_type == OP_CONST)
5719 o->op_type = OP_GV;
5720 return o;
5721}
22c35a8c 5722#endif
79072805
LW		 5723
5724OP *
cea2e8a9 5725Perl_ck_rvconst(pTHX_ register OP *o)
79072805 5726{
11343788 5727 SVOP *kid = (SVOP*)cUNOPo->op_first;
85e6fe83 5728
3280af22 5729 o->op_private |= (PL_hints & HINT_STRICT_REFS);
79072805 5730 if (kid->op_type == OP_CONST) {
44a8e56a 5731 char *name;
5732 int iscv;
5733 GV *gv;
779c5bc9 5734 SV *kidsv = kid->op_sv;
2d8e6c8d 5735 STRLEN n_a;
44a8e56a 5736
779c5bc9
GS		 5737 /* Is it a constant from cv_const_sv()? */
5738 if (SvROK(kidsv) && SvREADONLY(kidsv)) {
5739 SV *rsv = SvRV(kidsv);
5740 int svtype = SvTYPE(rsv);
5741 char *badtype = Nullch;
5742
5743 switch (o->op_type) {
5744 case OP_RV2SV:
5745 if (svtype > SVt_PVMG)
5746 badtype = "a SCALAR";
5747 break;
5748 case OP_RV2AV:
5749 if (svtype != SVt_PVAV)
5750 badtype = "an ARRAY";
5751 break;
5752 case OP_RV2HV:
5753 if (svtype != SVt_PVHV) {
5754 if (svtype == SVt_PVAV) { /* pseudohash? */
5755 SV **ksv = av_fetch((AV*)rsv, 0, FALSE);
5756 if (ksv && SvROK(*ksv)
5757 && SvTYPE(SvRV(*ksv)) == SVt_PVHV)
5758 {
5759 break;
5760 }
5761 }
5762 badtype = "a HASH";
5763 }
5764 break;
5765 case OP_RV2CV:
5766 if (svtype != SVt_PVCV)
5767 badtype = "a CODE";
5768 break;
5769 }
5770 if (badtype)
cea2e8a9 5771 Perl_croak(aTHX_ "Constant is not %s reference", badtype);
779c5bc9
GS		 5772 return o;
5773 }
2d8e6c8d 5774 name = SvPV(kidsv, n_a);
3280af22 5775 if ((PL_hints & HINT_STRICT_REFS) && (kid->op_private & OPpCONST_BARE)) {
44a8e56a 5776 char *badthing = Nullch;
5dc0d613 5777 switch (o->op_type) {
44a8e56a 5778 case OP_RV2SV:
5779 badthing = "a SCALAR";
5780 break;
5781 case OP_RV2AV:
5782 badthing = "an ARRAY";
5783 break;
5784 case OP_RV2HV:
5785 badthing = "a HASH";
5786 break;
5787 }
5788 if (badthing)
1c846c1f 5789 Perl_croak(aTHX_
44a8e56a 5790 "Can't use bareword (\"%s\") as %s ref while \"strict refs\" in use",
5791 name, badthing);
5792 }
93233ece
CS		 5793 /*
5794 * This is a little tricky. We only want to add the symbol if we
5795 * didn't add it in the lexer. Otherwise we get duplicate strict
5796 * warnings. But if we didn't add it in the lexer, we must at
5797 * least pretend like we wanted to add it even if it existed before,
5798 * or we get possible typo warnings. OPpCONST_ENTERED says
5799 * whether the lexer already added THIS instance of this symbol.
5800 */
5196be3e 5801 iscv = (o->op_type == OP_RV2CV) * 2;
93233ece 5802 do {
44a8e56a 5803 gv = gv_fetchpv(name,
748a9306 5804 iscv | !(kid->op_private & OPpCONST_ENTERED),
a0d0e21e
LW		 5805 iscv
5806 ? SVt_PVCV
11343788 5807 : o->op_type == OP_RV2SV
a0d0e21e 5808 ? SVt_PV
11343788 5809 : o->op_type == OP_RV2AV
a0d0e21e 5810 ? SVt_PVAV
11343788 5811 : o->op_type == OP_RV2HV
a0d0e21e
LW		 5812 ? SVt_PVHV
5813 : SVt_PVGV);
93233ece
CS		 5814 } while (!gv && !(kid->op_private & OPpCONST_ENTERED) && !iscv++);
5815 if (gv) {
5816 kid->op_type = OP_GV;
5817 SvREFCNT_dec(kid->op_sv);
350de78d 5818#ifdef USE_ITHREADS
638eceb6 5819 /* XXX hack: dependence on sizeof(PADOP) <= sizeof(SVOP) */
350de78d 5820 kPADOP->op_padix = pad_alloc(OP_GV, SVs_PADTMP);
63caf608 5821 SvREFCNT_dec(PL_curpad[kPADOP->op_padix]);
743e66e6 5822 GvIN_PAD_on(gv);
350de78d
GS		 5823 PL_curpad[kPADOP->op_padix] = SvREFCNT_inc(gv);
5824#else
93233ece 5825 kid->op_sv = SvREFCNT_inc(gv);
350de78d 5826#endif
23f1ca44 5827 kid->op_private = 0;
76cd736e 5828 kid->op_ppaddr = PL_ppaddr[OP_GV];
a0d0e21e 5829 }
79072805 5830 }
11343788 5831 return o;
79072805
LW		 5832}
5833
5834OP *
cea2e8a9 5835Perl_ck_ftst(pTHX_ OP *o)
79072805 5836{
11343788 5837 I32 type = o->op_type;
79072805 5838
d0dca557
JD		 5839 if (o->op_flags & OPf_REF) {
5840 /* nothing */
5841 }
5842 else if (o->op_flags & OPf_KIDS && cUNOPo->op_first->op_type != OP_STUB) {
11343788 5843 SVOP *kid = (SVOP*)cUNOPo->op_first;
79072805
LW		 5844
5845 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
2d8e6c8d 5846 STRLEN n_a;
a0d0e21e 5847 OP *newop = newGVOP(type, OPf_REF,
2d8e6c8d 5848 gv_fetchpv(SvPVx(kid->op_sv, n_a), TRUE, SVt_PVIO));
11343788 5849 op_free(o);
d0dca557 5850 o = newop;
79072805
LW		 5851 }
5852 }
5853 else {
11343788 5854 op_free(o);
79072805 5855 if (type == OP_FTTTY)
d0dca557 5856 o = newGVOP(type, OPf_REF, gv_fetchpv("main::STDIN", TRUE,
85e6fe83 5857 SVt_PVIO));
79072805 5858 else
d0dca557 5859 o = newUNOP(type, 0, newDEFSVOP());
79072805 5860 }
11343788 5861 return o;
79072805
LW		 5862}
5863
5864OP *
cea2e8a9 5865Perl_ck_fun(pTHX_ OP *o)
79072805
LW		 5866{
5867 register OP *kid;
5868 OP **tokid;
5869 OP *sibl;
5870 I32 numargs = 0;
11343788 5871 int type = o->op_type;
22c35a8c 5872 register I32 oa = PL_opargs[type] >> OASHIFT;
aeea060c 5873
11343788 5874 if (o->op_flags & OPf_STACKED) {
79072805
LW		 5875 if ((oa & OA_OPTIONAL) && (oa >> 4) && !((oa >> 4) & OA_OPTIONAL))
5876 oa &= ~OA_OPTIONAL;
5877 else
11343788 5878 return no_fh_allowed(o);
79072805
LW		 5879 }
5880
11343788 5881 if (o->op_flags & OPf_KIDS) {
2d8e6c8d 5882 STRLEN n_a;
11343788
MB		 5883 tokid = &cLISTOPo->op_first;
5884 kid = cLISTOPo->op_first;
8990e307 5885 if (kid->op_type == OP_PUSHMARK ||
155aba94 5886 (kid->op_type == OP_NULL && kid->op_targ == OP_PUSHMARK))
8990e307 5887 {
79072805
LW		 5888 tokid = &kid->op_sibling;
5889 kid = kid->op_sibling;
5890 }
22c35a8c 5891 if (!kid && PL_opargs[type] & OA_DEFGV)
54b9620d 5892 *tokid = kid = newDEFSVOP();
79072805
LW		 5893
5894 while (oa && kid) {
5895 numargs++;
5896 sibl = kid->op_sibling;
5897 switch (oa & 7) {
5898 case OA_SCALAR:
62c18ce2
GS		 5899 /* list seen where single (scalar) arg expected? */
5900 if (numargs == 1 && !(oa >> 4)
5901 && kid->op_type == OP_LIST && type != OP_SCALAR)
5902 {
5903 return too_many_arguments(o,PL_op_desc[type]);
5904 }
79072805
LW		 5905 scalar(kid);
5906 break;
5907 case OA_LIST:
5908 if (oa < 16) {
5909 kid = 0;
5910 continue;
5911 }
5912 else
5913 list(kid);
5914 break;
5915 case OA_AVREF:
936edb8b 5916 if ((type == OP_PUSH || type == OP_UNSHIFT)
f87c3213 5917 && !kid->op_sibling && ckWARN(WARN_SYNTAX))
9014280d 5918 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
de4864e4 5919 "Useless use of %s with no values",
936edb8b 5920 PL_op_desc[type]);
b2ffa427 5921
79072805 5922 if (kid->op_type == OP_CONST &&
62c18ce2
GS		 5923 (kid->op_private & OPpCONST_BARE))
5924 {
2d8e6c8d 5925 char *name = SvPVx(((SVOP*)kid)->op_sv, n_a);
79072805 5926 OP *newop = newAVREF(newGVOP(OP_GV, 0,
85e6fe83 5927 gv_fetchpv(name, TRUE, SVt_PVAV) ));
12bcd1a6
PM		 5928 if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
5929 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
57def98f 5930 "Array @%s missing the @ in argument %"IVdf" of %s()",
cf2093f6 5931 name, (IV)numargs, PL_op_desc[type]);
79072805
LW		 5932 op_free(kid);
5933 kid = newop;
5934 kid->op_sibling = sibl;
5935 *tokid = kid;
5936 }
8990e307 5937 else if (kid->op_type != OP_RV2AV && kid->op_type != OP_PADAV)
35cd451c 5938 bad_type(numargs, "array", PL_op_desc[type], kid);
a0d0e21e 5939 mod(kid, type);
79072805
LW		 5940 break;
5941 case OA_HVREF:
5942 if (kid->op_type == OP_CONST &&
62c18ce2
GS		 5943 (kid->op_private & OPpCONST_BARE))
5944 {
2d8e6c8d 5945 char *name = SvPVx(((SVOP*)kid)->op_sv, n_a);
79072805 5946 OP *newop = newHVREF(newGVOP(OP_GV, 0,
85e6fe83 5947 gv_fetchpv(name, TRUE, SVt_PVHV) ));
12bcd1a6
PM		 5948 if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
5949 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
57def98f 5950 "Hash %%%s missing the %% in argument %"IVdf" of %s()",
cf2093f6 5951 name, (IV)numargs, PL_op_desc[type]);
79072805
LW		 5952 op_free(kid);
5953 kid = newop;
5954 kid->op_sibling = sibl;
5955 *tokid = kid;
5956 }
8990e307 5957 else if (kid->op_type != OP_RV2HV && kid->op_type != OP_PADHV)
35cd451c 5958 bad_type(numargs, "hash", PL_op_desc[type], kid);
a0d0e21e 5959 mod(kid, type);
79072805
LW		 5960 break;
5961 case OA_CVREF:
5962 {
a0d0e21e 5963 OP *newop = newUNOP(OP_NULL, 0, kid);
79072805
LW		 5964 kid->op_sibling = 0;
5965 linklist(kid);
5966 newop->op_next = newop;
5967 kid = newop;
5968 kid->op_sibling = sibl;
5969 *tokid = kid;
5970 }
5971 break;
5972 case OA_FILEREF:
c340be78 5973 if (kid->op_type != OP_GV && kid->op_type != OP_RV2GV) {
79072805 5974 if (kid->op_type == OP_CONST &&
62c18ce2
GS		 5975 (kid->op_private & OPpCONST_BARE))
5976 {
79072805 5977 OP *newop = newGVOP(OP_GV, 0,
2d8e6c8d 5978 gv_fetchpv(SvPVx(((SVOP*)kid)->op_sv, n_a), TRUE,
85e6fe83 5979 SVt_PVIO) );
afbdacea 5980 if (!(o->op_private & 1) && /* if not unop */
8a996ce8 5981 kid == cLISTOPo->op_last)
364daeac 5982 cLISTOPo->op_last = newop;
79072805
LW		 5983 op_free(kid);
5984 kid = newop;
5985 }
1ea32a52
GS		 5986 else if (kid->op_type == OP_READLINE) {
5987 /* neophyte patrol: open(<FH>), close(<FH>) etc. */
53e06cf0 5988 bad_type(numargs, "HANDLE", OP_DESC(o), kid);
1ea32a52 5989 }
79072805 5990 else {
35cd451c 5991 I32 flags = OPf_SPECIAL;
a6c40364 5992 I32 priv = 0;
2c8ac474
GS		 5993 PADOFFSET targ = 0;
5994
35cd451c 5995 /* is this op a FH constructor? */
853846ea 5996 if (is_handle_constructor(o,numargs)) {
2c8ac474
GS		 5997 char *name = Nullch;
5998 STRLEN len;
5999
6000 flags = 0;
6001 /* Set a flag to tell rv2gv to vivify
853846ea
NIS		 6002 * need to "prove" flag does not mean something
6003 * else already - NI-S 1999/05/07
2c8ac474
GS		 6004 */
6005 priv = OPpDEREF;
6006 if (kid->op_type == OP_PADSV) {
6007 SV **namep = av_fetch(PL_comppad_name,
6008 kid->op_targ, 4);
6009 if (namep && *namep)
6010 name = SvPV(*namep, len);
6011 }
6012 else if (kid->op_type == OP_RV2SV
6013 && kUNOP->op_first->op_type == OP_GV)
6014 {
6015 GV *gv = cGVOPx_gv(kUNOP->op_first);
6016 name = GvNAME(gv);
6017 len = GvNAMELEN(gv);
6018 }
afd1915d
GS		 6019 else if (kid->op_type == OP_AELEM
6020 || kid->op_type == OP_HELEM)
6021 {
6022 name = "__ANONIO__";
6023 len = 10;
6024 mod(kid,type);
6025 }
2c8ac474
GS		 6026 if (name) {
6027 SV *namesv;
6028 targ = pad_alloc(OP_RV2GV, SVs_PADTMP);
6029 namesv = PL_curpad[targ];
155aba94 6030 (void)SvUPGRADE(namesv, SVt_PV);
2c8ac474
GS		 6031 if (*name != '$')
6032 sv_setpvn(namesv, "$", 1);
6033 sv_catpvn(namesv, name, len);
6034 }
853846ea 6035 }
79072805 6036 kid->op_sibling = 0;
35cd451c 6037 kid = newUNOP(OP_RV2GV, flags, scalar(kid));
2c8ac474
GS		 6038 kid->op_targ = targ;
6039 kid->op_private |= priv;
79072805
LW		 6040 }
6041 kid->op_sibling = sibl;
6042 *tokid = kid;
6043 }
6044 scalar(kid);
6045 break;
6046 case OA_SCALARREF:
a0d0e21e 6047 mod(scalar(kid), type);
79072805
LW		 6048 break;
6049 }
6050 oa >>= 4;
6051 tokid = &kid->op_sibling;
6052 kid = kid->op_sibling;
6053 }
11343788 6054 o->op_private |= numargs;
79072805 6055 if (kid)
53e06cf0 6056 return too_many_arguments(o,OP_DESC(o));
11343788 6057 listkids(o);
79072805 6058 }
22c35a8c 6059 else if (PL_opargs[type] & OA_DEFGV) {
11343788 6060 op_free(o);
54b9620d 6061 return newUNOP(type, 0, newDEFSVOP());
a0d0e21e
LW		 6062 }
6063
79072805
LW		 6064 if (oa) {
6065 while (oa & OA_OPTIONAL)
6066 oa >>= 4;
6067 if (oa && oa != OA_LIST)
53e06cf0 6068 return too_few_arguments(o,OP_DESC(o));
79072805 6069 }
11343788 6070 return o;
79072805
LW		 6071}
6072
6073OP *
cea2e8a9 6074Perl_ck_glob(pTHX_ OP *o)
79072805 6075{
fb73857a 6076 GV *gv;
6077
649da076 6078 o = ck_fun(o);
1f2bfc8a 6079 if ((o->op_flags & OPf_KIDS) && !cLISTOPo->op_first->op_sibling)
54b9620d 6080 append_elem(OP_GLOB, o, newDEFSVOP());
fb73857a 6081
b9f751c0
GS		 6082 if (!((gv = gv_fetchpv("glob", FALSE, SVt_PVCV))
6083 && GvCVu(gv) && GvIMPORTED_CV(gv)))
6084 {
fb73857a 6085 gv = gv_fetchpv("CORE::GLOBAL::glob", FALSE, SVt_PVCV);
b9f751c0 6086 }
b1cb66bf 6087
52bb0670 6088#if !defined(PERL_EXTERNAL_GLOB)
72b16652
GS		 6089 /* XXX this can be tightened up and made more failsafe. */
6090 if (!gv) {
7d3fb230 6091 GV *glob_gv;
72b16652 6092 ENTER;
00ca71c1
NIS		 6093 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
6094 newSVpvn("File::Glob", 10), Nullsv, Nullsv, Nullsv);
72b16652 6095 gv = gv_fetchpv("CORE::GLOBAL::glob", FALSE, SVt_PVCV);
7d3fb230
BS		 6096 glob_gv = gv_fetchpv("File::Glob::csh_glob", FALSE, SVt_PVCV);
6097 GvCV(gv) = GvCV(glob_gv);
445266f0 6098 SvREFCNT_inc((SV*)GvCV(gv));
7d3fb230 6099 GvIMPORTED_CV_on(gv);
72b16652
GS		 6100 LEAVE;
6101 }
52bb0670 6102#endif /* PERL_EXTERNAL_GLOB */
72b16652 6103
b9f751c0 6104 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
5196be3e 6105 append_elem(OP_GLOB, o,
80252599 6106 newSVOP(OP_CONST, 0, newSViv(PL_glob_index++)));
1f2bfc8a 6107 o->op_type = OP_LIST;
22c35a8c 6108 o->op_ppaddr = PL_ppaddr[OP_LIST];
1f2bfc8a 6109 cLISTOPo->op_first->op_type = OP_PUSHMARK;
22c35a8c 6110 cLISTOPo->op_first->op_ppaddr = PL_ppaddr[OP_PUSHMARK];
1f2bfc8a 6111 o = newUNOP(OP_ENTERSUB, OPf_STACKED,
aeea060c 6112 append_elem(OP_LIST, o,
1f2bfc8a
MB		 6113 scalar(newUNOP(OP_RV2CV, 0,
6114 newGVOP(OP_GV, 0, gv)))));
d58bf5aa
MB		 6115 o = newUNOP(OP_NULL, 0, ck_subr(o));
6116 o->op_targ = OP_GLOB; /* hint at what it used to be */
6117 return o;
b1cb66bf 6118 }
6119 gv = newGVgen("main");
a0d0e21e 6120 gv_IOadd(gv);
11343788
MB		 6121 append_elem(OP_GLOB, o, newGVOP(OP_GV, 0, gv));
6122 scalarkids(o);
649da076 6123 return o;
79072805
LW		 6124}
6125
6126OP *
cea2e8a9 6127Perl_ck_grep(pTHX_ OP *o)
79072805
LW		 6128{
6129 LOGOP *gwop;
6130 OP *kid;
11343788 6131 OPCODE type = o->op_type == OP_GREPSTART ? OP_GREPWHILE : OP_MAPWHILE;
79072805 6132
22c35a8c 6133 o->op_ppaddr = PL_ppaddr[OP_GREPSTART];
b7dc083c 6134 NewOp(1101, gwop, 1, LOGOP);
aeea060c 6135
11343788 6136 if (o->op_flags & OPf_STACKED) {
a0d0e21e 6137 OP* k;
11343788
MB		 6138 o = ck_sort(o);
6139 kid = cLISTOPo->op_first->op_sibling;
6140 for (k = cLISTOPo->op_first->op_sibling->op_next; k; k = k->op_next) {
a0d0e21e
LW		 6141 kid = k;
6142 }
6143 kid->op_next = (OP*)gwop;
11343788 6144 o->op_flags &= ~OPf_STACKED;
93a17b20 6145 }
11343788 6146 kid = cLISTOPo->op_first->op_sibling;
a0d0e21e
LW		 6147 if (type == OP_MAPWHILE)
6148 list(kid);
6149 else
6150 scalar(kid);
11343788 6151 o = ck_fun(o);
3280af22 6152 if (PL_error_count)
11343788 6153 return o;
aeea060c 6154 kid = cLISTOPo->op_first->op_sibling;
79072805 6155 if (kid->op_type != OP_NULL)
cea2e8a9 6156 Perl_croak(aTHX_ "panic: ck_grep");
79072805
LW		 6157 kid = kUNOP->op_first;
6158
a0d0e21e 6159 gwop->op_type = type;
22c35a8c 6160 gwop->op_ppaddr = PL_ppaddr[type];
11343788 6161 gwop->op_first = listkids(o);
79072805
LW		 6162 gwop->op_flags |= OPf_KIDS;
6163 gwop->op_private = 1;
6164 gwop->op_other = LINKLIST(kid);
a0d0e21e 6165 gwop->op_targ = pad_alloc(type, SVs_PADTMP);
79072805
LW		 6166 kid->op_next = (OP*)gwop;
6167
11343788 6168 kid = cLISTOPo->op_first->op_sibling;
a0d0e21e 6169 if (!kid || !kid->op_sibling)
53e06cf0 6170 return too_few_arguments(o,OP_DESC(o));
a0d0e21e
LW		 6171 for (kid = kid->op_sibling; kid; kid = kid->op_sibling)
6172 mod(kid, OP_GREPSTART);
6173
79072805
LW		 6174 return (OP*)gwop;
6175}
6176
6177OP *
cea2e8a9 6178Perl_ck_index(pTHX_ OP *o)
79072805 6179{
11343788
MB		 6180 if (o->op_flags & OPf_KIDS) {
6181 OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
0b71040e
LW		 6182 if (kid)
6183 kid = kid->op_sibling; /* get past "big" */
79072805 6184 if (kid && kid->op_type == OP_CONST)
2779dcf1 6185 fbm_compile(((SVOP*)kid)->op_sv, 0);
79072805 6186 }
11343788 6187 return ck_fun(o);
79072805
LW		 6188}
6189
6190OP *
cea2e8a9 6191Perl_ck_lengthconst(pTHX_ OP *o)
79072805
LW		 6192{
6193 /* XXX length optimization goes here */
11343788 6194 return ck_fun(o);
79072805
LW		 6195}
6196
6197OP *
cea2e8a9 6198Perl_ck_lfun(pTHX_ OP *o)
79072805 6199{
5dc0d613
MB		 6200 OPCODE type = o->op_type;
6201 return modkids(ck_fun(o), type);
79072805
LW		 6202}
6203
6204OP *
cea2e8a9 6205Perl_ck_defined(pTHX_ OP *o) /* 19990527 MJD */
69794302 6206{
12bcd1a6 6207 if ((o->op_flags & OPf_KIDS) && ckWARN2(WARN_DEPRECATED, WARN_SYNTAX)) {
d0334bed
GS		 6208 switch (cUNOPo->op_first->op_type) {
6209 case OP_RV2AV:
a8739d98
JH		 6210 /* This is needed for
6211 if (defined %stash::)
6212 to work. Do not break Tk.
6213 */
1c846c1f 6214 break; /* Globals via GV can be undef */
d0334bed
GS		 6215 case OP_PADAV:
6216 case OP_AASSIGN: /* Is this a good idea? */
12bcd1a6 6217 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
f10b0346 6218 "defined(@array) is deprecated");
12bcd1a6 6219 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
cc507455 6220 "\t(Maybe you should just omit the defined()?)\n");
69794302 6221 break;
d0334bed 6222 case OP_RV2HV:
a8739d98
JH		 6223 /* This is needed for
6224 if (defined %stash::)
6225 to work. Do not break Tk.
6226 */
1c846c1f 6227 break; /* Globals via GV can be undef */
d0334bed 6228 case OP_PADHV:
12bcd1a6 6229 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
894356b3 6230 "defined(%%hash) is deprecated");
12bcd1a6 6231 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
cc507455 6232 "\t(Maybe you should just omit the defined()?)\n");
d0334bed
GS		 6233 break;
6234 default:
6235 /* no warning */
6236 break;
6237 }
69794302
MJD		 6238 }
6239 return ck_rfun(o);
6240}
6241
6242OP *
cea2e8a9 6243Perl_ck_rfun(pTHX_ OP *o)
8990e307 6244{
5dc0d613
MB		 6245 OPCODE type = o->op_type;
6246 return refkids(ck_fun(o), type);
8990e307
LW		 6247}
6248
6249OP *
cea2e8a9 6250Perl_ck_listiob(pTHX_ OP *o)
79072805
LW		 6251{
6252 register OP *kid;
aeea060c 6253
11343788 6254 kid = cLISTOPo->op_first;
79072805 6255 if (!kid) {
11343788
MB		 6256 o = force_list(o);
6257 kid = cLISTOPo->op_first;
79072805
LW		 6258 }
6259 if (kid->op_type == OP_PUSHMARK)
6260 kid = kid->op_sibling;
11343788 6261 if (kid && o->op_flags & OPf_STACKED)
79072805
LW		 6262 kid = kid->op_sibling;
6263 else if (kid && !kid->op_sibling) { /* print HANDLE; */
6264 if (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE) {
11343788 6265 o->op_flags |= OPf_STACKED; /* make it a filehandle */
748a9306 6266 kid = newUNOP(OP_RV2GV, OPf_REF, scalar(kid));
11343788
MB		 6267 cLISTOPo->op_first->op_sibling = kid;
6268 cLISTOPo->op_last = kid;
79072805
LW		 6269 kid = kid->op_sibling;
6270 }
6271 }
b2ffa427 6272
79072805 6273 if (!kid)
54b9620d 6274 append_elem(o->op_type, o, newDEFSVOP());
79072805 6275
2de3dbcc 6276 return listkids(o);
bbce6d69 6277}
6278
6279OP *
b162f9ea
IZ		 6280Perl_ck_sassign(pTHX_ OP *o)
6281{
6282 OP *kid = cLISTOPo->op_first;
6283 /* has a disposable target? */
6284 if ((PL_opargs[kid->op_type] & OA_TARGLEX)
6b66af17
GS		 6285 && !(kid->op_flags & OPf_STACKED)
6286 /* Cannot steal the second time! */
6287 && !(kid->op_private & OPpTARGET_MY))
b162f9ea
IZ		 6288 {
6289 OP *kkid = kid->op_sibling;
6290
6291 /* Can just relocate the target. */
2c2d71f5
JH		 6292 if (kkid && kkid->op_type == OP_PADSV
6293 && !(kkid->op_private & OPpLVAL_INTRO))
6294 {
b162f9ea 6295 kid->op_targ = kkid->op_targ;
743e66e6 6296 kkid->op_targ = 0;
b162f9ea
IZ		 6297 /* Now we do not need PADSV and SASSIGN. */
6298 kid->op_sibling = o->op_sibling; /* NULL */
6299 cLISTOPo->op_first = NULL;
6300 op_free(o);
6301 op_free(kkid);
6302 kid->op_private |= OPpTARGET_MY; /* Used for context settings */
6303 return kid;
6304 }
6305 }
6306 return o;
6307}
6308
6309OP *
cea2e8a9 6310Perl_ck_match(pTHX_ OP *o)
79072805 6311{
5dc0d613 6312 o->op_private |= OPpRUNTIME;
11343788 6313 return o;
79072805
LW		 6314}
6315
6316OP *
f5d5a27c
CS		 6317Perl_ck_method(pTHX_ OP *o)
6318{
6319 OP *kid = cUNOPo->op_first;
6320 if (kid->op_type == OP_CONST) {
6321 SV* sv = kSVOP->op_sv;
6322 if (!(strchr(SvPVX(sv), ':') || strchr(SvPVX(sv), '\''))) {
6323 OP *cmop;
1c846c1f
NIS		 6324 if (!SvREADONLY(sv) || !SvFAKE(sv)) {
6325 sv = newSVpvn_share(SvPVX(sv), SvCUR(sv), 0);
6326 }
6327 else {
6328 kSVOP->op_sv = Nullsv;
6329 }
f5d5a27c 6330 cmop = newSVOP(OP_METHOD_NAMED, 0, sv);
f5d5a27c
CS		 6331 op_free(o);
6332 return cmop;
6333 }
6334 }
6335 return o;
6336}
6337
6338OP *
cea2e8a9 6339Perl_ck_null(pTHX_ OP *o)
79072805 6340{
11343788 6341 return o;
79072805
LW		 6342}
6343
6344OP *
16fe6d59
GS		 6345Perl_ck_open(pTHX_ OP *o)
6346{
6347 HV *table = GvHV(PL_hintgv);
6348 if (table) {
6349 SV **svp;
6350 I32 mode;
6351 svp = hv_fetch(table, "open_IN", 7, FALSE);
6352 if (svp && *svp) {
6353 mode = mode_from_discipline(*svp);
6354 if (mode & O_BINARY)
6355 o->op_private |= OPpOPEN_IN_RAW;
6356 else if (mode & O_TEXT)
6357 o->op_private |= OPpOPEN_IN_CRLF;
6358 }
6359
6360 svp = hv_fetch(table, "open_OUT", 8, FALSE);
6361 if (svp && *svp) {
6362 mode = mode_from_discipline(*svp);
6363 if (mode & O_BINARY)
6364 o->op_private |= OPpOPEN_OUT_RAW;
6365 else if (mode & O_TEXT)
6366 o->op_private |= OPpOPEN_OUT_CRLF;
6367 }
6368 }
6369 if (o->op_type == OP_BACKTICK)
6370 return o;
6371 return ck_fun(o);
6372}
6373
6374OP *
cea2e8a9 6375Perl_ck_repeat(pTHX_ OP *o)
79072805 6376{
11343788
MB		 6377 if (cBINOPo->op_first->op_flags & OPf_PARENS) {
6378 o->op_private |= OPpREPEAT_DOLIST;
6379 cBINOPo->op_first = force_list(cBINOPo->op_first);
79072805
LW		 6380 }
6381 else
11343788
MB		 6382 scalar(o);
6383 return o;
79072805
LW		 6384}
6385
6386OP *
cea2e8a9 6387Perl_ck_require(pTHX_ OP *o)
8990e307 6388{
ec4ab249
GA		 6389 GV* gv;
6390
11343788
MB		 6391 if (o->op_flags & OPf_KIDS) { /* Shall we supply missing .pm? */
6392 SVOP *kid = (SVOP*)cUNOPo->op_first;
8990e307
LW		 6393
6394 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
8990e307 6395 char *s;
a0d0e21e
LW		 6396 for (s = SvPVX(kid->op_sv); *s; s++) {
6397 if (*s == ':' && s[1] == ':') {
6398 *s = '/';
1aef975c 6399 Move(s+2, s+1, strlen(s+2)+1, char);
a0d0e21e
LW		 6400 --SvCUR(kid->op_sv);
6401 }
8990e307 6402 }
ce3b816e
GS		 6403 if (SvREADONLY(kid->op_sv)) {
6404 SvREADONLY_off(kid->op_sv);
6405 sv_catpvn(kid->op_sv, ".pm", 3);
6406 SvREADONLY_on(kid->op_sv);
6407 }
6408 else
6409 sv_catpvn(kid->op_sv, ".pm", 3);
8990e307
LW		 6410 }
6411 }
ec4ab249
GA		 6412
6413 /* handle override, if any */
6414 gv = gv_fetchpv("require", FALSE, SVt_PVCV);
b9f751c0 6415 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv)))
ec4ab249
GA		 6416 gv = gv_fetchpv("CORE::GLOBAL::require", FALSE, SVt_PVCV);
6417
b9f751c0 6418 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
ec4ab249
GA		 6419 OP *kid = cUNOPo->op_first;
6420 cUNOPo->op_first = 0;
6421 op_free(o);
6422 return ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
6423 append_elem(OP_LIST, kid,
6424 scalar(newUNOP(OP_RV2CV, 0,
6425 newGVOP(OP_GV, 0,
6426 gv))))));
6427 }
6428
11343788 6429 return ck_fun(o);
8990e307
LW		 6430}
6431
78f9721b
SM		 6432OP *
6433Perl_ck_return(pTHX_ OP *o)
6434{
6435 OP *kid;
6436 if (CvLVALUE(PL_compcv)) {
6437 for (kid = cLISTOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
6438 mod(kid, OP_LEAVESUBLV);
6439 }
6440 return o;
6441}
6442
22c35a8c 6443#if 0
8990e307 6444OP *
cea2e8a9 6445Perl_ck_retarget(pTHX_ OP *o)
79072805 6446{
cea2e8a9 6447 Perl_croak(aTHX_ "NOT IMPL LINE %d",__LINE__);
79072805 6448 /* STUB */
11343788 6449 return o;
79072805 6450}
22c35a8c 6451#endif
79072805
LW		 6452
6453OP *
cea2e8a9 6454Perl_ck_select(pTHX_ OP *o)
79072805 6455{
c07a80fd 6456 OP* kid;
11343788
MB		 6457 if (o->op_flags & OPf_KIDS) {
6458 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
2304df62 6459 if (kid && kid->op_sibling) {
11343788 6460 o->op_type = OP_SSELECT;
22c35a8c 6461 o->op_ppaddr = PL_ppaddr[OP_SSELECT];
11343788
MB		 6462 o = ck_fun(o);
6463 return fold_constants(o);
79072805
LW		 6464 }
6465 }
11343788
MB		 6466 o = ck_fun(o);
6467 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
c07a80fd 6468 if (kid && kid->op_type == OP_RV2GV)
6469 kid->op_private &= ~HINT_STRICT_REFS;
11343788 6470 return o;
79072805
LW		 6471}
6472
6473OP *
cea2e8a9 6474Perl_ck_shift(pTHX_ OP *o)
79072805 6475{
11343788 6476 I32 type = o->op_type;
79072805 6477
11343788 6478 if (!(o->op_flags & OPf_KIDS)) {
6d4ff0d2 6479 OP *argop;
b2ffa427 6480
11343788 6481 op_free(o);
4d1ff10f 6482#ifdef USE_5005THREADS
533c011a 6483 if (!CvUNIQUE(PL_compcv)) {
6d4ff0d2 6484 argop = newOP(OP_PADAV, OPf_REF);
6b88bc9c 6485 argop->op_targ = 0; /* PL_curpad[0] is @_ */
6d4ff0d2
MB		 6486 }
6487 else {
6488 argop = newUNOP(OP_RV2AV, 0,
6489 scalar(newGVOP(OP_GV, 0,
6490 gv_fetchpv("ARGV", TRUE, SVt_PVAV))));
6491 }
6492#else
6493 argop = newUNOP(OP_RV2AV, 0,
3280af22
NIS		 6494 scalar(newGVOP(OP_GV, 0, !CvUNIQUE(PL_compcv) ?
6495 PL_defgv : gv_fetchpv("ARGV", TRUE, SVt_PVAV))));
4d1ff10f 6496#endif /* USE_5005THREADS */
6d4ff0d2 6497 return newUNOP(type, 0, scalar(argop));
79072805 6498 }
11343788 6499 return scalar(modkids(ck_fun(o), type));
79072805
LW		 6500}
6501
6502OP *
cea2e8a9 6503Perl_ck_sort(pTHX_ OP *o)
79072805 6504{
8e3f9bdf 6505 OP *firstkid;
bbce6d69 6506
9ea6e965 6507 if (o->op_type == OP_SORT && o->op_flags & OPf_STACKED)
51a19bc0 6508 simplify_sort(o);
8e3f9bdf
GS		 6509 firstkid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6510 if (o->op_flags & OPf_STACKED) { /* may have been cleared */
9c5ffd7c 6511 OP *k = NULL;
8e3f9bdf 6512 OP *kid = cUNOPx(firstkid)->op_first; /* get past null */
79072805 6513
463ee0b2 6514 if (kid->op_type == OP_SCOPE || kid->op_type == OP_LEAVE) {
79072805 6515 linklist(kid);
463ee0b2
LW		 6516 if (kid->op_type == OP_SCOPE) {
6517 k = kid->op_next;
6518 kid->op_next = 0;
79072805 6519 }
463ee0b2 6520 else if (kid->op_type == OP_LEAVE) {
11343788 6521 if (o->op_type == OP_SORT) {
93c66552 6522 op_null(kid); /* wipe out leave */
748a9306 6523 kid->op_next = kid;
463ee0b2 6524
748a9306
LW		 6525 for (k = kLISTOP->op_first->op_next; k; k = k->op_next) {
6526 if (k->op_next == kid)
6527 k->op_next = 0;
71a29c3c
GS		 6528 /* don't descend into loops */
6529 else if (k->op_type == OP_ENTERLOOP
6530 || k->op_type == OP_ENTERITER)
6531 {
6532 k = cLOOPx(k)->op_lastop;
6533 }
748a9306 6534 }
463ee0b2 6535 }
748a9306
LW		 6536 else
6537 kid->op_next = 0; /* just disconnect the leave */
a0d0e21e 6538 k = kLISTOP->op_first;
463ee0b2 6539 }
a2efc822 6540 CALL_PEEP(k);
a0d0e21e 6541
8e3f9bdf
GS		 6542 kid = firstkid;
6543 if (o->op_type == OP_SORT) {
6544 /* provide scalar context for comparison function/block */
6545 kid = scalar(kid);
a0d0e21e 6546 kid->op_next = kid;
8e3f9bdf 6547 }
a0d0e21e
LW		 6548 else
6549 kid->op_next = k;
11343788 6550 o->op_flags |= OPf_SPECIAL;
79072805 6551 }
c6e96bcb 6552 else if (kid->op_type == OP_RV2SV || kid->op_type == OP_PADSV)
93c66552 6553 op_null(firstkid);
8e3f9bdf
GS		 6554
6555 firstkid = firstkid->op_sibling;
79072805 6556 }
bbce6d69 6557
8e3f9bdf
GS		 6558 /* provide list context for arguments */
6559 if (o->op_type == OP_SORT)
6560 list(firstkid);
6561
11343788 6562 return o;
79072805 6563}
bda4119b
GS		 6564
6565STATIC void
cea2e8a9 6566S_simplify_sort(pTHX_ OP *o)
9c007264
JH		 6567{
6568 register OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6569 OP *k;
6570 int reversed;
350de78d 6571 GV *gv;
9c007264
JH		 6572 if (!(o->op_flags & OPf_STACKED))
6573 return;
1c846c1f
NIS		 6574 GvMULTI_on(gv_fetchpv("a", TRUE, SVt_PV));
6575 GvMULTI_on(gv_fetchpv("b", TRUE, SVt_PV));
82092f1d 6576 kid = kUNOP->op_first; /* get past null */
9c007264
JH		 6577 if (kid->op_type != OP_SCOPE)
6578 return;
6579 kid = kLISTOP->op_last; /* get past scope */
6580 switch(kid->op_type) {
6581 case OP_NCMP:
6582 case OP_I_NCMP:
6583 case OP_SCMP:
6584 break;
6585 default:
6586 return;
6587 }
6588 k = kid; /* remember this node*/
6589 if (kBINOP->op_first->op_type != OP_RV2SV)
6590 return;
6591 kid = kBINOP->op_first; /* get past cmp */
6592 if (kUNOP->op_first->op_type != OP_GV)
6593 return;
6594 kid = kUNOP->op_first; /* get past rv2sv */
638eceb6 6595 gv = kGVOP_gv;
350de78d 6596 if (GvSTASH(gv) != PL_curstash)
9c007264 6597 return;
350de78d 6598 if (strEQ(GvNAME(gv), "a"))
9c007264 6599 reversed = 0;
0f79a09d 6600 else if (strEQ(GvNAME(gv), "b"))
9c007264
JH		 6601 reversed = 1;
6602 else
6603 return;
6604 kid = k; /* back to cmp */
6605 if (kBINOP->op_last->op_type != OP_RV2SV)
6606 return;
6607 kid = kBINOP->op_last; /* down to 2nd arg */
6608 if (kUNOP->op_first->op_type != OP_GV)
6609 return;
6610 kid = kUNOP->op_first; /* get past rv2sv */
638eceb6 6611 gv = kGVOP_gv;
350de78d 6612 if (GvSTASH(gv) != PL_curstash
9c007264 6613 || ( reversed
350de78d
GS		 6614 ? strNE(GvNAME(gv), "a")
6615 : strNE(GvNAME(gv), "b")))
9c007264
JH		 6616 return;
6617 o->op_flags &= ~(OPf_STACKED | OPf_SPECIAL);
6618 if (reversed)
6619 o->op_private |= OPpSORT_REVERSE;
6620 if (k->op_type == OP_NCMP)
6621 o->op_private |= OPpSORT_NUMERIC;
6622 if (k->op_type == OP_I_NCMP)
6623 o->op_private |= OPpSORT_NUMERIC | OPpSORT_INTEGER;
e507f050
SM		 6624 kid = cLISTOPo->op_first->op_sibling;
6625 cLISTOPo->op_first->op_sibling = kid->op_sibling; /* bypass old block */
6626 op_free(kid); /* then delete it */
9c007264 6627}
79072805
LW		 6628
6629OP *
cea2e8a9 6630Perl_ck_split(pTHX_ OP *o)
79072805
LW		 6631{
6632 register OP *kid;
aeea060c 6633
11343788
MB		 6634 if (o->op_flags & OPf_STACKED)
6635 return no_fh_allowed(o);
79072805 6636
11343788 6637 kid = cLISTOPo->op_first;
8990e307 6638 if (kid->op_type != OP_NULL)
cea2e8a9 6639 Perl_croak(aTHX_ "panic: ck_split");
8990e307 6640 kid = kid->op_sibling;
11343788
MB		 6641 op_free(cLISTOPo->op_first);
6642 cLISTOPo->op_first = kid;
85e6fe83 6643 if (!kid) {
79cb57f6 6644 cLISTOPo->op_first = kid = newSVOP(OP_CONST, 0, newSVpvn(" ", 1));
11343788 6645 cLISTOPo->op_last = kid; /* There was only one element previously */
85e6fe83 6646 }
79072805 6647
de4bf5b3 6648 if (kid->op_type != OP_MATCH || kid->op_flags & OPf_STACKED) {
79072805 6649 OP *sibl = kid->op_sibling;
463ee0b2 6650 kid->op_sibling = 0;
79072805 6651 kid = pmruntime( newPMOP(OP_MATCH, OPf_SPECIAL), kid, Nullop);
11343788
MB		 6652 if (cLISTOPo->op_first == cLISTOPo->op_last)
6653 cLISTOPo->op_last = kid;
6654 cLISTOPo->op_first = kid;
79072805
LW		 6655 kid->op_sibling = sibl;
6656 }
6657
6658 kid->op_type = OP_PUSHRE;
22c35a8c 6659 kid->op_ppaddr = PL_ppaddr[OP_PUSHRE];
79072805
LW		 6660 scalar(kid);
6661
6662 if (!kid->op_sibling)
54b9620d 6663 append_elem(OP_SPLIT, o, newDEFSVOP());
79072805
LW		 6664
6665 kid = kid->op_sibling;
6666 scalar(kid);
6667
6668 if (!kid->op_sibling)
11343788 6669 append_elem(OP_SPLIT, o, newSVOP(OP_CONST, 0, newSViv(0)));
79072805
LW		 6670
6671 kid = kid->op_sibling;
6672 scalar(kid);
6673
6674 if (kid->op_sibling)
53e06cf0 6675 return too_many_arguments(o,OP_DESC(o));
79072805 6676
11343788 6677 return o;
79072805
LW		 6678}
6679
6680OP *
1c846c1f 6681Perl_ck_join(pTHX_ OP *o)
eb6e2d6f
GS		 6682{
6683 if (ckWARN(WARN_SYNTAX)) {
6684 OP *kid = cLISTOPo->op_first->op_sibling;
6685 if (kid && kid->op_type == OP_MATCH) {
6686 char *pmstr = "STRING";
aaa362c4
RS		 6687 if (PM_GETRE(kPMOP))
6688 pmstr = PM_GETRE(kPMOP)->precomp;
9014280d 6689 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
eb6e2d6f
GS		 6690 "/%s/ should probably be written as \"%s\"",
6691 pmstr, pmstr);
6692 }
6693 }
6694 return ck_fun(o);
6695}
6696
6697OP *
cea2e8a9 6698Perl_ck_subr(pTHX_ OP *o)
79072805 6699{
11343788
MB		 6700 OP *prev = ((cUNOPo->op_first->op_sibling)
6701 ? cUNOPo : ((UNOP*)cUNOPo->op_first))->op_first;
6702 OP *o2 = prev->op_sibling;
4633a7c4
LW		 6703 OP *cvop;
6704 char *proto = 0;
6705 CV *cv = 0;
46fc3d4c 6706 GV *namegv = 0;
4633a7c4
LW		 6707 int optional = 0;
6708 I32 arg = 0;
5b794e05 6709 I32 contextclass = 0;
90b7f708 6710 char *e = 0;
2d8e6c8d 6711 STRLEN n_a;
4633a7c4 6712
d3011074 6713 o->op_private |= OPpENTERSUB_HASTARG;
11343788 6714 for (cvop = o2; cvop->op_sibling; cvop = cvop->op_sibling) ;
4633a7c4
LW		 6715 if (cvop->op_type == OP_RV2CV) {
6716 SVOP* tmpop;
11343788 6717 o->op_private |= (cvop->op_private & OPpENTERSUB_AMPER);
93c66552 6718 op_null(cvop); /* disable rv2cv */
4633a7c4 6719 tmpop = (SVOP*)((UNOP*)cvop)->op_first;
76cd736e 6720 if (tmpop->op_type == OP_GV && !(o->op_private & OPpENTERSUB_AMPER)) {
638eceb6 6721 GV *gv = cGVOPx_gv(tmpop);
350de78d 6722 cv = GvCVu(gv);
76cd736e
GS		 6723 if (!cv)
6724 tmpop->op_private |= OPpEARLY_CV;
6725 else if (SvPOK(cv)) {
350de78d 6726 namegv = CvANON(cv) ? gv : CvGV(cv);
2d8e6c8d 6727 proto = SvPV((SV*)cv, n_a);
46fc3d4c 6728 }
4633a7c4
LW		 6729 }
6730 }
f5d5a27c 6731 else if (cvop->op_type == OP_METHOD || cvop->op_type == OP_METHOD_NAMED) {
7a52d87a
GS		 6732 if (o2->op_type == OP_CONST)
6733 o2->op_private &= ~OPpCONST_STRICT;
58a40671
GS		 6734 else if (o2->op_type == OP_LIST) {
6735 OP *o = ((UNOP*)o2)->op_first->op_sibling;
6736 if (o && o->op_type == OP_CONST)
6737 o->op_private &= ~OPpCONST_STRICT;
6738 }
7a52d87a 6739 }
3280af22
NIS		 6740 o->op_private |= (PL_hints & HINT_STRICT_REFS);
6741 if (PERLDB_SUB && PL_curstash != PL_debstash)
11343788
MB		 6742 o->op_private |= OPpENTERSUB_DB;
6743 while (o2 != cvop) {
4633a7c4
LW		 6744 if (proto) {
6745 switch (*proto) {
6746 case '\0':
5dc0d613 6747 return too_many_arguments(o, gv_ename(namegv));
4633a7c4
LW		 6748 case ';':
6749 optional = 1;
6750 proto++;
6751 continue;
6752 case '$':
6753 proto++;
6754 arg++;
11343788 6755 scalar(o2);
4633a7c4
LW		 6756 break;
6757 case '%':
6758 case '@':
11343788 6759 list(o2);
4633a7c4
LW		 6760 arg++;
6761 break;
6762 case '&':
6763 proto++;
6764 arg++;
11343788 6765 if (o2->op_type != OP_REFGEN && o2->op_type != OP_UNDEF)
75fc29ea
GS		 6766 bad_type(arg,
6767 arg == 1 ? "block or sub {}" : "sub {}",
6768 gv_ename(namegv), o2);
4633a7c4
LW		 6769 break;
6770 case '*':
2ba6ecf4 6771 /* '*' allows any scalar type, including bareword */
4633a7c4
LW		 6772 proto++;
6773 arg++;
11343788 6774 if (o2->op_type == OP_RV2GV)
2ba6ecf4 6775 goto wrapref; /* autoconvert GLOB -> GLOBref */
7a52d87a
GS		 6776 else if (o2->op_type == OP_CONST)
6777 o2->op_private &= ~OPpCONST_STRICT;
9675f7ac
GS		 6778 else if (o2->op_type == OP_ENTERSUB) {
6779 /* accidental subroutine, revert to bareword */
6780 OP *gvop = ((UNOP*)o2)->op_first;
6781 if (gvop && gvop->op_type == OP_NULL) {
6782 gvop = ((UNOP*)gvop)->op_first;
6783 if (gvop) {
6784 for (; gvop->op_sibling; gvop = gvop->op_sibling)
6785 ;
6786 if (gvop &&
6787 (gvop->op_private & OPpENTERSUB_NOPAREN) &&
6788 (gvop = ((UNOP*)gvop)->op_first) &&
6789 gvop->op_type == OP_GV)
6790 {
638eceb6 6791 GV *gv = cGVOPx_gv(gvop);
9675f7ac 6792 OP *sibling = o2->op_sibling;
2692f720 6793 SV *n = newSVpvn("",0);
9675f7ac 6794 op_free(o2);
2692f720
GS		 6795 gv_fullname3(n, gv, "");
6796 if (SvCUR(n)>6 && strnEQ(SvPVX(n),"main::",6))
6797 sv_chop(n, SvPVX(n)+6);
6798 o2 = newSVOP(OP_CONST, 0, n);
9675f7ac
GS		 6799 prev->op_sibling = o2;
6800 o2->op_sibling = sibling;
6801 }
6802 }
6803 }
6804 }
2ba6ecf4
GS		 6805 scalar(o2);
6806 break;
5b794e05
JH		 6807 case '[': case ']':
6808 goto oops;
6809 break;
4633a7c4
LW		 6810 case '\\':
6811 proto++;
6812 arg++;
5b794e05 6813 again:
4633a7c4 6814 switch (*proto++) {
5b794e05
JH		 6815 case '[':
6816 if (contextclass++ == 0) {
841d93c8 6817 e = strchr(proto, ']');
5b794e05
JH		 6818 if (!e || e == proto)
6819 goto oops;
6820 }
6821 else
6822 goto oops;
6823 goto again;
6824 break;
6825 case ']':
466bafcd
RGS		 6826 if (contextclass) {
6827 char *p = proto;
6828 char s = *p;
6829 contextclass = 0;
6830 *p = '\0';
6831 while (*--p != '[');
1eb1540c 6832 bad_type(arg, Perl_form(aTHX_ "one of %s", p),
466bafcd
RGS		 6833 gv_ename(namegv), o2);
6834 *proto = s;
6835 } else
5b794e05
JH		 6836 goto oops;
6837 break;
4633a7c4 6838 case '*':
5b794e05
JH		 6839 if (o2->op_type == OP_RV2GV)
6840 goto wrapref;
6841 if (!contextclass)
6842 bad_type(arg, "symbol", gv_ename(namegv), o2);
6843 break;
4633a7c4 6844 case '&':
5b794e05
JH		 6845 if (o2->op_type == OP_ENTERSUB)
6846 goto wrapref;
6847 if (!contextclass)
6848 bad_type(arg, "subroutine entry", gv_ename(namegv), o2);
6849 break;
4633a7c4 6850 case '$':
5b794e05
JH		 6851 if (o2->op_type == OP_RV2SV ||
6852 o2->op_type == OP_PADSV ||
6853 o2->op_type == OP_HELEM ||
6854 o2->op_type == OP_AELEM ||
6855 o2->op_type == OP_THREADSV)
6856 goto wrapref;
6857 if (!contextclass)
5dc0d613 6858 bad_type(arg, "scalar", gv_ename(namegv), o2);
5b794e05 6859 break;
4633a7c4 6860 case '@':
5b794e05
JH		 6861 if (o2->op_type == OP_RV2AV ||
6862 o2->op_type == OP_PADAV)
6863 goto wrapref;
6864 if (!contextclass)
5dc0d613 6865 bad_type(arg, "array", gv_ename(namegv), o2);
5b794e05 6866 break;
4633a7c4 6867 case '%':
5b794e05
JH		 6868 if (o2->op_type == OP_RV2HV ||
6869 o2->op_type == OP_PADHV)
6870 goto wrapref;
6871 if (!contextclass)
6872 bad_type(arg, "hash", gv_ename(namegv), o2);
6873 break;
6874 wrapref:
4633a7c4 6875 {
11343788 6876 OP* kid = o2;
6fa846a0 6877 OP* sib = kid->op_sibling;
4633a7c4 6878 kid->op_sibling = 0;
6fa846a0
GS		 6879 o2 = newUNOP(OP_REFGEN, 0, kid);
6880 o2->op_sibling = sib;
e858de61 6881 prev->op_sibling = o2;
4633a7c4 6882 }
841d93c8 6883 if (contextclass && e) {
5b794e05
JH		 6884 proto = e + 1;
6885 contextclass = 0;
6886 }
4633a7c4
LW		 6887 break;
6888 default: goto oops;
6889 }
5b794e05
JH		 6890 if (contextclass)
6891 goto again;
4633a7c4 6892 break;
b1cb66bf 6893 case ' ':
6894 proto++;
6895 continue;
4633a7c4
LW		 6896 default:
6897 oops:
cea2e8a9 6898 Perl_croak(aTHX_ "Malformed prototype for %s: %s",
5b794e05 6899 gv_ename(namegv), SvPV((SV*)cv, n_a));
4633a7c4
LW		 6900 }
6901 }
6902 else
11343788
MB		 6903 list(o2);
6904 mod(o2, OP_ENTERSUB);
6905 prev = o2;
6906 o2 = o2->op_sibling;
4633a7c4 6907 }
fb73857a 6908 if (proto && !optional &&
6909 (*proto && *proto != '@' && *proto != '%' && *proto != ';'))
5dc0d613 6910 return too_few_arguments(o, gv_ename(namegv));
11343788 6911 return o;
79072805
LW		 6912}
6913
6914OP *
cea2e8a9 6915Perl_ck_svconst(pTHX_ OP *o)
8990e307 6916{
11343788
MB		 6917 SvREADONLY_on(cSVOPo->op_sv);
6918 return o;
8990e307
LW		 6919}
6920
6921OP *
cea2e8a9 6922Perl_ck_trunc(pTHX_ OP *o)
79072805 6923{
11343788
MB		 6924 if (o->op_flags & OPf_KIDS) {
6925 SVOP *kid = (SVOP*)cUNOPo->op_first;
79072805 6926
a0d0e21e
LW		 6927 if (kid->op_type == OP_NULL)
6928 kid = (SVOP*)kid->op_sibling;
bb53490d
GS		 6929 if (kid && kid->op_type == OP_CONST &&
6930 (kid->op_private & OPpCONST_BARE))
6931 {
11343788 6932 o->op_flags |= OPf_SPECIAL;
bb53490d
GS		 6933 kid->op_private &= ~OPpCONST_STRICT;
6934 }
79072805 6935 }
11343788 6936 return ck_fun(o);
79072805
LW		 6937}
6938
35fba0d9
RG		 6939OP *
6940Perl_ck_substr(pTHX_ OP *o)
6941{
6942 o = ck_fun(o);
6943 if ((o->op_flags & OPf_KIDS) && o->op_private == 4) {
6944 OP *kid = cLISTOPo->op_first;
6945
6946 if (kid->op_type == OP_NULL)
6947 kid = kid->op_sibling;
6948 if (kid)
6949 kid->op_flags |= OPf_MOD;
6950
6951 }
6952 return o;
6953}
6954
463ee0b2
LW		 6955/* A peephole optimizer. We visit the ops in the order they're to execute. */
6956
79072805 6957void
864dbfa3 6958Perl_peep(pTHX_ register OP *o)
79072805
LW		 6959{
6960 register OP* oldop = 0;
2d8e6c8d
GS		 6961 STRLEN n_a;
6962
a0d0e21e 6963 if (!o || o->op_seq)
79072805 6964 return;
a0d0e21e 6965 ENTER;
462e5cf6 6966 SAVEOP();
7766f137 6967 SAVEVPTR(PL_curcop);
a0d0e21e
LW		 6968 for (; o; o = o->op_next) {
6969 if (o->op_seq)
6970 break;
3280af22
NIS		 6971 if (!PL_op_seqmax)
6972 PL_op_seqmax++;
533c011a 6973 PL_op = o;
a0d0e21e 6974 switch (o->op_type) {
acb36ea4 6975 case OP_SETSTATE:
a0d0e21e
LW		 6976 case OP_NEXTSTATE:
6977 case OP_DBSTATE:
3280af22
NIS		 6978 PL_curcop = ((COP*)o); /* for warnings */
6979 o->op_seq = PL_op_seqmax++;
a0d0e21e
LW		 6980 break;
6981
a0d0e21e 6982 case OP_CONST:
7a52d87a
GS		 6983 if (cSVOPo->op_private & OPpCONST_STRICT)
6984 no_bareword_allowed(o);
7766f137
GS		 6985#ifdef USE_ITHREADS
6986 /* Relocate sv to the pad for thread safety.
6987 * Despite being a "constant", the SV is written to,
6988 * for reference counts, sv_upgrade() etc. */
6989 if (cSVOP->op_sv) {
6990 PADOFFSET ix = pad_alloc(OP_CONST, SVs_PADTMP);
6a7129a1
GS		 6991 if (SvPADTMP(cSVOPo->op_sv)) {
6992 /* If op_sv is already a PADTMP then it is being used by
9a049f1c 6993 * some pad, so make a copy. */
6a7129a1
GS		 6994 sv_setsv(PL_curpad[ix],cSVOPo->op_sv);
6995 SvREADONLY_on(PL_curpad[ix]);
6996 SvREFCNT_dec(cSVOPo->op_sv);
6997 }
6998 else {
6999 SvREFCNT_dec(PL_curpad[ix]);
7000 SvPADTMP_on(cSVOPo->op_sv);
7001 PL_curpad[ix] = cSVOPo->op_sv;
9a049f1c
JT		 7002 /* XXX I don't know how this isn't readonly already. */
7003 SvREADONLY_on(PL_curpad[ix]);
6a7129a1 7004 }
7766f137
GS		 7005 cSVOPo->op_sv = Nullsv;
7006 o->op_targ = ix;
7007 }
7008#endif
07447971
GS		 7009 o->op_seq = PL_op_seqmax++;
7010 break;
7011
ed7ab888 7012 case OP_CONCAT:
b162f9ea
IZ		 7013 if (o->op_next && o->op_next->op_type == OP_STRINGIFY) {
7014 if (o->op_next->op_private & OPpTARGET_MY) {
69b47968 7015 if (o->op_flags & OPf_STACKED) /* chained concats */
b162f9ea 7016 goto ignore_optimization;
cd06dffe 7017 else {
07447971 7018 /* assert(PL_opargs[o->op_type] & OA_TARGLEX); */
b162f9ea 7019 o->op_targ = o->op_next->op_targ;
743e66e6 7020 o->op_next->op_targ = 0;
2c2d71f5 7021 o->op_private |= OPpTARGET_MY;
b162f9ea
IZ		 7022 }
7023 }
93c66552 7024 op_null(o->op_next);
b162f9ea
IZ		 7025 }
7026 ignore_optimization:
3280af22 7027 o->op_seq = PL_op_seqmax++;
a0d0e21e 7028 break;
8990e307 7029 case OP_STUB:
54310121 7030 if ((o->op_flags & OPf_WANT) != OPf_WANT_LIST) {
3280af22 7031 o->op_seq = PL_op_seqmax++;
54310121 7032 break; /* Scalar stub must produce undef. List stub is noop */
8990e307 7033 }
748a9306 7034 goto nothin;
79072805 7035 case OP_NULL:
acb36ea4
GS		 7036 if (o->op_targ == OP_NEXTSTATE
7037 || o->op_targ == OP_DBSTATE
7038 || o->op_targ == OP_SETSTATE)
7039 {
3280af22 7040 PL_curcop = ((COP*)o);
acb36ea4 7041 }
dad75012
AMS		 7042 /* XXX: We avoid setting op_seq here to prevent later calls
7043 to peep() from mistakenly concluding that optimisation
7044 has already occurred. This doesn't fix the real problem,
7045 though (See 20010220.007). AMS 20010719 */
7046 if (oldop && o->op_next) {
7047 oldop->op_next = o->op_next;
7048 continue;
7049 }
7050 break;
79072805 7051 case OP_SCALAR:
93a17b20 7052 case OP_LINESEQ:
463ee0b2 7053 case OP_SCOPE:
748a9306 7054 nothin:
a0d0e21e
LW		 7055 if (oldop && o->op_next) {
7056 oldop->op_next = o->op_next;
79072805
LW		 7057 continue;
7058 }
3280af22 7059 o->op_seq = PL_op_seqmax++;
79072805
LW		 7060 break;
7061
7062 case OP_GV:
a0d0e21e 7063 if (o->op_next->op_type == OP_RV2SV) {
64aac5a9 7064 if (!(o->op_next->op_private & OPpDEREF)) {
93c66552 7065 op_null(o->op_next);
64aac5a9
GS		 7066 o->op_private |= o->op_next->op_private & (OPpLVAL_INTRO
7067 | OPpOUR_INTRO);
a0d0e21e
LW		 7068 o->op_next = o->op_next->op_next;
7069 o->op_type = OP_GVSV;
22c35a8c 7070 o->op_ppaddr = PL_ppaddr[OP_GVSV];
8990e307
LW		 7071 }
7072 }
a0d0e21e
LW		 7073 else if (o->op_next->op_type == OP_RV2AV) {
7074 OP* pop = o->op_next->op_next;
7075 IV i;
f9dc862f 7076 if (pop && pop->op_type == OP_CONST &&
533c011a 7077 (PL_op = pop->op_next) &&
8990e307 7078 pop->op_next->op_type == OP_AELEM &&
a0d0e21e 7079 !(pop->op_next->op_private &
78f9721b 7080 (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB)) &&
b0840a2a 7081 (i = SvIV(((SVOP*)pop)->op_sv) - PL_curcop->cop_arybase)
a0d0e21e 7082 <= 255 &&
8990e307
LW		 7083 i >= 0)
7084 {
350de78d 7085 GV *gv;
93c66552
DM		 7086 op_null(o->op_next);
7087 op_null(pop->op_next);
7088 op_null(pop);
a0d0e21e
LW		 7089 o->op_flags |= pop->op_next->op_flags & OPf_MOD;
7090 o->op_next = pop->op_next->op_next;
7091 o->op_type = OP_AELEMFAST;
22c35a8c 7092 o->op_ppaddr = PL_ppaddr[OP_AELEMFAST];
a0d0e21e 7093 o->op_private = (U8)i;
638eceb6 7094 gv = cGVOPo_gv;
350de78d 7095 GvAVn(gv);
8990e307 7096 }
79072805 7097 }
e476b1b5 7098 else if ((o->op_private & OPpEARLY_CV) && ckWARN(WARN_PROTOTYPE)) {
638eceb6 7099 GV *gv = cGVOPo_gv;
76cd736e
GS		 7100 if (SvTYPE(gv) == SVt_PVGV && GvCV(gv) && SvPVX(GvCV(gv))) {
7101 /* XXX could check prototype here instead of just carping */
7102 SV *sv = sv_newmortal();
7103 gv_efullname3(sv, gv, Nullch);
9014280d 7104 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE),
76cd736e
GS		 7105 "%s() called too early to check prototype",
7106 SvPV_nolen(sv));
7107 }
7108 }
89de2904
AMS		 7109 else if (o->op_next->op_type == OP_READLINE
7110 && o->op_next->op_next->op_type == OP_CONCAT
7111 && (o->op_next->op_next->op_flags & OPf_STACKED))
7112 {
d2c45030
AMS		 7113 /* Turn "$a .= <FH>" into an OP_RCATLINE. AMS 20010917 */
7114 o->op_type = OP_RCATLINE;
7115 o->op_flags |= OPf_STACKED;
7116 o->op_ppaddr = PL_ppaddr[OP_RCATLINE];
89de2904 7117 op_null(o->op_next->op_next);
d2c45030 7118 op_null(o->op_next);
89de2904 7119 }
76cd736e 7120
3280af22 7121 o->op_seq = PL_op_seqmax++;
79072805
LW		 7122 break;
7123
a0d0e21e 7124 case OP_MAPWHILE:
79072805
LW		 7125 case OP_GREPWHILE:
7126 case OP_AND:
7127 case OP_OR:
2c2d71f5
JH		 7128 case OP_ANDASSIGN:
7129 case OP_ORASSIGN:
1a67a97c
SM		 7130 case OP_COND_EXPR:
7131 case OP_RANGE:
3280af22 7132 o->op_seq = PL_op_seqmax++;
fd4d1407
IZ		 7133 while (cLOGOP->op_other->op_type == OP_NULL)
7134 cLOGOP->op_other = cLOGOP->op_other->op_next;
a2efc822 7135 peep(cLOGOP->op_other); /* Recursive calls are not replaced by fptr calls */
79072805
LW		 7136 break;
7137
79072805 7138 case OP_ENTERLOOP:
9c2ca71a 7139 case OP_ENTERITER:
3280af22 7140 o->op_seq = PL_op_seqmax++;
58cccf98
SM		 7141 while (cLOOP->op_redoop->op_type == OP_NULL)
7142 cLOOP->op_redoop = cLOOP->op_redoop->op_next;
79072805 7143 peep(cLOOP->op_redoop);
58cccf98
SM		 7144 while (cLOOP->op_nextop->op_type == OP_NULL)
7145 cLOOP->op_nextop = cLOOP->op_nextop->op_next;
79072805 7146 peep(cLOOP->op_nextop);
58cccf98
SM		 7147 while (cLOOP->op_lastop->op_type == OP_NULL)
7148 cLOOP->op_lastop = cLOOP->op_lastop->op_next;
79072805
LW		 7149 peep(cLOOP->op_lastop);
7150 break;
7151
8782bef2 7152 case OP_QR:
79072805
LW		 7153 case OP_MATCH:
7154 case OP_SUBST:
3280af22 7155 o->op_seq = PL_op_seqmax++;
9041c2e3 7156 while (cPMOP->op_pmreplstart &&
58cccf98
SM		 7157 cPMOP->op_pmreplstart->op_type == OP_NULL)
7158 cPMOP->op_pmreplstart = cPMOP->op_pmreplstart->op_next;
a0d0e21e 7159 peep(cPMOP->op_pmreplstart);
79072805
LW		 7160 break;
7161
a0d0e21e 7162 case OP_EXEC:
3280af22 7163 o->op_seq = PL_op_seqmax++;
1c846c1f 7164 if (ckWARN(WARN_SYNTAX) && o->op_next
599cee73 7165 && o->op_next->op_type == OP_NEXTSTATE) {
a0d0e21e 7166 if (o->op_next->op_sibling &&
20408e3c
GS		 7167 o->op_next->op_sibling->op_type != OP_EXIT &&
7168 o->op_next->op_sibling->op_type != OP_WARN &&
a0d0e21e 7169 o->op_next->op_sibling->op_type != OP_DIE) {
57843af0 7170 line_t oldline = CopLINE(PL_curcop);
a0d0e21e 7171
57843af0 7172 CopLINE_set(PL_curcop, CopLINE((COP*)o->op_next));
9014280d 7173 Perl_warner(aTHX_ packWARN(WARN_EXEC),
eeb6a2c9 7174 "Statement unlikely to be reached");
9014280d 7175 Perl_warner(aTHX_ packWARN(WARN_EXEC),
cc507455 7176 "\t(Maybe you meant system() when you said exec()?)\n");
57843af0 7177 CopLINE_set(PL_curcop, oldline);
a0d0e21e
LW		 7178 }
7179 }
7180 break;
b2ffa427 7181
c750a3ec
MB		 7182 case OP_HELEM: {
7183 UNOP *rop;
7184 SV *lexname;
7185 GV **fields;
9615e741 7186 SV **svp, **indsvp, *sv;
c750a3ec 7187 I32 ind;
1c846c1f 7188 char *key = NULL;
c750a3ec 7189 STRLEN keylen;
b2ffa427 7190
9615e741 7191 o->op_seq = PL_op_seqmax++;
1c846c1f
NIS		 7192
7193 if (((BINOP*)o)->op_last->op_type != OP_CONST)
c750a3ec 7194 break;
1c846c1f
NIS		 7195
7196 /* Make the CONST have a shared SV */
7197 svp = cSVOPx_svp(((BINOP*)o)->op_last);
3049cdab 7198 if ((!SvFAKE(sv = *svp) || !SvREADONLY(sv)) && !IS_PADCONST(sv)) {
1c846c1f 7199 key = SvPV(sv, keylen);
25716404
GS		 7200 lexname = newSVpvn_share(key,
7201 SvUTF8(sv) ? -(I32)keylen : keylen,
7202 0);
1c846c1f
NIS		 7203 SvREFCNT_dec(sv);
7204 *svp = lexname;
7205 }
7206
7207 if ((o->op_private & (OPpLVAL_INTRO)))
7208 break;
7209
c750a3ec
MB		 7210 rop = (UNOP*)((BINOP*)o)->op_first;
7211 if (rop->op_type != OP_RV2HV || rop->op_first->op_type != OP_PADSV)
7212 break;
3280af22 7213 lexname = *av_fetch(PL_comppad_name, rop->op_first->op_targ, TRUE);
524189f1 7214 if (!(SvFLAGS(lexname) & SVpad_TYPED))
c750a3ec 7215 break;
5196be3e 7216 fields = (GV**)hv_fetch(SvSTASH(lexname), "FIELDS", 6, FALSE);
c750a3ec
MB		 7217 if (!fields || !GvHV(*fields))
7218 break;
c750a3ec 7219 key = SvPV(*svp, keylen);
25716404
GS		 7220 indsvp = hv_fetch(GvHV(*fields), key,
7221 SvUTF8(*svp) ? -(I32)keylen : keylen, FALSE);
c750a3ec 7222 if (!indsvp) {
88e9b055 7223 Perl_croak(aTHX_ "No such pseudo-hash field \"%s\" in variable %s of type %s",
2d8e6c8d 7224 key, SvPV(lexname, n_a), HvNAME(SvSTASH(lexname)));
c750a3ec
MB		 7225 }
7226 ind = SvIV(*indsvp);
7227 if (ind < 1)
cea2e8a9 7228 Perl_croak(aTHX_ "Bad index while coercing array into hash");
c750a3ec 7229 rop->op_type = OP_RV2AV;
22c35a8c 7230 rop->op_ppaddr = PL_ppaddr[OP_RV2AV];
c750a3ec 7231 o->op_type = OP_AELEM;
22c35a8c 7232 o->op_ppaddr = PL_ppaddr[OP_AELEM];
9615e741
GS		 7233 sv = newSViv(ind);
7234 if (SvREADONLY(*svp))
7235 SvREADONLY_on(sv);
7236 SvFLAGS(sv) |= (SvFLAGS(*svp)
7237 & (SVs_PADBUSY|SVs_PADTMP|SVs_PADMY));
c750a3ec 7238 SvREFCNT_dec(*svp);
9615e741 7239 *svp = sv;
c750a3ec
MB		 7240 break;
7241 }
b2ffa427 7242
345599ca
GS		 7243 case OP_HSLICE: {
7244 UNOP *rop;
7245 SV *lexname;
7246 GV **fields;
9615e741 7247 SV **svp, **indsvp, *sv;
345599ca
GS		 7248 I32 ind;
7249 char *key;
7250 STRLEN keylen;
7251 SVOP *first_key_op, *key_op;
9615e741
GS		 7252
7253 o->op_seq = PL_op_seqmax++;
345599ca
GS		 7254 if ((o->op_private & (OPpLVAL_INTRO))
7255 /* I bet there's always a pushmark... */
7256 || ((LISTOP*)o)->op_first->op_sibling->op_type != OP_LIST)
7257 /* hmmm, no optimization if list contains only one key. */
7258 break;
7259 rop = (UNOP*)((LISTOP*)o)->op_last;
7260 if (rop->op_type != OP_RV2HV || rop->op_first->op_type != OP_PADSV)
7261 break;
7262 lexname = *av_fetch(PL_comppad_name, rop->op_first->op_targ, TRUE);
524189f1 7263 if (!(SvFLAGS(lexname) & SVpad_TYPED))
345599ca
GS		 7264 break;
7265 fields = (GV**)hv_fetch(SvSTASH(lexname), "FIELDS", 6, FALSE);
7266 if (!fields || !GvHV(*fields))
7267 break;
7268 /* Again guessing that the pushmark can be jumped over.... */
7269 first_key_op = (SVOP*)((LISTOP*)((LISTOP*)o)->op_first->op_sibling)
7270 ->op_first->op_sibling;
7271 /* Check that the key list contains only constants. */
7272 for (key_op = first_key_op; key_op;
7273 key_op = (SVOP*)key_op->op_sibling)
7274 if (key_op->op_type != OP_CONST)
7275 break;
7276 if (key_op)
7277 break;
7278 rop->op_type = OP_RV2AV;
7279 rop->op_ppaddr = PL_ppaddr[OP_RV2AV];
7280 o->op_type = OP_ASLICE;
7281 o->op_ppaddr = PL_ppaddr[OP_ASLICE];
7282 for (key_op = first_key_op; key_op;
7283 key_op = (SVOP*)key_op->op_sibling) {
7284 svp = cSVOPx_svp(key_op);
7285 key = SvPV(*svp, keylen);
25716404
GS		 7286 indsvp = hv_fetch(GvHV(*fields), key,
7287 SvUTF8(*svp) ? -(I32)keylen : keylen, FALSE);
345599ca 7288 if (!indsvp) {
9615e741
GS		 7289 Perl_croak(aTHX_ "No such pseudo-hash field \"%s\" "
7290 "in variable %s of type %s",
345599ca
GS		 7291 key, SvPV(lexname, n_a), HvNAME(SvSTASH(lexname)));
7292 }
7293 ind = SvIV(*indsvp);
7294 if (ind < 1)
7295 Perl_croak(aTHX_ "Bad index while coercing array into hash");
9615e741
GS		 7296 sv = newSViv(ind);
7297 if (SvREADONLY(*svp))
7298 SvREADONLY_on(sv);
7299 SvFLAGS(sv) |= (SvFLAGS(*svp)
7300 & (SVs_PADBUSY|SVs_PADTMP|SVs_PADMY));
345599ca 7301 SvREFCNT_dec(*svp);
9615e741 7302 *svp = sv;
345599ca
GS		 7303 }
7304 break;
7305 }
c750a3ec 7306
79072805 7307 default:
3280af22 7308 o->op_seq = PL_op_seqmax++;
79072805
LW		 7309 break;
7310 }
a0d0e21e 7311 oldop = o;
79072805 7312 }
a0d0e21e 7313 LEAVE;
79072805 7314}
beab0874 7315
19e8ce8e
AB		 7316
7317
7318char* Perl_custom_op_name(pTHX_ OP* o)
53e06cf0
SC		 7319{
7320 IV index = PTR2IV(o->op_ppaddr);
7321 SV* keysv;
7322 HE* he;
7323
7324 if (!PL_custom_op_names) /* This probably shouldn't happen */
7325 return PL_op_name[OP_CUSTOM];
7326
7327 keysv = sv_2mortal(newSViv(index));
7328
7329 he = hv_fetch_ent(PL_custom_op_names, keysv, 0, 0);
7330 if (!he)
7331 return PL_op_name[OP_CUSTOM]; /* Don't know who you are */
7332
7333 return SvPV_nolen(HeVAL(he));
7334}
7335
19e8ce8e 7336char* Perl_custom_op_desc(pTHX_ OP* o)
53e06cf0
SC		 7337{
7338 IV index = PTR2IV(o->op_ppaddr);
7339 SV* keysv;
7340 HE* he;
7341
7342 if (!PL_custom_op_descs)
7343 return PL_op_desc[OP_CUSTOM];
7344
7345 keysv = sv_2mortal(newSViv(index));
7346
7347 he = hv_fetch_ent(PL_custom_op_descs, keysv, 0, 0);
7348 if (!he)
7349 return PL_op_desc[OP_CUSTOM];
7350
7351 return SvPV_nolen(HeVAL(he));
7352}
19e8ce8e 7353
53e06cf0 7354
beab0874
JT		 7355#include "XSUB.h"
7356
7357/* Efficient sub that returns a constant scalar value. */
7358static void
acfe0abc 7359const_sv_xsub(pTHX_ CV* cv)
beab0874
JT		 7360{
7361 dXSARGS;
9cbac4c7
DM		 7362 if (items != 0) {
7363#if 0
7364 Perl_croak(aTHX_ "usage: %s::%s()",
7365 HvNAME(GvSTASH(CvGV(cv))), GvNAME(CvGV(cv)));
7366#endif
7367 }
9a049f1c 7368 EXTEND(sp, 1);
0768512c 7369 ST(0) = (SV*)XSANY.any_ptr;
beab0874
JT		 7370 XSRETURN(1);
7371}
Unnamed repository; edit this file 'description' to name the repository.