This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
patch based on:
[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
PP
189 name[2] = toCTRL(name[1]);
190 name[1] = '^';
191 }
cea2e8a9 192 yyerror(Perl_form(aTHX_ "Can't use global %s in \"my\"",name));
a0d0e21e 193 }
e476b1b5 194 if (ckWARN(WARN_MISC) && AvFILLp(PL_comppad_name) >= 0) {
3280af22 195 SV **svp = AvARRAY(PL_comppad_name);
33633739
GS
196 HV *ourstash = (PL_curstash ? PL_curstash : PL_defstash);
197 PADOFFSET top = AvFILLp(PL_comppad_name);
eb160463 198 for (off = top; (I32)off > PL_comppad_name_floor; off--) {
b1cb66bf 199 if ((sv = svp[off])
3280af22 200 && sv != &PL_sv_undef
c53d7c7d 201 && (SvIVX(sv) == PAD_MAX || SvIVX(sv) == 0)
33633739
GS
202 && (PL_in_my != KEY_our
203 || ((SvFLAGS(sv) & SVpad_OUR) && GvSTASH(sv) == ourstash))
b1cb66bf
PP
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
PP
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
PP
300 AV *curlist = CvPADLIST(cv);
301 SV **svp = av_fetch(curlist, 0, FALSE);
748a9306 302 AV *curname;
4fdae800 303
3280af22 304 if (!svp || *svp == &PL_sv_undef)
4633a7c4 305 continue;
748a9306
LW
306 curname = (AV*)*svp;
307 svp = AvARRAY(curname);
93965878 308 for (off = AvFILLp(curname); off > 0; off--) {
748a9306 309 if ((sv = svp[off]) &&
3280af22 310 sv != &PL_sv_undef &&
eb160463
GS
311 seq <= (U32)SvIVX(sv) &&
312 seq > (U32)I_32(SvNVX(sv)) &&
748a9306
LW
313 strEQ(SvPVX(sv), name))
314 {
5f05dabc
PP
315 I32 depth;
316 AV *oldpad;
317 SV *oldsv;
318
319 depth = CvDEPTH(cv);
320 if (!depth) {
9607fc9c
PP
321 if (newoff) {
322 if (SvFAKE(sv))
323 continue;
4fdae800 324 return 0; /* don't clone from inactive stack frame */
9607fc9c 325 }
5f05dabc
PP
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
PP
337 oldsv = Nullsv; /* no need to keep ref */
338 }
339 else {
28757baa
PP
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
PP
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
PP
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
PP
425 return 0;
426 }
93a17b20 427 break;
7766f137 428 case CXt_FORMAT:
93a17b20
LW
429 case CXt_SUB:
430 if (!saweval)
431 return 0;
432 cv = cx->blk_sub.cv;
3280af22 433 if (PL_debstash && CvSTASH(cv) == PL_debstash) { /* ignore DB'* scope */
748a9306 434 saweval = i; /* so we know where we were called from */
708c0d06 435 seq = cxstack[i].blk_oldcop->cop_seq;
93a17b20 436 continue;
93a17b20 437 }
2680586e 438 return pad_findlex(name, newoff, seq, cv, i-1, saweval,FINDLEX_NOSEARCH);
93a17b20
LW
439 }
440 }
441
748a9306
LW
442 return 0;
443}
a0d0e21e 444
748a9306 445PADOFFSET
864dbfa3 446Perl_pad_findmy(pTHX_ char *name)
748a9306
LW
447{
448 I32 off;
54310121 449 I32 pendoff = 0;
748a9306 450 SV *sv;
3280af22
NIS
451 SV **svp = AvARRAY(PL_comppad_name);
452 U32 seq = PL_cop_seqmax;
6b35e009 453 PERL_CONTEXT *cx;
33b8ce05 454 CV *outside;
748a9306 455
4d1ff10f 456#ifdef USE_5005THREADS
11343788
MB
457 /*
458 * Special case to get lexical (and hence per-thread) @_.
459 * XXX I need to find out how to tell at parse-time whether use
460 * of @_ should refer to a lexical (from a sub) or defgv (global
461 * scope and maybe weird sub-ish things like formats). See
462 * startsub in perly.y. It's possible that @_ could be lexical
463 * (at least from subs) even in non-threaded perl.
464 */
465 if (strEQ(name, "@_"))
466 return 0; /* success. (NOT_IN_PAD indicates failure) */
4d1ff10f 467#endif /* USE_5005THREADS */
11343788 468
748a9306 469 /* The one we're looking for is probably just before comppad_name_fill. */
3280af22 470 for (off = AvFILLp(PL_comppad_name); off > 0; off--) {
a0d0e21e 471 if ((sv = svp[off]) &&
3280af22 472 sv != &PL_sv_undef &&
54310121 473 (!SvIVX(sv) ||
eb160463
GS
474 (seq <= (U32)SvIVX(sv) &&
475 seq > (U32)I_32(SvNVX(sv)))) &&
a0d0e21e
LW
476 strEQ(SvPVX(sv), name))
477 {
77ca0c92 478 if (SvIVX(sv) || SvFLAGS(sv) & SVpad_OUR)
54310121
PP
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
PP
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
PP
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
PP
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 612#ifdef USE_ITHREADS
d3d0e6f1
NC
613#ifdef PERL_COPY_ON_WRITE
614 if (SvIsCOW(PL_curpad[po])) {
615 sv_force_normal_flags(PL_curpad[po], SV_COW_DROP_PV);
616 } else
617#endif
618 SvREADONLY_off(PL_curpad[po]); /* could be a freed constant */
2aa1bedc
GS
619#endif
620 }
3280af22
NIS
621 if ((I32)po < PL_padix)
622 PL_padix = po - 1;
79072805
LW
623}
624
625void
864dbfa3 626Perl_pad_swipe(pTHX_ PADOFFSET po)
79072805 627{
3280af22 628 if (AvARRAY(PL_comppad) != PL_curpad)
cea2e8a9 629 Perl_croak(aTHX_ "panic: pad_swipe curpad");
79072805 630 if (!po)
cea2e8a9 631 Perl_croak(aTHX_ "panic: pad_swipe po");
4d1ff10f 632#ifdef USE_5005THREADS
b900a521 633 DEBUG_X(PerlIO_printf(Perl_debug_log,
f1dbda3d
JH
634 "0x%"UVxf" Pad 0x%"UVxf" swipe %"IVdf"\n",
635 PTR2UV(thr), PTR2UV(PL_curpad), (IV)po));
11343788 636#else
97835f67
JH
637 DEBUG_X(PerlIO_printf(Perl_debug_log, "Pad 0x%"UVxf" swipe %"IVdf"\n",
638 PTR2UV(PL_curpad), (IV)po));
4d1ff10f 639#endif /* USE_5005THREADS */
3280af22
NIS
640 SvPADTMP_off(PL_curpad[po]);
641 PL_curpad[po] = NEWSV(1107,0);
642 SvPADTMP_on(PL_curpad[po]);
643 if ((I32)po < PL_padix)
644 PL_padix = po - 1;
79072805
LW
645}
646
d9bb4600
GS
647/* XXX pad_reset() is currently disabled because it results in serious bugs.
648 * It causes pad temp TARGs to be shared between OPs. Since TARGs are pushed
649 * on the stack by OPs that use them, there are several ways to get an alias
650 * to a shared TARG. Such an alias will change randomly and unpredictably.
651 * We avoid doing this until we can think of a Better Way.
652 * GSAR 97-10-29 */
79072805 653void
864dbfa3 654Perl_pad_reset(pTHX)
79072805 655{
d9bb4600 656#ifdef USE_BROKEN_PAD_RESET
79072805
LW
657 register I32 po;
658
6b88bc9c 659 if (AvARRAY(PL_comppad) != PL_curpad)
cea2e8a9 660 Perl_croak(aTHX_ "panic: pad_reset curpad");
4d1ff10f 661#ifdef USE_5005THREADS
b900a521
JH
662 DEBUG_X(PerlIO_printf(Perl_debug_log,
663 "0x%"UVxf" Pad 0x%"UVxf" reset\n",
664 PTR2UV(thr), PTR2UV(PL_curpad)));
11343788 665#else
b900a521
JH
666 DEBUG_X(PerlIO_printf(Perl_debug_log, "Pad 0x%"UVxf" reset\n",
667 PTR2UV(PL_curpad)));
4d1ff10f 668#endif /* USE_5005THREADS */
6b88bc9c
GS
669 if (!PL_tainting) { /* Can't mix tainted and non-tainted temporaries. */
670 for (po = AvMAX(PL_comppad); po > PL_padix_floor; po--) {
671 if (PL_curpad[po] && !SvIMMORTAL(PL_curpad[po]))
672 SvPADTMP_off(PL_curpad[po]);
748a9306 673 }
6b88bc9c 674 PL_padix = PL_padix_floor;
79072805 675 }
d9bb4600 676#endif
3280af22 677 PL_pad_reset_pending = FALSE;
79072805
LW
678}
679
4d1ff10f 680#ifdef USE_5005THREADS
54b9620d 681/* find_threadsv is not reentrant */
a863c7d1 682PADOFFSET
864dbfa3 683Perl_find_threadsv(pTHX_ const char *name)
a863c7d1 684{
a863c7d1
MB
685 char *p;
686 PADOFFSET key;
554b3eca 687 SV **svp;
54b9620d 688 /* We currently only handle names of a single character */
533c011a 689 p = strchr(PL_threadsv_names, *name);
a863c7d1
MB
690 if (!p)
691 return NOT_IN_PAD;
533c011a 692 key = p - PL_threadsv_names;
2d8e6c8d 693 MUTEX_LOCK(&thr->mutex);
54b9620d 694 svp = av_fetch(thr->threadsv, key, FALSE);
2d8e6c8d
GS
695 if (svp)
696 MUTEX_UNLOCK(&thr->mutex);
697 else {
554b3eca 698 SV *sv = NEWSV(0, 0);
54b9620d 699 av_store(thr->threadsv, key, sv);
940cb80d 700 thr->threadsvp = AvARRAY(thr->threadsv);
2d8e6c8d 701 MUTEX_UNLOCK(&thr->mutex);
554b3eca
MB
702 /*
703 * Some magic variables used to be automagically initialised
704 * in gv_fetchpv. Those which are now per-thread magicals get
705 * initialised here instead.
706 */
707 switch (*name) {
54b9620d
MB
708 case '_':
709 break;
554b3eca
MB
710 case ';':
711 sv_setpv(sv, "\034");
14befaf4 712 sv_magic(sv, 0, PERL_MAGIC_sv, name, 1);
554b3eca 713 break;
c277df42
IZ
714 case '&':
715 case '`':
716 case '\'':
533c011a 717 PL_sawampersand = TRUE;
a3f914c5
GS
718 /* FALL THROUGH */
719 case '1':
720 case '2':
721 case '3':
722 case '4':
723 case '5':
724 case '6':
725 case '7':
726 case '8':
727 case '9':
c277df42 728 SvREADONLY_on(sv);
d8b5173a 729 /* FALL THROUGH */
067391ea
GS
730
731 /* XXX %! tied to Errno.pm needs to be added here.
732 * See gv_fetchpv(). */
733 /* case '!': */
734
54b9620d 735 default:
14befaf4 736 sv_magic(sv, 0, PERL_MAGIC_sv, name, 1);
554b3eca 737 }
bf49b057 738 DEBUG_S(PerlIO_printf(Perl_error_log,
54b9620d 739 "find_threadsv: new SV %p for $%s%c\n",
554b3eca
MB
740 sv, (*name < 32) ? "^" : "",
741 (*name < 32) ? toCTRL(*name) : *name));
a863c7d1
MB
742 }
743 return key;
744}
4d1ff10f 745#endif /* USE_5005THREADS */
a863c7d1 746
79072805
LW
747/* Destructor */
748
749void
864dbfa3 750Perl_op_free(pTHX_ OP *o)
79072805 751{
85e6fe83 752 register OP *kid, *nextkid;
acb36ea4 753 OPCODE type;
79072805 754
5dc0d613 755 if (!o || o->op_seq == (U16)-1)
79072805
LW
756 return;
757
7934575e
GS
758 if (o->op_private & OPpREFCOUNTED) {
759 switch (o->op_type) {
760 case OP_LEAVESUB:
761 case OP_LEAVESUBLV:
762 case OP_LEAVEEVAL:
763 case OP_LEAVE:
764 case OP_SCOPE:
765 case OP_LEAVEWRITE:
766 OP_REFCNT_LOCK;
767 if (OpREFCNT_dec(o)) {
768 OP_REFCNT_UNLOCK;
769 return;
770 }
771 OP_REFCNT_UNLOCK;
772 break;
773 default:
774 break;
775 }
776 }
777
11343788
MB
778 if (o->op_flags & OPf_KIDS) {
779 for (kid = cUNOPo->op_first; kid; kid = nextkid) {
85e6fe83 780 nextkid = kid->op_sibling; /* Get before next freeing kid */
79072805 781 op_free(kid);
85e6fe83 782 }
79072805 783 }
acb36ea4
GS
784 type = o->op_type;
785 if (type == OP_NULL)
eb160463 786 type = (OPCODE)o->op_targ;
acb36ea4
GS
787
788 /* COP* is not cleared by op_clear() so that we may track line
789 * numbers etc even after null() */
790 if (type == OP_NEXTSTATE || type == OP_SETSTATE || type == OP_DBSTATE)
791 cop_free((COP*)o);
792
793 op_clear(o);
238a4c30 794 FreeOp(o);
acb36ea4 795}
79072805 796
93c66552
DM
797void
798Perl_op_clear(pTHX_ OP *o)
acb36ea4 799{
13137afc 800
11343788 801 switch (o->op_type) {
acb36ea4
GS
802 case OP_NULL: /* Was holding old type, if any. */
803 case OP_ENTEREVAL: /* Was holding hints. */
4d1ff10f 804#ifdef USE_5005THREADS
acb36ea4
GS
805 case OP_THREADSV: /* Was holding index into thr->threadsv AV. */
806#endif
807 o->op_targ = 0;
a0d0e21e 808 break;
4d1ff10f 809#ifdef USE_5005THREADS
8dd3ba40
SM
810 case OP_ENTERITER:
811 if (!(o->op_flags & OPf_SPECIAL))
812 break;
813 /* FALL THROUGH */
4d1ff10f 814#endif /* USE_5005THREADS */
a6006777 815 default:
ac4c12e7 816 if (!(o->op_flags & OPf_REF)
0b94c7bb 817 || (PL_check[o->op_type] != MEMBER_TO_FPTR(Perl_ck_ftst)))
a6006777
PP
818 break;
819 /* FALL THROUGH */
463ee0b2 820 case OP_GVSV:
79072805 821 case OP_GV:
a6006777 822 case OP_AELEMFAST:
350de78d 823#ifdef USE_ITHREADS
971a9dd3
GS
824 if (cPADOPo->op_padix > 0) {
825 if (PL_curpad) {
638eceb6 826 GV *gv = cGVOPo_gv;
971a9dd3
GS
827 pad_swipe(cPADOPo->op_padix);
828 /* No GvIN_PAD_off(gv) here, because other references may still
829 * exist on the pad */
830 SvREFCNT_dec(gv);
831 }
832 cPADOPo->op_padix = 0;
833 }
350de78d 834#else
971a9dd3 835 SvREFCNT_dec(cSVOPo->op_sv);
7934575e 836 cSVOPo->op_sv = Nullsv;
350de78d 837#endif
79072805 838 break;
a1ae71d2 839 case OP_METHOD_NAMED:
79072805 840 case OP_CONST:
11343788 841 SvREFCNT_dec(cSVOPo->op_sv);
acb36ea4 842 cSVOPo->op_sv = Nullsv;
79072805 843 break;
748a9306
LW
844 case OP_GOTO:
845 case OP_NEXT:
846 case OP_LAST:
847 case OP_REDO:
11343788 848 if (o->op_flags & (OPf_SPECIAL|OPf_STACKED|OPf_KIDS))
748a9306
LW
849 break;
850 /* FALL THROUGH */
a0d0e21e 851 case OP_TRANS:
acb36ea4 852 if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
a0ed51b3 853 SvREFCNT_dec(cSVOPo->op_sv);
acb36ea4
GS
854 cSVOPo->op_sv = Nullsv;
855 }
856 else {
a0ed51b3 857 Safefree(cPVOPo->op_pv);
acb36ea4
GS
858 cPVOPo->op_pv = Nullch;
859 }
a0d0e21e
LW
860 break;
861 case OP_SUBST:
11343788 862 op_free(cPMOPo->op_pmreplroot);
971a9dd3 863 goto clear_pmop;
748a9306 864 case OP_PUSHRE:
971a9dd3 865#ifdef USE_ITHREADS
ba89bb6e 866 if (INT2PTR(PADOFFSET, cPMOPo->op_pmreplroot)) {
971a9dd3 867 if (PL_curpad) {
ba89bb6e
AB
868 GV *gv = (GV*)PL_curpad[INT2PTR(PADOFFSET, cPMOPo->op_pmreplroot)];
869 pad_swipe(INT2PTR(PADOFFSET, cPMOPo->op_pmreplroot));
971a9dd3
GS
870 /* No GvIN_PAD_off(gv) here, because other references may still
871 * exist on the pad */
872 SvREFCNT_dec(gv);
873 }
874 }
875#else
876 SvREFCNT_dec((SV*)cPMOPo->op_pmreplroot);
877#endif
878 /* FALL THROUGH */
a0d0e21e 879 case OP_MATCH:
8782bef2 880 case OP_QR:
971a9dd3 881clear_pmop:
cb55de95
JH
882 {
883 HV *pmstash = PmopSTASH(cPMOPo);
884 if (pmstash && SvREFCNT(pmstash)) {
885 PMOP *pmop = HvPMROOT(pmstash);
886 PMOP *lastpmop = NULL;
887 while (pmop) {
888 if (cPMOPo == pmop) {
889 if (lastpmop)
890 lastpmop->op_pmnext = pmop->op_pmnext;
891 else
892 HvPMROOT(pmstash) = pmop->op_pmnext;
893 break;
894 }
895 lastpmop = pmop;
896 pmop = pmop->op_pmnext;
897 }
83da49e6 898 }
05ec9bb3 899 PmopSTASH_free(cPMOPo);
cb55de95 900 }
971a9dd3 901 cPMOPo->op_pmreplroot = Nullop;
5f8cb046
DM
902 /* we use the "SAFE" version of the PM_ macros here
903 * since sv_clean_all might release some PMOPs
904 * after PL_regex_padav has been cleared
905 * and the clearing of PL_regex_padav needs to
906 * happen before sv_clean_all
907 */
908 ReREFCNT_dec(PM_GETRE_SAFE(cPMOPo));
909 PM_SETRE_SAFE(cPMOPo, (REGEXP*)NULL);
13137afc
AB
910#ifdef USE_ITHREADS
911 if(PL_regex_pad) { /* We could be in destruction */
912 av_push((AV*) PL_regex_pad[0],(SV*) PL_regex_pad[(cPMOPo)->op_pmoffset]);
1cc8b4c5 913 SvREPADTMP_on(PL_regex_pad[(cPMOPo)->op_pmoffset]);
13137afc
AB
914 PM_SETRE(cPMOPo, (cPMOPo)->op_pmoffset);
915 }
1eb1540c 916#endif
13137afc 917
a0d0e21e 918 break;
79072805
LW
919 }
920
743e66e6 921 if (o->op_targ > 0) {
11343788 922 pad_free(o->op_targ);
743e66e6
GS
923 o->op_targ = 0;
924 }
79072805
LW
925}
926
76e3520e 927STATIC void
3eb57f73
HS
928S_cop_free(pTHX_ COP* cop)
929{
05ec9bb3
NIS
930 Safefree(cop->cop_label); /* FIXME: treaddead ??? */
931 CopFILE_free(cop);
932 CopSTASH_free(cop);
0453d815 933 if (! specialWARN(cop->cop_warnings))
3eb57f73 934 SvREFCNT_dec(cop->cop_warnings);
05ec9bb3
NIS
935 if (! specialCopIO(cop->cop_io)) {
936#ifdef USE_ITHREADS
042f6df8 937#if 0
05ec9bb3
NIS
938 STRLEN len;
939 char *s = SvPV(cop->cop_io,len);
b178108d
JH
940 Perl_warn(aTHX_ "io='%.*s'",(int) len,s); /* ??? --jhi */
941#endif
05ec9bb3 942#else
ac27b0f5 943 SvREFCNT_dec(cop->cop_io);
05ec9bb3
NIS
944#endif
945 }
3eb57f73
HS
946}
947
93c66552
DM
948void
949Perl_op_null(pTHX_ OP *o)
8990e307 950{
acb36ea4
GS
951 if (o->op_type == OP_NULL)
952 return;
953 op_clear(o);
11343788
MB
954 o->op_targ = o->op_type;
955 o->op_type = OP_NULL;
22c35a8c 956 o->op_ppaddr = PL_ppaddr[OP_NULL];
8990e307
LW
957}
958
79072805
LW
959/* Contextualizers */
960
463ee0b2 961#define LINKLIST(o) ((o)->op_next ? (o)->op_next : linklist((OP*)o))
79072805
LW
962
963OP *
864dbfa3 964Perl_linklist(pTHX_ OP *o)
79072805
LW
965{
966 register OP *kid;
967
11343788
MB
968 if (o->op_next)
969 return o->op_next;
79072805
LW
970
971 /* establish postfix order */
11343788
MB
972 if (cUNOPo->op_first) {
973 o->op_next = LINKLIST(cUNOPo->op_first);
974 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
79072805
LW
975 if (kid->op_sibling)
976 kid->op_next = LINKLIST(kid->op_sibling);
977 else
11343788 978 kid->op_next = o;
79072805
LW
979 }
980 }
981 else
11343788 982 o->op_next = o;
79072805 983
11343788 984 return o->op_next;
79072805
LW
985}
986
987OP *
864dbfa3 988Perl_scalarkids(pTHX_ OP *o)
79072805
LW
989{
990 OP *kid;
11343788
MB
991 if (o && o->op_flags & OPf_KIDS) {
992 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
79072805
LW
993 scalar(kid);
994 }
11343788 995 return o;
79072805
LW
996}
997
76e3520e 998STATIC OP *
cea2e8a9 999S_scalarboolean(pTHX_ OP *o)
8990e307 1000{
d008e5eb 1001 if (o->op_type == OP_SASSIGN && cBINOPo->op_first->op_type == OP_CONST) {
d008e5eb 1002 if (ckWARN(WARN_SYNTAX)) {
57843af0 1003 line_t oldline = CopLINE(PL_curcop);
a0d0e21e 1004
d008e5eb 1005 if (PL_copline != NOLINE)
57843af0 1006 CopLINE_set(PL_curcop, PL_copline);
9014280d 1007 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Found = in conditional, should be ==");
57843af0 1008 CopLINE_set(PL_curcop, oldline);
d008e5eb 1009 }
a0d0e21e 1010 }
11343788 1011 return scalar(o);
8990e307
LW
1012}
1013
1014OP *
864dbfa3 1015Perl_scalar(pTHX_ OP *o)
79072805
LW
1016{
1017 OP *kid;
1018
a0d0e21e 1019 /* assumes no premature commitment */
3280af22 1020 if (!o || (o->op_flags & OPf_WANT) || PL_error_count
5dc0d613 1021 || o->op_type == OP_RETURN)
7e363e51 1022 {
11343788 1023 return o;
7e363e51 1024 }
79072805 1025
5dc0d613 1026 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_SCALAR;
79072805 1027
11343788 1028 switch (o->op_type) {
79072805 1029 case OP_REPEAT:
11343788 1030 scalar(cBINOPo->op_first);
8990e307 1031 break;
79072805
LW
1032 case OP_OR:
1033 case OP_AND:
1034 case OP_COND_EXPR:
11343788 1035 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
8990e307 1036 scalar(kid);
79072805 1037 break;
a0d0e21e 1038 case OP_SPLIT:
11343788 1039 if ((kid = cLISTOPo->op_first) && kid->op_type == OP_PUSHRE) {
a0d0e21e 1040 if (!kPMOP->op_pmreplroot)
12bcd1a6 1041 deprecate_old("implicit split to @_");
a0d0e21e
LW
1042 }
1043 /* FALL THROUGH */
79072805 1044 case OP_MATCH:
8782bef2 1045 case OP_QR:
79072805
LW
1046 case OP_SUBST:
1047 case OP_NULL:
8990e307 1048 default:
11343788
MB
1049 if (o->op_flags & OPf_KIDS) {
1050 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling)
8990e307
LW
1051 scalar(kid);
1052 }
79072805
LW
1053 break;
1054 case OP_LEAVE:
1055 case OP_LEAVETRY:
5dc0d613 1056 kid = cLISTOPo->op_first;
54310121 1057 scalar(kid);
155aba94 1058 while ((kid = kid->op_sibling)) {
54310121
PP
1059 if (kid->op_sibling)
1060 scalarvoid(kid);
1061 else
1062 scalar(kid);
1063 }
3280af22 1064 WITH_THR(PL_curcop = &PL_compiling);
54310121 1065 break;
748a9306 1066 case OP_SCOPE:
79072805 1067 case OP_LINESEQ:
8990e307 1068 case OP_LIST:
11343788 1069 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
79072805
LW
1070 if (kid->op_sibling)
1071 scalarvoid(kid);
1072 else
1073 scalar(kid);
1074 }
3280af22 1075 WITH_THR(PL_curcop = &PL_compiling);
79072805 1076 break;
a801c63c
RGS
1077 case OP_SORT:
1078 if (ckWARN(WARN_VOID))
9014280d 1079 Perl_warner(aTHX_ packWARN(WARN_VOID), "Useless use of sort in scalar context");
79072805 1080 }
11343788 1081 return o;
79072805
LW
1082}
1083
1084OP *
864dbfa3 1085Perl_scalarvoid(pTHX_ OP *o)
79072805
LW
1086{
1087 OP *kid;
8990e307
LW
1088 char* useless = 0;
1089 SV* sv;
2ebea0a1
GS
1090 U8 want;
1091
acb36ea4
GS
1092 if (o->op_type == OP_NEXTSTATE
1093 || o->op_type == OP_SETSTATE
1094 || o->op_type == OP_DBSTATE
1095 || (o->op_type == OP_NULL && (o->op_targ == OP_NEXTSTATE
1096 || o->op_targ == OP_SETSTATE
1097 || o->op_targ == OP_DBSTATE)))
2ebea0a1 1098 PL_curcop = (COP*)o; /* for warning below */
79072805 1099
54310121 1100 /* assumes no premature commitment */
2ebea0a1
GS
1101 want = o->op_flags & OPf_WANT;
1102 if ((want && want != OPf_WANT_SCALAR) || PL_error_count
5dc0d613 1103 || o->op_type == OP_RETURN)
7e363e51 1104 {
11343788 1105 return o;
7e363e51 1106 }
79072805 1107
b162f9ea 1108 if ((o->op_private & OPpTARGET_MY)
7e363e51
GS
1109 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1110 {
b162f9ea 1111 return scalar(o); /* As if inside SASSIGN */
7e363e51 1112 }
1c846c1f 1113
5dc0d613 1114 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
79072805 1115
11343788 1116 switch (o->op_type) {
79072805 1117 default:
22c35a8c 1118 if (!(PL_opargs[o->op_type] & OA_FOLDCONST))
8990e307 1119 break;
36477c24
PP
1120 /* FALL THROUGH */
1121 case OP_REPEAT:
11343788 1122 if (o->op_flags & OPf_STACKED)
8990e307 1123 break;
5d82c453
GA
1124 goto func_ops;
1125 case OP_SUBSTR:
1126 if (o->op_private == 4)
1127 break;
8990e307
LW
1128 /* FALL THROUGH */
1129 case OP_GVSV:
1130 case OP_WANTARRAY:
1131 case OP_GV:
1132 case OP_PADSV:
1133 case OP_PADAV:
1134 case OP_PADHV:
1135 case OP_PADANY:
1136 case OP_AV2ARYLEN:
8990e307 1137 case OP_REF:
a0d0e21e
LW
1138 case OP_REFGEN:
1139 case OP_SREFGEN:
8990e307
LW
1140 case OP_DEFINED:
1141 case OP_HEX:
1142 case OP_OCT:
1143 case OP_LENGTH:
8990e307
LW
1144 case OP_VEC:
1145 case OP_INDEX:
1146 case OP_RINDEX:
1147 case OP_SPRINTF:
1148 case OP_AELEM:
1149 case OP_AELEMFAST:
1150 case OP_ASLICE:
8990e307
LW
1151 case OP_HELEM:
1152 case OP_HSLICE:
1153 case OP_UNPACK:
1154 case OP_PACK:
8990e307
LW
1155 case OP_JOIN:
1156 case OP_LSLICE:
1157 case OP_ANONLIST:
1158 case OP_ANONHASH:
1159 case OP_SORT:
1160 case OP_REVERSE:
1161 case OP_RANGE:
1162 case OP_FLIP:
1163 case OP_FLOP:
1164 case OP_CALLER:
1165 case OP_FILENO:
1166 case OP_EOF:
1167 case OP_TELL:
1168 case OP_GETSOCKNAME:
1169 case OP_GETPEERNAME:
1170 case OP_READLINK:
1171 case OP_TELLDIR:
1172 case OP_GETPPID:
1173 case OP_GETPGRP:
1174 case OP_GETPRIORITY:
1175 case OP_TIME:
1176 case OP_TMS:
1177 case OP_LOCALTIME:
1178 case OP_GMTIME:
1179 case OP_GHBYNAME:
1180 case OP_GHBYADDR:
1181 case OP_GHOSTENT:
1182 case OP_GNBYNAME:
1183 case OP_GNBYADDR:
1184 case OP_GNETENT:
1185 case OP_GPBYNAME:
1186 case OP_GPBYNUMBER:
1187 case OP_GPROTOENT:
1188 case OP_GSBYNAME:
1189 case OP_GSBYPORT:
1190 case OP_GSERVENT:
1191 case OP_GPWNAM:
1192 case OP_GPWUID:
1193 case OP_GGRNAM:
1194 case OP_GGRGID:
1195 case OP_GETLOGIN:
5d82c453 1196 func_ops:
64aac5a9 1197 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)))
53e06cf0 1198 useless = OP_DESC(o);
8990e307
LW
1199 break;
1200
1201 case OP_RV2GV:
1202 case OP_RV2SV:
1203 case OP_RV2AV:
1204 case OP_RV2HV:
192587c2 1205 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)) &&
11343788 1206 (!o->op_sibling || o->op_sibling->op_type != OP_READLINE))
8990e307
LW
1207 useless = "a variable";
1208 break;
79072805
LW
1209
1210 case OP_CONST:
7766f137 1211 sv = cSVOPo_sv;
7a52d87a
GS
1212 if (cSVOPo->op_private & OPpCONST_STRICT)
1213 no_bareword_allowed(o);
1214 else {
d008e5eb
GS
1215 if (ckWARN(WARN_VOID)) {
1216 useless = "a constant";
960b4253
MG
1217 /* the constants 0 and 1 are permitted as they are
1218 conventionally used as dummies in constructs like
1219 1 while some_condition_with_side_effects; */
d008e5eb
GS
1220 if (SvNIOK(sv) && (SvNV(sv) == 0.0 || SvNV(sv) == 1.0))
1221 useless = 0;
1222 else if (SvPOK(sv)) {
a52fe3ac
A
1223 /* perl4's way of mixing documentation and code
1224 (before the invention of POD) was based on a
1225 trick to mix nroff and perl code. The trick was
1226 built upon these three nroff macros being used in
1227 void context. The pink camel has the details in
1228 the script wrapman near page 319. */
d008e5eb
GS
1229 if (strnEQ(SvPVX(sv), "di", 2) ||
1230 strnEQ(SvPVX(sv), "ds", 2) ||
1231 strnEQ(SvPVX(sv), "ig", 2))
1232 useless = 0;
1233 }
8990e307
LW
1234 }
1235 }
93c66552 1236 op_null(o); /* don't execute or even remember it */
79072805
LW
1237 break;
1238
1239 case OP_POSTINC:
11343788 1240 o->op_type = OP_PREINC; /* pre-increment is faster */
22c35a8c 1241 o->op_ppaddr = PL_ppaddr[OP_PREINC];
79072805
LW
1242 break;
1243
1244 case OP_POSTDEC:
11343788 1245 o->op_type = OP_PREDEC; /* pre-decrement is faster */
22c35a8c 1246 o->op_ppaddr = PL_ppaddr[OP_PREDEC];
79072805
LW
1247 break;
1248
79072805
LW
1249 case OP_OR:
1250 case OP_AND:
c963b151 1251 case OP_DOR:
79072805 1252 case OP_COND_EXPR:
11343788 1253 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
79072805
LW
1254 scalarvoid(kid);
1255 break;
5aabfad6 1256
a0d0e21e 1257 case OP_NULL:
11343788 1258 if (o->op_flags & OPf_STACKED)
a0d0e21e 1259 break;
5aabfad6 1260 /* FALL THROUGH */
2ebea0a1
GS
1261 case OP_NEXTSTATE:
1262 case OP_DBSTATE:
79072805
LW
1263 case OP_ENTERTRY:
1264 case OP_ENTER:
11343788 1265 if (!(o->op_flags & OPf_KIDS))
79072805 1266 break;
54310121 1267 /* FALL THROUGH */
463ee0b2 1268 case OP_SCOPE:
79072805
LW
1269 case OP_LEAVE:
1270 case OP_LEAVETRY:
a0d0e21e 1271 case OP_LEAVELOOP:
79072805 1272 case OP_LINESEQ:
79072805 1273 case OP_LIST:
11343788 1274 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
79072805
LW
1275 scalarvoid(kid);
1276 break;
c90c0ff4 1277 case OP_ENTEREVAL:
5196be3e 1278 scalarkids(o);
c90c0ff4 1279 break;
5aabfad6 1280 case OP_REQUIRE:
c90c0ff4 1281 /* all requires must return a boolean value */
5196be3e 1282 o->op_flags &= ~OPf_WANT;
d6483035
GS
1283 /* FALL THROUGH */
1284 case OP_SCALAR:
5196be3e 1285 return scalar(o);
a0d0e21e 1286 case OP_SPLIT:
11343788 1287 if ((kid = cLISTOPo->op_first) && kid->op_type == OP_PUSHRE) {
a0d0e21e 1288 if (!kPMOP->op_pmreplroot)
12bcd1a6 1289 deprecate_old("implicit split to @_");
a0d0e21e
LW
1290 }
1291 break;
79072805 1292 }
411caa50 1293 if (useless && ckWARN(WARN_VOID))
9014280d 1294 Perl_warner(aTHX_ packWARN(WARN_VOID), "Useless use of %s in void context", useless);
11343788 1295 return o;
79072805
LW
1296}
1297
1298OP *
864dbfa3 1299Perl_listkids(pTHX_ OP *o)
79072805
LW
1300{
1301 OP *kid;
11343788
MB
1302 if (o && o->op_flags & OPf_KIDS) {
1303 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
79072805
LW
1304 list(kid);
1305 }
11343788 1306 return o;
79072805
LW
1307}
1308
1309OP *
864dbfa3 1310Perl_list(pTHX_ OP *o)
79072805
LW
1311{
1312 OP *kid;
1313
a0d0e21e 1314 /* assumes no premature commitment */
3280af22 1315 if (!o || (o->op_flags & OPf_WANT) || PL_error_count
5dc0d613 1316 || o->op_type == OP_RETURN)
7e363e51 1317 {
11343788 1318 return o;
7e363e51 1319 }
79072805 1320
b162f9ea 1321 if ((o->op_private & OPpTARGET_MY)
7e363e51
GS
1322 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1323 {
b162f9ea 1324 return o; /* As if inside SASSIGN */
7e363e51 1325 }
1c846c1f 1326
5dc0d613 1327 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_LIST;
79072805 1328
11343788 1329 switch (o->op_type) {
79072805
LW
1330 case OP_FLOP:
1331 case OP_REPEAT:
11343788 1332 list(cBINOPo->op_first);
79072805
LW
1333 break;
1334 case OP_OR:
1335 case OP_AND:
1336 case OP_COND_EXPR:
11343788 1337 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
79072805
LW
1338 list(kid);
1339 break;
1340 default:
1341 case OP_MATCH:
8782bef2 1342 case OP_QR:
79072805
LW
1343 case OP_SUBST:
1344 case OP_NULL:
11343788 1345 if (!(o->op_flags & OPf_KIDS))
79072805 1346 break;
11343788
MB
1347 if (!o->op_next && cUNOPo->op_first->op_type == OP_FLOP) {
1348 list(cBINOPo->op_first);
1349 return gen_constant_list(o);
79072805
LW
1350 }
1351 case OP_LIST:
11343788 1352 listkids(o);
79072805
LW
1353 break;
1354 case OP_LEAVE:
1355 case OP_LEAVETRY:
5dc0d613 1356 kid = cLISTOPo->op_first;
54310121 1357 list(kid);
155aba94 1358 while ((kid = kid->op_sibling)) {
54310121
PP
1359 if (kid->op_sibling)
1360 scalarvoid(kid);
1361 else
1362 list(kid);
1363 }
3280af22 1364 WITH_THR(PL_curcop = &PL_compiling);
54310121 1365 break;
748a9306 1366 case OP_SCOPE:
79072805 1367 case OP_LINESEQ:
11343788 1368 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
79072805
LW
1369 if (kid->op_sibling)
1370 scalarvoid(kid);
1371 else
1372 list(kid);
1373 }
3280af22 1374 WITH_THR(PL_curcop = &PL_compiling);
79072805 1375 break;
c90c0ff4
PP
1376 case OP_REQUIRE:
1377 /* all requires must return a boolean value */
5196be3e
MB
1378 o->op_flags &= ~OPf_WANT;
1379 return scalar(o);
79072805 1380 }
11343788 1381 return o;
79072805
LW
1382}
1383
1384OP *
864dbfa3 1385Perl_scalarseq(pTHX_ OP *o)
79072805
LW
1386{
1387 OP *kid;
1388
11343788
MB
1389 if (o) {
1390 if (o->op_type == OP_LINESEQ ||
1391 o->op_type == OP_SCOPE ||
1392 o->op_type == OP_LEAVE ||
1393 o->op_type == OP_LEAVETRY)
463ee0b2 1394 {
11343788 1395 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
ed6116ce 1396 if (kid->op_sibling) {
463ee0b2 1397 scalarvoid(kid);
ed6116ce 1398 }
463ee0b2 1399 }
3280af22 1400 PL_curcop = &PL_compiling;
79072805 1401 }
11343788 1402 o->op_flags &= ~OPf_PARENS;
3280af22 1403 if (PL_hints & HINT_BLOCK_SCOPE)
11343788 1404 o->op_flags |= OPf_PARENS;
79072805 1405 }
8990e307 1406 else
11343788
MB
1407 o = newOP(OP_STUB, 0);
1408 return o;
79072805
LW
1409}
1410
76e3520e 1411STATIC OP *
cea2e8a9 1412S_modkids(pTHX_ OP *o, I32 type)
79072805
LW
1413{
1414 OP *kid;
11343788
MB
1415 if (o && o->op_flags & OPf_KIDS) {
1416 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
463ee0b2 1417 mod(kid, type);
79072805 1418 }
11343788 1419 return o;
79072805
LW
1420}
1421
79072805 1422OP *
864dbfa3 1423Perl_mod(pTHX_ OP *o, I32 type)
79072805
LW
1424{
1425 OP *kid;
2d8e6c8d 1426 STRLEN n_a;
79072805 1427
3280af22 1428 if (!o || PL_error_count)
11343788 1429 return o;
79072805 1430
b162f9ea 1431 if ((o->op_private & OPpTARGET_MY)
7e363e51
GS
1432 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1433 {
b162f9ea 1434 return o;
7e363e51 1435 }
1c846c1f 1436
11343788 1437 switch (o->op_type) {
68dc0745 1438 case OP_UNDEF:
3280af22 1439 PL_modcount++;
5dc0d613 1440 return o;
a0d0e21e 1441 case OP_CONST:
11343788 1442 if (!(o->op_private & (OPpCONST_ARYBASE)))
a0d0e21e 1443 goto nomod;
3280af22 1444 if (PL_eval_start && PL_eval_start->op_type == OP_CONST) {
7766f137 1445 PL_compiling.cop_arybase = (I32)SvIV(cSVOPx(PL_eval_start)->op_sv);
3280af22 1446 PL_eval_start = 0;
a0d0e21e
LW
1447 }
1448 else if (!type) {
3280af22
NIS
1449 SAVEI32(PL_compiling.cop_arybase);
1450 PL_compiling.cop_arybase = 0;
a0d0e21e
LW
1451 }
1452 else if (type == OP_REFGEN)
1453 goto nomod;
1454 else
cea2e8a9 1455 Perl_croak(aTHX_ "That use of $[ is unsupported");
a0d0e21e 1456 break;
5f05dabc 1457 case OP_STUB:
5196be3e 1458 if (o->op_flags & OPf_PARENS)
5f05dabc
PP
1459 break;
1460 goto nomod;
a0d0e21e
LW
1461 case OP_ENTERSUB:
1462 if ((type == OP_UNDEF || type == OP_REFGEN) &&
11343788
MB
1463 !(o->op_flags & OPf_STACKED)) {
1464 o->op_type = OP_RV2CV; /* entersub => rv2cv */
22c35a8c 1465 o->op_ppaddr = PL_ppaddr[OP_RV2CV];
11343788 1466 assert(cUNOPo->op_first->op_type == OP_NULL);
93c66552 1467 op_null(((LISTOP*)cUNOPo->op_first)->op_first);/* disable pushmark */
79072805
LW
1468 break;
1469 }
95f0a2f1
SB
1470 else if (o->op_private & OPpENTERSUB_NOMOD)
1471 return o;
cd06dffe
GS
1472 else { /* lvalue subroutine call */
1473 o->op_private |= OPpLVAL_INTRO;
e6438c1a 1474 PL_modcount = RETURN_UNLIMITED_NUMBER;
4978d6d9 1475 if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN) {
cd06dffe
GS
1476 /* Backward compatibility mode: */
1477 o->op_private |= OPpENTERSUB_INARGS;
1478 break;
1479 }
1480 else { /* Compile-time error message: */
1481 OP *kid = cUNOPo->op_first;
1482 CV *cv;
1483 OP *okid;
1484
1485 if (kid->op_type == OP_PUSHMARK)
1486 goto skip_kids;
1487 if (kid->op_type != OP_NULL || kid->op_targ != OP_LIST)
1488 Perl_croak(aTHX_
1489 "panic: unexpected lvalue entersub "
55140b79 1490 "args: type/targ %ld:%"UVuf,
3d811634 1491 (long)kid->op_type, (UV)kid->op_targ);
cd06dffe
GS
1492 kid = kLISTOP->op_first;
1493 skip_kids:
1494 while (kid->op_sibling)
1495 kid = kid->op_sibling;
1496 if (!(kid->op_type == OP_NULL && kid->op_targ == OP_RV2CV)) {
1497 /* Indirect call */
1498 if (kid->op_type == OP_METHOD_NAMED
1499 || kid->op_type == OP_METHOD)
1500 {
87d7fd28 1501 UNOP *newop;
b2ffa427 1502
87d7fd28 1503 NewOp(1101, newop, 1, UNOP);
349fd7b7
GS
1504 newop->op_type = OP_RV2CV;
1505 newop->op_ppaddr = PL_ppaddr[OP_RV2CV];
87d7fd28
GS
1506 newop->op_first = Nullop;
1507 newop->op_next = (OP*)newop;
1508 kid->op_sibling = (OP*)newop;
349fd7b7 1509 newop->op_private |= OPpLVAL_INTRO;
cd06dffe
GS
1510 break;
1511 }
b2ffa427 1512
cd06dffe
GS
1513 if (kid->op_type != OP_RV2CV)
1514 Perl_croak(aTHX_
1515 "panic: unexpected lvalue entersub "
55140b79 1516 "entry via type/targ %ld:%"UVuf,
3d811634 1517 (long)kid->op_type, (UV)kid->op_targ);
cd06dffe
GS
1518 kid->op_private |= OPpLVAL_INTRO;
1519 break; /* Postpone until runtime */
1520 }
b2ffa427
NIS
1521
1522 okid = kid;
cd06dffe
GS
1523 kid = kUNOP->op_first;
1524 if (kid->op_type == OP_NULL && kid->op_targ == OP_RV2SV)
1525 kid = kUNOP->op_first;
b2ffa427 1526 if (kid->op_type == OP_NULL)
cd06dffe
GS
1527 Perl_croak(aTHX_
1528 "Unexpected constant lvalue entersub "
55140b79 1529 "entry via type/targ %ld:%"UVuf,
3d811634 1530 (long)kid->op_type, (UV)kid->op_targ);
cd06dffe
GS
1531 if (kid->op_type != OP_GV) {
1532 /* Restore RV2CV to check lvalueness */
1533 restore_2cv:
1534 if (kid->op_next && kid->op_next != kid) { /* Happens? */
1535 okid->op_next = kid->op_next;
1536 kid->op_next = okid;
1537 }
1538 else
1539 okid->op_next = Nullop;
1540 okid->op_type = OP_RV2CV;
1541 okid->op_targ = 0;
1542 okid->op_ppaddr = PL_ppaddr[OP_RV2CV];
1543 okid->op_private |= OPpLVAL_INTRO;
1544 break;
1545 }
b2ffa427 1546
638eceb6 1547 cv = GvCV(kGVOP_gv);
1c846c1f 1548 if (!cv)
cd06dffe
GS
1549 goto restore_2cv;
1550 if (CvLVALUE(cv))
1551 break;
1552 }
1553 }
79072805
LW
1554 /* FALL THROUGH */
1555 default:
a0d0e21e
LW
1556 nomod:
1557 /* grep, foreach, subcalls, refgen */
1558 if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN)
1559 break;
cea2e8a9 1560 yyerror(Perl_form(aTHX_ "Can't modify %s in %s",
638bc118 1561 (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)
cd06dffe
GS
1562 ? "do block"
1563 : (o->op_type == OP_ENTERSUB
1564 ? "non-lvalue subroutine call"
53e06cf0 1565 : OP_DESC(o))),
22c35a8c 1566 type ? PL_op_desc[type] : "local"));
11343788 1567 return o;
79072805 1568
a0d0e21e
LW
1569 case OP_PREINC:
1570 case OP_PREDEC:
1571 case OP_POW:
1572 case OP_MULTIPLY:
1573 case OP_DIVIDE:
1574 case OP_MODULO:
1575 case OP_REPEAT:
1576 case OP_ADD:
1577 case OP_SUBTRACT:
1578 case OP_CONCAT:
1579 case OP_LEFT_SHIFT:
1580 case OP_RIGHT_SHIFT:
1581 case OP_BIT_AND:
1582 case OP_BIT_XOR:
1583 case OP_BIT_OR:
1584 case OP_I_MULTIPLY:
1585 case OP_I_DIVIDE:
1586 case OP_I_MODULO:
1587 case OP_I_ADD:
1588 case OP_I_SUBTRACT:
11343788 1589 if (!(o->op_flags & OPf_STACKED))
a0d0e21e 1590 goto nomod;
3280af22 1591 PL_modcount++;
a0d0e21e 1592 break;
b2ffa427 1593
79072805 1594 case OP_COND_EXPR:
11343788 1595 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
463ee0b2 1596 mod(kid, type);
79072805
LW
1597 break;
1598
1599 case OP_RV2AV:
1600 case OP_RV2HV:
93af7a87 1601 if (!type && cUNOPo->op_first->op_type != OP_GV)
cea2e8a9 1602 Perl_croak(aTHX_ "Can't localize through a reference");
11343788 1603 if (type == OP_REFGEN && o->op_flags & OPf_PARENS) {
e6438c1a 1604 PL_modcount = RETURN_UNLIMITED_NUMBER;
11343788 1605 return o; /* Treat \(@foo) like ordinary list. */
748a9306
LW
1606 }
1607 /* FALL THROUGH */
79072805 1608 case OP_RV2GV:
5dc0d613 1609 if (scalar_mod_type(o, type))
3fe9a6f1 1610 goto nomod;
11343788 1611 ref(cUNOPo->op_first, o->op_type);
79072805 1612 /* FALL THROUGH */
79072805
LW
1613 case OP_ASLICE:
1614 case OP_HSLICE:
78f9721b
SM
1615 if (type == OP_LEAVESUBLV)
1616 o->op_private |= OPpMAYBE_LVSUB;
1617 /* FALL THROUGH */
1618 case OP_AASSIGN:
93a17b20
LW
1619 case OP_NEXTSTATE:
1620 case OP_DBSTATE:
e6438c1a 1621 PL_modcount = RETURN_UNLIMITED_NUMBER;
79072805 1622 break;
463ee0b2 1623 case OP_RV2SV:
11343788 1624 if (!type && cUNOPo->op_first->op_type != OP_GV)
cea2e8a9 1625 Perl_croak(aTHX_ "Can't localize through a reference");
aeea060c 1626 ref(cUNOPo->op_first, o->op_type);
463ee0b2 1627 /* FALL THROUGH */
79072805 1628 case OP_GV:
463ee0b2 1629 case OP_AV2ARYLEN:
3280af22 1630 PL_hints |= HINT_BLOCK_SCOPE;
463ee0b2 1631 case OP_SASSIGN:
bf4b1e52
GS
1632 case OP_ANDASSIGN:
1633 case OP_ORASSIGN:
c963b151 1634 case OP_DORASSIGN:
8990e307 1635 case OP_AELEMFAST:
3280af22 1636 PL_modcount++;
8990e307
LW
1637 break;
1638
748a9306
LW
1639 case OP_PADAV:
1640 case OP_PADHV:
e6438c1a 1641 PL_modcount = RETURN_UNLIMITED_NUMBER;
5196be3e
MB
1642 if (type == OP_REFGEN && o->op_flags & OPf_PARENS)
1643 return o; /* Treat \(@foo) like ordinary list. */
1644 if (scalar_mod_type(o, type))
3fe9a6f1 1645 goto nomod;
78f9721b
SM
1646 if (type == OP_LEAVESUBLV)
1647 o->op_private |= OPpMAYBE_LVSUB;
748a9306
LW
1648 /* FALL THROUGH */
1649 case OP_PADSV:
3280af22 1650 PL_modcount++;
748a9306 1651 if (!type)
cea2e8a9 1652 Perl_croak(aTHX_ "Can't localize lexical variable %s",
2d8e6c8d 1653 SvPV(*av_fetch(PL_comppad_name, o->op_targ, 4), n_a));
463ee0b2
LW
1654 break;
1655
4d1ff10f 1656#ifdef USE_5005THREADS
2faa37cc 1657 case OP_THREADSV:
533c011a 1658 PL_modcount++; /* XXX ??? */
554b3eca 1659 break;
4d1ff10f 1660#endif /* USE_5005THREADS */
554b3eca 1661
748a9306
LW
1662 case OP_PUSHMARK:
1663 break;
b2ffa427 1664
69969c6f
SB
1665 case OP_KEYS:
1666 if (type != OP_SASSIGN)
1667 goto nomod;
5d82c453
GA
1668 goto lvalue_func;
1669 case OP_SUBSTR:
1670 if (o->op_private == 4) /* don't allow 4 arg substr as lvalue */
1671 goto nomod;
5f05dabc 1672 /* FALL THROUGH */
a0d0e21e 1673 case OP_POS:
463ee0b2 1674 case OP_VEC:
78f9721b
SM
1675 if (type == OP_LEAVESUBLV)
1676 o->op_private |= OPpMAYBE_LVSUB;
5d82c453 1677 lvalue_func:
11343788
MB
1678 pad_free(o->op_targ);
1679 o->op_targ = pad_alloc(o->op_type, SVs_PADMY);
5dc0d613 1680 assert(SvTYPE(PAD_SV(o->op_targ)) == SVt_NULL);
11343788
MB
1681 if (o->op_flags & OPf_KIDS)
1682 mod(cBINOPo->op_first->op_sibling, type);
463ee0b2 1683 break;
a0d0e21e 1684
463ee0b2
LW
1685 case OP_AELEM:
1686 case OP_HELEM:
11343788 1687 ref(cBINOPo->op_first, o->op_type);
68dc0745 1688 if (type == OP_ENTERSUB &&
5dc0d613
MB
1689 !(o->op_private & (OPpLVAL_INTRO | OPpDEREF)))
1690 o->op_private |= OPpLVAL_DEFER;
78f9721b
SM
1691 if (type == OP_LEAVESUBLV)
1692 o->op_private |= OPpMAYBE_LVSUB;
3280af22 1693 PL_modcount++;
463ee0b2
LW
1694 break;
1695
1696 case OP_SCOPE:
1697 case OP_LEAVE:
1698 case OP_ENTER:
78f9721b 1699 case OP_LINESEQ:
11343788
MB
1700 if (o->op_flags & OPf_KIDS)
1701 mod(cLISTOPo->op_last, type);
a0d0e21e
LW
1702 break;
1703
1704 case OP_NULL:
638bc118
GS
1705 if (o->op_flags & OPf_SPECIAL) /* do BLOCK */
1706 goto nomod;
1707 else if (!(o->op_flags & OPf_KIDS))
463ee0b2 1708 break;
11343788
MB
1709 if (o->op_targ != OP_LIST) {
1710 mod(cBINOPo->op_first, type);
a0d0e21e
LW
1711 break;
1712 }
1713 /* FALL THROUGH */
463ee0b2 1714 case OP_LIST:
11343788 1715 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
463ee0b2
LW
1716 mod(kid, type);
1717 break;
78f9721b
SM
1718
1719 case OP_RETURN:
1720 if (type != OP_LEAVESUBLV)
1721 goto nomod;
1722 break; /* mod()ing was handled by ck_return() */
463ee0b2 1723 }
58d95175 1724
8be1be90
AMS
1725 /* [20011101.069] File test operators interpret OPf_REF to mean that
1726 their argument is a filehandle; thus \stat(".") should not set
1727 it. AMS 20011102 */
1728 if (type == OP_REFGEN &&
1729 PL_check[o->op_type] == MEMBER_TO_FPTR(Perl_ck_ftst))
1730 return o;
1731
1732 if (type != OP_LEAVESUBLV)
1733 o->op_flags |= OPf_MOD;
1734
1735 if (type == OP_AASSIGN || type == OP_SASSIGN)
1736 o->op_flags |= OPf_SPECIAL|OPf_REF;
1737 else if (!type) {
1738 o->op_private |= OPpLVAL_INTRO;
1739 o->op_flags &= ~OPf_SPECIAL;
1740 PL_hints |= HINT_BLOCK_SCOPE;
463ee0b2 1741 }
8be1be90
AMS
1742 else if (type != OP_GREPSTART && type != OP_ENTERSUB
1743 && type != OP_LEAVESUBLV)
1744 o->op_flags |= OPf_REF;
11343788 1745 return o;
463ee0b2
LW
1746}
1747
864dbfa3 1748STATIC bool
cea2e8a9 1749S_scalar_mod_type(pTHX_ OP *o, I32 type)
3fe9a6f1
PP
1750{
1751 switch (type) {
1752 case OP_SASSIGN:
5196be3e 1753 if (o->op_type == OP_RV2GV)
3fe9a6f1
PP
1754 return FALSE;
1755 /* FALL THROUGH */
1756 case OP_PREINC:
1757 case OP_PREDEC:
1758 case OP_POSTINC:
1759 case OP_POSTDEC:
1760 case OP_I_PREINC:
1761 case OP_I_PREDEC:
1762 case OP_I_POSTINC:
1763 case OP_I_POSTDEC:
1764 case OP_POW:
1765 case OP_MULTIPLY:
1766 case OP_DIVIDE:
1767 case OP_MODULO:
1768 case OP_REPEAT:
1769 case OP_ADD:
1770 case OP_SUBTRACT:
1771 case OP_I_MULTIPLY:
1772 case OP_I_DIVIDE:
1773 case OP_I_MODULO:
1774 case OP_I_ADD:
1775 case OP_I_SUBTRACT:
1776 case OP_LEFT_SHIFT:
1777 case OP_RIGHT_SHIFT:
1778 case OP_BIT_AND:
1779 case OP_BIT_XOR:
1780 case OP_BIT_OR:
1781 case OP_CONCAT:
1782 case OP_SUBST:
1783 case OP_TRANS:
49e9fbe6
GS
1784 case OP_READ:
1785 case OP_SYSREAD:
1786 case OP_RECV:
bf4b1e52
GS
1787 case OP_ANDASSIGN:
1788 case OP_ORASSIGN:
3fe9a6f1
PP
1789 return TRUE;
1790 default:
1791 return FALSE;
1792 }
1793}
1794
35cd451c 1795STATIC bool
cea2e8a9 1796S_is_handle_constructor(pTHX_ OP *o, I32 argnum)
35cd451c
GS
1797{
1798 switch (o->op_type) {
1799 case OP_PIPE_OP:
1800 case OP_SOCKPAIR:
1801 if (argnum == 2)
1802 return TRUE;
1803 /* FALL THROUGH */
1804 case OP_SYSOPEN:
1805 case OP_OPEN:
ded8aa31 1806 case OP_SELECT: /* XXX c.f. SelectSaver.pm */
35cd451c
GS
1807 case OP_SOCKET:
1808 case OP_OPEN_DIR:
1809 case OP_ACCEPT:
1810 if (argnum == 1)
1811 return TRUE;
1812 /* FALL THROUGH */
1813 default:
1814 return FALSE;
1815 }
1816}
1817
463ee0b2 1818OP *
864dbfa3 1819Perl_refkids(pTHX_ OP *o, I32 type)
463ee0b2
LW
1820{
1821 OP *kid;
11343788
MB
1822 if (o && o->op_flags & OPf_KIDS) {
1823 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
463ee0b2
LW
1824 ref(kid, type);
1825 }
11343788 1826 return o;
463ee0b2
LW
1827}
1828
1829OP *
864dbfa3 1830Perl_ref(pTHX_ OP *o, I32 type)
463ee0b2
LW
1831{
1832 OP *kid;
463ee0b2 1833
3280af22 1834 if (!o || PL_error_count)
11343788 1835 return o;
463ee0b2 1836
11343788 1837 switch (o->op_type) {
a0d0e21e 1838 case OP_ENTERSUB:
afebc493 1839 if ((type == OP_EXISTS || type == OP_DEFINED || type == OP_LOCK) &&
11343788
MB
1840 !(o->op_flags & OPf_STACKED)) {
1841 o->op_type = OP_RV2CV; /* entersub => rv2cv */
22c35a8c 1842 o->op_ppaddr = PL_ppaddr[OP_RV2CV];
11343788 1843 assert(cUNOPo->op_first->op_type == OP_NULL);
93c66552 1844 op_null(((LISTOP*)cUNOPo->op_first)->op_first); /* disable pushmark */
11343788 1845 o->op_flags |= OPf_SPECIAL;
8990e307
LW
1846 }
1847 break;
aeea060c 1848
463ee0b2 1849 case OP_COND_EXPR:
11343788 1850 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
463ee0b2
LW
1851 ref(kid, type);
1852 break;
8990e307 1853 case OP_RV2SV:
35cd451c
GS
1854 if (type == OP_DEFINED)
1855 o->op_flags |= OPf_SPECIAL; /* don't create GV */
11343788 1856 ref(cUNOPo->op_first, o->op_type);
4633a7c4
LW
1857 /* FALL THROUGH */
1858 case OP_PADSV:
5f05dabc 1859 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
5dc0d613
MB
1860 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
1861 : type == OP_RV2HV ? OPpDEREF_HV
1862 : OPpDEREF_SV);
11343788 1863 o->op_flags |= OPf_MOD;
a0d0e21e 1864 }
8990e307 1865 break;
1c846c1f 1866
2faa37cc 1867 case OP_THREADSV:
a863c7d1
MB
1868 o->op_flags |= OPf_MOD; /* XXX ??? */
1869 break;
1870
463ee0b2
LW
1871 case OP_RV2AV:
1872 case OP_RV2HV:
aeea060c 1873 o->op_flags |= OPf_REF;
8990e307 1874 /* FALL THROUGH */
463ee0b2 1875 case OP_RV2GV:
35cd451c
GS
1876 if (type == OP_DEFINED)
1877 o->op_flags |= OPf_SPECIAL; /* don't create GV */
11343788 1878 ref(cUNOPo->op_first, o->op_type);
463ee0b2 1879 break;
8990e307 1880
463ee0b2
LW
1881 case OP_PADAV:
1882 case OP_PADHV:
aeea060c 1883 o->op_flags |= OPf_REF;
79072805 1884 break;
aeea060c 1885
8990e307 1886 case OP_SCALAR:
79072805 1887 case OP_NULL:
11343788 1888 if (!(o->op_flags & OPf_KIDS))
463ee0b2 1889 break;
11343788 1890 ref(cBINOPo->op_first, type);
79072805
LW
1891 break;
1892 case OP_AELEM:
1893 case OP_HELEM:
11343788 1894 ref(cBINOPo->op_first, o->op_type);
5f05dabc 1895 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
5dc0d613
MB
1896 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
1897 : type == OP_RV2HV ? OPpDEREF_HV
1898 : OPpDEREF_SV);
11343788 1899 o->op_flags |= OPf_MOD;
8990e307 1900 }
79072805
LW
1901 break;
1902
463ee0b2 1903 case OP_SCOPE:
79072805
LW
1904 case OP_LEAVE:
1905 case OP_ENTER:
8990e307 1906 case OP_LIST:
11343788 1907 if (!(o->op_flags & OPf_KIDS))
79072805 1908 break;
11343788 1909 ref(cLISTOPo->op_last, type);
79072805 1910 break;
a0d0e21e
LW
1911 default:
1912 break;
79072805 1913 }
11343788 1914 return scalar(o);
8990e307 1915
79072805
LW
1916}
1917
09bef843
SB
1918STATIC OP *
1919S_dup_attrlist(pTHX_ OP *o)
1920{
1921 OP *rop = Nullop;
1922
1923 /* An attrlist is either a simple OP_CONST or an OP_LIST with kids,
1924 * where the first kid is OP_PUSHMARK and the remaining ones
1925 * are OP_CONST. We need to push the OP_CONST values.
1926 */
1927 if (o->op_type == OP_CONST)
1928 rop = newSVOP(OP_CONST, o->op_flags, SvREFCNT_inc(cSVOPo->op_sv));
1929 else {
1930 assert((o->op_type == OP_LIST) && (o->op_flags & OPf_KIDS));
1931 for (o = cLISTOPo->op_first; o; o=o->op_sibling) {
1932 if (o->op_type == OP_CONST)
1933 rop = append_elem(OP_LIST, rop,
1934 newSVOP(OP_CONST, o->op_flags,
1935 SvREFCNT_inc(cSVOPo->op_sv)));
1936 }
1937 }
1938 return rop;
1939}
1940
1941STATIC void
95f0a2f1 1942S_apply_attrs(pTHX_ HV *stash, SV *target, OP *attrs, bool for_my)
09bef843 1943{
09bef843
SB
1944 SV *stashsv;
1945
1946 /* fake up C<use attributes $pkg,$rv,@attrs> */
1947 ENTER; /* need to protect against side-effects of 'use' */
1948 SAVEINT(PL_expect);
a9164de8 1949 if (stash)
09bef843
SB
1950 stashsv = newSVpv(HvNAME(stash), 0);
1951 else
1952 stashsv = &PL_sv_no;
e4783991 1953
09bef843 1954#define ATTRSMODULE "attributes"
95f0a2f1
SB
1955#define ATTRSMODULE_PM "attributes.pm"
1956
1957 if (for_my) {
1958 SV **svp;
1959 /* Don't force the C<use> if we don't need it. */
1960 svp = hv_fetch(GvHVn(PL_incgv), ATTRSMODULE_PM,
1961 sizeof(ATTRSMODULE_PM)-1, 0);
1962 if (svp && *svp != &PL_sv_undef)
1963 ; /* already in %INC */
1964 else
1965 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
1966 newSVpvn(ATTRSMODULE, sizeof(ATTRSMODULE)-1),
1967 Nullsv);
1968 }
1969 else {
1970 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
1971 newSVpvn(ATTRSMODULE, sizeof(ATTRSMODULE)-1),
1972 Nullsv,
1973 prepend_elem(OP_LIST,
1974 newSVOP(OP_CONST, 0, stashsv),
1975 prepend_elem(OP_LIST,
1976 newSVOP(OP_CONST, 0,
1977 newRV(target)),
1978 dup_attrlist(attrs))));
1979 }
09bef843
SB
1980 LEAVE;
1981}
1982
95f0a2f1
SB
1983STATIC void
1984S_apply_attrs_my(pTHX_ HV *stash, OP *target, OP *attrs, OP **imopsp)
1985{
1986 OP *pack, *imop, *arg;
1987 SV *meth, *stashsv;
1988
1989 if (!attrs)
1990 return;
1991
1992 assert(target->op_type == OP_PADSV ||
1993 target->op_type == OP_PADHV ||
1994 target->op_type == OP_PADAV);
1995
1996 /* Ensure that attributes.pm is loaded. */
1997 apply_attrs(stash, pad_sv(target->op_targ), attrs, TRUE);
1998
1999 /* Need package name for method call. */
2000 pack = newSVOP(OP_CONST, 0, newSVpvn(ATTRSMODULE, sizeof(ATTRSMODULE)-1));
2001
2002 /* Build up the real arg-list. */
2003 if (stash)
2004 stashsv = newSVpv(HvNAME(stash), 0);
2005 else
2006 stashsv = &PL_sv_no;
2007 arg = newOP(OP_PADSV, 0);
2008 arg->op_targ = target->op_targ;
2009 arg = prepend_elem(OP_LIST,
2010 newSVOP(OP_CONST, 0, stashsv),
2011 prepend_elem(OP_LIST,
2012 newUNOP(OP_REFGEN, 0,
2013 mod(arg, OP_REFGEN)),
2014 dup_attrlist(attrs)));
2015
2016 /* Fake up a method call to import */
2017 meth = newSVpvn("import", 6);
2018 (void)SvUPGRADE(meth, SVt_PVIV);
2019 (void)SvIOK_on(meth);
5afd6d42 2020 PERL_HASH(SvUVX(meth), SvPVX(meth), SvCUR(meth));
95f0a2f1
SB
2021 imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL|OPf_WANT_VOID,
2022 append_elem(OP_LIST,
2023 prepend_elem(OP_LIST, pack, list(arg)),
2024 newSVOP(OP_METHOD_NAMED, 0, meth)));
2025 imop->op_private |= OPpENTERSUB_NOMOD;
2026
2027 /* Combine the ops. */
2028 *imopsp = append_elem(OP_LIST, *imopsp, imop);
2029}
2030
2031/*
2032=notfor apidoc apply_attrs_string
2033
2034Attempts to apply a list of attributes specified by the C<attrstr> and
2035C<len> arguments to the subroutine identified by the C<cv> argument which
2036is expected to be associated with the package identified by the C<stashpv>
2037argument (see L<attributes>). It gets this wrong, though, in that it
2038does not correctly identify the boundaries of the individual attribute
2039specifications within C<attrstr>. This is not really intended for the
2040public API, but has to be listed here for systems such as AIX which
2041need an explicit export list for symbols. (It's called from XS code
2042in support of the C<ATTRS:> keyword from F<xsubpp>.) Patches to fix it
2043to respect attribute syntax properly would be welcome.
2044
2045=cut
2046*/
2047
be3174d2
GS
2048void
2049Perl_apply_attrs_string(pTHX_ char *stashpv, CV *cv,
2050 char *attrstr, STRLEN len)
2051{
2052 OP *attrs = Nullop;
2053
2054 if (!len) {
2055 len = strlen(attrstr);
2056 }
2057
2058 while (len) {
2059 for (; isSPACE(*attrstr) && len; --len, ++attrstr) ;
2060 if (len) {
2061 char *sstr = attrstr;
2062 for (; !isSPACE(*attrstr) && len; --len, ++attrstr) ;
2063 attrs = append_elem(OP_LIST, attrs,
2064 newSVOP(OP_CONST, 0,
2065 newSVpvn(sstr, attrstr-sstr)));
2066 }
2067 }
2068
2069 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
2070 newSVpvn(ATTRSMODULE, sizeof(ATTRSMODULE)-1),
2071 Nullsv, prepend_elem(OP_LIST,
2072 newSVOP(OP_CONST, 0, newSVpv(stashpv,0)),
2073 prepend_elem(OP_LIST,
2074 newSVOP(OP_CONST, 0,
2075 newRV((SV*)cv)),
2076 attrs)));
2077}
2078
09bef843 2079STATIC OP *
95f0a2f1 2080S_my_kid(pTHX_ OP *o, OP *attrs, OP **imopsp)
93a17b20
LW
2081{
2082 OP *kid;
93a17b20
LW
2083 I32 type;
2084
3280af22 2085 if (!o || PL_error_count)
11343788 2086 return o;
93a17b20 2087
11343788 2088 type = o->op_type;
93a17b20 2089 if (type == OP_LIST) {
11343788 2090 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
95f0a2f1 2091 my_kid(kid, attrs, imopsp);
dab48698 2092 } else if (type == OP_UNDEF) {
7766148a 2093 return o;
77ca0c92
LW
2094 } else if (type == OP_RV2SV || /* "our" declaration */
2095 type == OP_RV2AV ||
2096 type == OP_RV2HV) { /* XXX does this let anything illegal in? */
1ce0b88c
RGS
2097 if (cUNOPo->op_first->op_type != OP_GV) { /* MJD 20011224 */
2098 yyerror(Perl_form(aTHX_ "Can't declare %s in %s",
2099 OP_DESC(o), PL_in_my == KEY_our ? "our" : "my"));
2100 } else if (attrs) {
2101 GV *gv = cGVOPx_gv(cUNOPo->op_first);
2102 PL_in_my = FALSE;
2103 PL_in_my_stash = Nullhv;
2104 apply_attrs(GvSTASH(gv),
2105 (type == OP_RV2SV ? GvSV(gv) :
2106 type == OP_RV2AV ? (SV*)GvAV(gv) :
2107 type == OP_RV2HV ? (SV*)GvHV(gv) : (SV*)gv),
2108 attrs, FALSE);
2109 }
192587c2 2110 o->op_private |= OPpOUR_INTRO;
77ca0c92 2111 return o;
95f0a2f1
SB
2112 }
2113 else if (type != OP_PADSV &&
93a17b20
LW
2114 type != OP_PADAV &&
2115 type != OP_PADHV &&
2116 type != OP_PUSHMARK)
2117 {
eb64745e 2118 yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"",
53e06cf0 2119 OP_DESC(o),
eb64745e 2120 PL_in_my == KEY_our ? "our" : "my"));
11343788 2121 return o;
93a17b20 2122 }
09bef843
SB
2123 else if (attrs && type != OP_PUSHMARK) {
2124 HV *stash;
09bef843
SB
2125 SV **namesvp;
2126
eb64745e
GS
2127 PL_in_my = FALSE;
2128 PL_in_my_stash = Nullhv;
2129
09bef843
SB
2130 /* check for C<my Dog $spot> when deciding package */
2131 namesvp = av_fetch(PL_comppad_name, o->op_targ, FALSE);
a9164de8 2132 if (namesvp && *namesvp && (SvFLAGS(*namesvp) & SVpad_TYPED))
09bef843
SB
2133 stash = SvSTASH(*namesvp);
2134 else
2135 stash = PL_curstash;
95f0a2f1 2136 apply_attrs_my(stash, o, attrs, imopsp);
09bef843 2137 }
11343788
MB
2138 o->op_flags |= OPf_MOD;
2139 o->op_private |= OPpLVAL_INTRO;
2140 return o;
93a17b20
LW
2141}
2142
2143OP *
09bef843
SB
2144Perl_my_attrs(pTHX_ OP *o, OP *attrs)
2145{
95f0a2f1
SB
2146 OP *rops = Nullop;
2147 int maybe_scalar = 0;
2148
d2be0de5
YST
2149/* [perl #17376]: this appears to be premature, and results in code such as
2150 C< my(%x); > executing in list mode rather than void mode */
2151#if 0
09bef843
SB
2152 if (o->op_flags & OPf_PARENS)
2153 list(o);
95f0a2f1
SB
2154 else
2155 maybe_scalar = 1;
d2be0de5
YST
2156#else
2157 maybe_scalar = 1;
2158#endif
09bef843
SB
2159 if (attrs)
2160 SAVEFREEOP(attrs);
95f0a2f1
SB
2161 o = my_kid(o, attrs, &rops);
2162 if (rops) {
2163 if (maybe_scalar && o->op_type == OP_PADSV) {
2164 o = scalar(append_list(OP_LIST, (LISTOP*)rops, (LISTOP*)o));
2165 o->op_private |= OPpLVAL_INTRO;
2166 }
2167 else
2168 o = append_list(OP_LIST, (LISTOP*)o, (LISTOP*)rops);
2169 }
eb64745e
GS
2170 PL_in_my = FALSE;
2171 PL_in_my_stash = Nullhv;
2172 return o;
09bef843
SB
2173}
2174
2175OP *
2176Perl_my(pTHX_ OP *o)
2177{
95f0a2f1 2178 return my_attrs(o, Nullop);
09bef843
SB
2179}
2180
2181OP *
864dbfa3 2182Perl_sawparens(pTHX_ OP *o)
79072805
LW
2183{
2184 if (o)
2185 o->op_flags |= OPf_PARENS;
2186 return o;
2187}
2188
2189OP *
864dbfa3 2190Perl_bind_match(pTHX_ I32 type, OP *left, OP *right)
79072805 2191{
11343788 2192 OP *o;
79072805 2193
e476b1b5 2194 if (ckWARN(WARN_MISC) &&
599cee73
PM
2195 (left->op_type == OP_RV2AV ||
2196 left->op_type == OP_RV2HV ||
2197 left->op_type == OP_PADAV ||
2198 left->op_type == OP_PADHV)) {
22c35a8c 2199 char *desc = PL_op_desc[(right->op_type == OP_SUBST ||
599cee73
PM
2200 right->op_type == OP_TRANS)
2201 ? right->op_type : OP_MATCH];
dff6d3cd
GS
2202 const char *sample = ((left->op_type == OP_RV2AV ||
2203 left->op_type == OP_PADAV)
2204 ? "@array" : "%hash");
9014280d 2205 Perl_warner(aTHX_ packWARN(WARN_MISC),
1c846c1f 2206 "Applying %s to %s will act on scalar(%s)",
599cee73 2207 desc, sample, sample);
2ae324a7
PP
2208 }
2209
5cc9e5c9
RH
2210 if (right->op_type == OP_CONST &&
2211 cSVOPx(right)->op_private & OPpCONST_BARE &&
2212 cSVOPx(right)->op_private & OPpCONST_STRICT)
2213 {
2214 no_bareword_allowed(right);
2215 }
2216
de4bf5b3
G
2217 if (!(right->op_flags & OPf_STACKED) &&
2218 (right->op_type == OP_MATCH ||
79072805 2219 right->op_type == OP_SUBST ||
de4bf5b3 2220 right->op_type == OP_TRANS)) {
79072805 2221 right->op_flags |= OPf_STACKED;
18808301
JH
2222 if (right->op_type != OP_MATCH &&
2223 ! (right->op_type == OP_TRANS &&
2224 right->op_private & OPpTRANS_IDENTICAL))
463ee0b2 2225 left = mod(left, right->op_type);
79072805 2226 if (right->op_type == OP_TRANS)
11343788 2227 o = newBINOP(OP_NULL, OPf_STACKED, scalar(left), right);
79072805 2228 else
11343788 2229 o = prepend_elem(right->op_type, scalar(left), right);
79072805 2230 if (type == OP_NOT)
11343788
MB
2231 return newUNOP(OP_NOT, 0, scalar(o));
2232 return o;
79072805
LW
2233 }
2234 else
2235 return bind_match(type, left,
2236 pmruntime(newPMOP(OP_MATCH, 0), right, Nullop));
2237}
2238
2239OP *
864dbfa3 2240Perl_invert(pTHX_ OP *o)
79072805 2241{
11343788
MB
2242 if (!o)
2243 return o;
79072805 2244 /* XXX need to optimize away NOT NOT here? Or do we let optimizer do it? */
11343788 2245 return newUNOP(OP_NOT, OPf_SPECIAL, scalar(o));
79072805
LW
2246}
2247
2248OP *
864dbfa3 2249Perl_scope(pTHX_ OP *o)
79072805
LW
2250{
2251 if (o) {
3280af22 2252 if (o->op_flags & OPf_PARENS || PERLDB_NOOPT || PL_tainting) {
463ee0b2
LW
2253 o = prepend_elem(OP_LINESEQ, newOP(OP_ENTER, 0), o);
2254 o->op_type = OP_LEAVE;
22c35a8c 2255 o->op_ppaddr = PL_ppaddr[OP_LEAVE];
463ee0b2
LW
2256 }
2257 else {
2258 if (o->op_type == OP_LINESEQ) {
2259 OP *kid;
2260 o->op_type = OP_SCOPE;
22c35a8c 2261 o->op_ppaddr = PL_ppaddr[OP_SCOPE];
c3ed7a6a
GS
2262 kid = ((LISTOP*)o)->op_first;
2263 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE)
93c66552 2264 op_null(kid);
463ee0b2
LW
2265 }
2266 else
748a9306 2267 o = newLISTOP(OP_SCOPE, 0, o, Nullop);
463ee0b2 2268 }
79072805
LW
2269 }
2270 return o;
2271}
2272
b3ac6de7 2273void
864dbfa3 2274Perl_save_hints(pTHX)
b3ac6de7 2275{
3280af22
NIS
2276 SAVEI32(PL_hints);
2277 SAVESPTR(GvHV(PL_hintgv));
2278 GvHV(PL_hintgv) = newHVhv(GvHV(PL_hintgv));
2279 SAVEFREESV(GvHV(PL_hintgv));
b3ac6de7
IZ
2280}
2281
a0d0e21e 2282int
864dbfa3 2283Perl_block_start(pTHX_ int full)
79072805 2284{
3280af22 2285 int retval = PL_savestack_ix;
b3ac6de7 2286
3280af22 2287 SAVEI32(PL_comppad_name_floor);
43d4d5c6
GS
2288 PL_comppad_name_floor = AvFILLp(PL_comppad_name);
2289 if (full)
2290 PL_comppad_name_fill = PL_comppad_name_floor;
2291 if (PL_comppad_name_floor < 0)
2292 PL_comppad_name_floor = 0;
3280af22
NIS
2293 SAVEI32(PL_min_intro_pending);
2294 SAVEI32(PL_max_intro_pending);
2295 PL_min_intro_pending = 0;
2296 SAVEI32(PL_comppad_name_fill);
2297 SAVEI32(PL_padix_floor);
2298 PL_padix_floor = PL_padix;
2299 PL_pad_reset_pending = FALSE;
b3ac6de7 2300 SAVEHINTS();
3280af22 2301 PL_hints &= ~HINT_BLOCK_SCOPE;
1c846c1f 2302 SAVESPTR(PL_compiling.cop_warnings);
0453d815 2303 if (! specialWARN(PL_compiling.cop_warnings)) {
599cee73
PM
2304 PL_compiling.cop_warnings = newSVsv(PL_compiling.cop_warnings) ;
2305 SAVEFREESV(PL_compiling.cop_warnings) ;
2306 }
ac27b0f5
NIS
2307 SAVESPTR(PL_compiling.cop_io);
2308 if (! specialCopIO(PL_compiling.cop_io)) {
2309 PL_compiling.cop_io = newSVsv(PL_compiling.cop_io) ;
2310 SAVEFREESV(PL_compiling.cop_io) ;
2311 }
a0d0e21e
LW
2312 return retval;
2313}
2314
2315OP*
864dbfa3 2316Perl_block_end(pTHX_ I32 floor, OP *seq)
a0d0e21e 2317{
3280af22 2318 int needblockscope = PL_hints & HINT_BLOCK_SCOPE;
d8a34499
IK
2319 line_t copline = PL_copline;
2320 /* there should be a nextstate in every block */
2321 OP* retval = seq ? scalarseq(seq) : newSTATEOP(0, Nullch, seq);
2322 PL_copline = copline; /* XXX newSTATEOP may reset PL_copline */
e9818f4e 2323 LEAVE_SCOPE(floor);
3280af22 2324 PL_pad_reset_pending = FALSE;
eb160463 2325 PL_compiling.op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
a0d0e21e 2326 if (needblockscope)
3280af22
NIS
2327 PL_hints |= HINT_BLOCK_SCOPE; /* propagate out */
2328 pad_leavemy(PL_comppad_name_fill);
2329 PL_cop_seqmax++;
a0d0e21e
LW
2330 return retval;
2331}
2332
76e3520e 2333STATIC OP *
cea2e8a9 2334S_newDEFSVOP(pTHX)
54b9620d 2335{
4d1ff10f 2336#ifdef USE_5005THREADS
54b9620d
MB
2337 OP *o = newOP(OP_THREADSV, 0);
2338 o->op_targ = find_threadsv("_");
2339 return o;
2340#else
3280af22 2341 return newSVREF(newGVOP(OP_GV, 0, PL_defgv));
4d1ff10f 2342#endif /* USE_5005THREADS */
54b9620d
MB
2343}
2344
a0d0e21e 2345void
864dbfa3 2346Perl_newPROG(pTHX_ OP *o)
a0d0e21e 2347{
3280af22 2348 if (PL_in_eval) {
b295d113
TH
2349 if (PL_eval_root)
2350 return;
faef0170
HS
2351 PL_eval_root = newUNOP(OP_LEAVEEVAL,
2352 ((PL_in_eval & EVAL_KEEPERR)
2353 ? OPf_SPECIAL : 0), o);
3280af22 2354 PL_eval_start = linklist(PL_eval_root);
7934575e
GS
2355 PL_eval_root->op_private |= OPpREFCOUNTED;
2356 OpREFCNT_set(PL_eval_root, 1);
3280af22 2357 PL_eval_root->op_next = 0;
a2efc822 2358 CALL_PEEP(PL_eval_start);
a0d0e21e
LW
2359 }
2360 else {
5dc0d613 2361 if (!o)
a0d0e21e 2362 return;
3280af22
NIS
2363 PL_main_root = scope(sawparens(scalarvoid(o)));
2364 PL_curcop = &PL_compiling;
2365 PL_main_start = LINKLIST(PL_main_root);
7934575e
GS
2366 PL_main_root->op_private |= OPpREFCOUNTED;
2367 OpREFCNT_set(PL_main_root, 1);
3280af22 2368 PL_main_root->op_next = 0;
a2efc822 2369 CALL_PEEP(PL_main_start);
3280af22 2370 PL_compcv = 0;
3841441e 2371
4fdae800 2372 /* Register with debugger */
84902520 2373 if (PERLDB_INTER) {
864dbfa3 2374 CV *cv = get_cv("DB::postponed", FALSE);
3841441e
CS
2375 if (cv) {
2376 dSP;
924508f0 2377 PUSHMARK(SP);
cc49e20b 2378 XPUSHs((SV*)CopFILEGV(&PL_compiling));
3841441e 2379 PUTBACK;
864dbfa3 2380 call_sv((SV*)cv, G_DISCARD);
3841441e
CS
2381 }
2382 }
79072805 2383 }
79072805
LW
2384}
2385
2386OP *
864dbfa3 2387Perl_localize(pTHX_ OP *o, I32 lex)
79072805
LW
2388{
2389 if (o->op_flags & OPf_PARENS)
d2be0de5
YST
2390/* [perl #17376]: this appears to be premature, and results in code such as
2391 C< our(%x); > executing in list mode rather than void mode */
2392#if 0
79072805 2393 list(o);
d2be0de5
YST
2394#else
2395 ;
2396#endif
8990e307 2397 else {
64420d0d
JH
2398 if (ckWARN(WARN_PARENTHESIS)
2399 && PL_bufptr > PL_oldbufptr && PL_bufptr[-1] == ',')
2400 {
2401 char *s = PL_bufptr;
2402
2403 while (*s && (isALNUM(*s) || UTF8_IS_CONTINUED(*s) || strchr("@$%, ", *s)))
2404 s++;
2405
a0d0e21e 2406 if (*s == ';' || *s == '=')
9014280d 2407 Perl_warner(aTHX_ packWARN(WARN_PARENTHESIS),
eb64745e
GS
2408 "Parentheses missing around \"%s\" list",
2409 lex ? (PL_in_my == KEY_our ? "our" : "my") : "local");
8990e307
LW
2410 }
2411 }
93a17b20 2412 if (lex)
eb64745e 2413 o = my(o);
93a17b20 2414 else
eb64745e
GS
2415 o = mod(o, OP_NULL); /* a bit kludgey */
2416 PL_in_my = FALSE;
2417 PL_in_my_stash = Nullhv;
2418 return o;
79072805
LW
2419}
2420
2421OP *
864dbfa3 2422Perl_jmaybe(pTHX_ OP *o)
79072805
LW
2423{
2424 if (o->op_type == OP_LIST) {
554b3eca 2425 OP *o2;
4d1ff10f 2426#ifdef USE_5005THREADS
2faa37cc 2427 o2 = newOP(OP_THREADSV, 0);
54b9620d 2428 o2->op_targ = find_threadsv(";");
554b3eca
MB
2429#else
2430 o2 = newSVREF(newGVOP(OP_GV, 0, gv_fetchpv(";", TRUE, SVt_PV))),
4d1ff10f 2431#endif /* USE_5005THREADS */
554b3eca 2432 o = convert(OP_JOIN, 0, prepend_elem(OP_LIST, o2, o));
79072805
LW
2433 }
2434 return o;
2435}
2436
2437OP *
864dbfa3 2438Perl_fold_constants(pTHX_ register OP *o)
79072805
LW
2439{
2440 register OP *curop;
2441 I32 type = o->op_type;
748a9306 2442 SV *sv;
79072805 2443
22c35a8c 2444 if (PL_opargs[type] & OA_RETSCALAR)
79072805 2445 scalar(o);
b162f9ea 2446 if (PL_opargs[type] & OA_TARGET && !o->op_targ)
ed6116ce 2447 o->op_targ = pad_alloc(type, SVs_PADTMP);
79072805 2448
eac055e9
GS
2449 /* integerize op, unless it happens to be C<-foo>.
2450 * XXX should pp_i_negate() do magic string negation instead? */
2451 if ((PL_opargs[type] & OA_OTHERINT) && (PL_hints & HINT_INTEGER)
2452 && !(type == OP_NEGATE && cUNOPo->op_first->op_type == OP_CONST
2453 && (cUNOPo->op_first->op_private & OPpCONST_BARE)))
2454 {
22c35a8c 2455 o->op_ppaddr = PL_ppaddr[type = ++(o->op_type)];
eac055e9 2456 }
85e6fe83 2457
22c35a8c 2458 if (!(PL_opargs[type] & OA_FOLDCONST))
79072805
LW
2459 goto nope;
2460
de939608 2461 switch (type) {
7a52d87a
GS
2462 case OP_NEGATE:
2463 /* XXX might want a ck_negate() for this */
2464 cUNOPo->op_first->op_private &= ~OPpCONST_STRICT;
2465 break;
de939608
CS
2466 case OP_SPRINTF:
2467 case OP_UCFIRST:
2468 case OP_LCFIRST:
2469 case OP_UC:
2470 case OP_LC:
69dcf70c
MB
2471 case OP_SLT:
2472 case OP_SGT:
2473 case OP_SLE:
2474 case OP_SGE:
2475 case OP_SCMP:
2de3dbcc
JH
2476 /* XXX what about the numeric ops? */
2477 if (PL_hints & HINT_LOCALE)
de939608
CS
2478 goto nope;
2479 }
2480
3280af22 2481 if (PL_error_count)
a0d0e21e
LW
2482 goto nope; /* Don't try to run w/ errors */
2483
79072805 2484 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
11fa937b
GS
2485 if ((curop->op_type != OP_CONST ||
2486 (curop->op_private & OPpCONST_BARE)) &&
7a52d87a
GS
2487 curop->op_type != OP_LIST &&
2488 curop->op_type != OP_SCALAR &&
2489 curop->op_type != OP_NULL &&
2490 curop->op_type != OP_PUSHMARK)
2491 {
79072805
LW
2492 goto nope;
2493 }
2494 }
2495
2496 curop = LINKLIST(o);
2497 o->op_next = 0;
533c011a 2498 PL_op = curop;
cea2e8a9 2499 CALLRUNOPS(aTHX);
3280af22 2500 sv = *(PL_stack_sp--);
748a9306 2501 if (o->op_targ && sv == PAD_SV(o->op_targ)) /* grab pad temp? */
79072805 2502 pad_swipe(o->op_targ);
748a9306
LW
2503 else if (SvTEMP(sv)) { /* grab mortal temp? */
2504 (void)SvREFCNT_inc(sv);
2505 SvTEMP_off(sv);
85e6fe83 2506 }
79072805
LW
2507 op_free(o);
2508 if (type == OP_RV2GV)
b1cb66bf 2509 return newGVOP(OP_GV, 0, (GV*)sv);
748a9306 2510 else {
ee580363
GS
2511 /* try to smush double to int, but don't smush -2.0 to -2 */
2512 if ((SvFLAGS(sv) & (SVf_IOK|SVf_NOK|SVf_POK)) == SVf_NOK &&
2513 type != OP_NEGATE)
2514 {
28e5dec8
JH
2515#ifdef PERL_PRESERVE_IVUV
2516 /* Only bother to attempt to fold to IV if
2517 most operators will benefit */
2518 SvIV_please(sv);
2519#endif
748a9306 2520 }
a86a20aa 2521 return newSVOP(OP_CONST, 0, sv);
748a9306 2522 }
aeea060c 2523
79072805 2524 nope:
79072805
LW
2525 return o;
2526}
2527
2528OP *
864dbfa3 2529Perl_gen_constant_list(pTHX_ register OP *o)
79072805
LW
2530{
2531 register OP *curop;
3280af22 2532 I32 oldtmps_floor = PL_tmps_floor;
79072805 2533
a0d0e21e 2534 list(o);
3280af22 2535 if (PL_error_count)
a0d0e21e
LW
2536 return o; /* Don't attempt to run with errors */
2537
533c011a 2538 PL_op = curop = LINKLIST(o);
a0d0e21e 2539 o->op_next = 0;
a2efc822 2540 CALL_PEEP(curop);
cea2e8a9
GS
2541 pp_pushmark();
2542 CALLRUNOPS(aTHX);
533c011a 2543 PL_op = curop;
cea2e8a9 2544 pp_anonlist();
3280af22 2545 PL_tmps_floor = oldtmps_floor;
79072805
LW
2546
2547 o->op_type = OP_RV2AV;
22c35a8c 2548 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
c13f253a 2549 o->op_seq = 0; /* needs to be revisited in peep() */
79072805 2550 curop = ((UNOP*)o)->op_first;
3280af22 2551 ((UNOP*)o)->op_first = newSVOP(OP_CONST, 0, SvREFCNT_inc(*PL_stack_sp--));
79072805 2552 op_free(curop);
79072805
LW
2553 linklist(o);
2554 return list(o);
2555}
2556
2557OP *
864dbfa3 2558Perl_convert(pTHX_ I32 type, I32 flags, OP *o)
79072805 2559{
11343788
MB
2560 if (!o || o->op_type != OP_LIST)
2561 o = newLISTOP(OP_LIST, 0, o, Nullop);
748a9306 2562 else
5dc0d613 2563 o->op_flags &= ~OPf_WANT;
79072805 2564
22c35a8c 2565 if (!(PL_opargs[type] & OA_MARK))
93c66552 2566 op_null(cLISTOPo->op_first);
8990e307 2567
eb160463 2568 o->op_type = (OPCODE)type;
22c35a8c 2569 o->op_ppaddr = PL_ppaddr[type];
11343788 2570 o->op_flags |= flags;
79072805 2571
11343788
MB
2572 o = CHECKOP(type, o);
2573 if (o->op_type != type)
2574 return o;
79072805 2575
11343788 2576 return fold_constants(o);
79072805
LW
2577}
2578
2579/* List constructors */
2580
2581OP *
864dbfa3 2582Perl_append_elem(pTHX_ I32 type, OP *first, OP *last)
79072805
LW
2583{
2584 if (!first)
2585 return last;
8990e307
LW
2586
2587 if (!last)
79072805 2588 return first;
8990e307 2589
155aba94
GS
2590 if (first->op_type != type
2591 || (type == OP_LIST && (first->op_flags & OPf_PARENS)))
2592 {
2593 return newLISTOP(type, 0, first, last);
2594 }
79072805 2595
a0d0e21e
LW
2596 if (first->op_flags & OPf_KIDS)
2597 ((LISTOP*)first)->op_last->op_sibling = last;
2598 else {
2599 first->op_flags |= OPf_KIDS;
2600 ((LISTOP*)first)->op_first = last;
2601 }
2602 ((LISTOP*)first)->op_last = last;
a0d0e21e 2603 return first;
79072805
LW
2604}
2605
2606OP *
864dbfa3 2607Perl_append_list(pTHX_ I32 type, LISTOP *first, LISTOP *last)
79072805
LW
2608{
2609 if (!first)
2610 return (OP*)last;
8990e307
LW
2611
2612 if (!last)
79072805 2613 return (OP*)first;
8990e307
LW
2614
2615 if (first->op_type != type)
79072805 2616 return prepend_elem(type, (OP*)first, (OP*)last);
8990e307
LW
2617
2618 if (last->op_type != type)
79072805
LW
2619 return append_elem(type, (OP*)first, (OP*)last);
2620
2621 first->op_last->op_sibling = last->op_first;
2622 first->op_last = last->op_last;
117dada2 2623 first->op_flags |= (last->op_flags & OPf_KIDS);
1c846c1f 2624
238a4c30
NIS
2625 FreeOp(last);
2626
79072805
LW
2627 return (OP*)first;
2628}
2629
2630OP *
864dbfa3 2631Perl_prepend_elem(pTHX_ I32 type, OP *first, OP *last)
79072805
LW
2632{
2633 if (!first)
2634 return last;
8990e307
LW
2635
2636 if (!last)
79072805 2637 return first;
8990e307
LW
2638
2639 if (last->op_type == type) {
2640 if (type == OP_LIST) { /* already a PUSHMARK there */
2641 first->op_sibling = ((LISTOP*)last)->op_first->op_sibling;
2642 ((LISTOP*)last)->op_first->op_sibling = first;
36a5d4ba
DC
2643 if (!(first->op_flags & OPf_PARENS))
2644 last->op_flags &= ~OPf_PARENS;
8990e307
LW
2645 }
2646 else {
2647 if (!(last->op_flags & OPf_KIDS)) {
2648 ((LISTOP*)last)->op_last = first;
2649 last->op_flags |= OPf_KIDS;
2650 }
2651 first->op_sibling = ((LISTOP*)last)->op_first;
2652 ((LISTOP*)last)->op_first = first;
79072805 2653 }
117dada2 2654 last->op_flags |= OPf_KIDS;
79072805
LW
2655 return last;
2656 }
2657
2658 return newLISTOP(type, 0, first, last);
2659}
2660
2661/* Constructors */
2662
2663OP *
864dbfa3 2664Perl_newNULLLIST(pTHX)
79072805 2665{
8990e307
LW
2666 return newOP(OP_STUB, 0);
2667}
2668
2669OP *
864dbfa3 2670Perl_force_list(pTHX_ OP *o)
8990e307 2671{
11343788
MB
2672 if (!o || o->op_type != OP_LIST)
2673 o = newLISTOP(OP_LIST, 0, o, Nullop);
93c66552 2674 op_null(o);
11343788 2675 return o;
79072805
LW
2676}
2677
2678OP *
864dbfa3 2679Perl_newLISTOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
79072805
LW
2680{
2681 LISTOP *listop;
2682
b7dc083c 2683 NewOp(1101, listop, 1, LISTOP);
79072805 2684
eb160463 2685 listop->op_type = (OPCODE)type;
22c35a8c 2686 listop->op_ppaddr = PL_ppaddr[type];
117dada2
SM
2687 if (first || last)
2688 flags |= OPf_KIDS;
eb160463 2689 listop->op_flags = (U8)flags;
79072805
LW
2690
2691 if (!last && first)
2692 last = first;
2693 else if (!first && last)
2694 first = last;
8990e307
LW
2695 else if (first)
2696 first->op_sibling = last;
79072805
LW
2697 listop->op_first = first;
2698 listop->op_last = last;
8990e307
LW
2699 if (type == OP_LIST) {
2700 OP* pushop;
2701 pushop = newOP(OP_PUSHMARK, 0);
2702 pushop->op_sibling = first;
2703 listop->op_first = pushop;
2704 listop->op_flags |= OPf_KIDS;
2705 if (!last)
2706 listop->op_last = pushop;
2707 }
79072805
LW
2708
2709 return (OP*)listop;
2710}
2711
2712OP *
864dbfa3 2713Perl_newOP(pTHX_ I32 type, I32 flags)
79072805 2714{
11343788 2715 OP *o;
b7dc083c 2716 NewOp(1101, o, 1, OP);
eb160463 2717 o->op_type = (OPCODE)type;
22c35a8c 2718 o->op_ppaddr = PL_ppaddr[type];
eb160463 2719 o->op_flags = (U8)flags;
79072805 2720
11343788 2721 o->op_next = o;
eb160463 2722 o->op_private = (U8)(0 | (flags >> 8));
22c35a8c 2723 if (PL_opargs[type] & OA_RETSCALAR)
11343788 2724 scalar(o);
22c35a8c 2725 if (PL_opargs[type] & OA_TARGET)
11343788
MB
2726 o->op_targ = pad_alloc(type, SVs_PADTMP);
2727 return CHECKOP(type, o);
79072805
LW
2728}
2729
2730OP *
864dbfa3 2731Perl_newUNOP(pTHX_ I32 type, I32 flags, OP *first)
79072805
LW
2732{
2733 UNOP *unop;
2734
93a17b20 2735 if (!first)
aeea060c 2736 first = newOP(OP_STUB, 0);
22c35a8c 2737 if (PL_opargs[type] & OA_MARK)
8990e307 2738 first = force_list(first);
93a17b20 2739
b7dc083c 2740 NewOp(1101, unop, 1, UNOP);
eb160463 2741 unop->op_type = (OPCODE)type;
22c35a8c 2742 unop->op_ppaddr = PL_ppaddr[type];
79072805
LW
2743 unop->op_first = first;
2744 unop->op_flags = flags | OPf_KIDS;
eb160463 2745 unop->op_private = (U8)(1 | (flags >> 8));
e50aee73 2746 unop = (UNOP*) CHECKOP(type, unop);
79072805
LW
2747 if (unop->op_next)
2748 return (OP*)unop;
2749
a0d0e21e 2750 return fold_constants((OP *) unop);
79072805
LW
2751}
2752
2753OP *
864dbfa3 2754Perl_newBINOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
79072805
LW
2755{
2756 BINOP *binop;
b7dc083c 2757 NewOp(1101, binop, 1, BINOP);
79072805
LW
2758
2759 if (!first)
2760 first = newOP(OP_NULL, 0);
2761
eb160463 2762 binop->op_type = (OPCODE)type;
22c35a8c 2763 binop->op_ppaddr = PL_ppaddr[type];
79072805
LW
2764 binop->op_first = first;
2765 binop->op_flags = flags | OPf_KIDS;
2766 if (!last) {
2767 last = first;
eb160463 2768 binop->op_private = (U8)(1 | (flags >> 8));
79072805
LW
2769 }
2770 else {
eb160463 2771 binop->op_private = (U8)(2 | (flags >> 8));
79072805
LW
2772 first->op_sibling = last;
2773 }
2774
e50aee73 2775 binop = (BINOP*)CHECKOP(type, binop);
eb160463 2776 if (binop->op_next || binop->op_type != (OPCODE)type)
79072805
LW
2777 return (OP*)binop;
2778
7284ab6f 2779 binop->op_last = binop->op_first->op_sibling;
79072805 2780
a0d0e21e 2781 return fold_constants((OP *)binop);
79072805
LW
2782}
2783
a0ed51b3 2784static int
2b9d42f0
NIS
2785uvcompare(const void *a, const void *b)
2786{
2787 if (*((UV *)a) < (*(UV *)b))
2788 return -1;
2789 if (*((UV *)a) > (*(UV *)b))
2790 return 1;
2791 if (*((UV *)a+1) < (*(UV *)b+1))
2792 return -1;
2793 if (*((UV *)a+1) > (*(UV *)b+1))
2794 return 1;
a0ed51b3
LW
2795 return 0;
2796}
2797
79072805 2798OP *
864dbfa3 2799Perl_pmtrans(pTHX_ OP *o, OP *expr, OP *repl)
79072805 2800{
79072805
LW
2801 SV *tstr = ((SVOP*)expr)->op_sv;
2802 SV *rstr = ((SVOP*)repl)->op_sv;
463ee0b2
LW
2803 STRLEN tlen;
2804 STRLEN rlen;
9b877dbb
IH
2805 U8 *t = (U8*)SvPV(tstr, tlen);
2806 U8 *r = (U8*)SvPV(rstr, rlen);
79072805
LW
2807 register I32 i;
2808 register I32 j;
a0ed51b3 2809 I32 del;
79072805 2810 I32 complement;
5d06d08e 2811 I32 squash;
9b877dbb 2812 I32 grows = 0;
79072805
LW
2813 register short *tbl;
2814
800b4dc4 2815 PL_hints |= HINT_BLOCK_SCOPE;
11343788 2816 complement = o->op_private & OPpTRANS_COMPLEMENT;
a0ed51b3 2817 del = o->op_private & OPpTRANS_DELETE;
5d06d08e 2818 squash = o->op_private & OPpTRANS_SQUASH;
1c846c1f 2819
036b4402
GS
2820 if (SvUTF8(tstr))
2821 o->op_private |= OPpTRANS_FROM_UTF;
1c846c1f
NIS
2822
2823 if (SvUTF8(rstr))
036b4402 2824 o->op_private |= OPpTRANS_TO_UTF;
79072805 2825
a0ed51b3 2826 if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
79cb57f6 2827 SV* listsv = newSVpvn("# comment\n",10);
a0ed51b3
LW
2828 SV* transv = 0;
2829 U8* tend = t + tlen;
2830 U8* rend = r + rlen;
ba210ebe 2831 STRLEN ulen;
a0ed51b3
LW
2832 U32 tfirst = 1;
2833 U32 tlast = 0;
2834 I32 tdiff;
2835 U32 rfirst = 1;
2836 U32 rlast = 0;
2837 I32 rdiff;
2838 I32 diff;
2839 I32 none = 0;
2840 U32 max = 0;
2841 I32 bits;
a0ed51b3 2842 I32 havefinal = 0;
9c5ffd7c 2843 U32 final = 0;
a0ed51b3
LW
2844 I32 from_utf = o->op_private & OPpTRANS_FROM_UTF;
2845 I32 to_utf = o->op_private & OPpTRANS_TO_UTF;
bf4a1e57
JH
2846 U8* tsave = NULL;
2847 U8* rsave = NULL;
2848
2849 if (!from_utf) {
2850 STRLEN len = tlen;
2851 tsave = t = bytes_to_utf8(t, &len);
2852 tend = t + len;
2853 }
2854 if (!to_utf && rlen) {
2855 STRLEN len = rlen;
2856 rsave = r = bytes_to_utf8(r, &len);
2857 rend = r + len;
2858 }
a0ed51b3 2859
2b9d42f0
NIS
2860/* There are several snags with this code on EBCDIC:
2861 1. 0xFF is a legal UTF-EBCDIC byte (there are no illegal bytes).
2862 2. scan_const() in toke.c has encoded chars in native encoding which makes
2863 ranges at least in EBCDIC 0..255 range the bottom odd.
2864*/
2865
a0ed51b3 2866 if (complement) {
ad391ad9 2867 U8 tmpbuf[UTF8_MAXLEN+1];
2b9d42f0 2868 UV *cp;
a0ed51b3 2869 UV nextmin = 0;
2b9d42f0 2870 New(1109, cp, 2*tlen, UV);
a0ed51b3 2871 i = 0;
79cb57f6 2872 transv = newSVpvn("",0);
a0ed51b3 2873 while (t < tend) {
2b9d42f0
NIS
2874 cp[2*i] = utf8n_to_uvuni(t, tend-t, &ulen, 0);
2875 t += ulen;
2876 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) {
a0ed51b3 2877 t++;
2b9d42f0
NIS
2878 cp[2*i+1] = utf8n_to_uvuni(t, tend-t, &ulen, 0);
2879 t += ulen;
a0ed51b3 2880 }
2b9d42f0
NIS
2881 else {
2882 cp[2*i+1] = cp[2*i];
2883 }
2884 i++;
a0ed51b3 2885 }
2b9d42f0 2886 qsort(cp, i, 2*sizeof(UV), uvcompare);
a0ed51b3 2887 for (j = 0; j < i; j++) {
2b9d42f0 2888 UV val = cp[2*j];
a0ed51b3
LW
2889 diff = val - nextmin;
2890 if (diff > 0) {
9041c2e3 2891 t = uvuni_to_utf8(tmpbuf,nextmin);
dfe13c55 2892 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
a0ed51b3 2893 if (diff > 1) {
2b9d42f0 2894 U8 range_mark = UTF_TO_NATIVE(0xff);
9041c2e3 2895 t = uvuni_to_utf8(tmpbuf, val - 1);
2b9d42f0 2896 sv_catpvn(transv, (char *)&range_mark, 1);
dfe13c55 2897 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
a0ed51b3
LW
2898 }
2899 }
2b9d42f0 2900 val = cp[2*j+1];
a0ed51b3
LW
2901 if (val >= nextmin)
2902 nextmin = val + 1;
2903 }
9041c2e3 2904 t = uvuni_to_utf8(tmpbuf,nextmin);
dfe13c55 2905 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2b9d42f0
NIS
2906 {
2907 U8 range_mark = UTF_TO_NATIVE(0xff);
2908 sv_catpvn(transv, (char *)&range_mark, 1);
2909 }
b851fbc1
JH
2910 t = uvuni_to_utf8_flags(tmpbuf, 0x7fffffff,
2911 UNICODE_ALLOW_SUPER);
dfe13c55
GS
2912 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2913 t = (U8*)SvPVX(transv);
a0ed51b3
LW
2914 tlen = SvCUR(transv);
2915 tend = t + tlen;
455d824a 2916 Safefree(cp);
a0ed51b3
LW
2917 }
2918 else if (!rlen && !del) {
2919 r = t; rlen = tlen; rend = tend;
4757a243
LW
2920 }
2921 if (!squash) {
05d340b8 2922 if ((!rlen && !del) || t == r ||
12ae5dfc 2923 (tlen == rlen && memEQ((char *)t, (char *)r, tlen)))
01ec43d0 2924 {
4757a243 2925 o->op_private |= OPpTRANS_IDENTICAL;
01ec43d0 2926 }
a0ed51b3
LW
2927 }
2928
2929 while (t < tend || tfirst <= tlast) {
2930 /* see if we need more "t" chars */
2931 if (tfirst > tlast) {
9041c2e3 2932 tfirst = (I32)utf8n_to_uvuni(t, tend - t, &ulen, 0);
a0ed51b3 2933 t += ulen;
2b9d42f0 2934 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) { /* illegal utf8 val indicates range */
ba210ebe 2935 t++;
9041c2e3 2936 tlast = (I32)utf8n_to_uvuni(t, tend - t, &ulen, 0);
a0ed51b3
LW
2937 t += ulen;
2938 }
2939 else
2940 tlast = tfirst;
2941 }
2942
2943 /* now see if we need more "r" chars */
2944 if (rfirst > rlast) {
2945 if (r < rend) {
9041c2e3 2946 rfirst = (I32)utf8n_to_uvuni(r, rend - r, &ulen, 0);
a0ed51b3 2947 r += ulen;
2b9d42f0 2948 if (r < rend && NATIVE_TO_UTF(*r) == 0xff) { /* illegal utf8 val indicates range */
ba210ebe 2949 r++;
9041c2e3 2950 rlast = (I32)utf8n_to_uvuni(r, rend - r, &ulen, 0);
a0ed51b3
LW
2951 r += ulen;
2952 }
2953 else
2954 rlast = rfirst;
2955 }
2956 else {
2957 if (!havefinal++)
2958 final = rlast;
2959 rfirst = rlast = 0xffffffff;
2960 }
2961 }
2962
2963 /* now see which range will peter our first, if either. */
2964 tdiff = tlast - tfirst;
2965 rdiff = rlast - rfirst;
2966
2967 if (tdiff <= rdiff)
2968 diff = tdiff;
2969 else
2970 diff = rdiff;
2971
2972 if (rfirst == 0xffffffff) {
2973 diff = tdiff; /* oops, pretend rdiff is infinite */
2974 if (diff > 0)
894356b3
GS
2975 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\tXXXX\n",
2976 (long)tfirst, (long)tlast);
a0ed51b3 2977 else
894356b3 2978 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\tXXXX\n", (long)tfirst);
a0ed51b3
LW
2979 }
2980 else {
2981 if (diff > 0)
894356b3
GS
2982 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\t%04lx\n",
2983 (long)tfirst, (long)(tfirst + diff),
2984 (long)rfirst);
a0ed51b3 2985 else
894356b3
GS
2986 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\t%04lx\n",
2987 (long)tfirst, (long)rfirst);
a0ed51b3
LW
2988
2989 if (rfirst + diff > max)
2990 max = rfirst + diff;
9b877dbb 2991 if (!grows)
45005bfb
JH
2992 grows = (tfirst < rfirst &&
2993 UNISKIP(tfirst) < UNISKIP(rfirst + diff));
2994 rfirst += diff + 1;
a0ed51b3
LW
2995 }
2996 tfirst += diff + 1;
2997 }
2998
2999 none = ++max;
3000 if (del)
3001 del = ++max;
3002
3003 if (max > 0xffff)
3004 bits = 32;
3005 else if (max > 0xff)
3006 bits = 16;
3007 else
3008 bits = 8;
3009
455d824a 3010 Safefree(cPVOPo->op_pv);
a0ed51b3
LW
3011 cSVOPo->op_sv = (SV*)swash_init("utf8", "", listsv, bits, none);
3012 SvREFCNT_dec(listsv);
3013 if (transv)
3014 SvREFCNT_dec(transv);
3015
45005bfb 3016 if (!del && havefinal && rlen)
b448e4fe
JH
3017 (void)hv_store((HV*)SvRV((cSVOPo->op_sv)), "FINAL", 5,
3018 newSVuv((UV)final), 0);
a0ed51b3 3019
9b877dbb 3020 if (grows)
a0ed51b3
LW
3021 o->op_private |= OPpTRANS_GROWS;
3022
9b877dbb
IH
3023 if (tsave)
3024 Safefree(tsave);
3025 if (rsave)
3026 Safefree(rsave);
3027
a0ed51b3
LW
3028 op_free(expr);
3029 op_free(repl);
3030 return o;
3031 }
3032
3033 tbl = (short*)cPVOPo->op_pv;
79072805
LW
3034 if (complement) {
3035 Zero(tbl, 256, short);
eb160463 3036 for (i = 0; i < (I32)tlen; i++)
ec49126f 3037 tbl[t[i]] = -1;
79072805
LW
3038 for (i = 0, j = 0; i < 256; i++) {
3039 if (!tbl[i]) {
eb160463 3040 if (j >= (I32)rlen) {
a0ed51b3 3041 if (del)
79072805
LW
3042 tbl[i] = -2;
3043 else if (rlen)
ec49126f 3044 tbl[i] = r[j-1];
79072805 3045 else
eb160463 3046 tbl[i] = (short)i;
79072805 3047 }
9b877dbb
IH
3048 else {
3049 if (i < 128 && r[j] >= 128)
3050 grows = 1;
ec49126f 3051 tbl[i] = r[j++];
9b877dbb 3052 }
79072805
LW
3053 }
3054 }
05d340b8
JH
3055 if (!del) {
3056 if (!rlen) {
3057 j = rlen;
3058 if (!squash)
3059 o->op_private |= OPpTRANS_IDENTICAL;
3060 }
eb160463 3061 else if (j >= (I32)rlen)
05d340b8
JH
3062 j = rlen - 1;
3063 else
3064 cPVOPo->op_pv = (char*)Renew(tbl, 0x101+rlen-j, short);
8973db79 3065 tbl[0x100] = rlen - j;
eb160463 3066 for (i=0; i < (I32)rlen - j; i++)
8973db79
JH
3067 tbl[0x101+i] = r[j+i];
3068 }
79072805
LW
3069 }
3070 else {
a0ed51b3 3071 if (!rlen && !del) {
79072805 3072 r = t; rlen = tlen;
5d06d08e 3073 if (!squash)
4757a243 3074 o->op_private |= OPpTRANS_IDENTICAL;
79072805 3075 }
94bfe852
RGS
3076 else if (!squash && rlen == tlen && memEQ((char*)t, (char*)r, tlen)) {
3077 o->op_private |= OPpTRANS_IDENTICAL;
3078 }
79072805
LW
3079 for (i = 0; i < 256; i++)
3080 tbl[i] = -1;
eb160463
GS
3081 for (i = 0, j = 0; i < (I32)tlen; i++,j++) {
3082 if (j >= (I32)rlen) {
a0ed51b3 3083 if (del) {
ec49126f
PP
3084 if (tbl[t[i]] == -1)
3085 tbl[t[i]] = -2;
79072805
LW
3086 continue;
3087 }
3088 --j;
3089 }
9b877dbb
IH
3090 if (tbl[t[i]] == -1) {
3091 if (t[i] < 128 && r[j] >= 128)
3092 grows = 1;
ec49126f 3093 tbl[t[i]] = r[j];
9b877dbb 3094 }
79072805
LW
3095 }
3096 }
9b877dbb
IH
3097 if (grows)
3098 o->op_private |= OPpTRANS_GROWS;
79072805
LW
3099 op_free(expr);
3100 op_free(repl);
3101
11343788 3102 return o;
79072805
LW
3103}
3104
3105OP *
864dbfa3 3106Perl_newPMOP(pTHX_ I32 type, I32 flags)
79072805
LW
3107{
3108 PMOP *pmop;
3109
b7dc083c 3110 NewOp(1101, pmop, 1, PMOP);
eb160463 3111 pmop->op_type = (OPCODE)type;
22c35a8c 3112 pmop->op_ppaddr = PL_ppaddr[type];
eb160463
GS
3113 pmop->op_flags = (U8)flags;
3114 pmop->op_private = (U8)(0 | (flags >> 8));
79072805 3115
3280af22 3116 if (PL_hints & HINT_RE_TAINT)
b3eb6a9b 3117 pmop->op_pmpermflags |= PMf_RETAINT;
3280af22 3118 if (PL_hints & HINT_LOCALE)
b3eb6a9b
GS
3119 pmop->op_pmpermflags |= PMf_LOCALE;
3120 pmop->op_pmflags = pmop->op_pmpermflags;
36477c24 3121
debc9467 3122#ifdef USE_ITHREADS
13137afc
AB
3123 {
3124 SV* repointer;
3125 if(av_len((AV*) PL_regex_pad[0]) > -1) {
3126 repointer = av_pop((AV*)PL_regex_pad[0]);
3127 pmop->op_pmoffset = SvIV(repointer);
1cc8b4c5 3128 SvREPADTMP_off(repointer);
13137afc 3129 sv_setiv(repointer,0);
1eb1540c 3130 } else {
13137afc
AB
3131 repointer = newSViv(0);
3132 av_push(PL_regex_padav,SvREFCNT_inc(repointer));
3133 pmop->op_pmoffset = av_len(PL_regex_padav);
3134 PL_regex_pad = AvARRAY(PL_regex_padav);
1fcf4c12 3135 }
13137afc 3136 }
debc9467 3137#endif
1eb1540c 3138
1fcf4c12 3139 /* link into pm list */
3280af22
NIS
3140 if (type != OP_TRANS && PL_curstash) {
3141 pmop->op_pmnext = HvPMROOT(PL_curstash);
3142 HvPMROOT(PL_curstash) = pmop;
cb55de95 3143 PmopSTASH_set(pmop,PL_curstash);
79072805
LW
3144 }
3145
3146 return (OP*)pmop;
3147}
3148
3149OP *
864dbfa3 3150Perl_pmruntime(pTHX_ OP *o, OP *expr, OP *repl)
79072805
LW
3151{
3152 PMOP *pm;
3153 LOGOP *rcop;
ce862d02 3154 I32 repl_has_vars = 0;
79072805 3155
11343788
MB
3156 if (o->op_type == OP_TRANS)
3157 return pmtrans(o, expr, repl);
79072805 3158
3280af22 3159 PL_hints |= HINT_BLOCK_SCOPE;
11343788 3160 pm = (PMOP*)o;
79072805
LW
3161
3162 if (expr->op_type == OP_CONST) {
463ee0b2 3163 STRLEN plen;
79072805 3164 SV *pat = ((SVOP*)expr)->op_sv;
463ee0b2 3165 char *p = SvPV(pat, plen);
11343788 3166 if ((o->op_flags & OPf_SPECIAL) && strEQ(p, " ")) {
93a17b20 3167 sv_setpvn(pat, "\\s+", 3);
463ee0b2 3168 p = SvPV(pat, plen);
79072805
LW
3169 pm->op_pmflags |= PMf_SKIPWHITE;
3170 }
5b71a6a7 3171 if (DO_UTF8(pat))
a5961de5 3172 pm->op_pmdynflags |= PMdf_UTF8;
aaa362c4
RS
3173 PM_SETRE(pm, CALLREGCOMP(aTHX_ p, p + plen, pm));
3174 if (strEQ("\\s+", PM_GETRE(pm)->precomp))
85e6fe83 3175 pm->op_pmflags |= PMf_WHITE;
79072805
LW
3176 op_free(expr);
3177 }
3178 else {
3280af22 3179 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL))
1c846c1f 3180 expr = newUNOP((!(PL_hints & HINT_RE_EVAL)
2cd61cdb
IZ
3181 ? OP_REGCRESET
3182 : OP_REGCMAYBE),0,expr);
463ee0b2 3183
b7dc083c 3184 NewOp(1101, rcop, 1, LOGOP);
79072805 3185 rcop->op_type = OP_REGCOMP;
22c35a8c 3186 rcop->op_ppaddr = PL_ppaddr[OP_REGCOMP];
79072805 3187 rcop->op_first = scalar(expr);
1c846c1f 3188 rcop->op_flags |= ((PL_hints & HINT_RE_EVAL)
2cd61cdb
IZ
3189 ? (OPf_SPECIAL | OPf_KIDS)
3190 : OPf_KIDS);
79072805 3191 rcop->op_private = 1;
11343788 3192 rcop->op_other = o;
79072805
LW
3193
3194 /* establish postfix order */
3280af22 3195 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL)) {
463ee0b2
LW
3196 LINKLIST(expr);
3197 rcop->op_next = expr;
3198 ((UNOP*)expr)->op_first->op_next = (OP*)rcop;
3199 }
3200 else {
3201 rcop->op_next = LINKLIST(expr);
3202 expr->op_next = (OP*)rcop;
3203 }
79072805 3204
11343788 3205 prepend_elem(o->op_type, scalar((OP*)rcop), o);
79072805
LW
3206 }
3207
3208 if (repl) {
748a9306 3209 OP *curop;
0244c3a4 3210 if (pm->op_pmflags & PMf_EVAL) {
748a9306 3211 curop = 0;
57843af0 3212 if (CopLINE(PL_curcop) < PL_multi_end)
eb160463 3213 CopLINE_set(PL_curcop, (line_t)PL_multi_end);
0244c3a4 3214 }
4d1ff10f 3215#ifdef USE_5005THREADS
2faa37cc 3216 else if (repl->op_type == OP_THREADSV
554b3eca 3217 && strchr("&`'123456789+",
533c011a 3218 PL_threadsv_names[repl->op_targ]))
554b3eca
MB
3219 {
3220 curop = 0;
3221 }
4d1ff10f 3222#endif /* USE_5005THREADS */
748a9306
LW
3223 else if (repl->op_type == OP_CONST)
3224 curop = repl;
79072805 3225 else {
79072805
LW
3226 OP *lastop = 0;
3227 for (curop = LINKLIST(repl); curop!=repl; curop = LINKLIST(curop)) {
22c35a8c 3228 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
4d1ff10f 3229#ifdef USE_5005THREADS
ce862d02
IZ
3230 if (curop->op_type == OP_THREADSV) {
3231 repl_has_vars = 1;
be949f6f 3232 if (strchr("&`'123456789+", curop->op_private))
ce862d02 3233 break;
554b3eca
MB
3234 }
3235#else
79072805 3236 if (curop->op_type == OP_GV) {
638eceb6 3237 GV *gv = cGVOPx_gv(curop);
ce862d02 3238 repl_has_vars = 1;
93a17b20 3239 if (strchr("&`'123456789+", *GvENAME(gv)))
79072805
LW
3240 break;
3241 }
4d1ff10f 3242#endif /* USE_5005THREADS */
79072805
LW
3243 else if (curop->op_type == OP_RV2CV)
3244 break;
3245 else if (curop->op_type == OP_RV2SV ||
3246 curop->op_type == OP_RV2AV ||
3247 curop->op_type == OP_RV2HV ||
3248 curop->op_type == OP_RV2GV) {
3249 if (lastop && lastop->op_type != OP_GV) /*funny deref?*/
3250 break;
3251 }
748a9306
LW
3252 else if (curop->op_type == OP_PADSV ||
3253 curop->op_type == OP_PADAV ||
3254 curop->op_type == OP_PADHV ||
554b3eca 3255 curop->op_type == OP_PADANY) {
ce862d02 3256 repl_has_vars = 1;
748a9306 3257 }
1167e5da
SM
3258 else if (curop->op_type == OP_PUSHRE)
3259 ; /* Okay here, dangerous in newASSIGNOP */
79072805
LW
3260 else
3261 break;
3262 }
3263 lastop = curop;
3264 }
748a9306 3265 }
ce862d02 3266 if (curop == repl
1c846c1f 3267 && !(repl_has_vars
aaa362c4
RS
3268 && (!PM_GETRE(pm)
3269 || PM_GETRE(pm)->reganch & ROPT_EVAL_SEEN))) {
748a9306 3270 pm->op_pmflags |= PMf_CONST; /* const for long enough */
4633a7c4 3271 pm->op_pmpermflags |= PMf_CONST; /* const for long enough */
11343788 3272 prepend_elem(o->op_type, scalar(repl), o);
748a9306
LW
3273 }
3274 else {
aaa362c4 3275 if (curop == repl && !PM_GETRE(pm)) { /* Has variables. */
ce862d02
IZ
3276 pm->op_pmflags |= PMf_MAYBE_CONST;
3277 pm->op_pmpermflags |= PMf_MAYBE_CONST;
3278 }
b7dc083c 3279 NewOp(1101, rcop, 1, LOGOP);
748a9306 3280 rcop->op_type = OP_SUBSTCONT;
22c35a8c 3281 rcop->op_ppaddr = PL_ppaddr[OP_SUBSTCONT];
748a9306
LW
3282 rcop->op_first = scalar(repl);
3283 rcop->op_flags |= OPf_KIDS;
3284 rcop->op_private = 1;
11343788 3285 rcop->op_other = o;
748a9306
LW
3286
3287 /* establish postfix order */
3288 rcop->op_next = LINKLIST(repl);
3289 repl->op_next = (OP*)rcop;
3290
3291 pm->op_pmreplroot = scalar((OP*)rcop);
3292 pm->op_pmreplstart = LINKLIST(rcop);
3293 rcop->op_next = 0;
79072805
LW
3294 }
3295 }
3296
3297 return (OP*)pm;
3298}
3299
3300OP *
864dbfa3 3301Perl_newSVOP(pTHX_ I32 type, I32 flags, SV *sv)
79072805
LW
3302{
3303 SVOP *svop;
b7dc083c 3304 NewOp(1101, svop, 1, SVOP);
eb160463 3305 svop->op_type = (OPCODE)type;
22c35a8c 3306 svop->op_ppaddr = PL_ppaddr[type];
79072805
LW
3307 svop->op_sv = sv;
3308 svop->op_next = (OP*)svop;
eb160463 3309 svop->op_flags = (U8)flags;
22c35a8c 3310 if (PL_opargs[type] & OA_RETSCALAR)
463ee0b2 3311 scalar((OP*)svop);
22c35a8c 3312 if (PL_opargs[type] & OA_TARGET)
ed6116ce 3313 svop->op_targ = pad_alloc(type, SVs_PADTMP);
e50aee73 3314 return CHECKOP(type, svop);
79072805
LW
3315}
3316
3317OP *
350de78d
GS
3318Perl_newPADOP(pTHX_ I32 type, I32 flags, SV *sv)
3319{
3320 PADOP *padop;
3321 NewOp(1101, padop, 1, PADOP);
eb160463 3322 padop->op_type = (OPCODE)type;
350de78d
GS
3323 padop->op_ppaddr = PL_ppaddr[type];
3324 padop->op_padix = pad_alloc(type, SVs_PADTMP);
7766f137 3325 SvREFCNT_dec(PL_curpad[padop->op_padix]);
350de78d 3326 PL_curpad[padop->op_padix] = sv;
7766f137 3327 SvPADTMP_on(sv);
350de78d 3328 padop->op_next = (OP*)padop;
eb160463 3329 padop->op_flags = (U8)flags;
350de78d
GS
3330 if (PL_opargs[type] & OA_RETSCALAR)
3331 scalar((OP*)padop);
3332 if (PL_opargs[type] & OA_TARGET)
3333 padop->op_targ = pad_alloc(type, SVs_PADTMP);
3334 return CHECKOP(type, padop);
3335}
3336
3337OP *
864dbfa3 3338Perl_newGVOP(pTHX_ I32 type, I32 flags, GV *gv)
79072805 3339{
350de78d 3340#ifdef USE_ITHREADS
743e66e6 3341 GvIN_PAD_on(gv);
350de78d
GS
3342 return newPADOP(type, flags, SvREFCNT_inc(gv));
3343#else
7934575e 3344 return newSVOP(type, flags, SvREFCNT_inc(gv));
350de78d 3345#endif
79072805
LW
3346}
3347
3348OP *
864dbfa3 3349Perl_newPVOP(pTHX_ I32 type, I32 flags, char *pv)
79072805
LW
3350{
3351 PVOP *pvop;
b7dc083c 3352 NewOp(1101, pvop, 1, PVOP);
eb160463 3353 pvop->op_type = (OPCODE)type;
22c35a8c 3354 pvop->op_ppaddr = PL_ppaddr[type];
79072805
LW
3355 pvop->op_pv = pv;
3356 pvop->op_next = (OP*)pvop;
eb160463 3357 pvop->op_flags = (U8)flags;
22c35a8c 3358 if (PL_opargs[type] & OA_RETSCALAR)
463ee0b2 3359 scalar((OP*)pvop);
22c35a8c 3360 if (PL_opargs[type] & OA_TARGET)
ed6116ce 3361 pvop->op_targ = pad_alloc(type, SVs_PADTMP);
e50aee73 3362 return CHECKOP(type, pvop);
79072805
LW
3363}
3364
79072805 3365void
864dbfa3 3366Perl_package(pTHX_ OP *o)
79072805 3367{
de11ba31
AMS
3368 char *name;
3369 STRLEN len;
79072805 3370
3280af22
NIS
3371 save_hptr(&PL_curstash);
3372 save_item(PL_curstname);
de11ba31
AMS
3373
3374 name = SvPV(cSVOPo->op_sv, len);
3375 PL_curstash = gv_stashpvn(name, len, TRUE);
3376 sv_setpvn(PL_curstname, name, len);
3377 op_free(o);
3378
7ad382f4 3379 PL_hints |= HINT_BLOCK_SCOPE;
3280af22
NIS
3380 PL_copline = NOLINE;
3381 PL_expect = XSTATE;
79072805
LW
3382}
3383
85e6fe83 3384void
864dbfa3 3385Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *id, OP *arg)
85e6fe83 3386{
a0d0e21e 3387 OP *pack;
a0d0e21e 3388 OP *imop;
b1cb66bf 3389 OP *veop;
85e6fe83 3390
a0d0e21e 3391 if (id->op_type != OP_CONST)
cea2e8a9 3392 Perl_croak(aTHX_ "Module name must be constant");
85e6fe83 3393
b1cb66bf
PP
3394 veop = Nullop;
3395
0f79a09d 3396 if (version != Nullop) {
b1cb66bf
PP
3397 SV *vesv = ((SVOP*)version)->op_sv;
3398
44dcb63b 3399 if (arg == Nullop && !SvNIOKp(vesv)) {
b1cb66bf
PP
3400 arg = version;
3401 }
3402 else {
3403 OP *pack;
0f79a09d 3404 SV *meth;
b1cb66bf 3405
44dcb63b 3406 if (version->op_type != OP_CONST || !SvNIOKp(vesv))
cea2e8a9 3407 Perl_croak(aTHX_ "Version number must be constant number");
b1cb66bf
PP
3408
3409 /* Make copy of id so we don't free it twice */
3410 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)id)->op_sv));
3411
3412 /* Fake up a method call to VERSION */
0f79a09d
GS
3413 meth = newSVpvn("VERSION",7);
3414 sv_upgrade(meth, SVt_PVIV);
155aba94 3415 (void)SvIOK_on(meth);
5afd6d42 3416 PERL_HASH(SvUVX(meth), SvPVX(meth), SvCUR(meth));
b1cb66bf
PP
3417 veop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
3418 append_elem(OP_LIST,
0f79a09d
GS
3419 prepend_elem(OP_LIST, pack, list(version)),
3420 newSVOP(OP_METHOD_NAMED, 0, meth)));
b1cb66bf
PP
3421 }
3422 }
aeea060c 3423
a0d0e21e 3424 /* Fake up an import/unimport */
4633a7c4
LW
3425 if (arg && arg->op_type == OP_STUB)
3426 imop = arg; /* no import on explicit () */
44dcb63b 3427 else if (SvNIOKp(((SVOP*)id)->op_sv)) {
b1cb66bf
PP
3428 imop = Nullop; /* use 5.0; */
3429 }
4633a7c4 3430 else {
0f79a09d
GS
3431 SV *meth;
3432
4633a7c4
LW
3433 /* Make copy of id so we don't free it twice */
3434 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)id)->op_sv));
0f79a09d
GS
3435
3436 /* Fake up a method call to import/unimport */
b47cad08 3437 meth = aver ? newSVpvn("import",6) : newSVpvn("unimport", 8);
ad4c42df 3438 (void)SvUPGRADE(meth, SVt_PVIV);
155aba94 3439 (void)SvIOK_on(meth);
5afd6d42 3440 PERL_HASH(SvUVX(meth), SvPVX(meth), SvCUR(meth));
4633a7c4 3441 imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
0f79a09d
GS
3442 append_elem(OP_LIST,
3443 prepend_elem(OP_LIST, pack, list(arg)),
3444 newSVOP(OP_METHOD_NAMED, 0, meth)));
4633a7c4
LW
3445 }
3446
a0d0e21e 3447 /* Fake up the BEGIN {}, which does its thing immediately. */
09bef843 3448 newATTRSUB(floor,
79cb57f6 3449 newSVOP(OP_CONST, 0, newSVpvn("BEGIN", 5)),
4633a7c4 3450 Nullop,
09bef843 3451 Nullop,
a0d0e21e 3452 append_elem(OP_LINESEQ,
b1cb66bf 3453 append_elem(OP_LINESEQ,
ec4ab249 3454 newSTATEOP(0, Nullch, newUNOP(OP_REQUIRE, 0, id)),
b1cb66bf 3455 newSTATEOP(0, Nullch, veop)),
a0d0e21e 3456 newSTATEOP(0, Nullch, imop) ));
85e6fe83 3457
70f5e4ed
JH
3458 /* The "did you use incorrect case?" warning used to be here.
3459 * The problem is that on case-insensitive filesystems one
3460 * might get false positives for "use" (and "require"):
3461 * "use Strict" or "require CARP" will work. This causes
3462 * portability problems for the script: in case-strict
3463 * filesystems the script will stop working.
3464 *
3465 * The "incorrect case" warning checked whether "use Foo"
3466 * imported "Foo" to your namespace, but that is wrong, too:
3467 * there is no requirement nor promise in the language that
3468 * a Foo.pm should or would contain anything in package "Foo".
3469 *
3470 * There is very little Configure-wise that can be done, either:
3471 * the case-sensitivity of the build filesystem of Perl does not
3472 * help in guessing the case-sensitivity of the runtime environment.
3473 */
18fc9488 3474
c305c6a0 3475 PL_hints |= HINT_BLOCK_SCOPE;
3280af22
NIS
3476 PL_copline = NOLINE;
3477 PL_expect = XSTATE;
85e6fe83
LW
3478}
3479
7d3fb230 3480/*
ccfc67b7
JH
3481=head1 Embedding Functions
3482
7d3fb230
BS
3483=for apidoc load_module
3484
3485Loads the module whose name is pointed to by the string part of name.
3486Note that the actual module name, not its filename, should be given.
3487Eg, "Foo::Bar" instead of "Foo/Bar.pm". flags can be any of
3488PERL_LOADMOD_DENY, PERL_LOADMOD_NOIMPORT, or PERL_LOADMOD_IMPORT_OPS
3489(or 0 for no flags). ver, if specified, provides version semantics
3490similar to C<use Foo::Bar VERSION>. The optional trailing SV*
3491arguments can be used to specify arguments to the module's import()
3492method, similar to C<use Foo::Bar VERSION LIST>.
3493
3494=cut */