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