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