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