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