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