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