This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
https://perl5.git.perl.org / perl5.git / blame
? search:
summary | shortlog | log | commit | commitdiff | tree
blob | blame (incremental) | history | HEAD
Integrate mainline.
[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 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 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 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 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 287 I32 depth;
288 AV *oldpad;
289 SV *oldsv;
290
291 depth = CvDEPTH(cv);
292 if (!depth) {
9607fc9c 293 if (newoff) {
294 if (SvFAKE(sv))
295 continue;
4fdae800 296 return 0; /* don't clone from inactive stack frame */
9607fc9c 297 }
5f05dabc 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 309 oldsv = Nullsv; /* no need to keep ref */
310 }
311 else {
28757baa 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 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 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 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 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 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 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 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 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 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 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 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 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 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 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 1715{
1716 switch (type) {
1717 case OP_SASSIGN:
5196be3e 1718 if (o->op_type == OP_RV2GV)
3fe9a6f1 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 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 2072 }
2073
de4bf5b3
MG		 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
MG		 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 2712 U8* tsave = from_utf ? NULL : trlist_upgrade(&t, &tend);
45005bfb 2713 U8* rsave = (to_utf || !rlen) ? 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;
9b877dbb 2835 if (!grows)
45005bfb
JH		 2836 grows = (tfirst < rfirst &&
2837 UNISKIP(tfirst) < UNISKIP(rfirst + diff));
2838 rfirst += diff + 1;
a0ed51b3
LW		 2839 }
2840 tfirst += diff + 1;
2841 }
2842
2843 none = ++max;
2844 if (del)
2845 del = ++max;
2846
2847 if (max > 0xffff)
2848 bits = 32;
2849 else if (max > 0xff)
2850 bits = 16;
2851 else
2852 bits = 8;
2853
455d824a 2854 Safefree(cPVOPo->op_pv);
a0ed51b3
LW		 2855 cSVOPo->op_sv = (SV*)swash_init("utf8", "", listsv, bits, none);
2856 SvREFCNT_dec(listsv);
2857 if (transv)
2858 SvREFCNT_dec(transv);
2859
45005bfb 2860 if (!del && havefinal && rlen)
b448e4fe
JH		 2861 (void)hv_store((HV*)SvRV((cSVOPo->op_sv)), "FINAL", 5,
2862 newSVuv((UV)final), 0);
a0ed51b3 2863
9b877dbb 2864 if (grows)
a0ed51b3
LW		 2865 o->op_private |= OPpTRANS_GROWS;
2866
9b877dbb
IH		 2867 if (tsave)
2868 Safefree(tsave);
2869 if (rsave)
2870 Safefree(rsave);
2871
a0ed51b3
LW		 2872 op_free(expr);
2873 op_free(repl);
2874 return o;
2875 }
2876
2877 tbl = (short*)cPVOPo->op_pv;
79072805
LW		 2878 if (complement) {
2879 Zero(tbl, 256, short);
2880 for (i = 0; i < tlen; i++)
ec49126f 2881 tbl[t[i]] = -1;
79072805
LW		 2882 for (i = 0, j = 0; i < 256; i++) {
2883 if (!tbl[i]) {
2884 if (j >= rlen) {
a0ed51b3 2885 if (del)
79072805
LW		 2886 tbl[i] = -2;
2887 else if (rlen)
ec49126f 2888 tbl[i] = r[j-1];
79072805
LW		 2889 else
2890 tbl[i] = i;
2891 }
9b877dbb
IH		 2892 else {
2893 if (i < 128 && r[j] >= 128)
2894 grows = 1;
ec49126f 2895 tbl[i] = r[j++];
9b877dbb 2896 }
79072805
LW		 2897 }
2898 }
05d340b8
JH		 2899 if (!del) {
2900 if (!rlen) {
2901 j = rlen;
2902 if (!squash)
2903 o->op_private |= OPpTRANS_IDENTICAL;
2904 }
2905 else if (j >= rlen)
2906 j = rlen - 1;
2907 else
2908 cPVOPo->op_pv = (char*)Renew(tbl, 0x101+rlen-j, short);
8973db79
JH		 2909 tbl[0x100] = rlen - j;
2910 for (i=0; i < rlen - j; i++)
2911 tbl[0x101+i] = r[j+i];
2912 }
79072805
LW		 2913 }
2914 else {
a0ed51b3 2915 if (!rlen && !del) {
79072805 2916 r = t; rlen = tlen;
5d06d08e 2917 if (!squash)
4757a243 2918 o->op_private |= OPpTRANS_IDENTICAL;
79072805
LW		 2919 }
2920 for (i = 0; i < 256; i++)
2921 tbl[i] = -1;
2922 for (i = 0, j = 0; i < tlen; i++,j++) {
2923 if (j >= rlen) {
a0ed51b3 2924 if (del) {
ec49126f 2925 if (tbl[t[i]] == -1)
2926 tbl[t[i]] = -2;
79072805
LW		 2927 continue;
2928 }
2929 --j;
2930 }
9b877dbb
IH		 2931 if (tbl[t[i]] == -1) {
2932 if (t[i] < 128 && r[j] >= 128)
2933 grows = 1;
ec49126f 2934 tbl[t[i]] = r[j];
9b877dbb 2935 }
79072805
LW		 2936 }
2937 }
9b877dbb
IH		 2938 if (grows)
2939 o->op_private |= OPpTRANS_GROWS;
79072805
LW		 2940 op_free(expr);
2941 op_free(repl);
2942
11343788 2943 return o;
79072805
LW		 2944}
2945
2946OP *
864dbfa3 2947Perl_newPMOP(pTHX_ I32 type, I32 flags)
79072805
LW		 2948{
2949 PMOP *pmop;
2950
b7dc083c 2951 NewOp(1101, pmop, 1, PMOP);
79072805 2952 pmop->op_type = type;
22c35a8c 2953 pmop->op_ppaddr = PL_ppaddr[type];
79072805 2954 pmop->op_flags = flags;
c07a80fd 2955 pmop->op_private = 0 | (flags >> 8);
79072805 2956
3280af22 2957 if (PL_hints & HINT_RE_TAINT)
b3eb6a9b 2958 pmop->op_pmpermflags |= PMf_RETAINT;
3280af22 2959 if (PL_hints & HINT_LOCALE)
b3eb6a9b
GS		 2960 pmop->op_pmpermflags |= PMf_LOCALE;
2961 pmop->op_pmflags = pmop->op_pmpermflags;
36477c24 2962
79072805 2963 /* link into pm list */
3280af22
NIS		 2964 if (type != OP_TRANS && PL_curstash) {
2965 pmop->op_pmnext = HvPMROOT(PL_curstash);
2966 HvPMROOT(PL_curstash) = pmop;
cb55de95 2967 PmopSTASH_set(pmop,PL_curstash);
79072805
LW		 2968 }
2969
2970 return (OP*)pmop;
2971}
2972
2973OP *
864dbfa3 2974Perl_pmruntime(pTHX_ OP *o, OP *expr, OP *repl)
79072805
LW		 2975{
2976 PMOP *pm;
2977 LOGOP *rcop;
ce862d02 2978 I32 repl_has_vars = 0;
79072805 2979
11343788
MB		 2980 if (o->op_type == OP_TRANS)
2981 return pmtrans(o, expr, repl);
79072805 2982
3280af22 2983 PL_hints |= HINT_BLOCK_SCOPE;
11343788 2984 pm = (PMOP*)o;
79072805
LW		 2985
2986 if (expr->op_type == OP_CONST) {
463ee0b2 2987 STRLEN plen;
79072805 2988 SV *pat = ((SVOP*)expr)->op_sv;
463ee0b2 2989 char *p = SvPV(pat, plen);
11343788 2990 if ((o->op_flags & OPf_SPECIAL) && strEQ(p, " ")) {
93a17b20 2991 sv_setpvn(pat, "\\s+", 3);
463ee0b2 2992 p = SvPV(pat, plen);
79072805
LW		 2993 pm->op_pmflags |= PMf_SKIPWHITE;
2994 }
1fd7b382 2995 if ((PL_hints & HINT_UTF8) || DO_UTF8(pat))
7e2040f0 2996 pm->op_pmdynflags |= PMdf_UTF8;
cea2e8a9 2997 pm->op_pmregexp = CALLREGCOMP(aTHX_ p, p + plen, pm);
aeea060c 2998 if (strEQ("\\s+", pm->op_pmregexp->precomp))
85e6fe83 2999 pm->op_pmflags |= PMf_WHITE;
79072805
LW		 3000 op_free(expr);
3001 }
3002 else {
393fec97
GS		 3003 if (PL_hints & HINT_UTF8)
3004 pm->op_pmdynflags |= PMdf_UTF8;
3280af22 3005 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL))
1c846c1f 3006 expr = newUNOP((!(PL_hints & HINT_RE_EVAL)
2cd61cdb
IZ		 3007 ? OP_REGCRESET
3008 : OP_REGCMAYBE),0,expr);
463ee0b2 3009
b7dc083c 3010 NewOp(1101, rcop, 1, LOGOP);
79072805 3011 rcop->op_type = OP_REGCOMP;
22c35a8c 3012 rcop->op_ppaddr = PL_ppaddr[OP_REGCOMP];
79072805 3013 rcop->op_first = scalar(expr);
1c846c1f 3014 rcop->op_flags |= ((PL_hints & HINT_RE_EVAL)
2cd61cdb
IZ		 3015 ? (OPf_SPECIAL | OPf_KIDS)
3016 : OPf_KIDS);
79072805 3017 rcop->op_private = 1;
11343788 3018 rcop->op_other = o;
79072805
LW		 3019
3020 /* establish postfix order */
3280af22 3021 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL)) {
463ee0b2
LW		 3022 LINKLIST(expr);
3023 rcop->op_next = expr;
3024 ((UNOP*)expr)->op_first->op_next = (OP*)rcop;
3025 }
3026 else {
3027 rcop->op_next = LINKLIST(expr);
3028 expr->op_next = (OP*)rcop;
3029 }
79072805 3030
11343788 3031 prepend_elem(o->op_type, scalar((OP*)rcop), o);
79072805
LW		 3032 }
3033
3034 if (repl) {
748a9306 3035 OP *curop;
0244c3a4 3036 if (pm->op_pmflags & PMf_EVAL) {
748a9306 3037 curop = 0;
57843af0
GS		 3038 if (CopLINE(PL_curcop) < PL_multi_end)
3039 CopLINE_set(PL_curcop, PL_multi_end);
0244c3a4 3040 }
554b3eca 3041#ifdef USE_THREADS
2faa37cc 3042 else if (repl->op_type == OP_THREADSV
554b3eca 3043 && strchr("&`'123456789+",
533c011a 3044 PL_threadsv_names[repl->op_targ]))
554b3eca
MB		 3045 {
3046 curop = 0;
3047 }
3048#endif /* USE_THREADS */
748a9306
LW		 3049 else if (repl->op_type == OP_CONST)
3050 curop = repl;
79072805 3051 else {
79072805
LW		 3052 OP *lastop = 0;
3053 for (curop = LINKLIST(repl); curop!=repl; curop = LINKLIST(curop)) {
22c35a8c 3054 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
554b3eca 3055#ifdef USE_THREADS
ce862d02
IZ		 3056 if (curop->op_type == OP_THREADSV) {
3057 repl_has_vars = 1;
be949f6f 3058 if (strchr("&`'123456789+", curop->op_private))
ce862d02 3059 break;
554b3eca
MB		 3060 }
3061#else
79072805 3062 if (curop->op_type == OP_GV) {
638eceb6 3063 GV *gv = cGVOPx_gv(curop);
ce862d02 3064 repl_has_vars = 1;
93a17b20 3065 if (strchr("&`'123456789+", *GvENAME(gv)))
79072805
LW		 3066 break;
3067 }
554b3eca 3068#endif /* USE_THREADS */
79072805
LW		 3069 else if (curop->op_type == OP_RV2CV)
3070 break;
3071 else if (curop->op_type == OP_RV2SV ||
3072 curop->op_type == OP_RV2AV ||
3073 curop->op_type == OP_RV2HV ||
3074 curop->op_type == OP_RV2GV) {
3075 if (lastop && lastop->op_type != OP_GV) /*funny deref?*/
3076 break;
3077 }
748a9306
LW		 3078 else if (curop->op_type == OP_PADSV ||
3079 curop->op_type == OP_PADAV ||
3080 curop->op_type == OP_PADHV ||
554b3eca 3081 curop->op_type == OP_PADANY) {
ce862d02 3082 repl_has_vars = 1;
748a9306 3083 }
1167e5da
SM		 3084 else if (curop->op_type == OP_PUSHRE)
3085 ; /* Okay here, dangerous in newASSIGNOP */
79072805
LW		 3086 else
3087 break;
3088 }
3089 lastop = curop;
3090 }
748a9306 3091 }
ce862d02 3092 if (curop == repl
1c846c1f
NIS		 3093 && !(repl_has_vars
3094 && (!pm->op_pmregexp
ce862d02 3095 || pm->op_pmregexp->reganch & ROPT_EVAL_SEEN))) {
748a9306 3096 pm->op_pmflags |= PMf_CONST; /* const for long enough */
4633a7c4 3097 pm->op_pmpermflags |= PMf_CONST; /* const for long enough */
11343788 3098 prepend_elem(o->op_type, scalar(repl), o);
748a9306
LW		 3099 }
3100 else {
ce862d02
IZ		 3101 if (curop == repl && !pm->op_pmregexp) { /* Has variables. */
3102 pm->op_pmflags |= PMf_MAYBE_CONST;
3103 pm->op_pmpermflags |= PMf_MAYBE_CONST;
3104 }
b7dc083c 3105 NewOp(1101, rcop, 1, LOGOP);
748a9306 3106 rcop->op_type = OP_SUBSTCONT;
22c35a8c 3107 rcop->op_ppaddr = PL_ppaddr[OP_SUBSTCONT];
748a9306
LW		 3108 rcop->op_first = scalar(repl);
3109 rcop->op_flags |= OPf_KIDS;
3110 rcop->op_private = 1;
11343788 3111 rcop->op_other = o;
748a9306
LW		 3112
3113 /* establish postfix order */
3114 rcop->op_next = LINKLIST(repl);
3115 repl->op_next = (OP*)rcop;
3116
3117 pm->op_pmreplroot = scalar((OP*)rcop);
3118 pm->op_pmreplstart = LINKLIST(rcop);
3119 rcop->op_next = 0;
79072805
LW		 3120 }
3121 }
3122
3123 return (OP*)pm;
3124}
3125
3126OP *
864dbfa3 3127Perl_newSVOP(pTHX_ I32 type, I32 flags, SV *sv)
79072805
LW		 3128{
3129 SVOP *svop;
b7dc083c 3130 NewOp(1101, svop, 1, SVOP);
79072805 3131 svop->op_type = type;
22c35a8c 3132 svop->op_ppaddr = PL_ppaddr[type];
79072805
LW		 3133 svop->op_sv = sv;
3134 svop->op_next = (OP*)svop;
3135 svop->op_flags = flags;
22c35a8c 3136 if (PL_opargs[type] & OA_RETSCALAR)
463ee0b2 3137 scalar((OP*)svop);
22c35a8c 3138 if (PL_opargs[type] & OA_TARGET)
ed6116ce 3139 svop->op_targ = pad_alloc(type, SVs_PADTMP);
e50aee73 3140 return CHECKOP(type, svop);
79072805
LW		 3141}
3142
3143OP *
350de78d
GS		 3144Perl_newPADOP(pTHX_ I32 type, I32 flags, SV *sv)
3145{
3146 PADOP *padop;
3147 NewOp(1101, padop, 1, PADOP);
3148 padop->op_type = type;
3149 padop->op_ppaddr = PL_ppaddr[type];
3150 padop->op_padix = pad_alloc(type, SVs_PADTMP);
7766f137 3151 SvREFCNT_dec(PL_curpad[padop->op_padix]);
350de78d 3152 PL_curpad[padop->op_padix] = sv;
7766f137 3153 SvPADTMP_on(sv);
350de78d
GS		 3154 padop->op_next = (OP*)padop;
3155 padop->op_flags = flags;
3156 if (PL_opargs[type] & OA_RETSCALAR)
3157 scalar((OP*)padop);
3158 if (PL_opargs[type] & OA_TARGET)
3159 padop->op_targ = pad_alloc(type, SVs_PADTMP);
3160 return CHECKOP(type, padop);
3161}
3162
3163OP *
864dbfa3 3164Perl_newGVOP(pTHX_ I32 type, I32 flags, GV *gv)
79072805 3165{
350de78d 3166#ifdef USE_ITHREADS
743e66e6 3167 GvIN_PAD_on(gv);
350de78d
GS		 3168 return newPADOP(type, flags, SvREFCNT_inc(gv));
3169#else
7934575e 3170 return newSVOP(type, flags, SvREFCNT_inc(gv));
350de78d 3171#endif
79072805
LW		 3172}
3173
3174OP *
864dbfa3 3175Perl_newPVOP(pTHX_ I32 type, I32 flags, char *pv)
79072805
LW		 3176{
3177 PVOP *pvop;
b7dc083c 3178 NewOp(1101, pvop, 1, PVOP);
79072805 3179 pvop->op_type = type;
22c35a8c 3180 pvop->op_ppaddr = PL_ppaddr[type];
79072805
LW		 3181 pvop->op_pv = pv;
3182 pvop->op_next = (OP*)pvop;
3183 pvop->op_flags = flags;
22c35a8c 3184 if (PL_opargs[type] & OA_RETSCALAR)
463ee0b2 3185 scalar((OP*)pvop);
22c35a8c 3186 if (PL_opargs[type] & OA_TARGET)
ed6116ce 3187 pvop->op_targ = pad_alloc(type, SVs_PADTMP);
e50aee73 3188 return CHECKOP(type, pvop);
79072805
LW		 3189}
3190
79072805 3191void
864dbfa3 3192Perl_package(pTHX_ OP *o)
79072805 3193{
93a17b20 3194 SV *sv;
79072805 3195
3280af22
NIS		 3196 save_hptr(&PL_curstash);
3197 save_item(PL_curstname);
11343788 3198 if (o) {
463ee0b2
LW		 3199 STRLEN len;
3200 char *name;
11343788 3201 sv = cSVOPo->op_sv;
463ee0b2 3202 name = SvPV(sv, len);
3280af22
NIS		 3203 PL_curstash = gv_stashpvn(name,len,TRUE);
3204 sv_setpvn(PL_curstname, name, len);
11343788 3205 op_free(o);
93a17b20
LW		 3206 }
3207 else {
3280af22
NIS		 3208 sv_setpv(PL_curstname,"<none>");
3209 PL_curstash = Nullhv;
93a17b20 3210 }
7ad382f4 3211 PL_hints |= HINT_BLOCK_SCOPE;
3280af22
NIS		 3212 PL_copline = NOLINE;
3213 PL_expect = XSTATE;
79072805
LW		 3214}
3215
85e6fe83 3216void
864dbfa3 3217Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *id, OP *arg)
85e6fe83 3218{
a0d0e21e 3219 OP *pack;
a0d0e21e
LW		 3220 OP *rqop;
3221 OP *imop;
b1cb66bf 3222 OP *veop;
78ca652e 3223 GV *gv;
85e6fe83 3224
a0d0e21e 3225 if (id->op_type != OP_CONST)
cea2e8a9 3226 Perl_croak(aTHX_ "Module name must be constant");
85e6fe83 3227
b1cb66bf 3228 veop = Nullop;
3229
0f79a09d 3230 if (version != Nullop) {
b1cb66bf 3231 SV *vesv = ((SVOP*)version)->op_sv;
3232
44dcb63b 3233 if (arg == Nullop && !SvNIOKp(vesv)) {
b1cb66bf 3234 arg = version;
3235 }
3236 else {
3237 OP *pack;
0f79a09d 3238 SV *meth;
b1cb66bf 3239
44dcb63b 3240 if (version->op_type != OP_CONST || !SvNIOKp(vesv))
cea2e8a9 3241 Perl_croak(aTHX_ "Version number must be constant number");
b1cb66bf 3242
3243 /* Make copy of id so we don't free it twice */
3244 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)id)->op_sv));
3245
3246 /* Fake up a method call to VERSION */
0f79a09d
GS		 3247 meth = newSVpvn("VERSION",7);
3248 sv_upgrade(meth, SVt_PVIV);
155aba94 3249 (void)SvIOK_on(meth);
0f79a09d 3250 PERL_HASH(SvUVX(meth), SvPVX(meth), SvCUR(meth));
b1cb66bf 3251 veop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
3252 append_elem(OP_LIST,
0f79a09d
GS		 3253 prepend_elem(OP_LIST, pack, list(version)),
3254 newSVOP(OP_METHOD_NAMED, 0, meth)));
b1cb66bf 3255 }
3256 }
aeea060c 3257
a0d0e21e 3258 /* Fake up an import/unimport */
4633a7c4
LW		 3259 if (arg && arg->op_type == OP_STUB)
3260 imop = arg; /* no import on explicit () */
44dcb63b 3261 else if (SvNIOKp(((SVOP*)id)->op_sv)) {
b1cb66bf 3262 imop = Nullop; /* use 5.0; */
3263 }
4633a7c4 3264 else {
0f79a09d
GS		 3265 SV *meth;
3266
4633a7c4
LW		 3267 /* Make copy of id so we don't free it twice */
3268 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)id)->op_sv));
0f79a09d
GS		 3269
3270 /* Fake up a method call to import/unimport */
3271 meth = aver ? newSVpvn("import",6) : newSVpvn("unimport", 8);;
3272 sv_upgrade(meth, SVt_PVIV);
155aba94 3273 (void)SvIOK_on(meth);
0f79a09d 3274 PERL_HASH(SvUVX(meth), SvPVX(meth), SvCUR(meth));
4633a7c4 3275 imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
0f79a09d
GS		 3276 append_elem(OP_LIST,
3277 prepend_elem(OP_LIST, pack, list(arg)),
3278 newSVOP(OP_METHOD_NAMED, 0, meth)));
4633a7c4
LW		 3279 }
3280
78ca652e
GS		 3281 /* Fake up a require, handle override, if any */
3282 gv = gv_fetchpv("require", FALSE, SVt_PVCV);
3283 if (!(gv && GvIMPORTED_CV(gv)))
3284 gv = gv_fetchpv("CORE::GLOBAL::require", FALSE, SVt_PVCV);
3285
3286 if (gv && GvIMPORTED_CV(gv)) {
3287 rqop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
3288 append_elem(OP_LIST, id,
3289 scalar(newUNOP(OP_RV2CV, 0,
3290 newGVOP(OP_GV, 0,
3291 gv))))));
3292 }
3293 else {
3294 rqop = newUNOP(OP_REQUIRE, 0, id);
3295 }
a0d0e21e
LW		 3296
3297 /* Fake up the BEGIN {}, which does its thing immediately. */
09bef843 3298 newATTRSUB(floor,
79cb57f6 3299 newSVOP(OP_CONST, 0, newSVpvn("BEGIN", 5)),
4633a7c4 3300 Nullop,
09bef843 3301 Nullop,
a0d0e21e 3302 append_elem(OP_LINESEQ,
b1cb66bf 3303 append_elem(OP_LINESEQ,
3304 newSTATEOP(0, Nullch, rqop),
3305 newSTATEOP(0, Nullch, veop)),
a0d0e21e 3306 newSTATEOP(0, Nullch, imop) ));
85e6fe83 3307
c305c6a0 3308 PL_hints |= HINT_BLOCK_SCOPE;
3280af22
NIS		 3309 PL_copline = NOLINE;
3310 PL_expect = XSTATE;
85e6fe83
LW		 3311}
3312
e4783991
GS		 3313void
3314Perl_load_module(pTHX_ U32 flags, SV *name, SV *ver, ...)
3315{
3316 va_list args;
3317 va_start(args, ver);
3318 vload_module(flags, name, ver, &args);
3319 va_end(args);
3320}
3321
3322#ifdef PERL_IMPLICIT_CONTEXT
3323void
3324Perl_load_module_nocontext(U32 flags, SV *name, SV *ver, ...)
3325{
3326 dTHX;
3327 va_list args;
3328 va_start(args, ver);
3329 vload_module(flags, name, ver, &args);
3330 va_end(args);
3331}
3332#endif
3333
3334void
3335Perl_vload_module(pTHX_ U32 flags, SV *name, SV *ver, va_list *args)
3336{
3337 OP *modname, *veop, *imop;
3338
3339 modname = newSVOP(OP_CONST, 0, name);
3340 modname->op_private |= OPpCONST_BARE;
3341 if (ver) {
3342 veop = newSVOP(OP_CONST, 0, ver);
3343 }
3344 else
3345 veop = Nullop;
3346 if (flags & PERL_LOADMOD_NOIMPORT) {
3347 imop = sawparens(newNULLLIST());
3348 }
3349 else if (flags & PERL_LOADMOD_IMPORT_OPS) {
3350 imop = va_arg(*args, OP*);
3351 }
3352 else {
3353 SV *sv;
3354 imop = Nullop;
3355 sv = va_arg(*args, SV*);
3356 while (sv) {
3357 imop = append_elem(OP_LIST, imop, newSVOP(OP_CONST, 0, sv));
3358 sv = va_arg(*args, SV*);
3359 }
3360 }
81885997
GS		 3361 {
3362 line_t ocopline = PL_copline;
3363 int oexpect = PL_expect;
3364
3365 utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(FALSE, 0),
3366 veop, modname, imop);
3367 PL_expect = oexpect;
3368 PL_copline = ocopline;
3369 }
e4783991
GS		 3370}
3371
79072805 3372OP *
864dbfa3 3373Perl_dofile(pTHX_ OP *term)
78ca652e
GS		 3374{
3375 OP *doop;
3376 GV *gv;
3377
3378 gv = gv_fetchpv("do", FALSE, SVt_PVCV);
3379 if (!(gv && GvIMPORTED_CV(gv)))
3380 gv = gv_fetchpv("CORE::GLOBAL::do", FALSE, SVt_PVCV);
3381
3382 if (gv && GvIMPORTED_CV(gv)) {
3383 doop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
3384 append_elem(OP_LIST, term,
3385 scalar(newUNOP(OP_RV2CV, 0,
3386 newGVOP(OP_GV, 0,
3387 gv))))));
3388 }
3389 else {
3390 doop = newUNOP(OP_DOFILE, 0, scalar(term));
3391 }
3392 return doop;
3393}
3394
3395OP *
864dbfa3 3396Perl_newSLICEOP(pTHX_ I32 flags, OP *subscript, OP *listval)
79072805
LW		 3397{
3398 return newBINOP(OP_LSLICE, flags,
8990e307
LW		 3399 list(force_list(subscript)),
3400 list(force_list(listval)) );
79072805
LW		 3401}
3402
76e3520e 3403STATIC I32
cea2e8a9 3404S_list_assignment(pTHX_ register OP *o)
79072805 3405{
11343788 3406 if (!o)
79072805
LW		 3407 return TRUE;
3408
11343788
MB		 3409 if (o->op_type == OP_NULL && o->op_flags & OPf_KIDS)
3410 o = cUNOPo->op_first;
79072805 3411
11343788 3412 if (o->op_type == OP_COND_EXPR) {
1a67a97c
SM		 3413 I32 t = list_assignment(cLOGOPo->op_first->op_sibling);
3414 I32 f = list_assignment(cLOGOPo->op_first->op_sibling->op_sibling);
79072805
LW		 3415
3416 if (t && f)
3417 return TRUE;
3418 if (t || f)
3419 yyerror("Assignment to both a list and a scalar");
3420 return FALSE;
3421 }
3422
11343788
MB		 3423 if (o->op_type == OP_LIST || o->op_flags & OPf_PARENS ||
3424 o->op_type == OP_RV2AV || o->op_type == OP_RV2HV ||
3425 o->op_type == OP_ASLICE || o->op_type == OP_HSLICE)
79072805
LW		 3426 return TRUE;
3427
11343788 3428 if (o->op_type == OP_PADAV || o->op_type == OP_PADHV)
93a17b20
LW		 3429 return TRUE;
3430
11343788 3431 if (o->op_type == OP_RV2SV)
79072805
LW		 3432 return FALSE;
3433
3434 return FALSE;
3435}
3436
3437OP *
864dbfa3 3438Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right)
79072805 3439{
11343788 3440 OP *o;
79072805 3441
a0d0e21e
LW		 3442 if (optype) {
3443 if (optype == OP_ANDASSIGN || optype == OP_ORASSIGN) {
3444 return newLOGOP(optype, 0,
3445 mod(scalar(left), optype),
3446 newUNOP(OP_SASSIGN, 0, scalar(right)));
3447 }
3448 else {
3449 return newBINOP(optype, OPf_STACKED,
3450 mod(scalar(left), optype), scalar(right));
3451 }
3452 }
3453
79072805 3454 if (list_assignment(left)) {
10c8fecd
GS		 3455 OP *curop;
3456
3280af22
NIS		 3457 PL_modcount = 0;
3458 PL_eval_start = right; /* Grandfathering $[ assignment here. Bletch.*/
463ee0b2 3459 left = mod(left, OP_AASSIGN);
3280af22
NIS		 3460 if (PL_eval_start)
3461 PL_eval_start = 0;
748a9306 3462 else {
a0d0e21e
LW		 3463 op_free(left);
3464 op_free(right);
3465 return Nullop;
3466 }
10c8fecd
GS		 3467 curop = list(force_list(left));
3468 o = newBINOP(OP_AASSIGN, flags, list(force_list(right)), curop);
11343788 3469 o->op_private = 0 | (flags >> 8);
10c8fecd
GS		 3470 for (curop = ((LISTOP*)curop)->op_first;
3471 curop; curop = curop->op_sibling)
3472 {
3473 if (curop->op_type == OP_RV2HV &&
3474 ((UNOP*)curop)->op_first->op_type != OP_GV) {
3475 o->op_private |= OPpASSIGN_HASH;
3476 break;
3477 }
3478 }
a0d0e21e 3479 if (!(left->op_private & OPpLVAL_INTRO)) {
11343788 3480 OP *lastop = o;
3280af22 3481 PL_generation++;
11343788 3482 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
22c35a8c 3483 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
79072805 3484 if (curop->op_type == OP_GV) {
638eceb6 3485 GV *gv = cGVOPx_gv(curop);
3280af22 3486 if (gv == PL_defgv || SvCUR(gv) == PL_generation)
79072805 3487 break;
3280af22 3488 SvCUR(gv) = PL_generation;
79072805 3489 }
748a9306
LW		 3490 else if (curop->op_type == OP_PADSV ||
3491 curop->op_type == OP_PADAV ||
3492 curop->op_type == OP_PADHV ||
3493 curop->op_type == OP_PADANY) {
3280af22 3494 SV **svp = AvARRAY(PL_comppad_name);
8e07c86e 3495 SV *sv = svp[curop->op_targ];
3280af22 3496 if (SvCUR(sv) == PL_generation)
748a9306 3497 break;
3280af22 3498 SvCUR(sv) = PL_generation; /* (SvCUR not used any more) */
748a9306 3499 }
79072805
LW		 3500 else if (curop->op_type == OP_RV2CV)
3501 break;
3502 else if (curop->op_type == OP_RV2SV ||
3503 curop->op_type == OP_RV2AV ||
3504 curop->op_type == OP_RV2HV ||
3505 curop->op_type == OP_RV2GV) {
3506 if (lastop->op_type != OP_GV) /* funny deref? */
3507 break;
3508 }
1167e5da
SM		 3509 else if (curop->op_type == OP_PUSHRE) {
3510 if (((PMOP*)curop)->op_pmreplroot) {
b3f5893f
GS		 3511#ifdef USE_ITHREADS
3512 GV *gv = (GV*)PL_curpad[(PADOFFSET)((PMOP*)curop)->op_pmreplroot];
3513#else
1167e5da 3514 GV *gv = (GV*)((PMOP*)curop)->op_pmreplroot;
b3f5893f 3515#endif
3280af22 3516 if (gv == PL_defgv || SvCUR(gv) == PL_generation)
1167e5da 3517 break;
3280af22 3518 SvCUR(gv) = PL_generation;
1167e5da
SM		 3519 }
3520 }
79072805
LW		 3521 else
3522 break;
3523 }
3524 lastop = curop;
3525 }
11343788 3526 if (curop != o)
10c8fecd 3527 o->op_private |= OPpASSIGN_COMMON;
79072805 3528 }
c07a80fd 3529 if (right && right->op_type == OP_SPLIT) {
3530 OP* tmpop;
3531 if ((tmpop = ((LISTOP*)right)->op_first) &&
3532 tmpop->op_type == OP_PUSHRE)
3533 {
3534 PMOP *pm = (PMOP*)tmpop;
3535 if (left->op_type == OP_RV2AV &&
3536 !(left->op_private & OPpLVAL_INTRO) &&
11343788 3537 !(o->op_private & OPpASSIGN_COMMON) )
c07a80fd 3538 {
3539 tmpop = ((UNOP*)left)->op_first;
3540 if (tmpop->op_type == OP_GV && !pm->op_pmreplroot) {
971a9dd3
GS		 3541#ifdef USE_ITHREADS
3542 pm->op_pmreplroot = (OP*)cPADOPx(tmpop)->op_padix;
3543 cPADOPx(tmpop)->op_padix = 0; /* steal it */
3544#else
3545 pm->op_pmreplroot = (OP*)cSVOPx(tmpop)->op_sv;
3546 cSVOPx(tmpop)->op_sv = Nullsv; /* steal it */
3547#endif
c07a80fd 3548 pm->op_pmflags |= PMf_ONCE;
11343788 3549 tmpop = cUNOPo->op_first; /* to list (nulled) */
c07a80fd 3550 tmpop = ((UNOP*)tmpop)->op_first; /* to pushmark */
3551 tmpop->op_sibling = Nullop; /* don't free split */
3552 right->op_next = tmpop->op_next; /* fix starting loc */
11343788 3553 op_free(o); /* blow off assign */
54310121 3554 right->op_flags &= ~OPf_WANT;
a5f75d66 3555 /* "I don't know and I don't care." */
c07a80fd 3556 return right;
3557 }