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