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