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