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