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