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