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