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