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