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
Forgotten checkin.
[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
5cc9e5c9
RH		 2056 if (right->op_type == OP_CONST &&
2057 cSVOPx(right)->op_private & OPpCONST_BARE &&
2058 cSVOPx(right)->op_private & OPpCONST_STRICT)
2059 {
2060 no_bareword_allowed(right);
2061 }
2062
de4bf5b3
MG		 2063 if (!(right->op_flags & OPf_STACKED) &&
2064 (right->op_type == OP_MATCH ||
79072805 2065 right->op_type == OP_SUBST ||
de4bf5b3 2066 right->op_type == OP_TRANS)) {
79072805 2067 right->op_flags |= OPf_STACKED;
18808301
JH		 2068 if (right->op_type != OP_MATCH &&
2069 ! (right->op_type == OP_TRANS &&
2070 right->op_private & OPpTRANS_IDENTICAL))
463ee0b2 2071 left = mod(left, right->op_type);
79072805 2072 if (right->op_type == OP_TRANS)
11343788 2073 o = newBINOP(OP_NULL, OPf_STACKED, scalar(left), right);
79072805 2074 else
11343788 2075 o = prepend_elem(right->op_type, scalar(left), right);
79072805 2076 if (type == OP_NOT)
11343788
MB		 2077 return newUNOP(OP_NOT, 0, scalar(o));
2078 return o;
79072805
LW		 2079 }
2080 else
2081 return bind_match(type, left,
2082 pmruntime(newPMOP(OP_MATCH, 0), right, Nullop));
2083}
2084
2085OP *
864dbfa3 2086Perl_invert(pTHX_ OP *o)
79072805 2087{
11343788
MB		 2088 if (!o)
2089 return o;
79072805 2090 /* XXX need to optimize away NOT NOT here? Or do we let optimizer do it? */
11343788 2091 return newUNOP(OP_NOT, OPf_SPECIAL, scalar(o));
79072805
LW		 2092}
2093
2094OP *
864dbfa3 2095Perl_scope(pTHX_ OP *o)
79072805
LW		 2096{
2097 if (o) {
3280af22 2098 if (o->op_flags & OPf_PARENS || PERLDB_NOOPT || PL_tainting) {
463ee0b2
LW		 2099 o = prepend_elem(OP_LINESEQ, newOP(OP_ENTER, 0), o);
2100 o->op_type = OP_LEAVE;
22c35a8c 2101 o->op_ppaddr = PL_ppaddr[OP_LEAVE];
463ee0b2
LW		 2102 }
2103 else {
2104 if (o->op_type == OP_LINESEQ) {
2105 OP *kid;
2106 o->op_type = OP_SCOPE;
22c35a8c 2107 o->op_ppaddr = PL_ppaddr[OP_SCOPE];
c3ed7a6a
GS		 2108 kid = ((LISTOP*)o)->op_first;
2109 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE)
93c66552 2110 op_null(kid);
463ee0b2
LW		 2111 }
2112 else
748a9306 2113 o = newLISTOP(OP_SCOPE, 0, o, Nullop);
463ee0b2 2114 }
79072805
LW		 2115 }
2116 return o;
2117}
2118
b3ac6de7 2119void
864dbfa3 2120Perl_save_hints(pTHX)
b3ac6de7 2121{
3280af22
NIS		 2122 SAVEI32(PL_hints);
2123 SAVESPTR(GvHV(PL_hintgv));
2124 GvHV(PL_hintgv) = newHVhv(GvHV(PL_hintgv));
2125 SAVEFREESV(GvHV(PL_hintgv));
b3ac6de7
IZ		 2126}
2127
a0d0e21e 2128int
864dbfa3 2129Perl_block_start(pTHX_ int full)
79072805 2130{
3280af22 2131 int retval = PL_savestack_ix;
b3ac6de7 2132
3280af22 2133 SAVEI32(PL_comppad_name_floor);
43d4d5c6
GS		 2134 PL_comppad_name_floor = AvFILLp(PL_comppad_name);
2135 if (full)
2136 PL_comppad_name_fill = PL_comppad_name_floor;
2137 if (PL_comppad_name_floor < 0)
2138 PL_comppad_name_floor = 0;
3280af22
NIS		 2139 SAVEI32(PL_min_intro_pending);
2140 SAVEI32(PL_max_intro_pending);
2141 PL_min_intro_pending = 0;
2142 SAVEI32(PL_comppad_name_fill);
2143 SAVEI32(PL_padix_floor);
2144 PL_padix_floor = PL_padix;
2145 PL_pad_reset_pending = FALSE;
b3ac6de7 2146 SAVEHINTS();
3280af22 2147 PL_hints &= ~HINT_BLOCK_SCOPE;
1c846c1f 2148 SAVESPTR(PL_compiling.cop_warnings);
0453d815 2149 if (! specialWARN(PL_compiling.cop_warnings)) {
599cee73
PM		 2150 PL_compiling.cop_warnings = newSVsv(PL_compiling.cop_warnings) ;
2151 SAVEFREESV(PL_compiling.cop_warnings) ;
2152 }
ac27b0f5
NIS		 2153 SAVESPTR(PL_compiling.cop_io);
2154 if (! specialCopIO(PL_compiling.cop_io)) {
2155 PL_compiling.cop_io = newSVsv(PL_compiling.cop_io) ;
2156 SAVEFREESV(PL_compiling.cop_io) ;
2157 }
a0d0e21e
LW		 2158 return retval;
2159}
2160
2161OP*
864dbfa3 2162Perl_block_end(pTHX_ I32 floor, OP *seq)
a0d0e21e 2163{
3280af22 2164 int needblockscope = PL_hints & HINT_BLOCK_SCOPE;
d8a34499
IK		 2165 line_t copline = PL_copline;
2166 /* there should be a nextstate in every block */
2167 OP* retval = seq ? scalarseq(seq) : newSTATEOP(0, Nullch, seq);
2168 PL_copline = copline; /* XXX newSTATEOP may reset PL_copline */
e9818f4e 2169 LEAVE_SCOPE(floor);
3280af22 2170 PL_pad_reset_pending = FALSE;
e24b16f9 2171 PL_compiling.op_private = PL_hints;
a0d0e21e 2172 if (needblockscope)
3280af22
NIS		 2173 PL_hints |= HINT_BLOCK_SCOPE; /* propagate out */
2174 pad_leavemy(PL_comppad_name_fill);
2175 PL_cop_seqmax++;
a0d0e21e
LW		 2176 return retval;
2177}
2178
76e3520e 2179STATIC OP *
cea2e8a9 2180S_newDEFSVOP(pTHX)
54b9620d 2181{
4d1ff10f 2182#ifdef USE_5005THREADS
54b9620d
MB		 2183 OP *o = newOP(OP_THREADSV, 0);
2184 o->op_targ = find_threadsv("_");
2185 return o;
2186#else
3280af22 2187 return newSVREF(newGVOP(OP_GV, 0, PL_defgv));
4d1ff10f 2188#endif /* USE_5005THREADS */
54b9620d
MB		 2189}
2190
a0d0e21e 2191void
864dbfa3 2192Perl_newPROG(pTHX_ OP *o)
a0d0e21e 2193{
3280af22 2194 if (PL_in_eval) {
b295d113
TH		 2195 if (PL_eval_root)
2196 return;
faef0170
HS		 2197 PL_eval_root = newUNOP(OP_LEAVEEVAL,
2198 ((PL_in_eval & EVAL_KEEPERR)
2199 ? OPf_SPECIAL : 0), o);
3280af22 2200 PL_eval_start = linklist(PL_eval_root);
7934575e
GS		 2201 PL_eval_root->op_private |= OPpREFCOUNTED;
2202 OpREFCNT_set(PL_eval_root, 1);
3280af22 2203 PL_eval_root->op_next = 0;
a2efc822 2204 CALL_PEEP(PL_eval_start);
a0d0e21e
LW		 2205 }
2206 else {
5dc0d613 2207 if (!o)
a0d0e21e 2208 return;
3280af22
NIS		 2209 PL_main_root = scope(sawparens(scalarvoid(o)));
2210 PL_curcop = &PL_compiling;
2211 PL_main_start = LINKLIST(PL_main_root);
7934575e
GS		 2212 PL_main_root->op_private |= OPpREFCOUNTED;
2213 OpREFCNT_set(PL_main_root, 1);
3280af22 2214 PL_main_root->op_next = 0;
a2efc822 2215 CALL_PEEP(PL_main_start);
3280af22 2216 PL_compcv = 0;
3841441e 2217
4fdae800 2218 /* Register with debugger */
84902520 2219 if (PERLDB_INTER) {
864dbfa3 2220 CV *cv = get_cv("DB::postponed", FALSE);
3841441e
CS		 2221 if (cv) {
2222 dSP;
924508f0 2223 PUSHMARK(SP);
cc49e20b 2224 XPUSHs((SV*)CopFILEGV(&PL_compiling));
3841441e 2225 PUTBACK;
864dbfa3 2226 call_sv((SV*)cv, G_DISCARD);
3841441e
CS		 2227 }
2228 }
79072805 2229 }
79072805
LW		 2230}
2231
2232OP *
864dbfa3 2233Perl_localize(pTHX_ OP *o, I32 lex)
79072805
LW		 2234{
2235 if (o->op_flags & OPf_PARENS)
2236 list(o);
8990e307 2237 else {
64420d0d
JH		 2238 if (ckWARN(WARN_PARENTHESIS)
2239 && PL_bufptr > PL_oldbufptr && PL_bufptr[-1] == ',')
2240 {
2241 char *s = PL_bufptr;
2242
2243 while (*s && (isALNUM(*s) || UTF8_IS_CONTINUED(*s) || strchr("@$%, ", *s)))
2244 s++;
2245
a0d0e21e 2246 if (*s == ';' || *s == '=')
eb64745e
GS		 2247 Perl_warner(aTHX_ WARN_PARENTHESIS,
2248 "Parentheses missing around \"%s\" list",
2249 lex ? (PL_in_my == KEY_our ? "our" : "my") : "local");
8990e307
LW		 2250 }
2251 }
93a17b20 2252 if (lex)
eb64745e 2253 o = my(o);
93a17b20 2254 else
eb64745e
GS		 2255 o = mod(o, OP_NULL); /* a bit kludgey */
2256 PL_in_my = FALSE;
2257 PL_in_my_stash = Nullhv;
2258 return o;
79072805
LW		 2259}
2260
2261OP *
864dbfa3 2262Perl_jmaybe(pTHX_ OP *o)
79072805
LW		 2263{
2264 if (o->op_type == OP_LIST) {
554b3eca 2265 OP *o2;
4d1ff10f 2266#ifdef USE_5005THREADS
2faa37cc 2267 o2 = newOP(OP_THREADSV, 0);
54b9620d 2268 o2->op_targ = find_threadsv(";");
554b3eca
MB		 2269#else
2270 o2 = newSVREF(newGVOP(OP_GV, 0, gv_fetchpv(";", TRUE, SVt_PV))),
4d1ff10f 2271#endif /* USE_5005THREADS */
554b3eca 2272 o = convert(OP_JOIN, 0, prepend_elem(OP_LIST, o2, o));
79072805
LW		 2273 }
2274 return o;
2275}
2276
2277OP *
864dbfa3 2278Perl_fold_constants(pTHX_ register OP *o)
79072805
LW		 2279{
2280 register OP *curop;
2281 I32 type = o->op_type;
748a9306 2282 SV *sv;
79072805 2283
22c35a8c 2284 if (PL_opargs[type] & OA_RETSCALAR)
79072805 2285 scalar(o);
b162f9ea 2286 if (PL_opargs[type] & OA_TARGET && !o->op_targ)
ed6116ce 2287 o->op_targ = pad_alloc(type, SVs_PADTMP);
79072805 2288
eac055e9
GS		 2289 /* integerize op, unless it happens to be C<-foo>.
2290 * XXX should pp_i_negate() do magic string negation instead? */
2291 if ((PL_opargs[type] & OA_OTHERINT) && (PL_hints & HINT_INTEGER)
2292 && !(type == OP_NEGATE && cUNOPo->op_first->op_type == OP_CONST
2293 && (cUNOPo->op_first->op_private & OPpCONST_BARE)))
2294 {
22c35a8c 2295 o->op_ppaddr = PL_ppaddr[type = ++(o->op_type)];
eac055e9 2296 }
85e6fe83 2297
22c35a8c 2298 if (!(PL_opargs[type] & OA_FOLDCONST))
79072805
LW		 2299 goto nope;
2300
de939608 2301 switch (type) {
7a52d87a
GS		 2302 case OP_NEGATE:
2303 /* XXX might want a ck_negate() for this */
2304 cUNOPo->op_first->op_private &= ~OPpCONST_STRICT;
2305 break;
de939608
CS		 2306 case OP_SPRINTF:
2307 case OP_UCFIRST:
2308 case OP_LCFIRST:
2309 case OP_UC:
2310 case OP_LC:
69dcf70c
MB		 2311 case OP_SLT:
2312 case OP_SGT:
2313 case OP_SLE:
2314 case OP_SGE:
2315 case OP_SCMP:
2de3dbcc
JH		 2316 /* XXX what about the numeric ops? */
2317 if (PL_hints & HINT_LOCALE)
de939608
CS		 2318 goto nope;
2319 }
2320
3280af22 2321 if (PL_error_count)
a0d0e21e
LW		 2322 goto nope; /* Don't try to run w/ errors */
2323
79072805 2324 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
11fa937b
GS		 2325 if ((curop->op_type != OP_CONST ||
2326 (curop->op_private & OPpCONST_BARE)) &&
7a52d87a
GS		 2327 curop->op_type != OP_LIST &&
2328 curop->op_type != OP_SCALAR &&
2329 curop->op_type != OP_NULL &&
2330 curop->op_type != OP_PUSHMARK)
2331 {
79072805
LW		 2332 goto nope;
2333 }
2334 }
2335
2336 curop = LINKLIST(o);
2337 o->op_next = 0;
533c011a 2338 PL_op = curop;
cea2e8a9 2339 CALLRUNOPS(aTHX);
3280af22 2340 sv = *(PL_stack_sp--);
748a9306 2341 if (o->op_targ && sv == PAD_SV(o->op_targ)) /* grab pad temp? */
79072805 2342 pad_swipe(o->op_targ);
748a9306
LW		 2343 else if (SvTEMP(sv)) { /* grab mortal temp? */
2344 (void)SvREFCNT_inc(sv);
2345 SvTEMP_off(sv);
85e6fe83 2346 }
79072805
LW		 2347 op_free(o);
2348 if (type == OP_RV2GV)
b1cb66bf 2349 return newGVOP(OP_GV, 0, (GV*)sv);
748a9306 2350 else {
ee580363
GS		 2351 /* try to smush double to int, but don't smush -2.0 to -2 */
2352 if ((SvFLAGS(sv) & (SVf_IOK|SVf_NOK|SVf_POK)) == SVf_NOK &&
2353 type != OP_NEGATE)
2354 {
28e5dec8
JH		 2355#ifdef PERL_PRESERVE_IVUV
2356 /* Only bother to attempt to fold to IV if
2357 most operators will benefit */
2358 SvIV_please(sv);
2359#endif
748a9306 2360 }
a86a20aa 2361 return newSVOP(OP_CONST, 0, sv);
748a9306 2362 }
aeea060c 2363
79072805 2364 nope:
22c35a8c 2365 if (!(PL_opargs[type] & OA_OTHERINT))
79072805 2366 return o;
79072805 2367
3280af22 2368 if (!(PL_hints & HINT_INTEGER)) {
4bb9f687
GS		 2369 if (type == OP_MODULO
2370 || type == OP_DIVIDE
2371 || !(o->op_flags & OPf_KIDS))
2372 {
85e6fe83 2373 return o;
4bb9f687 2374 }
85e6fe83
LW		 2375
2376 for (curop = ((UNOP*)o)->op_first; curop; curop = curop->op_sibling) {
2377 if (curop->op_type == OP_CONST) {
b1cb66bf 2378 if (SvIOK(((SVOP*)curop)->op_sv))
85e6fe83
LW		 2379 continue;
2380 return o;
2381 }
22c35a8c 2382 if (PL_opargs[curop->op_type] & OA_RETINTEGER)
79072805
LW		 2383 continue;
2384 return o;
2385 }
22c35a8c 2386 o->op_ppaddr = PL_ppaddr[++(o->op_type)];
79072805
LW		 2387 }
2388
79072805
LW		 2389 return o;
2390}
2391
2392OP *
864dbfa3 2393Perl_gen_constant_list(pTHX_ register OP *o)
79072805
LW		 2394{
2395 register OP *curop;
3280af22 2396 I32 oldtmps_floor = PL_tmps_floor;
79072805 2397
a0d0e21e 2398 list(o);
3280af22 2399 if (PL_error_count)
a0d0e21e
LW		 2400 return o; /* Don't attempt to run with errors */
2401
533c011a 2402 PL_op = curop = LINKLIST(o);
a0d0e21e 2403 o->op_next = 0;
a2efc822 2404 CALL_PEEP(curop);
cea2e8a9
GS		 2405 pp_pushmark();
2406 CALLRUNOPS(aTHX);
533c011a 2407 PL_op = curop;
cea2e8a9 2408 pp_anonlist();
3280af22 2409 PL_tmps_floor = oldtmps_floor;
79072805
LW		 2410
2411 o->op_type = OP_RV2AV;
22c35a8c 2412 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
79072805 2413 curop = ((UNOP*)o)->op_first;
3280af22 2414 ((UNOP*)o)->op_first = newSVOP(OP_CONST, 0, SvREFCNT_inc(*PL_stack_sp--));
79072805 2415 op_free(curop);
79072805
LW		 2416 linklist(o);
2417 return list(o);
2418}
2419
2420OP *
864dbfa3 2421Perl_convert(pTHX_ I32 type, I32 flags, OP *o)
79072805 2422{
11343788
MB		 2423 if (!o || o->op_type != OP_LIST)
2424 o = newLISTOP(OP_LIST, 0, o, Nullop);
748a9306 2425 else
5dc0d613 2426 o->op_flags &= ~OPf_WANT;
79072805 2427
22c35a8c 2428 if (!(PL_opargs[type] & OA_MARK))
93c66552 2429 op_null(cLISTOPo->op_first);
8990e307 2430
11343788 2431 o->op_type = type;
22c35a8c 2432 o->op_ppaddr = PL_ppaddr[type];
11343788 2433 o->op_flags |= flags;
79072805 2434
11343788
MB		 2435 o = CHECKOP(type, o);
2436 if (o->op_type != type)
2437 return o;
79072805 2438
11343788 2439 return fold_constants(o);
79072805
LW		 2440}
2441
2442/* List constructors */
2443
2444OP *
864dbfa3 2445Perl_append_elem(pTHX_ I32 type, OP *first, OP *last)
79072805
LW		 2446{
2447 if (!first)
2448 return last;
8990e307
LW		 2449
2450 if (!last)
79072805 2451 return first;
8990e307 2452
155aba94
GS		 2453 if (first->op_type != type
2454 || (type == OP_LIST && (first->op_flags & OPf_PARENS)))
2455 {
2456 return newLISTOP(type, 0, first, last);
2457 }
79072805 2458
a0d0e21e
LW		 2459 if (first->op_flags & OPf_KIDS)
2460 ((LISTOP*)first)->op_last->op_sibling = last;
2461 else {
2462 first->op_flags |= OPf_KIDS;
2463 ((LISTOP*)first)->op_first = last;
2464 }
2465 ((LISTOP*)first)->op_last = last;
a0d0e21e 2466 return first;
79072805
LW		 2467}
2468
2469OP *
864dbfa3 2470Perl_append_list(pTHX_ I32 type, LISTOP *first, LISTOP *last)
79072805
LW		 2471{
2472 if (!first)
2473 return (OP*)last;
8990e307
LW		 2474
2475 if (!last)
79072805 2476 return (OP*)first;
8990e307
LW		 2477
2478 if (first->op_type != type)
79072805 2479 return prepend_elem(type, (OP*)first, (OP*)last);
8990e307
LW		 2480
2481 if (last->op_type != type)
79072805
LW		 2482 return append_elem(type, (OP*)first, (OP*)last);
2483
2484 first->op_last->op_sibling = last->op_first;
2485 first->op_last = last->op_last;
117dada2 2486 first->op_flags |= (last->op_flags & OPf_KIDS);
1c846c1f 2487
b7dc083c
NIS		 2488#ifdef PL_OP_SLAB_ALLOC
2489#else
1c846c1f 2490 Safefree(last);
b7dc083c 2491#endif
79072805
LW		 2492 return (OP*)first;
2493}
2494
2495OP *
864dbfa3 2496Perl_prepend_elem(pTHX_ I32 type, OP *first, OP *last)
79072805
LW		 2497{
2498 if (!first)
2499 return last;
8990e307
LW		 2500
2501 if (!last)
79072805 2502 return first;
8990e307
LW		 2503
2504 if (last->op_type == type) {
2505 if (type == OP_LIST) { /* already a PUSHMARK there */
2506 first->op_sibling = ((LISTOP*)last)->op_first->op_sibling;
2507 ((LISTOP*)last)->op_first->op_sibling = first;
36a5d4ba
DC		 2508 if (!(first->op_flags & OPf_PARENS))
2509 last->op_flags &= ~OPf_PARENS;
8990e307
LW		 2510 }
2511 else {
2512 if (!(last->op_flags & OPf_KIDS)) {
2513 ((LISTOP*)last)->op_last = first;
2514 last->op_flags |= OPf_KIDS;
2515 }
2516 first->op_sibling = ((LISTOP*)last)->op_first;
2517 ((LISTOP*)last)->op_first = first;
79072805 2518 }
117dada2 2519 last->op_flags |= OPf_KIDS;
79072805
LW		 2520 return last;
2521 }
2522
2523 return newLISTOP(type, 0, first, last);
2524}
2525
2526/* Constructors */
2527
2528OP *
864dbfa3 2529Perl_newNULLLIST(pTHX)
79072805 2530{
8990e307
LW		 2531 return newOP(OP_STUB, 0);
2532}
2533
2534OP *
864dbfa3 2535Perl_force_list(pTHX_ OP *o)
8990e307 2536{
11343788
MB		 2537 if (!o || o->op_type != OP_LIST)
2538 o = newLISTOP(OP_LIST, 0, o, Nullop);
93c66552 2539 op_null(o);
11343788 2540 return o;
79072805
LW		 2541}
2542
2543OP *
864dbfa3 2544Perl_newLISTOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
79072805
LW		 2545{
2546 LISTOP *listop;
2547
b7dc083c 2548 NewOp(1101, listop, 1, LISTOP);
79072805
LW		 2549
2550 listop->op_type = type;
22c35a8c 2551 listop->op_ppaddr = PL_ppaddr[type];
117dada2
SM		 2552 if (first || last)
2553 flags |= OPf_KIDS;
79072805 2554 listop->op_flags = flags;
79072805
LW		 2555
2556 if (!last && first)
2557 last = first;
2558 else if (!first && last)
2559 first = last;
8990e307
LW		 2560 else if (first)
2561 first->op_sibling = last;
79072805
LW		 2562 listop->op_first = first;
2563 listop->op_last = last;
8990e307
LW		 2564 if (type == OP_LIST) {
2565 OP* pushop;
2566 pushop = newOP(OP_PUSHMARK, 0);
2567 pushop->op_sibling = first;
2568 listop->op_first = pushop;
2569 listop->op_flags |= OPf_KIDS;
2570 if (!last)
2571 listop->op_last = pushop;
2572 }
79072805
LW		 2573
2574 return (OP*)listop;
2575}
2576
2577OP *
864dbfa3 2578Perl_newOP(pTHX_ I32 type, I32 flags)
79072805 2579{
11343788 2580 OP *o;
b7dc083c 2581 NewOp(1101, o, 1, OP);
11343788 2582 o->op_type = type;
22c35a8c 2583 o->op_ppaddr = PL_ppaddr[type];
11343788 2584 o->op_flags = flags;
79072805 2585
11343788
MB		 2586 o->op_next = o;
2587 o->op_private = 0 + (flags >> 8);
22c35a8c 2588 if (PL_opargs[type] & OA_RETSCALAR)
11343788 2589 scalar(o);
22c35a8c 2590 if (PL_opargs[type] & OA_TARGET)
11343788
MB		 2591 o->op_targ = pad_alloc(type, SVs_PADTMP);
2592 return CHECKOP(type, o);
79072805
LW		 2593}
2594
2595OP *
864dbfa3 2596Perl_newUNOP(pTHX_ I32 type, I32 flags, OP *first)
79072805
LW		 2597{
2598 UNOP *unop;
2599
93a17b20 2600 if (!first)
aeea060c 2601 first = newOP(OP_STUB, 0);
22c35a8c 2602 if (PL_opargs[type] & OA_MARK)
8990e307 2603 first = force_list(first);
93a17b20 2604
b7dc083c 2605 NewOp(1101, unop, 1, UNOP);
79072805 2606 unop->op_type = type;
22c35a8c 2607 unop->op_ppaddr = PL_ppaddr[type];
79072805
LW		 2608 unop->op_first = first;
2609 unop->op_flags = flags | OPf_KIDS;
c07a80fd 2610 unop->op_private = 1 | (flags >> 8);
e50aee73 2611 unop = (UNOP*) CHECKOP(type, unop);
79072805
LW		 2612 if (unop->op_next)
2613 return (OP*)unop;
2614
a0d0e21e 2615 return fold_constants((OP *) unop);
79072805
LW		 2616}
2617
2618OP *
864dbfa3 2619Perl_newBINOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
79072805
LW		 2620{
2621 BINOP *binop;
b7dc083c 2622 NewOp(1101, binop, 1, BINOP);
79072805
LW		 2623
2624 if (!first)
2625 first = newOP(OP_NULL, 0);
2626
2627 binop->op_type = type;
22c35a8c 2628 binop->op_ppaddr = PL_ppaddr[type];
79072805
LW		 2629 binop->op_first = first;
2630 binop->op_flags = flags | OPf_KIDS;
2631 if (!last) {
2632 last = first;
c07a80fd 2633 binop->op_private = 1 | (flags >> 8);
79072805
LW		 2634 }
2635 else {
c07a80fd 2636 binop->op_private = 2 | (flags >> 8);
79072805
LW		 2637 first->op_sibling = last;
2638 }
2639
e50aee73 2640 binop = (BINOP*)CHECKOP(type, binop);
b162f9ea 2641 if (binop->op_next || binop->op_type != type)
79072805
LW		 2642 return (OP*)binop;
2643
7284ab6f 2644 binop->op_last = binop->op_first->op_sibling;
79072805 2645
a0d0e21e 2646 return fold_constants((OP *)binop);
79072805
LW		 2647}
2648
a0ed51b3 2649static int
2b9d42f0
NIS		 2650uvcompare(const void *a, const void *b)
2651{
2652 if (*((UV *)a) < (*(UV *)b))
2653 return -1;
2654 if (*((UV *)a) > (*(UV *)b))
2655 return 1;
2656 if (*((UV *)a+1) < (*(UV *)b+1))
2657 return -1;
2658 if (*((UV *)a+1) > (*(UV *)b+1))
2659 return 1;
a0ed51b3
LW		 2660 return 0;
2661}
2662
79072805 2663OP *
864dbfa3 2664Perl_pmtrans(pTHX_ OP *o, OP *expr, OP *repl)
79072805 2665{
79072805
LW		 2666 SV *tstr = ((SVOP*)expr)->op_sv;
2667 SV *rstr = ((SVOP*)repl)->op_sv;
463ee0b2
LW		 2668 STRLEN tlen;
2669 STRLEN rlen;
9b877dbb
IH		 2670 U8 *t = (U8*)SvPV(tstr, tlen);
2671 U8 *r = (U8*)SvPV(rstr, rlen);
79072805
LW		 2672 register I32 i;
2673 register I32 j;
a0ed51b3 2674 I32 del;
79072805 2675 I32 complement;
5d06d08e 2676 I32 squash;
9b877dbb 2677 I32 grows = 0;
79072805
LW		 2678 register short *tbl;
2679
800b4dc4 2680 PL_hints |= HINT_BLOCK_SCOPE;
11343788 2681 complement = o->op_private & OPpTRANS_COMPLEMENT;
a0ed51b3 2682 del = o->op_private & OPpTRANS_DELETE;
5d06d08e 2683 squash = o->op_private & OPpTRANS_SQUASH;
1c846c1f 2684
036b4402
GS		 2685 if (SvUTF8(tstr))
2686 o->op_private |= OPpTRANS_FROM_UTF;
1c846c1f
NIS		 2687
2688 if (SvUTF8(rstr))
036b4402 2689 o->op_private |= OPpTRANS_TO_UTF;
79072805 2690
a0ed51b3 2691 if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
79cb57f6 2692 SV* listsv = newSVpvn("# comment\n",10);
a0ed51b3
LW		 2693 SV* transv = 0;
2694 U8* tend = t + tlen;
2695 U8* rend = r + rlen;
ba210ebe 2696 STRLEN ulen;
a0ed51b3
LW		 2697 U32 tfirst = 1;
2698 U32 tlast = 0;
2699 I32 tdiff;
2700 U32 rfirst = 1;
2701 U32 rlast = 0;
2702 I32 rdiff;
2703 I32 diff;
2704 I32 none = 0;
2705 U32 max = 0;
2706 I32 bits;
a0ed51b3 2707 I32 havefinal = 0;
9c5ffd7c 2708 U32 final = 0;
a0ed51b3
LW		 2709 I32 from_utf = o->op_private & OPpTRANS_FROM_UTF;
2710 I32 to_utf = o->op_private & OPpTRANS_TO_UTF;
bf4a1e57
JH		 2711 U8* tsave = NULL;
2712 U8* rsave = NULL;
2713
2714 if (!from_utf) {
2715 STRLEN len = tlen;
2716 tsave = t = bytes_to_utf8(t, &len);
2717 tend = t + len;
2718 }
2719 if (!to_utf && rlen) {
2720 STRLEN len = rlen;
2721 rsave = r = bytes_to_utf8(r, &len);
2722 rend = r + len;
2723 }
a0ed51b3 2724
2b9d42f0
NIS		 2725/* There are several snags with this code on EBCDIC:
2726 1. 0xFF is a legal UTF-EBCDIC byte (there are no illegal bytes).
2727 2. scan_const() in toke.c has encoded chars in native encoding which makes
2728 ranges at least in EBCDIC 0..255 range the bottom odd.
2729*/
2730
a0ed51b3 2731 if (complement) {
ad391ad9 2732 U8 tmpbuf[UTF8_MAXLEN+1];
2b9d42f0 2733 UV *cp;
a0ed51b3 2734 UV nextmin = 0;
2b9d42f0 2735 New(1109, cp, 2*tlen, UV);
a0ed51b3 2736 i = 0;
79cb57f6 2737 transv = newSVpvn("",0);
a0ed51b3 2738 while (t < tend) {
2b9d42f0
NIS		 2739 cp[2*i] = utf8n_to_uvuni(t, tend-t, &ulen, 0);
2740 t += ulen;
2741 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) {
a0ed51b3 2742 t++;
2b9d42f0
NIS		 2743 cp[2*i+1] = utf8n_to_uvuni(t, tend-t, &ulen, 0);
2744 t += ulen;
a0ed51b3 2745 }
2b9d42f0
NIS		 2746 else {
2747 cp[2*i+1] = cp[2*i];
2748 }
2749 i++;
a0ed51b3 2750 }
2b9d42f0 2751 qsort(cp, i, 2*sizeof(UV), uvcompare);
a0ed51b3 2752 for (j = 0; j < i; j++) {
2b9d42f0 2753 UV val = cp[2*j];
a0ed51b3
LW		 2754 diff = val - nextmin;
2755 if (diff > 0) {
9041c2e3 2756 t = uvuni_to_utf8(tmpbuf,nextmin);
dfe13c55 2757 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
a0ed51b3 2758 if (diff > 1) {
2b9d42f0 2759 U8 range_mark = UTF_TO_NATIVE(0xff);
9041c2e3 2760 t = uvuni_to_utf8(tmpbuf, val - 1);
2b9d42f0 2761 sv_catpvn(transv, (char *)&range_mark, 1);
dfe13c55 2762 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
a0ed51b3
LW		 2763 }
2764 }
2b9d42f0 2765 val = cp[2*j+1];
a0ed51b3
LW		 2766 if (val >= nextmin)
2767 nextmin = val + 1;
2768 }
9041c2e3 2769 t = uvuni_to_utf8(tmpbuf,nextmin);
dfe13c55 2770 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2b9d42f0
NIS		 2771 {
2772 U8 range_mark = UTF_TO_NATIVE(0xff);
2773 sv_catpvn(transv, (char *)&range_mark, 1);
2774 }
9041c2e3 2775 t = uvuni_to_utf8(tmpbuf, 0x7fffffff);
dfe13c55
GS		 2776 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2777 t = (U8*)SvPVX(transv);
a0ed51b3
LW		 2778 tlen = SvCUR(transv);
2779 tend = t + tlen;
455d824a 2780 Safefree(cp);
a0ed51b3
LW		 2781 }
2782 else if (!rlen && !del) {
2783 r = t; rlen = tlen; rend = tend;
4757a243
LW		 2784 }
2785 if (!squash) {
05d340b8 2786 if ((!rlen && !del) || t == r ||
12ae5dfc 2787 (tlen == rlen && memEQ((char *)t, (char *)r, tlen)))
01ec43d0 2788 {
4757a243 2789 o->op_private |= OPpTRANS_IDENTICAL;
01ec43d0 2790 }
a0ed51b3
LW		 2791 }
2792
2793 while (t < tend || tfirst <= tlast) {
2794 /* see if we need more "t" chars */
2795 if (tfirst > tlast) {
9041c2e3 2796 tfirst = (I32)utf8n_to_uvuni(t, tend - t, &ulen, 0);
a0ed51b3 2797 t += ulen;
2b9d42f0 2798 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) { /* illegal utf8 val indicates range */
ba210ebe 2799 t++;
9041c2e3 2800 tlast = (I32)utf8n_to_uvuni(t, tend - t, &ulen, 0);
a0ed51b3
LW		 2801 t += ulen;
2802 }
2803 else
2804 tlast = tfirst;
2805 }
2806
2807 /* now see if we need more "r" chars */
2808 if (rfirst > rlast) {
2809 if (r < rend) {
9041c2e3 2810 rfirst = (I32)utf8n_to_uvuni(r, rend - r, &ulen, 0);
a0ed51b3 2811 r += ulen;
2b9d42f0 2812 if (r < rend && NATIVE_TO_UTF(*r) == 0xff) { /* illegal utf8 val indicates range */
ba210ebe 2813 r++;
9041c2e3 2814 rlast = (I32)utf8n_to_uvuni(r, rend - r, &ulen, 0);
a0ed51b3
LW		 2815 r += ulen;
2816 }
2817 else
2818 rlast = rfirst;
2819 }
2820 else {
2821 if (!havefinal++)
2822 final = rlast;
2823 rfirst = rlast = 0xffffffff;
2824 }
2825 }
2826
2827 /* now see which range will peter our first, if either. */
2828 tdiff = tlast - tfirst;
2829 rdiff = rlast - rfirst;
2830
2831 if (tdiff <= rdiff)
2832 diff = tdiff;
2833 else
2834 diff = rdiff;
2835
2836 if (rfirst == 0xffffffff) {
2837 diff = tdiff; /* oops, pretend rdiff is infinite */
2838 if (diff > 0)
894356b3
GS		 2839 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\tXXXX\n",
2840 (long)tfirst, (long)tlast);
a0ed51b3 2841 else
894356b3 2842 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\tXXXX\n", (long)tfirst);
a0ed51b3
LW		 2843 }
2844 else {
2845 if (diff > 0)
894356b3
GS		 2846 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\t%04lx\n",
2847 (long)tfirst, (long)(tfirst + diff),
2848 (long)rfirst);
a0ed51b3 2849 else
894356b3
GS		 2850 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\t%04lx\n",
2851 (long)tfirst, (long)rfirst);
a0ed51b3
LW		 2852
2853 if (rfirst + diff > max)
2854 max = rfirst + diff;
9b877dbb 2855 if (!grows)
45005bfb
JH		 2856 grows = (tfirst < rfirst &&
2857 UNISKIP(tfirst) < UNISKIP(rfirst + diff));
2858 rfirst += diff + 1;
a0ed51b3
LW		 2859 }
2860 tfirst += diff + 1;
2861 }
2862
2863 none = ++max;
2864 if (del)
2865 del = ++max;
2866
2867 if (max > 0xffff)
2868 bits = 32;
2869 else if (max > 0xff)
2870 bits = 16;
2871 else
2872 bits = 8;
2873
455d824a 2874 Safefree(cPVOPo->op_pv);
a0ed51b3
LW		 2875 cSVOPo->op_sv = (SV*)swash_init("utf8", "", listsv, bits, none);
2876 SvREFCNT_dec(listsv);
2877 if (transv)
2878 SvREFCNT_dec(transv);
2879
45005bfb 2880 if (!del && havefinal && rlen)
b448e4fe
JH		 2881 (void)hv_store((HV*)SvRV((cSVOPo->op_sv)), "FINAL", 5,
2882 newSVuv((UV)final), 0);
a0ed51b3 2883
9b877dbb 2884 if (grows)
a0ed51b3
LW		 2885 o->op_private |= OPpTRANS_GROWS;
2886
9b877dbb
IH		 2887 if (tsave)
2888 Safefree(tsave);
2889 if (rsave)
2890 Safefree(rsave);
2891
a0ed51b3
LW		 2892 op_free(expr);
2893 op_free(repl);
2894 return o;
2895 }
2896
2897 tbl = (short*)cPVOPo->op_pv;
79072805
LW		 2898 if (complement) {
2899 Zero(tbl, 256, short);
2900 for (i = 0; i < tlen; i++)
ec49126f 2901 tbl[t[i]] = -1;
79072805
LW		 2902 for (i = 0, j = 0; i < 256; i++) {
2903 if (!tbl[i]) {
2904 if (j >= rlen) {
a0ed51b3 2905 if (del)
79072805
LW		 2906 tbl[i] = -2;
2907 else if (rlen)
ec49126f 2908 tbl[i] = r[j-1];
79072805
LW		 2909 else
2910 tbl[i] = i;
2911 }
9b877dbb
IH		 2912 else {
2913 if (i < 128 && r[j] >= 128)
2914 grows = 1;
ec49126f 2915 tbl[i] = r[j++];
9b877dbb 2916 }
79072805
LW		 2917 }
2918 }
05d340b8
JH		 2919 if (!del) {
2920 if (!rlen) {
2921 j = rlen;
2922 if (!squash)
2923 o->op_private |= OPpTRANS_IDENTICAL;
2924 }
2925 else if (j >= rlen)
2926 j = rlen - 1;
2927 else
2928 cPVOPo->op_pv = (char*)Renew(tbl, 0x101+rlen-j, short);
8973db79
JH		 2929 tbl[0x100] = rlen - j;
2930 for (i=0; i < rlen - j; i++)
2931 tbl[0x101+i] = r[j+i];
2932 }
79072805
LW		 2933 }
2934 else {
a0ed51b3 2935 if (!rlen && !del) {
79072805 2936 r = t; rlen = tlen;
5d06d08e 2937 if (!squash)
4757a243 2938 o->op_private |= OPpTRANS_IDENTICAL;
79072805 2939 }
94bfe852
RGS		 2940 else if (!squash && rlen == tlen && memEQ((char*)t, (char*)r, tlen)) {
2941 o->op_private |= OPpTRANS_IDENTICAL;
2942 }
79072805
LW		 2943 for (i = 0; i < 256; i++)
2944 tbl[i] = -1;
2945 for (i = 0, j = 0; i < tlen; i++,j++) {
2946 if (j >= rlen) {
a0ed51b3 2947 if (del) {
ec49126f 2948 if (tbl[t[i]] == -1)
2949 tbl[t[i]] = -2;
79072805
LW		 2950 continue;
2951 }
2952 --j;
2953 }
9b877dbb
IH		 2954 if (tbl[t[i]] == -1) {
2955 if (t[i] < 128 && r[j] >= 128)
2956 grows = 1;
ec49126f 2957 tbl[t[i]] = r[j];
9b877dbb 2958 }
79072805
LW		 2959 }
2960 }
9b877dbb
IH		 2961 if (grows)
2962 o->op_private |= OPpTRANS_GROWS;
79072805
LW		 2963 op_free(expr);
2964 op_free(repl);
2965
11343788 2966 return o;
79072805
LW		 2967}
2968
2969OP *
864dbfa3 2970Perl_newPMOP(pTHX_ I32 type, I32 flags)
79072805
LW		 2971{
2972 PMOP *pmop;
2973
b7dc083c 2974 NewOp(1101, pmop, 1, PMOP);
79072805 2975 pmop->op_type = type;
22c35a8c 2976 pmop->op_ppaddr = PL_ppaddr[type];
79072805 2977 pmop->op_flags = flags;
c07a80fd 2978 pmop->op_private = 0 | (flags >> 8);
79072805 2979
3280af22 2980 if (PL_hints & HINT_RE_TAINT)
b3eb6a9b 2981 pmop->op_pmpermflags |= PMf_RETAINT;
3280af22 2982 if (PL_hints & HINT_LOCALE)
b3eb6a9b
GS		 2983 pmop->op_pmpermflags |= PMf_LOCALE;
2984 pmop->op_pmflags = pmop->op_pmpermflags;
36477c24 2985
debc9467 2986#ifdef USE_ITHREADS
13137afc
AB		 2987 {
2988 SV* repointer;
2989 if(av_len((AV*) PL_regex_pad[0]) > -1) {
2990 repointer = av_pop((AV*)PL_regex_pad[0]);
2991 pmop->op_pmoffset = SvIV(repointer);
1cc8b4c5 2992 SvREPADTMP_off(repointer);
13137afc
AB		 2993 sv_setiv(repointer,0);
2994 } else {
2995 repointer = newSViv(0);
2996 av_push(PL_regex_padav,SvREFCNT_inc(repointer));
2997 pmop->op_pmoffset = av_len(PL_regex_padav);
2998 PL_regex_pad = AvARRAY(PL_regex_padav);
1fcf4c12 2999 }
13137afc 3000 }
debc9467 3001#endif
1fcf4c12
AB		 3002
3003 /* link into pm list */
3280af22
NIS		 3004 if (type != OP_TRANS && PL_curstash) {
3005 pmop->op_pmnext = HvPMROOT(PL_curstash);
3006 HvPMROOT(PL_curstash) = pmop;
cb55de95 3007 PmopSTASH_set(pmop,PL_curstash);
79072805
LW		 3008 }
3009
3010 return (OP*)pmop;
3011}
3012
3013OP *
864dbfa3 3014Perl_pmruntime(pTHX_ OP *o, OP *expr, OP *repl)
79072805
LW		 3015{
3016 PMOP *pm;
3017 LOGOP *rcop;
ce862d02 3018 I32 repl_has_vars = 0;
79072805 3019
11343788
MB		 3020 if (o->op_type == OP_TRANS)
3021 return pmtrans(o, expr, repl);
79072805 3022
3280af22 3023 PL_hints |= HINT_BLOCK_SCOPE;
11343788 3024 pm = (PMOP*)o;
79072805
LW		 3025
3026 if (expr->op_type == OP_CONST) {
463ee0b2 3027 STRLEN plen;
79072805 3028 SV *pat = ((SVOP*)expr)->op_sv;
463ee0b2 3029 char *p = SvPV(pat, plen);
11343788 3030 if ((o->op_flags & OPf_SPECIAL) && strEQ(p, " ")) {
93a17b20 3031 sv_setpvn(pat, "\\s+", 3);
463ee0b2 3032 p = SvPV(pat, plen);
79072805
LW		 3033 pm->op_pmflags |= PMf_SKIPWHITE;
3034 }
aaa362c4
RS		 3035 PM_SETRE(pm, CALLREGCOMP(aTHX_ p, p + plen, pm));
3036 if (strEQ("\\s+", PM_GETRE(pm)->precomp))
85e6fe83 3037 pm->op_pmflags |= PMf_WHITE;
79072805
LW		 3038 op_free(expr);
3039 }
3040 else {
3280af22 3041 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL))
1c846c1f 3042 expr = newUNOP((!(PL_hints & HINT_RE_EVAL)
2cd61cdb
IZ		 3043 ? OP_REGCRESET
3044 : OP_REGCMAYBE),0,expr);
463ee0b2 3045
b7dc083c 3046 NewOp(1101, rcop, 1, LOGOP);
79072805 3047 rcop->op_type = OP_REGCOMP;
22c35a8c 3048 rcop->op_ppaddr = PL_ppaddr[OP_REGCOMP];
79072805 3049 rcop->op_first = scalar(expr);
1c846c1f 3050 rcop->op_flags |= ((PL_hints & HINT_RE_EVAL)
2cd61cdb
IZ		 3051 ? (OPf_SPECIAL | OPf_KIDS)
3052 : OPf_KIDS);
79072805 3053 rcop->op_private = 1;
11343788 3054 rcop->op_other = o;
79072805
LW		 3055
3056 /* establish postfix order */
3280af22 3057 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL)) {
463ee0b2
LW		 3058 LINKLIST(expr);
3059 rcop->op_next = expr;
3060 ((UNOP*)expr)->op_first->op_next = (OP*)rcop;
3061 }
3062 else {
3063 rcop->op_next = LINKLIST(expr);
3064 expr->op_next = (OP*)rcop;
3065 }
79072805 3066
11343788 3067 prepend_elem(o->op_type, scalar((OP*)rcop), o);
79072805
LW		 3068 }
3069
3070 if (repl) {
748a9306 3071 OP *curop;
0244c3a4 3072 if (pm->op_pmflags & PMf_EVAL) {
748a9306 3073 curop = 0;
57843af0
GS		 3074 if (CopLINE(PL_curcop) < PL_multi_end)
3075 CopLINE_set(PL_curcop, PL_multi_end);
0244c3a4 3076 }
4d1ff10f 3077#ifdef USE_5005THREADS
2faa37cc 3078 else if (repl->op_type == OP_THREADSV
554b3eca 3079 && strchr("&`'123456789+",
533c011a 3080 PL_threadsv_names[repl->op_targ]))
554b3eca
MB		 3081 {
3082 curop = 0;
3083 }
4d1ff10f 3084#endif /* USE_5005THREADS */
748a9306
LW		 3085 else if (repl->op_type == OP_CONST)
3086 curop = repl;
79072805 3087 else {
79072805
LW		 3088 OP *lastop = 0;
3089 for (curop = LINKLIST(repl); curop!=repl; curop = LINKLIST(curop)) {
22c35a8c 3090 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
4d1ff10f 3091#ifdef USE_5005THREADS
ce862d02
IZ		 3092 if (curop->op_type == OP_THREADSV) {
3093 repl_has_vars = 1;
be949f6f 3094 if (strchr("&`'123456789+", curop->op_private))
ce862d02 3095 break;
554b3eca
MB		 3096 }
3097#else
79072805 3098 if (curop->op_type == OP_GV) {
638eceb6 3099 GV *gv = cGVOPx_gv(curop);
ce862d02 3100 repl_has_vars = 1;
93a17b20 3101 if (strchr("&`'123456789+", *GvENAME(gv)))
79072805
LW		 3102 break;
3103 }
4d1ff10f 3104#endif /* USE_5005THREADS */
79072805
LW		 3105 else if (curop->op_type == OP_RV2CV)
3106 break;
3107 else if (curop->op_type == OP_RV2SV ||
3108 curop->op_type == OP_RV2AV ||
3109 curop->op_type == OP_RV2HV ||
3110 curop->op_type == OP_RV2GV) {
3111 if (lastop && lastop->op_type != OP_GV) /*funny deref?*/
3112 break;
3113 }
748a9306
LW		 3114 else if (curop->op_type == OP_PADSV ||
3115 curop->op_type == OP_PADAV ||
3116 curop->op_type == OP_PADHV ||
554b3eca 3117 curop->op_type == OP_PADANY) {
ce862d02 3118 repl_has_vars = 1;
748a9306 3119 }
1167e5da
SM		 3120 else if (curop->op_type == OP_PUSHRE)
3121 ; /* Okay here, dangerous in newASSIGNOP */
79072805
LW		 3122 else
3123 break;
3124 }
3125 lastop = curop;
3126 }
748a9306 3127 }
ce862d02 3128 if (curop == repl
1c846c1f 3129 && !(repl_has_vars
aaa362c4
RS		 3130 && (!PM_GETRE(pm)
3131 || PM_GETRE(pm)->reganch & ROPT_EVAL_SEEN))) {
748a9306 3132 pm->op_pmflags |= PMf_CONST; /* const for long enough */
4633a7c4 3133 pm->op_pmpermflags |= PMf_CONST; /* const for long enough */
11343788 3134 prepend_elem(o->op_type, scalar(repl), o);
748a9306
LW		 3135 }
3136 else {
aaa362c4 3137 if (curop == repl && !PM_GETRE(pm)) { /* Has variables. */
ce862d02
IZ		 3138 pm->op_pmflags |= PMf_MAYBE_CONST;
3139 pm->op_pmpermflags |= PMf_MAYBE_CONST;
3140 }
b7dc083c 3141 NewOp(1101, rcop, 1, LOGOP);
748a9306 3142 rcop->op_type = OP_SUBSTCONT;
22c35a8c 3143 rcop->op_ppaddr = PL_ppaddr[OP_SUBSTCONT];
748a9306
LW		 3144 rcop->op_first = scalar(repl);
3145 rcop->op_flags |= OPf_KIDS;
3146 rcop->op_private = 1;
11343788 3147 rcop->op_other = o;
748a9306
LW		 3148
3149 /* establish postfix order */
3150 rcop->op_next = LINKLIST(repl);
3151 repl->op_next = (OP*)rcop;
3152
3153 pm->op_pmreplroot = scalar((OP*)rcop);
3154 pm->op_pmreplstart = LINKLIST(rcop);
3155 rcop->op_next = 0;
79072805
LW		 3156 }
3157 }
3158
3159 return (OP*)pm;
3160}
3161
3162OP *
864dbfa3 3163Perl_newSVOP(pTHX_ I32 type, I32 flags, SV *sv)
79072805
LW		 3164{
3165 SVOP *svop;
b7dc083c 3166 NewOp(1101, svop, 1, SVOP);
79072805 3167 svop->op_type = type;
22c35a8c 3168 svop->op_ppaddr = PL_ppaddr[type];
79072805
LW		 3169 svop->op_sv = sv;
3170 svop->op_next = (OP*)svop;
3171 svop->op_flags = flags;
22c35a8c 3172 if (PL_opargs[type] & OA_RETSCALAR)
463ee0b2 3173 scalar((OP*)svop);
22c35a8c 3174 if (PL_opargs[type] & OA_TARGET)
ed6116ce 3175 svop->op_targ = pad_alloc(type, SVs_PADTMP);
e50aee73 3176 return CHECKOP(type, svop);
79072805
LW		 3177}
3178
3179OP *
350de78d
GS		 3180Perl_newPADOP(pTHX_ I32 type, I32 flags, SV *sv)
3181{
3182 PADOP *padop;
3183 NewOp(1101, padop, 1, PADOP);
3184 padop->op_type = type;
3185 padop->op_ppaddr = PL_ppaddr[type];
3186 padop->op_padix = pad_alloc(type, SVs_PADTMP);
7766f137 3187 SvREFCNT_dec(PL_curpad[padop->op_padix]);
350de78d 3188 PL_curpad[padop->op_padix] = sv;
7766f137 3189 SvPADTMP_on(sv);
350de78d
GS		 3190 padop->op_next = (OP*)padop;
3191 padop->op_flags = flags;
3192 if (PL_opargs[type] & OA_RETSCALAR)
3193 scalar((OP*)padop);
3194 if (PL_opargs[type] & OA_TARGET)
3195 padop->op_targ = pad_alloc(type, SVs_PADTMP);
3196 return CHECKOP(type, padop);
3197}
3198
3199OP *
864dbfa3 3200Perl_newGVOP(pTHX_ I32 type, I32 flags, GV *gv)
79072805 3201{
350de78d 3202#ifdef USE_ITHREADS
743e66e6 3203 GvIN_PAD_on(gv);
350de78d
GS		 3204 return newPADOP(type, flags, SvREFCNT_inc(gv));
3205#else
7934575e 3206 return newSVOP(type, flags, SvREFCNT_inc(gv));
350de78d 3207#endif
79072805
LW		 3208}
3209
3210OP *
864dbfa3 3211Perl_newPVOP(pTHX_ I32 type, I32 flags, char *pv)
79072805
LW		 3212{
3213 PVOP *pvop;
b7dc083c 3214 NewOp(1101, pvop, 1, PVOP);
79072805 3215 pvop->op_type = type;
22c35a8c 3216 pvop->op_ppaddr = PL_ppaddr[type];
79072805
LW		 3217 pvop->op_pv = pv;
3218 pvop->op_next = (OP*)pvop;
3219 pvop->op_flags = flags;
22c35a8c 3220 if (PL_opargs[type] & OA_RETSCALAR)
463ee0b2 3221 scalar((OP*)pvop);
22c35a8c 3222 if (PL_opargs[type] & OA_TARGET)
ed6116ce 3223 pvop->op_targ = pad_alloc(type, SVs_PADTMP);
e50aee73 3224 return CHECKOP(type, pvop);
79072805
LW		 3225}
3226
79072805 3227void
864dbfa3 3228Perl_package(pTHX_ OP *o)
79072805 3229{
93a17b20 3230 SV *sv;
79072805 3231
3280af22
NIS		 3232 save_hptr(&PL_curstash);
3233 save_item(PL_curstname);
11343788 3234 if (o) {
463ee0b2
LW		 3235 STRLEN len;
3236 char *name;
11343788 3237 sv = cSVOPo->op_sv;
463ee0b2 3238 name = SvPV(sv, len);
3280af22
NIS		 3239 PL_curstash = gv_stashpvn(name,len,TRUE);
3240 sv_setpvn(PL_curstname, name, len);
11343788 3241 op_free(o);
93a17b20
LW		 3242 }
3243 else {
f2c0fa37 3244 deprecate("\"package\" with no arguments");
3280af22
NIS		 3245 sv_setpv(PL_curstname,"<none>");
3246 PL_curstash = Nullhv;
93a17b20 3247 }
7ad382f4 3248 PL_hints |= HINT_BLOCK_SCOPE;
3280af22
NIS		 3249 PL_copline = NOLINE;
3250 PL_expect = XSTATE;
79072805
LW		 3251}
3252
85e6fe83 3253void
864dbfa3 3254Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *id, OP *arg)
85e6fe83 3255{
a0d0e21e 3256 OP *pack;
a0d0e21e 3257 OP *imop;
b1cb66bf 3258 OP *veop;
18fc9488 3259 char *packname = Nullch;
c4e33207 3260 STRLEN packlen = 0;
18fc9488 3261 SV *packsv;
85e6fe83 3262
a0d0e21e 3263 if (id->op_type != OP_CONST)
cea2e8a9 3264 Perl_croak(aTHX_ "Module name must be constant");
85e6fe83 3265
b1cb66bf 3266 veop = Nullop;
3267
0f79a09d 3268 if (version != Nullop) {
b1cb66bf 3269 SV *vesv = ((SVOP*)version)->op_sv;
3270
44dcb63b 3271 if (arg == Nullop && !SvNIOKp(vesv)) {
b1cb66bf 3272 arg = version;
3273 }
3274 else {
3275 OP *pack;
0f79a09d 3276 SV *meth;
b1cb66bf 3277
44dcb63b 3278 if (version->op_type != OP_CONST || !SvNIOKp(vesv))
cea2e8a9 3279 Perl_croak(aTHX_ "Version number must be constant number");
b1cb66bf 3280
3281 /* Make copy of id so we don't free it twice */
3282 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)id)->op_sv));
3283
3284 /* Fake up a method call to VERSION */
0f79a09d
GS		 3285 meth = newSVpvn("VERSION",7);
3286 sv_upgrade(meth, SVt_PVIV);
155aba94 3287 (void)SvIOK_on(meth);
0f79a09d 3288 PERL_HASH(SvUVX(meth), SvPVX(meth), SvCUR(meth));
b1cb66bf 3289 veop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
3290 append_elem(OP_LIST,
0f79a09d
GS		 3291 prepend_elem(OP_LIST, pack, list(version)),
3292 newSVOP(OP_METHOD_NAMED, 0, meth)));
b1cb66bf 3293 }
3294 }
aeea060c 3295
a0d0e21e 3296 /* Fake up an import/unimport */
4633a7c4
LW		 3297 if (arg && arg->op_type == OP_STUB)
3298 imop = arg; /* no import on explicit () */
44dcb63b 3299 else if (SvNIOKp(((SVOP*)id)->op_sv)) {
b1cb66bf 3300 imop = Nullop; /* use 5.0; */
3301 }
4633a7c4 3302 else {
0f79a09d
GS		 3303 SV *meth;
3304
4633a7c4
LW		 3305 /* Make copy of id so we don't free it twice */
3306 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)id)->op_sv));
0f79a09d
GS		 3307
3308 /* Fake up a method call to import/unimport */
3309 meth = aver ? newSVpvn("import",6) : newSVpvn("unimport", 8);;
ad4c42df 3310 (void)SvUPGRADE(meth, SVt_PVIV);
155aba94 3311 (void)SvIOK_on(meth);
0f79a09d 3312 PERL_HASH(SvUVX(meth), SvPVX(meth), SvCUR(meth));
4633a7c4 3313 imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
0f79a09d
GS		 3314 append_elem(OP_LIST,
3315 prepend_elem(OP_LIST, pack, list(arg)),
3316 newSVOP(OP_METHOD_NAMED, 0, meth)));
4633a7c4
LW		 3317 }
3318
d04f2e46
DM		 3319 if (ckWARN(WARN_MISC) &&
3320 imop && (imop != arg) && /* no warning on use 5.0; or explicit () */
3321 SvPOK(packsv = ((SVOP*)id)->op_sv))
3322 {
18fc9488
DM		 3323 /* BEGIN will free the ops, so we need to make a copy */
3324 packlen = SvCUR(packsv);
3325 packname = savepvn(SvPVX(packsv), packlen);
3326 }
3327
a0d0e21e 3328 /* Fake up the BEGIN {}, which does its thing immediately. */
09bef843 3329 newATTRSUB(floor,
79cb57f6 3330 newSVOP(OP_CONST, 0, newSVpvn("BEGIN", 5)),
4633a7c4 3331 Nullop,
09bef843 3332 Nullop,
a0d0e21e 3333 append_elem(OP_LINESEQ,
b1cb66bf 3334 append_elem(OP_LINESEQ,
ec4ab249 3335 newSTATEOP(0, Nullch, newUNOP(OP_REQUIRE, 0, id)),
b1cb66bf 3336 newSTATEOP(0, Nullch, veop)),
a0d0e21e 3337 newSTATEOP(0, Nullch, imop) ));
85e6fe83 3338
18fc9488
DM		 3339 if (packname) {
3340 if (ckWARN(WARN_MISC) && !gv_stashpvn(packname, packlen, FALSE)) {
3341 Perl_warner(aTHX_ WARN_MISC,
3342 "Package `%s' not found "
3343 "(did you use the incorrect case?)", packname);
3344 }
3345 safefree(packname);
3346 }
3347
c305c6a0 3348 PL_hints |= HINT_BLOCK_SCOPE;
3280af22
NIS		 3349 PL_copline = NOLINE;
3350 PL_expect = XSTATE;
85e6fe83
LW		 3351}
3352
7d3fb230
BS		 3353/*
3354=for apidoc load_module
3355
3356Loads the module whose name is pointed to by the string part of name.
3357Note that the actual module name, not its filename, should be given.
3358Eg, "Foo::Bar" instead of "Foo/Bar.pm". flags can be any of
3359PERL_LOADMOD_DENY, PERL_LOADMOD_NOIMPORT, or PERL_LOADMOD_IMPORT_OPS
3360(or 0 for no flags). ver, if specified, provides version semantics
3361similar to C<use Foo::Bar VERSION>. The optional trailing SV*
3362arguments can be used to specify arguments to the module's import()
3363method, similar to C<use Foo::Bar VERSION LIST>.
3364
3365=cut */
3366
e4783991
GS		 3367void
3368Perl_load_module(pTHX_ U32 flags, SV *name, SV *ver, ...)
3369{
3370 va_list args;
3371 va_start(args, ver);
3372 vload_module(flags, name, ver, &args);
3373 va_end(args);
3374}
3375
3376#ifdef PERL_IMPLICIT_CONTEXT
3377void
3378Perl_load_module_nocontext(U32 flags, SV *name, SV *ver, ...)
3379{
3380 dTHX;
3381 va_list args;
3382 va_start(args, ver);
3383 vload_module(flags, name, ver, &args);
3384 va_end(args);
3385}
3386#endif
3387
3388void
3389Perl_vload_module(pTHX_ U32 flags, SV *name, SV *ver, va_list *args)
3390{
3391 OP *modname, *veop, *imop;
3392
3393 modname = newSVOP(OP_CONST, 0, name);
3394 modname->op_private |= OPpCONST_BARE;
3395 if (ver) {
3396 veop = newSVOP(OP_CONST, 0, ver);
3397 }
3398 else
3399 veop = Nullop;
3400 if (flags & PERL_LOADMOD_NOIMPORT) {
3401 imop = sawparens(newNULLLIST());
3402 }
3403 else if (flags & PERL_LOADMOD_IMPORT_OPS) {
3404 imop = va_arg(*args, OP*);
3405 }
3406 else {
3407 SV *sv;
3408 imop = Nullop;
3409 sv = va_arg(*args, SV*);
3410 while (sv) {
3411 imop = append_elem(OP_LIST, imop, newSVOP(OP_CONST, 0, sv));
3412 sv = va_arg(*args, SV*);
3413 }
3414 }
81885997
GS		 3415 {
3416 line_t ocopline = PL_copline;
3417 int oexpect = PL_expect;
3418
3419 utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(FALSE, 0),
3420 veop, modname, imop);
3421 PL_expect = oexpect;
3422 PL_copline = ocopline;
3423 }
e4783991
GS		 3424}
3425
79072805 3426OP *
864dbfa3 3427Perl_dofile(pTHX_ OP *term)
78ca652e
GS		 3428{
3429 OP *doop;
3430 GV *gv;
3431
3432 gv = gv_fetchpv("do", FALSE, SVt_PVCV);
b9f751c0 3433 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv)))
78ca652e
GS		 3434 gv = gv_fetchpv("CORE::GLOBAL::do", FALSE, SVt_PVCV);
3435
b9f751c0 3436 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
78ca652e
GS		 3437 doop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
3438 append_elem(OP_LIST, term,
3439 scalar(newUNOP(OP_RV2CV, 0,
3440 newGVOP(OP_GV, 0,
3441 gv))))));
3442 }
3443 else {
3444 doop = newUNOP(OP_DOFILE, 0, scalar(term));
3445 }
3446 return doop;
3447}
3448
3449OP *
864dbfa3 3450Perl_newSLICEOP(pTHX_ I32 flags, OP *subscript, OP *listval)
79072805
LW		 3451{
3452 return newBINOP(OP_LSLICE, flags,
8990e307
LW		 3453 list(force_list(subscript)),
3454 list(force_list(listval)) );
79072805
LW		 3455}
3456
76e3520e 3457STATIC I32
cea2e8a9 3458S_list_assignment(pTHX_ register OP *o)
79072805 3459{
11343788 3460 if (!o)
79072805
LW		 3461 return TRUE;
3462
11343788
MB		 3463 if (o->op_type == OP_NULL && o->op_flags & OPf_KIDS)
3464 o = cUNOPo->op_first;
79072805 3465
11343788 3466 if (o->op_type == OP_COND_EXPR) {
1a67a97c
SM		 3467 I32 t = list_assignment(cLOGOPo->op_first->op_sibling);
3468 I32 f = list_assignment(cLOGOPo->op_first->op_sibling->op_sibling);
79072805
LW		 3469
3470 if (t && f)
3471 return TRUE;
3472 if (t || f)
3473 yyerror("Assignment to both a list and a scalar");
3474 return FALSE;
3475 }
3476
11343788
MB		 3477 if (o->op_type == OP_LIST || o->op_flags & OPf_PARENS ||
3478 o->op_type == OP_RV2AV || o->op_type == OP_RV2HV ||
3479 o->op_type == OP_ASLICE || o->op_type == OP_HSLICE)
79072805
LW		 3480 return TRUE;
3481
11343788 3482 if (o->op_type == OP_PADAV || o->op_type == OP_PADHV)
93a17b20
LW		 3483 return TRUE;
3484
11343788 3485 if (o->op_type == OP_RV2SV)
79072805
LW		 3486 return FALSE;
3487
3488 return FALSE;
3489}
3490
3491OP *
864dbfa3 3492Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right)
79072805 3493{
11343788 3494 OP *o;
79072805 3495
a0d0e21e
LW		 3496 if (optype) {
3497 if (optype == OP_ANDASSIGN || optype == OP_ORASSIGN) {
3498 return newLOGOP(optype, 0,
3499 mod(scalar(left), optype),
3500 newUNOP(OP_SASSIGN, 0, scalar(right)));
3501 }
3502 else {
3503 return newBINOP(optype, OPf_STACKED,
3504 mod(scalar(left), optype), scalar(right));
3505 }
3506 }
3507
79072805 3508 if (list_assignment(left)) {
10c8fecd
GS		 3509 OP *curop;
3510
3280af22
NIS		 3511 PL_modcount = 0;
3512 PL_eval_start = right; /* Grandfathering $[ assignment here. Bletch.*/
463ee0b2 3513 left = mod(left, OP_AASSIGN);
3280af22
NIS		 3514 if (PL_eval_start)
3515 PL_eval_start = 0;
748a9306 3516 else {
a0d0e21e
LW		 3517 op_free(left);
3518 op_free(right);