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
Four Storable patches towards Storable 2.11 :
[perl5.git] / op.c
CommitLineData
a0d0e21e 1/* op.c
79072805 2 *
4bb101f2
JH		 3 * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
4 * 2000, 2001, 2002, 2003, by Larry Wall and others
79072805
LW		 5 *
6 * You may distribute under the terms of either the GNU General Public
7 * License or the Artistic License, as specified in the README file.
8 *
a0d0e21e
LW		 9 */
10
11/*
12 * "You see: Mr. Drogo, he married poor Miss Primula Brandybuck. She was
13 * our Mr. Bilbo's first cousin on the mother's side (her mother being the
14 * youngest of the Old Took's daughters); and Mr. Drogo was his second
15 * cousin. So Mr. Frodo is his first *and* second cousin, once removed
16 * either way, as the saying is, if you follow me." --the Gaffer
79072805
LW		 17 */
18
ccfc67b7 19
79072805 20#include "EXTERN.h"
864dbfa3 21#define PERL_IN_OP_C
79072805 22#include "perl.h"
77ca0c92 23#include "keywords.h"
79072805 24
a07e034d 25#define CALL_PEEP(o) CALL_FPTR(PL_peepp)(aTHX_ o)
a2efc822 26
238a4c30
NIS		 27#if defined(PL_OP_SLAB_ALLOC)
28
29#ifndef PERL_SLAB_SIZE
30#define PERL_SLAB_SIZE 2048
31#endif
32
c7e45529
AE		 33void *
34Perl_Slab_Alloc(pTHX_ int m, size_t sz)
1c846c1f 35{
5a8e194f
NIS		 36 /*
37 * To make incrementing use count easy PL_OpSlab is an I32 *
38 * To make inserting the link to slab PL_OpPtr is I32 **
39 * So compute size in units of sizeof(I32 *) as that is how Pl_OpPtr increments
40 * Add an overhead for pointer to slab and round up as a number of pointers
41 */
42 sz = (sz + 2*sizeof(I32 *) -1)/sizeof(I32 *);
238a4c30 43 if ((PL_OpSpace -= sz) < 0) {
083fcd59
JH		 44 PL_OpPtr = (I32 **) PerlMemShared_malloc(PERL_SLAB_SIZE*sizeof(I32*));
45 if (!PL_OpPtr) {
238a4c30
NIS		 46 return NULL;
47 }
5a8e194f
NIS		 48 Zero(PL_OpPtr,PERL_SLAB_SIZE,I32 **);
49 /* We reserve the 0'th I32 sized chunk as a use count */
50 PL_OpSlab = (I32 *) PL_OpPtr;
51 /* Reduce size by the use count word, and by the size we need.
52 * Latter is to mimic the '-=' in the if() above
53 */
54 PL_OpSpace = PERL_SLAB_SIZE - (sizeof(I32)+sizeof(I32 **)-1)/sizeof(I32 **) - sz;
238a4c30
NIS		 55 /* Allocation pointer starts at the top.
56 Theory: because we build leaves before trunk allocating at end
57 means that at run time access is cache friendly upward
58 */
5a8e194f 59 PL_OpPtr += PERL_SLAB_SIZE;
238a4c30
NIS		 60 }
61 assert( PL_OpSpace >= 0 );
62 /* Move the allocation pointer down */
63 PL_OpPtr -= sz;
5a8e194f 64 assert( PL_OpPtr > (I32 **) PL_OpSlab );
238a4c30
NIS		 65 *PL_OpPtr = PL_OpSlab; /* Note which slab it belongs to */
66 (*PL_OpSlab)++; /* Increment use count of slab */
5a8e194f 67 assert( PL_OpPtr+sz <= ((I32 **) PL_OpSlab + PERL_SLAB_SIZE) );
238a4c30
NIS		 68 assert( *PL_OpSlab > 0 );
69 return (void *)(PL_OpPtr + 1);
70}
71
c7e45529
AE		 72void
73Perl_Slab_Free(pTHX_ void *op)
238a4c30 74{
5a8e194f
NIS		 75 I32 **ptr = (I32 **) op;
76 I32 *slab = ptr[-1];
77 assert( ptr-1 > (I32 **) slab );
78 assert( ptr < ( (I32 **) slab + PERL_SLAB_SIZE) );
238a4c30
NIS		 79 assert( *slab > 0 );
80 if (--(*slab) == 0) {
7e4e8c89
NC		 81# ifdef NETWARE
82# define PerlMemShared PerlMem
83# endif
083fcd59
JH		 84
85 PerlMemShared_free(slab);
238a4c30
NIS		 86 if (slab == PL_OpSlab) {
87 PL_OpSpace = 0;
88 }
89 }
b7dc083c 90}
b7dc083c 91#endif
e50aee73 92/*
5dc0d613 93 * In the following definition, the ", Nullop" is just to make the compiler
a5f75d66 94 * think the expression is of the right type: croak actually does a Siglongjmp.
e50aee73 95 */
11343788 96#define CHECKOP(type,o) \
3280af22 97 ((PL_op_mask && PL_op_mask[type]) \
5dc0d613 98 ? ( op_free((OP*)o), \
cb77fdf0 99 Perl_croak(aTHX_ "'%s' trapped by operation mask", PL_op_desc[type]), \
28757baa 100 Nullop ) \
fc0dc3b3 101 : CALL_FPTR(PL_check[type])(aTHX_ (OP*)o))
e50aee73 102
e6438c1a 103#define RETURN_UNLIMITED_NUMBER (PERL_INT_MAX / 2)
c53d7c7d 104
76e3520e 105STATIC char*
cea2e8a9 106S_gv_ename(pTHX_ GV *gv)
4633a7c4 107{
2d8e6c8d 108 STRLEN n_a;
4633a7c4 109 SV* tmpsv = sv_newmortal();
46fc3d4c 110 gv_efullname3(tmpsv, gv, Nullch);
2d8e6c8d 111 return SvPV(tmpsv,n_a);
4633a7c4
LW		 112}
113
76e3520e 114STATIC OP *
cea2e8a9 115S_no_fh_allowed(pTHX_ OP *o)
79072805 116{
cea2e8a9 117 yyerror(Perl_form(aTHX_ "Missing comma after first argument to %s function",
53e06cf0 118 OP_DESC(o)));
11343788 119 return o;
79072805
LW		 120}
121
76e3520e 122STATIC OP *
cea2e8a9 123S_too_few_arguments(pTHX_ OP *o, char *name)
79072805 124{
cea2e8a9 125 yyerror(Perl_form(aTHX_ "Not enough arguments for %s", name));
11343788 126 return o;
79072805
LW		 127}
128
76e3520e 129STATIC OP *
cea2e8a9 130S_too_many_arguments(pTHX_ OP *o, char *name)
79072805 131{
cea2e8a9 132 yyerror(Perl_form(aTHX_ "Too many arguments for %s", name));
11343788 133 return o;
79072805
LW		 134}
135
76e3520e 136STATIC void
cea2e8a9 137S_bad_type(pTHX_ I32 n, char *t, char *name, OP *kid)
8990e307 138{
cea2e8a9 139 yyerror(Perl_form(aTHX_ "Type of arg %d to %s must be %s (not %s)",
53e06cf0 140 (int)n, name, t, OP_DESC(kid)));
8990e307
LW		 141}
142
7a52d87a 143STATIC void
cea2e8a9 144S_no_bareword_allowed(pTHX_ OP *o)
7a52d87a 145{
5a844595 146 qerror(Perl_mess(aTHX_
35c1215d
NC		 147 "Bareword \"%"SVf"\" not allowed while \"strict subs\" in use",
148 cSVOPo_sv));
7a52d87a
GS		 149}
150
79072805
LW		 151/* "register" allocation */
152
153PADOFFSET
dd2155a4 154Perl_allocmy(pTHX_ char *name)
93a17b20 155{
a0d0e21e 156 PADOFFSET off;
a0d0e21e 157
59f00321 158 /* complain about "my $<special_var>" etc etc */
155aba94
GS		 159 if (!(PL_in_my == KEY_our ||
160 isALPHA(name[1]) ||
39e02b42 161 (USE_UTF8_IN_NAMES && UTF8_IS_START(name[1])) ||
59f00321 162 (name[1] == '_' && (*name == '$' || (int)strlen(name) > 2))))
834a4ddd 163 {
c4d0567e 164 if (!isPRINT(name[1]) || strchr("\t\n\r\f", name[1])) {
2b92dfce
GS		 165 /* 1999-02-27 mjd@plover.com */
166 char *p;
167 p = strchr(name, '\0');
168 /* The next block assumes the buffer is at least 205 chars
169 long. At present, it's always at least 256 chars. */
170 if (p-name > 200) {
171 strcpy(name+200, "...");
172 p = name+199;
173 }
174 else {
175 p[1] = '\0';
176 }
177 /* Move everything else down one character */
178 for (; p-name > 2; p--)
179 *p = *(p-1);
46fc3d4c 180 name[2] = toCTRL(name[1]);
181 name[1] = '^';
182 }
cea2e8a9 183 yyerror(Perl_form(aTHX_ "Can't use global %s in \"my\"",name));
a0d0e21e 184 }
748a9306 185
dd2155a4
DM		 186 /* check for duplicate declaration */
187 pad_check_dup(name,
c5661c80 188 (bool)(PL_in_my == KEY_our),
dd2155a4
DM		 189 (PL_curstash ? PL_curstash : PL_defstash)
190 );
33b8ce05 191
dd2155a4
DM		 192 if (PL_in_my_stash && *name != '$') {
193 yyerror(Perl_form(aTHX_
194 "Can't declare class for non-scalar %s in \"%s\"",
195 name, PL_in_my == KEY_our ? "our" : "my"));
6b35e009
GS		 196 }
197
dd2155a4 198 /* allocate a spare slot and store the name in that slot */
93a17b20 199
dd2155a4
DM		 200 off = pad_add_name(name,
201 PL_in_my_stash,
202 (PL_in_my == KEY_our
203 ? (PL_curstash ? PL_curstash : PL_defstash)
204 : Nullhv
205 ),
206 0 /* not fake */
207 );
208 return off;
79072805
LW		 209}
210
79072805
LW		 211/* Destructor */
212
213void
864dbfa3 214Perl_op_free(pTHX_ OP *o)
79072805 215{
85e6fe83 216 register OP *kid, *nextkid;
acb36ea4 217 OPCODE type;
79072805 218
2814eb74 219 if (!o || o->op_static)
79072805
LW		 220 return;
221
7934575e
GS		 222 if (o->op_private & OPpREFCOUNTED) {
223 switch (o->op_type) {
224 case OP_LEAVESUB:
225 case OP_LEAVESUBLV:
226 case OP_LEAVEEVAL:
227 case OP_LEAVE:
228 case OP_SCOPE:
229 case OP_LEAVEWRITE:
230 OP_REFCNT_LOCK;
231 if (OpREFCNT_dec(o)) {
232 OP_REFCNT_UNLOCK;
233 return;
234 }
235 OP_REFCNT_UNLOCK;
236 break;
237 default:
238 break;
239 }
240 }
241
11343788
MB		 242 if (o->op_flags & OPf_KIDS) {
243 for (kid = cUNOPo->op_first; kid; kid = nextkid) {
85e6fe83 244 nextkid = kid->op_sibling; /* Get before next freeing kid */
79072805 245 op_free(kid);
85e6fe83 246 }
79072805 247 }
acb36ea4
GS		 248 type = o->op_type;
249 if (type == OP_NULL)
eb160463 250 type = (OPCODE)o->op_targ;
acb36ea4
GS		 251
252 /* COP* is not cleared by op_clear() so that we may track line
253 * numbers etc even after null() */
254 if (type == OP_NEXTSTATE || type == OP_SETSTATE || type == OP_DBSTATE)
255 cop_free((COP*)o);
256
257 op_clear(o);
238a4c30 258 FreeOp(o);
acb36ea4 259}
79072805 260
93c66552
DM		 261void
262Perl_op_clear(pTHX_ OP *o)
acb36ea4 263{
13137afc 264
11343788 265 switch (o->op_type) {
acb36ea4
GS		 266 case OP_NULL: /* Was holding old type, if any. */
267 case OP_ENTEREVAL: /* Was holding hints. */
acb36ea4 268 o->op_targ = 0;
a0d0e21e 269 break;
a6006777 270 default:
ac4c12e7 271 if (!(o->op_flags & OPf_REF)
0b94c7bb 272 || (PL_check[o->op_type] != MEMBER_TO_FPTR(Perl_ck_ftst)))
a6006777 273 break;
274 /* FALL THROUGH */
463ee0b2 275 case OP_GVSV:
79072805 276 case OP_GV:
a6006777 277 case OP_AELEMFAST:
6a077020
DM		 278 if (! (o->op_type == OP_AELEMFAST && o->op_flags & OPf_SPECIAL)) {
279 /* not an OP_PADAV replacement */
350de78d 280#ifdef USE_ITHREADS
6a077020
DM		 281 if (cPADOPo->op_padix > 0) {
282 /* No GvIN_PAD_off(cGVOPo_gv) here, because other references
283 * may still exist on the pad */
284 pad_swipe(cPADOPo->op_padix, TRUE);
285 cPADOPo->op_padix = 0;
286 }
350de78d 287#else
6a077020
DM		 288 SvREFCNT_dec(cSVOPo->op_sv);
289 cSVOPo->op_sv = Nullsv;
350de78d 290#endif
6a077020 291 }
79072805 292 break;
a1ae71d2 293 case OP_METHOD_NAMED:
79072805 294 case OP_CONST:
11343788 295 SvREFCNT_dec(cSVOPo->op_sv);
acb36ea4 296 cSVOPo->op_sv = Nullsv;
3b1c21fa
AB		 297#ifdef USE_ITHREADS
298 /** Bug #15654
299 Even if op_clear does a pad_free for the target of the op,
6a077020 300 pad_free doesn't actually remove the sv that exists in the pad;
3b1c21fa
AB		 301 instead it lives on. This results in that it could be reused as
302 a target later on when the pad was reallocated.
303 **/
304 if(o->op_targ) {
305 pad_swipe(o->op_targ,1);
306 o->op_targ = 0;
307 }
308#endif
79072805 309 break;
748a9306
LW		 310 case OP_GOTO:
311 case OP_NEXT:
312 case OP_LAST:
313 case OP_REDO:
11343788 314 if (o->op_flags & (OPf_SPECIAL|OPf_STACKED|OPf_KIDS))
748a9306
LW		 315 break;
316 /* FALL THROUGH */
a0d0e21e 317 case OP_TRANS:
acb36ea4 318 if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
a0ed51b3 319 SvREFCNT_dec(cSVOPo->op_sv);
acb36ea4
GS		 320 cSVOPo->op_sv = Nullsv;
321 }
322 else {
a0ed51b3 323 Safefree(cPVOPo->op_pv);
acb36ea4
GS		 324 cPVOPo->op_pv = Nullch;
325 }
a0d0e21e
LW		 326 break;
327 case OP_SUBST:
11343788 328 op_free(cPMOPo->op_pmreplroot);
971a9dd3 329 goto clear_pmop;
748a9306 330 case OP_PUSHRE:
971a9dd3 331#ifdef USE_ITHREADS
ba89bb6e 332 if (INT2PTR(PADOFFSET, cPMOPo->op_pmreplroot)) {
dd2155a4
DM		 333 /* No GvIN_PAD_off here, because other references may still
334 * exist on the pad */
335 pad_swipe(INT2PTR(PADOFFSET, cPMOPo->op_pmreplroot), TRUE);
971a9dd3
GS		 336 }
337#else
338 SvREFCNT_dec((SV*)cPMOPo->op_pmreplroot);
339#endif
340 /* FALL THROUGH */
a0d0e21e 341 case OP_MATCH:
8782bef2 342 case OP_QR:
971a9dd3 343clear_pmop:
cb55de95
JH		 344 {
345 HV *pmstash = PmopSTASH(cPMOPo);
346 if (pmstash && SvREFCNT(pmstash)) {
347 PMOP *pmop = HvPMROOT(pmstash);
348 PMOP *lastpmop = NULL;
349 while (pmop) {
350 if (cPMOPo == pmop) {
351 if (lastpmop)
352 lastpmop->op_pmnext = pmop->op_pmnext;
353 else
354 HvPMROOT(pmstash) = pmop->op_pmnext;
355 break;
356 }
357 lastpmop = pmop;
358 pmop = pmop->op_pmnext;
359 }
83da49e6 360 }
05ec9bb3 361 PmopSTASH_free(cPMOPo);
cb55de95 362 }
971a9dd3 363 cPMOPo->op_pmreplroot = Nullop;
5f8cb046
DM		 364 /* we use the "SAFE" version of the PM_ macros here
365 * since sv_clean_all might release some PMOPs
366 * after PL_regex_padav has been cleared
367 * and the clearing of PL_regex_padav needs to
368 * happen before sv_clean_all
369 */
370 ReREFCNT_dec(PM_GETRE_SAFE(cPMOPo));
371 PM_SETRE_SAFE(cPMOPo, (REGEXP*)NULL);
13137afc
AB		 372#ifdef USE_ITHREADS
373 if(PL_regex_pad) { /* We could be in destruction */
374 av_push((AV*) PL_regex_pad[0],(SV*) PL_regex_pad[(cPMOPo)->op_pmoffset]);
1cc8b4c5 375 SvREPADTMP_on(PL_regex_pad[(cPMOPo)->op_pmoffset]);
13137afc
AB		 376 PM_SETRE(cPMOPo, (cPMOPo)->op_pmoffset);
377 }
1eb1540c 378#endif
13137afc 379
a0d0e21e 380 break;
79072805
LW		 381 }
382
743e66e6 383 if (o->op_targ > 0) {
11343788 384 pad_free(o->op_targ);
743e66e6
GS		 385 o->op_targ = 0;
386 }
79072805
LW		 387}
388
76e3520e 389STATIC void
3eb57f73
HS		 390S_cop_free(pTHX_ COP* cop)
391{
05ec9bb3
NIS		 392 Safefree(cop->cop_label); /* FIXME: treaddead ??? */
393 CopFILE_free(cop);
394 CopSTASH_free(cop);
0453d815 395 if (! specialWARN(cop->cop_warnings))
3eb57f73 396 SvREFCNT_dec(cop->cop_warnings);
05ec9bb3
NIS		 397 if (! specialCopIO(cop->cop_io)) {
398#ifdef USE_ITHREADS
042f6df8 399#if 0
05ec9bb3
NIS		 400 STRLEN len;
401 char *s = SvPV(cop->cop_io,len);
b178108d
JH		 402 Perl_warn(aTHX_ "io='%.*s'",(int) len,s); /* ??? --jhi */
403#endif
05ec9bb3 404#else
ac27b0f5 405 SvREFCNT_dec(cop->cop_io);
05ec9bb3
NIS		 406#endif
407 }
3eb57f73
HS		 408}
409
93c66552
DM		 410void
411Perl_op_null(pTHX_ OP *o)
8990e307 412{
acb36ea4
GS		 413 if (o->op_type == OP_NULL)
414 return;
415 op_clear(o);
11343788
MB		 416 o->op_targ = o->op_type;
417 o->op_type = OP_NULL;
22c35a8c 418 o->op_ppaddr = PL_ppaddr[OP_NULL];
8990e307
LW		 419}
420
79072805
LW		 421/* Contextualizers */
422
463ee0b2 423#define LINKLIST(o) ((o)->op_next ? (o)->op_next : linklist((OP*)o))
79072805
LW		 424
425OP *
864dbfa3 426Perl_linklist(pTHX_ OP *o)
79072805
LW		 427{
428 register OP *kid;
429
11343788
MB		 430 if (o->op_next)
431 return o->op_next;
79072805
LW		 432
433 /* establish postfix order */
11343788
MB		 434 if (cUNOPo->op_first) {
435 o->op_next = LINKLIST(cUNOPo->op_first);
436 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
79072805
LW		 437 if (kid->op_sibling)
438 kid->op_next = LINKLIST(kid->op_sibling);
439 else
11343788 440 kid->op_next = o;
79072805
LW		 441 }
442 }
443 else
11343788 444 o->op_next = o;
79072805 445
11343788 446 return o->op_next;
79072805
LW		 447}
448
449OP *
864dbfa3 450Perl_scalarkids(pTHX_ OP *o)
79072805
LW		 451{
452 OP *kid;
11343788
MB		 453 if (o && o->op_flags & OPf_KIDS) {
454 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
79072805
LW		 455 scalar(kid);
456 }
11343788 457 return o;
79072805
LW		 458}
459
76e3520e 460STATIC OP *
cea2e8a9 461S_scalarboolean(pTHX_ OP *o)
8990e307 462{
d008e5eb 463 if (o->op_type == OP_SASSIGN && cBINOPo->op_first->op_type == OP_CONST) {
d008e5eb 464 if (ckWARN(WARN_SYNTAX)) {
57843af0 465 line_t oldline = CopLINE(PL_curcop);
a0d0e21e 466
d008e5eb 467 if (PL_copline != NOLINE)
57843af0 468 CopLINE_set(PL_curcop, PL_copline);
9014280d 469 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Found = in conditional, should be ==");
57843af0 470 CopLINE_set(PL_curcop, oldline);
d008e5eb 471 }
a0d0e21e 472 }
11343788 473 return scalar(o);
8990e307
LW		 474}
475
476OP *
864dbfa3 477Perl_scalar(pTHX_ OP *o)
79072805
LW		 478{
479 OP *kid;
480
a0d0e21e 481 /* assumes no premature commitment */
3280af22 482 if (!o || (o->op_flags & OPf_WANT) || PL_error_count
5dc0d613 483 || o->op_type == OP_RETURN)
7e363e51 484 {
11343788 485 return o;
7e363e51 486 }
79072805 487
5dc0d613 488 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_SCALAR;
79072805 489
11343788 490 switch (o->op_type) {
79072805 491 case OP_REPEAT:
11343788 492 scalar(cBINOPo->op_first);
8990e307 493 break;
79072805
LW		 494 case OP_OR:
495 case OP_AND:
496 case OP_COND_EXPR:
11343788 497 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
8990e307 498 scalar(kid);
79072805 499 break;
a0d0e21e 500 case OP_SPLIT:
11343788 501 if ((kid = cLISTOPo->op_first) && kid->op_type == OP_PUSHRE) {
a0d0e21e 502 if (!kPMOP->op_pmreplroot)
12bcd1a6 503 deprecate_old("implicit split to @_");
a0d0e21e
LW		 504 }
505 /* FALL THROUGH */
79072805 506 case OP_MATCH:
8782bef2 507 case OP_QR:
79072805
LW		 508 case OP_SUBST:
509 case OP_NULL:
8990e307 510 default:
11343788
MB		 511 if (o->op_flags & OPf_KIDS) {
512 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling)
8990e307
LW		 513 scalar(kid);
514 }
79072805
LW		 515 break;
516 case OP_LEAVE:
517 case OP_LEAVETRY:
5dc0d613 518 kid = cLISTOPo->op_first;
54310121 519 scalar(kid);
155aba94 520 while ((kid = kid->op_sibling)) {
54310121 521 if (kid->op_sibling)
522 scalarvoid(kid);
523 else
524 scalar(kid);
525 }
3280af22 526 WITH_THR(PL_curcop = &PL_compiling);
54310121 527 break;
748a9306 528 case OP_SCOPE:
79072805 529 case OP_LINESEQ:
8990e307 530 case OP_LIST:
11343788 531 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
79072805
LW		 532 if (kid->op_sibling)
533 scalarvoid(kid);
534 else
535 scalar(kid);
536 }
3280af22 537 WITH_THR(PL_curcop = &PL_compiling);
79072805 538 break;
a801c63c
RGS		 539 case OP_SORT:
540 if (ckWARN(WARN_VOID))
9014280d 541 Perl_warner(aTHX_ packWARN(WARN_VOID), "Useless use of sort in scalar context");
79072805 542 }
11343788 543 return o;
79072805
LW		 544}
545
546OP *
864dbfa3 547Perl_scalarvoid(pTHX_ OP *o)
79072805
LW		 548{
549 OP *kid;
8990e307
LW		 550 char* useless = 0;
551 SV* sv;
2ebea0a1
GS		 552 U8 want;
553
acb36ea4
GS		 554 if (o->op_type == OP_NEXTSTATE
555 || o->op_type == OP_SETSTATE
556 || o->op_type == OP_DBSTATE
557 || (o->op_type == OP_NULL && (o->op_targ == OP_NEXTSTATE
558 || o->op_targ == OP_SETSTATE
559 || o->op_targ == OP_DBSTATE)))
2ebea0a1 560 PL_curcop = (COP*)o; /* for warning below */
79072805 561
54310121 562 /* assumes no premature commitment */
2ebea0a1
GS		 563 want = o->op_flags & OPf_WANT;
564 if ((want && want != OPf_WANT_SCALAR) || PL_error_count
5dc0d613 565 || o->op_type == OP_RETURN)
7e363e51 566 {
11343788 567 return o;
7e363e51 568 }
79072805 569
b162f9ea 570 if ((o->op_private & OPpTARGET_MY)
7e363e51
GS		 571 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
572 {
b162f9ea 573 return scalar(o); /* As if inside SASSIGN */
7e363e51 574 }
1c846c1f 575
5dc0d613 576 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
79072805 577
11343788 578 switch (o->op_type) {
79072805 579 default:
22c35a8c 580 if (!(PL_opargs[o->op_type] & OA_FOLDCONST))
8990e307 581 break;
36477c24 582 /* FALL THROUGH */
583 case OP_REPEAT:
11343788 584 if (o->op_flags & OPf_STACKED)
8990e307 585 break;
5d82c453
GA		 586 goto func_ops;
587 case OP_SUBSTR:
588 if (o->op_private == 4)
589 break;
8990e307
LW		 590 /* FALL THROUGH */
591 case OP_GVSV:
592 case OP_WANTARRAY:
593 case OP_GV:
594 case OP_PADSV:
595 case OP_PADAV:
596 case OP_PADHV:
597 case OP_PADANY:
598 case OP_AV2ARYLEN:
8990e307 599 case OP_REF:
a0d0e21e
LW		 600 case OP_REFGEN:
601 case OP_SREFGEN:
8990e307
LW		 602 case OP_DEFINED:
603 case OP_HEX:
604 case OP_OCT:
605 case OP_LENGTH:
8990e307
LW		 606 case OP_VEC:
607 case OP_INDEX:
608 case OP_RINDEX:
609 case OP_SPRINTF:
610 case OP_AELEM:
611 case OP_AELEMFAST:
612 case OP_ASLICE:
8990e307
LW		 613 case OP_HELEM:
614 case OP_HSLICE:
615 case OP_UNPACK:
616 case OP_PACK:
8990e307
LW		 617 case OP_JOIN:
618 case OP_LSLICE:
619 case OP_ANONLIST:
620 case OP_ANONHASH:
621 case OP_SORT:
622 case OP_REVERSE:
623 case OP_RANGE:
624 case OP_FLIP:
625 case OP_FLOP:
626 case OP_CALLER:
627 case OP_FILENO:
628 case OP_EOF:
629 case OP_TELL:
630 case OP_GETSOCKNAME:
631 case OP_GETPEERNAME:
632 case OP_READLINK:
633 case OP_TELLDIR:
634 case OP_GETPPID:
635 case OP_GETPGRP:
636 case OP_GETPRIORITY:
637 case OP_TIME:
638 case OP_TMS:
639 case OP_LOCALTIME:
640 case OP_GMTIME:
641 case OP_GHBYNAME:
642 case OP_GHBYADDR:
643 case OP_GHOSTENT:
644 case OP_GNBYNAME:
645 case OP_GNBYADDR:
646 case OP_GNETENT:
647 case OP_GPBYNAME:
648 case OP_GPBYNUMBER:
649 case OP_GPROTOENT:
650 case OP_GSBYNAME:
651 case OP_GSBYPORT:
652 case OP_GSERVENT:
653 case OP_GPWNAM:
654 case OP_GPWUID:
655 case OP_GGRNAM:
656 case OP_GGRGID:
657 case OP_GETLOGIN:
78e1b766 658 case OP_PROTOTYPE:
5d82c453 659 func_ops:
64aac5a9 660 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)))
53e06cf0 661 useless = OP_DESC(o);
8990e307
LW		 662 break;
663
664 case OP_RV2GV:
665 case OP_RV2SV:
666 case OP_RV2AV:
667 case OP_RV2HV:
192587c2 668 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)) &&
11343788 669 (!o->op_sibling || o->op_sibling->op_type != OP_READLINE))
8990e307
LW		 670 useless = "a variable";
671 break;
79072805
LW		 672
673 case OP_CONST:
7766f137 674 sv = cSVOPo_sv;
7a52d87a
GS		 675 if (cSVOPo->op_private & OPpCONST_STRICT)
676 no_bareword_allowed(o);
677 else {
d008e5eb
GS		 678 if (ckWARN(WARN_VOID)) {
679 useless = "a constant";
e7fec78e 680 /* don't warn on optimised away booleans, eg
b5a930ec 681 * use constant Foo, 5; Foo || print; */
e7fec78e
DM		 682 if (cSVOPo->op_private & OPpCONST_SHORTCIRCUIT)
683 useless = 0;
960b4253
MG		 684 /* the constants 0 and 1 are permitted as they are
685 conventionally used as dummies in constructs like
686 1 while some_condition_with_side_effects; */
e7fec78e 687 else if (SvNIOK(sv) && (SvNV(sv) == 0.0 || SvNV(sv) == 1.0))
d008e5eb
GS		 688 useless = 0;
689 else if (SvPOK(sv)) {
a52fe3ac
A		 690 /* perl4's way of mixing documentation and code
691 (before the invention of POD) was based on a
692 trick to mix nroff and perl code. The trick was
693 built upon these three nroff macros being used in
694 void context. The pink camel has the details in
695 the script wrapman near page 319. */
d008e5eb
GS		 696 if (strnEQ(SvPVX(sv), "di", 2) ||
697 strnEQ(SvPVX(sv), "ds", 2) ||
698 strnEQ(SvPVX(sv), "ig", 2))
699 useless = 0;
700 }
8990e307
LW		 701 }
702 }
93c66552 703 op_null(o); /* don't execute or even remember it */
79072805
LW		 704 break;
705
706 case OP_POSTINC:
11343788 707 o->op_type = OP_PREINC; /* pre-increment is faster */
22c35a8c 708 o->op_ppaddr = PL_ppaddr[OP_PREINC];
79072805
LW		 709 break;
710
711 case OP_POSTDEC:
11343788 712 o->op_type = OP_PREDEC; /* pre-decrement is faster */
22c35a8c 713 o->op_ppaddr = PL_ppaddr[OP_PREDEC];
79072805
LW		 714 break;
715
79072805
LW		 716 case OP_OR:
717 case OP_AND:
c963b151 718 case OP_DOR:
79072805 719 case OP_COND_EXPR:
11343788 720 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
79072805
LW		 721 scalarvoid(kid);
722 break;
5aabfad6 723
a0d0e21e 724 case OP_NULL:
11343788 725 if (o->op_flags & OPf_STACKED)
a0d0e21e 726 break;
5aabfad6 727 /* FALL THROUGH */
2ebea0a1
GS		 728 case OP_NEXTSTATE:
729 case OP_DBSTATE:
79072805
LW		 730 case OP_ENTERTRY:
731 case OP_ENTER:
11343788 732 if (!(o->op_flags & OPf_KIDS))
79072805 733 break;
54310121 734 /* FALL THROUGH */
463ee0b2 735 case OP_SCOPE:
79072805
LW		 736 case OP_LEAVE:
737 case OP_LEAVETRY:
a0d0e21e 738 case OP_LEAVELOOP:
79072805 739 case OP_LINESEQ:
79072805 740 case OP_LIST:
11343788 741 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
79072805
LW		 742 scalarvoid(kid);
743 break;
c90c0ff4 744 case OP_ENTEREVAL:
5196be3e 745 scalarkids(o);
c90c0ff4 746 break;
5aabfad6 747 case OP_REQUIRE:
c90c0ff4 748 /* all requires must return a boolean value */
5196be3e 749 o->op_flags &= ~OPf_WANT;
d6483035
GS		 750 /* FALL THROUGH */
751 case OP_SCALAR:
5196be3e 752 return scalar(o);
a0d0e21e 753 case OP_SPLIT:
11343788 754 if ((kid = cLISTOPo->op_first) && kid->op_type == OP_PUSHRE) {
a0d0e21e 755 if (!kPMOP->op_pmreplroot)
12bcd1a6 756 deprecate_old("implicit split to @_");
a0d0e21e
LW		 757 }
758 break;
79072805 759 }
411caa50 760 if (useless && ckWARN(WARN_VOID))
9014280d 761 Perl_warner(aTHX_ packWARN(WARN_VOID), "Useless use of %s in void context", useless);
11343788 762 return o;
79072805
LW		 763}
764
765OP *
864dbfa3 766Perl_listkids(pTHX_ OP *o)
79072805
LW		 767{
768 OP *kid;
11343788
MB		 769 if (o && o->op_flags & OPf_KIDS) {
770 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
79072805
LW		 771 list(kid);
772 }
11343788 773 return o;
79072805
LW		 774}
775
776OP *
864dbfa3 777Perl_list(pTHX_ OP *o)
79072805
LW		 778{
779 OP *kid;
780
a0d0e21e 781 /* assumes no premature commitment */
3280af22 782 if (!o || (o->op_flags & OPf_WANT) || PL_error_count
5dc0d613 783 || o->op_type == OP_RETURN)
7e363e51 784 {
11343788 785 return o;
7e363e51 786 }
79072805 787
b162f9ea 788 if ((o->op_private & OPpTARGET_MY)
7e363e51
GS		 789 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
790 {
b162f9ea 791 return o; /* As if inside SASSIGN */
7e363e51 792 }
1c846c1f 793
5dc0d613 794 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_LIST;
79072805 795
11343788 796 switch (o->op_type) {
79072805
LW		 797 case OP_FLOP:
798 case OP_REPEAT:
11343788 799 list(cBINOPo->op_first);
79072805
LW		 800 break;
801 case OP_OR:
802 case OP_AND:
803 case OP_COND_EXPR:
11343788 804 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
79072805
LW		 805 list(kid);
806 break;
807 default:
808 case OP_MATCH:
8782bef2 809 case OP_QR:
79072805
LW		 810 case OP_SUBST:
811 case OP_NULL:
11343788 812 if (!(o->op_flags & OPf_KIDS))
79072805 813 break;
11343788
MB		 814 if (!o->op_next && cUNOPo->op_first->op_type == OP_FLOP) {
815 list(cBINOPo->op_first);
816 return gen_constant_list(o);
79072805
LW		 817 }
818 case OP_LIST:
11343788 819 listkids(o);
79072805
LW		 820 break;
821 case OP_LEAVE:
822 case OP_LEAVETRY:
5dc0d613 823 kid = cLISTOPo->op_first;
54310121 824 list(kid);
155aba94 825 while ((kid = kid->op_sibling)) {
54310121 826 if (kid->op_sibling)
827 scalarvoid(kid);
828 else
829 list(kid);
830 }
3280af22 831 WITH_THR(PL_curcop = &PL_compiling);
54310121 832 break;
748a9306 833 case OP_SCOPE:
79072805 834 case OP_LINESEQ:
11343788 835 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
79072805
LW		 836 if (kid->op_sibling)
837 scalarvoid(kid);
838 else
839 list(kid);
840 }
3280af22 841 WITH_THR(PL_curcop = &PL_compiling);
79072805 842 break;
c90c0ff4 843 case OP_REQUIRE:
844 /* all requires must return a boolean value */
5196be3e
MB		 845 o->op_flags &= ~OPf_WANT;
846 return scalar(o);
79072805 847 }
11343788 848 return o;
79072805
LW		 849}
850
851OP *
864dbfa3 852Perl_scalarseq(pTHX_ OP *o)
79072805
LW		 853{
854 OP *kid;
855
11343788
MB		 856 if (o) {
857 if (o->op_type == OP_LINESEQ ||
858 o->op_type == OP_SCOPE ||
859 o->op_type == OP_LEAVE ||
860 o->op_type == OP_LEAVETRY)
463ee0b2 861 {
11343788 862 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
ed6116ce 863 if (kid->op_sibling) {
463ee0b2 864 scalarvoid(kid);
ed6116ce 865 }
463ee0b2 866 }
3280af22 867 PL_curcop = &PL_compiling;
79072805 868 }
11343788 869 o->op_flags &= ~OPf_PARENS;
3280af22 870 if (PL_hints & HINT_BLOCK_SCOPE)
11343788 871 o->op_flags |= OPf_PARENS;
79072805 872 }
8990e307 873 else
11343788
MB		 874 o = newOP(OP_STUB, 0);
875 return o;
79072805
LW		 876}
877
76e3520e 878STATIC OP *
cea2e8a9 879S_modkids(pTHX_ OP *o, I32 type)
79072805
LW		 880{
881 OP *kid;
11343788
MB		 882 if (o && o->op_flags & OPf_KIDS) {
883 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
463ee0b2 884 mod(kid, type);
79072805 885 }
11343788 886 return o;
79072805
LW		 887}
888
ddeae0f1
DM		 889/* Propagate lvalue ("modifiable") context to an op and it's children.
890 * 'type' represents the context type, roughly based on the type of op that
891 * would do the modifying, although local() is represented by OP_NULL.
892 * It's responsible for detecting things that can't be modified, flag
893 * things that need to behave specially in an lvalue context (e.g., "$$x = 5"
894 * might have to vivify a reference in $x), and so on.
895 *
896 * For example, "$a+1 = 2" would cause mod() to be called with o being
897 * OP_ADD and type being OP_SASSIGN, and would output an error.
898 */
899
79072805 900OP *
864dbfa3 901Perl_mod(pTHX_ OP *o, I32 type)
79072805
LW		 902{
903 OP *kid;
ddeae0f1
DM		 904 /* -1 = error on localize, 0 = ignore localize, 1 = ok to localize */
905 int localize = -1;
79072805 906
3280af22 907 if (!o || PL_error_count)
11343788 908 return o;
79072805 909
b162f9ea 910 if ((o->op_private & OPpTARGET_MY)
7e363e51
GS		 911 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
912 {
b162f9ea 913 return o;
7e363e51 914 }
1c846c1f 915
11343788 916 switch (o->op_type) {
68dc0745 917 case OP_UNDEF:
ddeae0f1 918 localize = 0;
3280af22 919 PL_modcount++;
5dc0d613 920 return o;
a0d0e21e 921 case OP_CONST:
11343788 922 if (!(o->op_private & (OPpCONST_ARYBASE)))
a0d0e21e 923 goto nomod;
3280af22 924 if (PL_eval_start && PL_eval_start->op_type == OP_CONST) {
7766f137 925 PL_compiling.cop_arybase = (I32)SvIV(cSVOPx(PL_eval_start)->op_sv);
3280af22 926 PL_eval_start = 0;
a0d0e21e
LW		 927 }
928 else if (!type) {
3280af22
NIS		 929 SAVEI32(PL_compiling.cop_arybase);
930 PL_compiling.cop_arybase = 0;
a0d0e21e
LW		 931 }
932 else if (type == OP_REFGEN)
933 goto nomod;
934 else
cea2e8a9 935 Perl_croak(aTHX_ "That use of $[ is unsupported");
a0d0e21e 936 break;
5f05dabc 937 case OP_STUB:
5196be3e 938 if (o->op_flags & OPf_PARENS)
5f05dabc 939 break;
940 goto nomod;
a0d0e21e
LW		 941 case OP_ENTERSUB:
942 if ((type == OP_UNDEF || type == OP_REFGEN) &&
11343788
MB		 943 !(o->op_flags & OPf_STACKED)) {
944 o->op_type = OP_RV2CV; /* entersub => rv2cv */
22c35a8c 945 o->op_ppaddr = PL_ppaddr[OP_RV2CV];
11343788 946 assert(cUNOPo->op_first->op_type == OP_NULL);
93c66552 947 op_null(((LISTOP*)cUNOPo->op_first)->op_first);/* disable pushmark */
79072805
LW		 948 break;
949 }
95f0a2f1
SB		 950 else if (o->op_private & OPpENTERSUB_NOMOD)
951 return o;
cd06dffe
GS		 952 else { /* lvalue subroutine call */
953 o->op_private |= OPpLVAL_INTRO;
e6438c1a 954 PL_modcount = RETURN_UNLIMITED_NUMBER;
4978d6d9 955 if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN) {
cd06dffe
GS		 956 /* Backward compatibility mode: */
957 o->op_private |= OPpENTERSUB_INARGS;
958 break;
959 }
960 else { /* Compile-time error message: */
961 OP *kid = cUNOPo->op_first;
962 CV *cv;
963 OP *okid;
964
965 if (kid->op_type == OP_PUSHMARK)
966 goto skip_kids;
967 if (kid->op_type != OP_NULL || kid->op_targ != OP_LIST)
968 Perl_croak(aTHX_
969 "panic: unexpected lvalue entersub "
55140b79 970 "args: type/targ %ld:%"UVuf,
3d811634 971 (long)kid->op_type, (UV)kid->op_targ);
cd06dffe
GS		 972 kid = kLISTOP->op_first;
973 skip_kids:
974 while (kid->op_sibling)
975 kid = kid->op_sibling;
976 if (!(kid->op_type == OP_NULL && kid->op_targ == OP_RV2CV)) {
977 /* Indirect call */
978 if (kid->op_type == OP_METHOD_NAMED
979 || kid->op_type == OP_METHOD)
980 {
87d7fd28 981 UNOP *newop;
b2ffa427 982
87d7fd28 983 NewOp(1101, newop, 1, UNOP);
349fd7b7
GS		 984 newop->op_type = OP_RV2CV;
985 newop->op_ppaddr = PL_ppaddr[OP_RV2CV];
87d7fd28
GS		 986 newop->op_first = Nullop;
987 newop->op_next = (OP*)newop;
988 kid->op_sibling = (OP*)newop;
349fd7b7 989 newop->op_private |= OPpLVAL_INTRO;
cd06dffe
GS		 990 break;
991 }
b2ffa427 992
cd06dffe
GS		 993 if (kid->op_type != OP_RV2CV)
994 Perl_croak(aTHX_
995 "panic: unexpected lvalue entersub "
55140b79 996 "entry via type/targ %ld:%"UVuf,
3d811634 997 (long)kid->op_type, (UV)kid->op_targ);
cd06dffe
GS		 998 kid->op_private |= OPpLVAL_INTRO;
999 break; /* Postpone until runtime */
1000 }
b2ffa427
NIS		 1001
1002 okid = kid;
cd06dffe
GS		 1003 kid = kUNOP->op_first;
1004 if (kid->op_type == OP_NULL && kid->op_targ == OP_RV2SV)
1005 kid = kUNOP->op_first;
b2ffa427 1006 if (kid->op_type == OP_NULL)
cd06dffe
GS		 1007 Perl_croak(aTHX_
1008 "Unexpected constant lvalue entersub "
55140b79 1009 "entry via type/targ %ld:%"UVuf,
3d811634 1010 (long)kid->op_type, (UV)kid->op_targ);
cd06dffe
GS		 1011 if (kid->op_type != OP_GV) {
1012 /* Restore RV2CV to check lvalueness */
1013 restore_2cv:
1014 if (kid->op_next && kid->op_next != kid) { /* Happens? */
1015 okid->op_next = kid->op_next;
1016 kid->op_next = okid;
1017 }
1018 else
1019 okid->op_next = Nullop;
1020 okid->op_type = OP_RV2CV;
1021 okid->op_targ = 0;
1022 okid->op_ppaddr = PL_ppaddr[OP_RV2CV];
1023 okid->op_private |= OPpLVAL_INTRO;
1024 break;
1025 }
b2ffa427 1026
638eceb6 1027 cv = GvCV(kGVOP_gv);
1c846c1f 1028 if (!cv)
cd06dffe
GS		 1029 goto restore_2cv;
1030 if (CvLVALUE(cv))
1031 break;
1032 }
1033 }
79072805
LW		 1034 /* FALL THROUGH */
1035 default:
a0d0e21e
LW		 1036 nomod:
1037 /* grep, foreach, subcalls, refgen */
1038 if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN)
1039 break;
cea2e8a9 1040 yyerror(Perl_form(aTHX_ "Can't modify %s in %s",
638bc118 1041 (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)
cd06dffe
GS		 1042 ? "do block"
1043 : (o->op_type == OP_ENTERSUB
1044 ? "non-lvalue subroutine call"
53e06cf0 1045 : OP_DESC(o))),
22c35a8c 1046 type ? PL_op_desc[type] : "local"));
11343788 1047 return o;
79072805 1048
a0d0e21e
LW		 1049 case OP_PREINC:
1050 case OP_PREDEC:
1051 case OP_POW:
1052 case OP_MULTIPLY:
1053 case OP_DIVIDE:
1054 case OP_MODULO:
1055 case OP_REPEAT:
1056 case OP_ADD:
1057 case OP_SUBTRACT:
1058 case OP_CONCAT:
1059 case OP_LEFT_SHIFT:
1060 case OP_RIGHT_SHIFT:
1061 case OP_BIT_AND:
1062 case OP_BIT_XOR:
1063 case OP_BIT_OR:
1064 case OP_I_MULTIPLY:
1065 case OP_I_DIVIDE:
1066 case OP_I_MODULO:
1067 case OP_I_ADD:
1068 case OP_I_SUBTRACT:
11343788 1069 if (!(o->op_flags & OPf_STACKED))
a0d0e21e 1070 goto nomod;
3280af22 1071 PL_modcount++;
a0d0e21e 1072 break;
b2ffa427 1073
79072805 1074 case OP_COND_EXPR:
ddeae0f1 1075 localize = 1;
11343788 1076 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
463ee0b2 1077 mod(kid, type);
79072805
LW		 1078 break;
1079
1080 case OP_RV2AV:
1081 case OP_RV2HV:
11343788 1082 if (type == OP_REFGEN && o->op_flags & OPf_PARENS) {
e6438c1a 1083 PL_modcount = RETURN_UNLIMITED_NUMBER;
11343788 1084 return o; /* Treat \(@foo) like ordinary list. */
748a9306
LW		 1085 }
1086 /* FALL THROUGH */
79072805 1087 case OP_RV2GV:
5dc0d613 1088 if (scalar_mod_type(o, type))
3fe9a6f1 1089 goto nomod;
11343788 1090 ref(cUNOPo->op_first, o->op_type);
79072805 1091 /* FALL THROUGH */
79072805
LW		 1092 case OP_ASLICE:
1093 case OP_HSLICE:
78f9721b
SM		 1094 if (type == OP_LEAVESUBLV)
1095 o->op_private |= OPpMAYBE_LVSUB;
ddeae0f1 1096 localize = 1;
78f9721b
SM		 1097 /* FALL THROUGH */
1098 case OP_AASSIGN:
93a17b20
LW		 1099 case OP_NEXTSTATE:
1100 case OP_DBSTATE:
e6438c1a 1101 PL_modcount = RETURN_UNLIMITED_NUMBER;
79072805 1102 break;
463ee0b2 1103 case OP_RV2SV:
aeea060c 1104 ref(cUNOPo->op_first, o->op_type);
ddeae0f1 1105 localize = 1;
463ee0b2 1106 /* FALL THROUGH */
79072805 1107 case OP_GV:
463ee0b2 1108 case OP_AV2ARYLEN:
3280af22 1109 PL_hints |= HINT_BLOCK_SCOPE;
463ee0b2 1110 case OP_SASSIGN:
bf4b1e52
GS		 1111 case OP_ANDASSIGN:
1112 case OP_ORASSIGN:
c963b151 1113 case OP_DORASSIGN:
ddeae0f1
DM		 1114 PL_modcount++;
1115 break;
1116
8990e307 1117 case OP_AELEMFAST:
6a077020 1118 localize = -1;
3280af22 1119 PL_modcount++;
8990e307
LW		 1120 break;
1121
748a9306
LW		 1122 case OP_PADAV:
1123 case OP_PADHV:
e6438c1a 1124 PL_modcount = RETURN_UNLIMITED_NUMBER;
5196be3e
MB		 1125 if (type == OP_REFGEN && o->op_flags & OPf_PARENS)
1126 return o; /* Treat \(@foo) like ordinary list. */
1127 if (scalar_mod_type(o, type))
3fe9a6f1 1128 goto nomod;
78f9721b
SM		 1129 if (type == OP_LEAVESUBLV)
1130 o->op_private |= OPpMAYBE_LVSUB;
748a9306
LW		 1131 /* FALL THROUGH */
1132 case OP_PADSV:
3280af22 1133 PL_modcount++;
ddeae0f1 1134 if (!type) /* local() */
cea2e8a9 1135 Perl_croak(aTHX_ "Can't localize lexical variable %s",
dd2155a4 1136 PAD_COMPNAME_PV(o->op_targ));
463ee0b2
LW		 1137 break;
1138
748a9306 1139 case OP_PUSHMARK:
ddeae0f1 1140 localize = 0;
748a9306 1141 break;
b2ffa427 1142
69969c6f
SB		 1143 case OP_KEYS:
1144 if (type != OP_SASSIGN)
1145 goto nomod;
5d82c453
GA		 1146 goto lvalue_func;
1147 case OP_SUBSTR:
1148 if (o->op_private == 4) /* don't allow 4 arg substr as lvalue */
1149 goto nomod;
5f05dabc 1150 /* FALL THROUGH */
a0d0e21e 1151 case OP_POS:
463ee0b2 1152 case OP_VEC:
78f9721b
SM		 1153 if (type == OP_LEAVESUBLV)
1154 o->op_private |= OPpMAYBE_LVSUB;
5d82c453 1155 lvalue_func:
11343788
MB		 1156 pad_free(o->op_targ);
1157 o->op_targ = pad_alloc(o->op_type, SVs_PADMY);
5dc0d613 1158 assert(SvTYPE(PAD_SV(o->op_targ)) == SVt_NULL);
11343788
MB		 1159 if (o->op_flags & OPf_KIDS)
1160 mod(cBINOPo->op_first->op_sibling, type);
463ee0b2 1161 break;
a0d0e21e 1162
463ee0b2
LW		 1163 case OP_AELEM:
1164 case OP_HELEM:
11343788 1165 ref(cBINOPo->op_first, o->op_type);
68dc0745 1166 if (type == OP_ENTERSUB &&
5dc0d613
MB		 1167 !(o->op_private & (OPpLVAL_INTRO | OPpDEREF)))
1168 o->op_private |= OPpLVAL_DEFER;
78f9721b
SM		 1169 if (type == OP_LEAVESUBLV)
1170 o->op_private |= OPpMAYBE_LVSUB;
ddeae0f1 1171 localize = 1;
3280af22 1172 PL_modcount++;
463ee0b2
LW		 1173 break;
1174
1175 case OP_SCOPE:
1176 case OP_LEAVE:
1177 case OP_ENTER:
78f9721b 1178 case OP_LINESEQ:
ddeae0f1 1179 localize = 0;
11343788
MB		 1180 if (o->op_flags & OPf_KIDS)
1181 mod(cLISTOPo->op_last, type);
a0d0e21e
LW		 1182 break;
1183
1184 case OP_NULL:
ddeae0f1 1185 localize = 0;
638bc118
GS		 1186 if (o->op_flags & OPf_SPECIAL) /* do BLOCK */
1187 goto nomod;
1188 else if (!(o->op_flags & OPf_KIDS))
463ee0b2 1189 break;
11343788
MB		 1190 if (o->op_targ != OP_LIST) {
1191 mod(cBINOPo->op_first, type);
a0d0e21e
LW		 1192 break;
1193 }
1194 /* FALL THROUGH */
463ee0b2 1195 case OP_LIST:
ddeae0f1 1196 localize = 0;
11343788 1197 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
463ee0b2
LW		 1198 mod(kid, type);
1199 break;
78f9721b
SM		 1200
1201 case OP_RETURN:
1202 if (type != OP_LEAVESUBLV)
1203 goto nomod;
1204 break; /* mod()ing was handled by ck_return() */
463ee0b2 1205 }
58d95175 1206
8be1be90
AMS		 1207 /* [20011101.069] File test operators interpret OPf_REF to mean that
1208 their argument is a filehandle; thus \stat(".") should not set
1209 it. AMS 20011102 */
1210 if (type == OP_REFGEN &&
1211 PL_check[o->op_type] == MEMBER_TO_FPTR(Perl_ck_ftst))
1212 return o;
1213
1214 if (type != OP_LEAVESUBLV)
1215 o->op_flags |= OPf_MOD;
1216
1217 if (type == OP_AASSIGN || type == OP_SASSIGN)
1218 o->op_flags |= OPf_SPECIAL|OPf_REF;
ddeae0f1
DM		 1219 else if (!type) { /* local() */
1220 switch (localize) {
1221 case 1:
1222 o->op_private |= OPpLVAL_INTRO;
1223 o->op_flags &= ~OPf_SPECIAL;
1224 PL_hints |= HINT_BLOCK_SCOPE;
1225 break;
1226 case 0:
1227 break;
1228 case -1:
1229 if (ckWARN(WARN_SYNTAX)) {
1230 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
1231 "Useless localization of %s", OP_DESC(o));
1232 }
1233 }
463ee0b2 1234 }
8be1be90
AMS		 1235 else if (type != OP_GREPSTART && type != OP_ENTERSUB
1236 && type != OP_LEAVESUBLV)
1237 o->op_flags |= OPf_REF;
11343788 1238 return o;
463ee0b2
LW		 1239}
1240
864dbfa3 1241STATIC bool
cea2e8a9 1242S_scalar_mod_type(pTHX_ OP *o, I32 type)
3fe9a6f1 1243{
1244 switch (type) {
1245 case OP_SASSIGN:
5196be3e 1246 if (o->op_type == OP_RV2GV)
3fe9a6f1 1247 return FALSE;
1248 /* FALL THROUGH */
1249 case OP_PREINC:
1250 case OP_PREDEC:
1251 case OP_POSTINC:
1252 case OP_POSTDEC:
1253 case OP_I_PREINC:
1254 case OP_I_PREDEC:
1255 case OP_I_POSTINC:
1256 case OP_I_POSTDEC:
1257 case OP_POW:
1258 case OP_MULTIPLY:
1259 case OP_DIVIDE:
1260 case OP_MODULO:
1261 case OP_REPEAT:
1262 case OP_ADD:
1263 case OP_SUBTRACT:
1264 case OP_I_MULTIPLY:
1265 case OP_I_DIVIDE:
1266 case OP_I_MODULO:
1267 case OP_I_ADD:
1268 case OP_I_SUBTRACT:
1269 case OP_LEFT_SHIFT:
1270 case OP_RIGHT_SHIFT:
1271 case OP_BIT_AND:
1272 case OP_BIT_XOR:
1273 case OP_BIT_OR:
1274 case OP_CONCAT:
1275 case OP_SUBST:
1276 case OP_TRANS:
49e9fbe6
GS		 1277 case OP_READ:
1278 case OP_SYSREAD:
1279 case OP_RECV:
bf4b1e52
GS		 1280 case OP_ANDASSIGN:
1281 case OP_ORASSIGN:
3fe9a6f1 1282 return TRUE;
1283 default:
1284 return FALSE;
1285 }
1286}
1287
35cd451c 1288STATIC bool
cea2e8a9 1289S_is_handle_constructor(pTHX_ OP *o, I32 argnum)
35cd451c
GS		 1290{
1291 switch (o->op_type) {
1292 case OP_PIPE_OP:
1293 case OP_SOCKPAIR:
1294 if (argnum == 2)
1295 return TRUE;
1296 /* FALL THROUGH */
1297 case OP_SYSOPEN:
1298 case OP_OPEN:
ded8aa31 1299 case OP_SELECT: /* XXX c.f. SelectSaver.pm */
35cd451c
GS		 1300 case OP_SOCKET:
1301 case OP_OPEN_DIR:
1302 case OP_ACCEPT:
1303 if (argnum == 1)
1304 return TRUE;
1305 /* FALL THROUGH */
1306 default:
1307 return FALSE;
1308 }
1309}
1310
463ee0b2 1311OP *
864dbfa3 1312Perl_refkids(pTHX_ OP *o, I32 type)
463ee0b2
LW		 1313{
1314 OP *kid;
11343788
MB		 1315 if (o && o->op_flags & OPf_KIDS) {
1316 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
463ee0b2
LW		 1317 ref(kid, type);
1318 }
11343788 1319 return o;
463ee0b2
LW		 1320}
1321
1322OP *
864dbfa3 1323Perl_ref(pTHX_ OP *o, I32 type)
463ee0b2
LW		 1324{
1325 OP *kid;
463ee0b2 1326
3280af22 1327 if (!o || PL_error_count)
11343788 1328 return o;
463ee0b2 1329
11343788 1330 switch (o->op_type) {
a0d0e21e 1331 case OP_ENTERSUB:
afebc493 1332 if ((type == OP_EXISTS || type == OP_DEFINED || type == OP_LOCK) &&
11343788
MB		 1333 !(o->op_flags & OPf_STACKED)) {
1334 o->op_type = OP_RV2CV; /* entersub => rv2cv */
22c35a8c 1335 o->op_ppaddr = PL_ppaddr[OP_RV2CV];
11343788 1336 assert(cUNOPo->op_first->op_type == OP_NULL);
93c66552 1337 op_null(((LISTOP*)cUNOPo->op_first)->op_first); /* disable pushmark */
11343788 1338 o->op_flags |= OPf_SPECIAL;
8990e307
LW		 1339 }
1340 break;
aeea060c 1341
463ee0b2 1342 case OP_COND_EXPR:
11343788 1343 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
463ee0b2
LW		 1344 ref(kid, type);
1345 break;
8990e307 1346 case OP_RV2SV:
35cd451c
GS		 1347 if (type == OP_DEFINED)
1348 o->op_flags |= OPf_SPECIAL; /* don't create GV */
11343788 1349 ref(cUNOPo->op_first, o->op_type);
4633a7c4
LW		 1350 /* FALL THROUGH */
1351 case OP_PADSV:
5f05dabc 1352 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
5dc0d613
MB		 1353 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
1354 : type == OP_RV2HV ? OPpDEREF_HV
1355 : OPpDEREF_SV);
11343788 1356 o->op_flags |= OPf_MOD;
a0d0e21e 1357 }
8990e307 1358 break;
1c846c1f 1359
2faa37cc 1360 case OP_THREADSV:
a863c7d1
MB		 1361 o->op_flags |= OPf_MOD; /* XXX ??? */
1362 break;
1363
463ee0b2
LW		 1364 case OP_RV2AV:
1365 case OP_RV2HV:
aeea060c 1366 o->op_flags |= OPf_REF;
8990e307 1367 /* FALL THROUGH */
463ee0b2 1368 case OP_RV2GV:
35cd451c
GS		 1369 if (type == OP_DEFINED)
1370 o->op_flags |= OPf_SPECIAL; /* don't create GV */
11343788 1371 ref(cUNOPo->op_first, o->op_type);
463ee0b2 1372 break;
8990e307 1373
463ee0b2
LW		 1374 case OP_PADAV:
1375 case OP_PADHV:
aeea060c 1376 o->op_flags |= OPf_REF;
79072805 1377 break;
aeea060c 1378
8990e307 1379 case OP_SCALAR:
79072805 1380 case OP_NULL:
11343788 1381 if (!(o->op_flags & OPf_KIDS))
463ee0b2 1382 break;
11343788 1383 ref(cBINOPo->op_first, type);
79072805
LW		 1384 break;
1385 case OP_AELEM:
1386 case OP_HELEM:
11343788 1387 ref(cBINOPo->op_first, o->op_type);
5f05dabc 1388 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
5dc0d613
MB		 1389 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
1390 : type == OP_RV2HV ? OPpDEREF_HV
1391 : OPpDEREF_SV);
11343788 1392 o->op_flags |= OPf_MOD;
8990e307 1393 }
79072805
LW		 1394 break;
1395
463ee0b2 1396 case OP_SCOPE:
79072805
LW		 1397 case OP_LEAVE:
1398 case OP_ENTER:
8990e307 1399 case OP_LIST:
11343788 1400 if (!(o->op_flags & OPf_KIDS))
79072805 1401 break;
11343788 1402 ref(cLISTOPo->op_last, type);
79072805 1403 break;
a0d0e21e
LW		 1404 default:
1405 break;
79072805 1406 }
11343788 1407 return scalar(o);
8990e307 1408
79072805
LW		 1409}
1410
09bef843
SB		 1411STATIC OP *
1412S_dup_attrlist(pTHX_ OP *o)
1413{
1414 OP *rop = Nullop;
1415
1416 /* An attrlist is either a simple OP_CONST or an OP_LIST with kids,
1417 * where the first kid is OP_PUSHMARK and the remaining ones
1418 * are OP_CONST. We need to push the OP_CONST values.
1419 */
1420 if (o->op_type == OP_CONST)
1421 rop = newSVOP(OP_CONST, o->op_flags, SvREFCNT_inc(cSVOPo->op_sv));
1422 else {
1423 assert((o->op_type == OP_LIST) && (o->op_flags & OPf_KIDS));
1424 for (o = cLISTOPo->op_first; o; o=o->op_sibling) {
1425 if (o->op_type == OP_CONST)
1426 rop = append_elem(OP_LIST, rop,
1427 newSVOP(OP_CONST, o->op_flags,
1428 SvREFCNT_inc(cSVOPo->op_sv)));
1429 }
1430 }
1431 return rop;
1432}
1433
1434STATIC void
95f0a2f1 1435S_apply_attrs(pTHX_ HV *stash, SV *target, OP *attrs, bool for_my)
09bef843 1436{
09bef843
SB		 1437 SV *stashsv;
1438
1439 /* fake up C<use attributes $pkg,$rv,@attrs> */
1440 ENTER; /* need to protect against side-effects of 'use' */
1441 SAVEINT(PL_expect);
a9164de8 1442 if (stash)
09bef843
SB		 1443 stashsv = newSVpv(HvNAME(stash), 0);
1444 else
1445 stashsv = &PL_sv_no;
e4783991 1446
09bef843 1447#define ATTRSMODULE "attributes"
95f0a2f1
SB		 1448#define ATTRSMODULE_PM "attributes.pm"
1449
1450 if (for_my) {
1451 SV **svp;
1452 /* Don't force the C<use> if we don't need it. */
1453 svp = hv_fetch(GvHVn(PL_incgv), ATTRSMODULE_PM,
1454 sizeof(ATTRSMODULE_PM)-1, 0);
1455 if (svp && *svp != &PL_sv_undef)
1456 ; /* already in %INC */
1457 else
1458 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
1459 newSVpvn(ATTRSMODULE, sizeof(ATTRSMODULE)-1),
1460 Nullsv);
1461 }
1462 else {
1463 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
1464 newSVpvn(ATTRSMODULE, sizeof(ATTRSMODULE)-1),
1465 Nullsv,
1466 prepend_elem(OP_LIST,
1467 newSVOP(OP_CONST, 0, stashsv),
1468 prepend_elem(OP_LIST,
1469 newSVOP(OP_CONST, 0,
1470 newRV(target)),
1471 dup_attrlist(attrs))));
1472 }
09bef843
SB		 1473 LEAVE;
1474}
1475
95f0a2f1
SB		 1476STATIC void
1477S_apply_attrs_my(pTHX_ HV *stash, OP *target, OP *attrs, OP **imopsp)
1478{
1479 OP *pack, *imop, *arg;
1480 SV *meth, *stashsv;
1481
1482 if (!attrs)
1483 return;
1484
1485 assert(target->op_type == OP_PADSV ||
1486 target->op_type == OP_PADHV ||
1487 target->op_type == OP_PADAV);
1488
1489 /* Ensure that attributes.pm is loaded. */
dd2155a4 1490 apply_attrs(stash, PAD_SV(target->op_targ), attrs, TRUE);
95f0a2f1
SB		 1491
1492 /* Need package name for method call. */
1493 pack = newSVOP(OP_CONST, 0, newSVpvn(ATTRSMODULE, sizeof(ATTRSMODULE)-1));
1494
1495 /* Build up the real arg-list. */
1496 if (stash)
1497 stashsv = newSVpv(HvNAME(stash), 0);
1498 else
1499 stashsv = &PL_sv_no;
1500 arg = newOP(OP_PADSV, 0);
1501 arg->op_targ = target->op_targ;
1502 arg = prepend_elem(OP_LIST,
1503 newSVOP(OP_CONST, 0, stashsv),
1504 prepend_elem(OP_LIST,
1505 newUNOP(OP_REFGEN, 0,
1506 mod(arg, OP_REFGEN)),
1507 dup_attrlist(attrs)));
1508
1509 /* Fake up a method call to import */
1510 meth = newSVpvn("import", 6);
1511 (void)SvUPGRADE(meth, SVt_PVIV);
1512 (void)SvIOK_on(meth);
5afd6d42 1513 PERL_HASH(SvUVX(meth), SvPVX(meth), SvCUR(meth));
95f0a2f1
SB		 1514 imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL|OPf_WANT_VOID,
1515 append_elem(OP_LIST,
1516 prepend_elem(OP_LIST, pack, list(arg)),
1517 newSVOP(OP_METHOD_NAMED, 0, meth)));
1518 imop->op_private |= OPpENTERSUB_NOMOD;
1519
1520 /* Combine the ops. */
1521 *imopsp = append_elem(OP_LIST, *imopsp, imop);
1522}
1523
1524/*
1525=notfor apidoc apply_attrs_string
1526
1527Attempts to apply a list of attributes specified by the C<attrstr> and
1528C<len> arguments to the subroutine identified by the C<cv> argument which
1529is expected to be associated with the package identified by the C<stashpv>
1530argument (see L<attributes>). It gets this wrong, though, in that it
1531does not correctly identify the boundaries of the individual attribute
1532specifications within C<attrstr>. This is not really intended for the
1533public API, but has to be listed here for systems such as AIX which
1534need an explicit export list for symbols. (It's called from XS code
1535in support of the C<ATTRS:> keyword from F<xsubpp>.) Patches to fix it
1536to respect attribute syntax properly would be welcome.
1537
1538=cut
1539*/
1540
be3174d2
GS		 1541void
1542Perl_apply_attrs_string(pTHX_ char *stashpv, CV *cv,
1543 char *attrstr, STRLEN len)
1544{
1545 OP *attrs = Nullop;
1546
1547 if (!len) {
1548 len = strlen(attrstr);
1549 }
1550
1551 while (len) {
1552 for (; isSPACE(*attrstr) && len; --len, ++attrstr) ;
1553 if (len) {
1554 char *sstr = attrstr;
1555 for (; !isSPACE(*attrstr) && len; --len, ++attrstr) ;
1556 attrs = append_elem(OP_LIST, attrs,
1557 newSVOP(OP_CONST, 0,
1558 newSVpvn(sstr, attrstr-sstr)));
1559 }
1560 }
1561
1562 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
1563 newSVpvn(ATTRSMODULE, sizeof(ATTRSMODULE)-1),
1564 Nullsv, prepend_elem(OP_LIST,
1565 newSVOP(OP_CONST, 0, newSVpv(stashpv,0)),
1566 prepend_elem(OP_LIST,
1567 newSVOP(OP_CONST, 0,
1568 newRV((SV*)cv)),
1569 attrs)));
1570}
1571
09bef843 1572STATIC OP *
95f0a2f1 1573S_my_kid(pTHX_ OP *o, OP *attrs, OP **imopsp)
93a17b20
LW		 1574{
1575 OP *kid;
93a17b20
LW		 1576 I32 type;
1577
3280af22 1578 if (!o || PL_error_count)
11343788 1579 return o;
93a17b20 1580
11343788 1581 type = o->op_type;
93a17b20 1582 if (type == OP_LIST) {
11343788 1583 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
95f0a2f1 1584 my_kid(kid, attrs, imopsp);
dab48698 1585 } else if (type == OP_UNDEF) {
7766148a 1586 return o;
77ca0c92
LW		 1587 } else if (type == OP_RV2SV || /* "our" declaration */
1588 type == OP_RV2AV ||
1589 type == OP_RV2HV) { /* XXX does this let anything illegal in? */
1ce0b88c
RGS		 1590 if (cUNOPo->op_first->op_type != OP_GV) { /* MJD 20011224 */
1591 yyerror(Perl_form(aTHX_ "Can't declare %s in %s",
1592 OP_DESC(o), PL_in_my == KEY_our ? "our" : "my"));
1593 } else if (attrs) {
1594 GV *gv = cGVOPx_gv(cUNOPo->op_first);
1595 PL_in_my = FALSE;
1596 PL_in_my_stash = Nullhv;
1597 apply_attrs(GvSTASH(gv),
1598 (type == OP_RV2SV ? GvSV(gv) :
1599 type == OP_RV2AV ? (SV*)GvAV(gv) :
1600 type == OP_RV2HV ? (SV*)GvHV(gv) : (SV*)gv),
1601 attrs, FALSE);
1602 }
192587c2 1603 o->op_private |= OPpOUR_INTRO;
77ca0c92 1604 return o;
95f0a2f1
SB		 1605 }
1606 else if (type != OP_PADSV &&
93a17b20
LW		 1607 type != OP_PADAV &&
1608 type != OP_PADHV &&
1609 type != OP_PUSHMARK)
1610 {
eb64745e 1611 yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"",
53e06cf0 1612 OP_DESC(o),
eb64745e 1613 PL_in_my == KEY_our ? "our" : "my"));
11343788 1614 return o;
93a17b20 1615 }
09bef843
SB		 1616 else if (attrs && type != OP_PUSHMARK) {
1617 HV *stash;
09bef843 1618
eb64745e
GS		 1619 PL_in_my = FALSE;
1620 PL_in_my_stash = Nullhv;
1621
09bef843 1622 /* check for C<my Dog $spot> when deciding package */
dd2155a4
DM		 1623 stash = PAD_COMPNAME_TYPE(o->op_targ);
1624 if (!stash)
09bef843 1625 stash = PL_curstash;
95f0a2f1 1626 apply_attrs_my(stash, o, attrs, imopsp);
09bef843 1627 }
11343788
MB		 1628 o->op_flags |= OPf_MOD;
1629 o->op_private |= OPpLVAL_INTRO;
1630 return o;
93a17b20
LW		 1631}
1632
1633OP *
09bef843
SB		 1634Perl_my_attrs(pTHX_ OP *o, OP *attrs)
1635{
95f0a2f1
SB		 1636 OP *rops = Nullop;
1637 int maybe_scalar = 0;
1638
d2be0de5 1639/* [perl #17376]: this appears to be premature, and results in code such as
c754c3d7 1640 C< our(%x); > executing in list mode rather than void mode */
d2be0de5 1641#if 0
09bef843
SB		 1642 if (o->op_flags & OPf_PARENS)
1643 list(o);
95f0a2f1
SB		 1644 else
1645 maybe_scalar = 1;
d2be0de5
YST		 1646#else
1647 maybe_scalar = 1;
1648#endif
09bef843
SB		 1649 if (attrs)
1650 SAVEFREEOP(attrs);
95f0a2f1
SB		 1651 o = my_kid(o, attrs, &rops);
1652 if (rops) {
1653 if (maybe_scalar && o->op_type == OP_PADSV) {
1654 o = scalar(append_list(OP_LIST, (LISTOP*)rops, (LISTOP*)o));
1655 o->op_private |= OPpLVAL_INTRO;
1656 }
1657 else
1658 o = append_list(OP_LIST, (LISTOP*)o, (LISTOP*)rops);
1659 }
eb64745e
GS		 1660 PL_in_my = FALSE;
1661 PL_in_my_stash = Nullhv;
1662 return o;
09bef843
SB		 1663}
1664
1665OP *
1666Perl_my(pTHX_ OP *o)
1667{
95f0a2f1 1668 return my_attrs(o, Nullop);
09bef843
SB		 1669}
1670
1671OP *
864dbfa3 1672Perl_sawparens(pTHX_ OP *o)
79072805
LW		 1673{
1674 if (o)
1675 o->op_flags |= OPf_PARENS;
1676 return o;
1677}
1678
1679OP *
864dbfa3 1680Perl_bind_match(pTHX_ I32 type, OP *left, OP *right)
79072805 1681{
11343788 1682 OP *o;
59f00321 1683 bool ismatchop = 0;
79072805 1684
e476b1b5 1685 if (ckWARN(WARN_MISC) &&
599cee73
PM		 1686 (left->op_type == OP_RV2AV ||
1687 left->op_type == OP_RV2HV ||
1688 left->op_type == OP_PADAV ||
1689 left->op_type == OP_PADHV)) {
22c35a8c 1690 char *desc = PL_op_desc[(right->op_type == OP_SUBST ||
599cee73
PM		 1691 right->op_type == OP_TRANS)
1692 ? right->op_type : OP_MATCH];
dff6d3cd
GS		 1693 const char *sample = ((left->op_type == OP_RV2AV ||
1694 left->op_type == OP_PADAV)
1695 ? "@array" : "%hash");
9014280d 1696 Perl_warner(aTHX_ packWARN(WARN_MISC),
1c846c1f 1697 "Applying %s to %s will act on scalar(%s)",
599cee73 1698 desc, sample, sample);
2ae324a7 1699 }
1700
5cc9e5c9
RH		 1701 if (right->op_type == OP_CONST &&
1702 cSVOPx(right)->op_private & OPpCONST_BARE &&
1703 cSVOPx(right)->op_private & OPpCONST_STRICT)
1704 {
1705 no_bareword_allowed(right);
1706 }
1707
59f00321
RGS		 1708 ismatchop = right->op_type == OP_MATCH ||
1709 right->op_type == OP_SUBST ||
1710 right->op_type == OP_TRANS;
1711 if (ismatchop && right->op_private & OPpTARGET_MY) {
1712 right->op_targ = 0;
1713 right->op_private &= ~OPpTARGET_MY;
1714 }
1715 if (!(right->op_flags & OPf_STACKED) && ismatchop) {
79072805 1716 right->op_flags |= OPf_STACKED;
18808301
JH		 1717 if (right->op_type != OP_MATCH &&
1718 ! (right->op_type == OP_TRANS &&
1719 right->op_private & OPpTRANS_IDENTICAL))
463ee0b2 1720 left = mod(left, right->op_type);
79072805 1721 if (right->op_type == OP_TRANS)
11343788 1722 o = newBINOP(OP_NULL, OPf_STACKED, scalar(left), right);
79072805 1723 else
11343788 1724 o = prepend_elem(right->op_type, scalar(left), right);
79072805 1725 if (type == OP_NOT)
11343788
MB		 1726 return newUNOP(OP_NOT, 0, scalar(o));
1727 return o;
79072805
LW		 1728 }
1729 else
1730 return bind_match(type, left,
1731 pmruntime(newPMOP(OP_MATCH, 0), right, Nullop));
1732}
1733
1734OP *
864dbfa3 1735Perl_invert(pTHX_ OP *o)
79072805 1736{
11343788
MB		 1737 if (!o)
1738 return o;
79072805 1739 /* XXX need to optimize away NOT NOT here? Or do we let optimizer do it? */
11343788 1740 return newUNOP(OP_NOT, OPf_SPECIAL, scalar(o));
79072805
LW		 1741}
1742
1743OP *
864dbfa3 1744Perl_scope(pTHX_ OP *o)
79072805
LW		 1745{
1746 if (o) {
3280af22 1747 if (o->op_flags & OPf_PARENS || PERLDB_NOOPT || PL_tainting) {
463ee0b2
LW		 1748 o = prepend_elem(OP_LINESEQ, newOP(OP_ENTER, 0), o);
1749 o->op_type = OP_LEAVE;
22c35a8c 1750 o->op_ppaddr = PL_ppaddr[OP_LEAVE];
463ee0b2 1751 }
fdb22418
HS		 1752 else if (o->op_type == OP_LINESEQ) {
1753 OP *kid;
1754 o->op_type = OP_SCOPE;
1755 o->op_ppaddr = PL_ppaddr[OP_SCOPE];
1756 kid = ((LISTOP*)o)->op_first;
1757 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE)
1758 op_null(kid);
463ee0b2 1759 }
fdb22418
HS		 1760 else
1761 o = newLISTOP(OP_SCOPE, 0, o, Nullop);
79072805
LW		 1762 }
1763 return o;
1764}
1765
b3ac6de7 1766void
864dbfa3 1767Perl_save_hints(pTHX)
b3ac6de7 1768{
3280af22
NIS		 1769 SAVEI32(PL_hints);
1770 SAVESPTR(GvHV(PL_hintgv));
1771 GvHV(PL_hintgv) = newHVhv(GvHV(PL_hintgv));
1772 SAVEFREESV(GvHV(PL_hintgv));
b3ac6de7
IZ		 1773}
1774
a0d0e21e 1775int
864dbfa3 1776Perl_block_start(pTHX_ int full)
79072805 1777{
3280af22 1778 int retval = PL_savestack_ix;
dd2155a4 1779 pad_block_start(full);
b3ac6de7 1780 SAVEHINTS();
3280af22 1781 PL_hints &= ~HINT_BLOCK_SCOPE;
1c846c1f 1782 SAVESPTR(PL_compiling.cop_warnings);
0453d815 1783 if (! specialWARN(PL_compiling.cop_warnings)) {
599cee73
PM		 1784 PL_compiling.cop_warnings = newSVsv(PL_compiling.cop_warnings) ;
1785 SAVEFREESV(PL_compiling.cop_warnings) ;
1786 }
ac27b0f5
NIS		 1787 SAVESPTR(PL_compiling.cop_io);
1788 if (! specialCopIO(PL_compiling.cop_io)) {
1789 PL_compiling.cop_io = newSVsv(PL_compiling.cop_io) ;
1790 SAVEFREESV(PL_compiling.cop_io) ;
1791 }
a0d0e21e
LW		 1792 return retval;
1793}
1794
1795OP*
864dbfa3 1796Perl_block_end(pTHX_ I32 floor, OP *seq)
a0d0e21e 1797{
3280af22 1798 int needblockscope = PL_hints & HINT_BLOCK_SCOPE;
e9f19e3c 1799 OP* retval = scalarseq(seq);
e9818f4e 1800 LEAVE_SCOPE(floor);
eb160463 1801 PL_compiling.op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
a0d0e21e 1802 if (needblockscope)
3280af22 1803 PL_hints |= HINT_BLOCK_SCOPE; /* propagate out */
dd2155a4 1804 pad_leavemy();
a0d0e21e
LW		 1805 return retval;
1806}
1807
76e3520e 1808STATIC OP *
cea2e8a9 1809S_newDEFSVOP(pTHX)
54b9620d 1810{
59f00321
RGS		 1811 I32 offset = pad_findmy("$_");
1812 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS(offset) & SVpad_OUR) {
1813 return newSVREF(newGVOP(OP_GV, 0, PL_defgv));
1814 }
1815 else {
1816 OP *o = newOP(OP_PADSV, 0);
1817 o->op_targ = offset;
1818 return o;
1819 }
54b9620d
MB		 1820}
1821
a0d0e21e 1822void
864dbfa3 1823Perl_newPROG(pTHX_ OP *o)
a0d0e21e 1824{
3280af22 1825 if (PL_in_eval) {
b295d113
TH		 1826 if (PL_eval_root)
1827 return;
faef0170
HS		 1828 PL_eval_root = newUNOP(OP_LEAVEEVAL,
1829 ((PL_in_eval & EVAL_KEEPERR)
1830 ? OPf_SPECIAL : 0), o);
3280af22 1831 PL_eval_start = linklist(PL_eval_root);
7934575e
GS		 1832 PL_eval_root->op_private |= OPpREFCOUNTED;
1833 OpREFCNT_set(PL_eval_root, 1);
3280af22 1834 PL_eval_root->op_next = 0;
a2efc822 1835 CALL_PEEP(PL_eval_start);
a0d0e21e
LW		 1836 }
1837 else {
6be89cf9
AE		 1838 if (o->op_type == OP_STUB) {
1839 PL_comppad_name = 0;
1840 PL_compcv = 0;
2a4f803a 1841 FreeOp(o);
a0d0e21e 1842 return;
6be89cf9 1843 }
3280af22
NIS		 1844 PL_main_root = scope(sawparens(scalarvoid(o)));
1845 PL_curcop = &PL_compiling;
1846 PL_main_start = LINKLIST(PL_main_root);
7934575e
GS		 1847 PL_main_root->op_private |= OPpREFCOUNTED;
1848 OpREFCNT_set(PL_main_root, 1);
3280af22 1849 PL_main_root->op_next = 0;
a2efc822 1850 CALL_PEEP(PL_main_start);
3280af22 1851 PL_compcv = 0;
3841441e 1852
4fdae800 1853 /* Register with debugger */
84902520 1854 if (PERLDB_INTER) {
864dbfa3 1855 CV *cv = get_cv("DB::postponed", FALSE);
3841441e
CS		 1856 if (cv) {
1857 dSP;
924508f0 1858 PUSHMARK(SP);
cc49e20b 1859 XPUSHs((SV*)CopFILEGV(&PL_compiling));
3841441e 1860 PUTBACK;
864dbfa3 1861 call_sv((SV*)cv, G_DISCARD);
3841441e
CS		 1862 }
1863 }
79072805 1864 }
79072805
LW		 1865}
1866
1867OP *
864dbfa3 1868Perl_localize(pTHX_ OP *o, I32 lex)
79072805
LW		 1869{
1870 if (o->op_flags & OPf_PARENS)
d2be0de5
YST		 1871/* [perl #17376]: this appears to be premature, and results in code such as
1872 C< our(%x); > executing in list mode rather than void mode */
1873#if 0
79072805 1874 list(o);
d2be0de5
YST		 1875#else
1876 ;
1877#endif
8990e307 1878 else {
64420d0d
JH		 1879 if (ckWARN(WARN_PARENTHESIS)
1880 && PL_bufptr > PL_oldbufptr && PL_bufptr[-1] == ',')
1881 {
1882 char *s = PL_bufptr;
bac662ee 1883 bool sigil = FALSE;
64420d0d 1884
8473848f 1885 /* some heuristics to detect a potential error */
bac662ee 1886 while (*s && (strchr(", \t\n", *s)))
64420d0d 1887 s++;
8473848f 1888
bac662ee
TS		 1889 while (1) {
1890 if (*s && strchr("@$%*", *s) && *++s
1891 && (isALNUM(*s) || UTF8_IS_CONTINUED(*s))) {
1892 s++;
1893 sigil = TRUE;
1894 while (*s && (isALNUM(*s) || UTF8_IS_CONTINUED(*s)))
1895 s++;
1896 while (*s && (strchr(", \t\n", *s)))
1897 s++;
1898 }
1899 else
1900 break;
1901 }
1902 if (sigil && (*s == ';' || *s == '=')) {
1903 Perl_warner(aTHX_ packWARN(WARN_PARENTHESIS),
8473848f
RGS		 1904 "Parentheses missing around \"%s\" list",
1905 lex ? (PL_in_my == KEY_our ? "our" : "my")
1906 : "local");
1907 }
8990e307
LW		 1908 }
1909 }
93a17b20 1910 if (lex)
eb64745e 1911 o = my(o);
93a17b20 1912 else
eb64745e
GS		 1913 o = mod(o, OP_NULL); /* a bit kludgey */
1914 PL_in_my = FALSE;
1915 PL_in_my_stash = Nullhv;
1916 return o;
79072805
LW		 1917}
1918
1919OP *
864dbfa3 1920Perl_jmaybe(pTHX_ OP *o)
79072805
LW		 1921{
1922 if (o->op_type == OP_LIST) {
554b3eca 1923 OP *o2;
554b3eca 1924 o2 = newSVREF(newGVOP(OP_GV, 0, gv_fetchpv(";", TRUE, SVt_PV))),
554b3eca 1925 o = convert(OP_JOIN, 0, prepend_elem(OP_LIST, o2, o));
79072805
LW		 1926 }
1927 return o;
1928}
1929
1930OP *
864dbfa3 1931Perl_fold_constants(pTHX_ register OP *o)
79072805
LW		 1932{
1933 register OP *curop;
1934 I32 type = o->op_type;
748a9306 1935 SV *sv;
79072805 1936
22c35a8c 1937 if (PL_opargs[type] & OA_RETSCALAR)
79072805 1938 scalar(o);
b162f9ea 1939 if (PL_opargs[type] & OA_TARGET && !o->op_targ)
ed6116ce 1940 o->op_targ = pad_alloc(type, SVs_PADTMP);
79072805 1941
eac055e9
GS		 1942 /* integerize op, unless it happens to be C<-foo>.
1943 * XXX should pp_i_negate() do magic string negation instead? */
1944 if ((PL_opargs[type] & OA_OTHERINT) && (PL_hints & HINT_INTEGER)
1945 && !(type == OP_NEGATE && cUNOPo->op_first->op_type == OP_CONST
1946 && (cUNOPo->op_first->op_private & OPpCONST_BARE)))
1947 {
22c35a8c 1948 o->op_ppaddr = PL_ppaddr[type = ++(o->op_type)];
eac055e9 1949 }
85e6fe83 1950
22c35a8c 1951 if (!(PL_opargs[type] & OA_FOLDCONST))
79072805
LW		 1952 goto nope;
1953
de939608 1954 switch (type) {
7a52d87a
GS		 1955 case OP_NEGATE:
1956 /* XXX might want a ck_negate() for this */
1957 cUNOPo->op_first->op_private &= ~OPpCONST_STRICT;
1958 break;
de939608
CS		 1959 case OP_SPRINTF:
1960 case OP_UCFIRST:
1961 case OP_LCFIRST:
1962 case OP_UC:
1963 case OP_LC:
69dcf70c
MB		 1964 case OP_SLT:
1965 case OP_SGT:
1966 case OP_SLE:
1967 case OP_SGE:
1968 case OP_SCMP:
2de3dbcc
JH		 1969 /* XXX what about the numeric ops? */
1970 if (PL_hints & HINT_LOCALE)
de939608
CS		 1971 goto nope;
1972 }
1973
3280af22 1974 if (PL_error_count)
a0d0e21e
LW		 1975 goto nope; /* Don't try to run w/ errors */
1976
79072805 1977 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
11fa937b
GS		 1978 if ((curop->op_type != OP_CONST ||
1979 (curop->op_private & OPpCONST_BARE)) &&
7a52d87a
GS		 1980 curop->op_type != OP_LIST &&
1981 curop->op_type != OP_SCALAR &&
1982 curop->op_type != OP_NULL &&
1983 curop->op_type != OP_PUSHMARK)
1984 {
79072805
LW		 1985 goto nope;
1986 }
1987 }
1988
1989 curop = LINKLIST(o);
1990 o->op_next = 0;
533c011a 1991 PL_op = curop;
cea2e8a9 1992 CALLRUNOPS(aTHX);
3280af22 1993 sv = *(PL_stack_sp--);
748a9306 1994 if (o->op_targ && sv == PAD_SV(o->op_targ)) /* grab pad temp? */
dd2155a4 1995 pad_swipe(o->op_targ, FALSE);
748a9306
LW		 1996 else if (SvTEMP(sv)) { /* grab mortal temp? */
1997 (void)SvREFCNT_inc(sv);
1998 SvTEMP_off(sv);
85e6fe83 1999 }
79072805
LW		 2000 op_free(o);
2001 if (type == OP_RV2GV)
b1cb66bf 2002 return newGVOP(OP_GV, 0, (GV*)sv);
52a96ae6 2003 return newSVOP(OP_CONST, 0, sv);
aeea060c 2004
79072805 2005 nope:
79072805
LW		 2006 return o;
2007}
2008
2009OP *
864dbfa3 2010Perl_gen_constant_list(pTHX_ register OP *o)
79072805
LW		 2011{
2012 register OP *curop;
3280af22 2013 I32 oldtmps_floor = PL_tmps_floor;
79072805 2014
a0d0e21e 2015 list(o);
3280af22 2016 if (PL_error_count)
a0d0e21e
LW		 2017 return o; /* Don't attempt to run with errors */
2018
533c011a 2019 PL_op = curop = LINKLIST(o);
a0d0e21e 2020 o->op_next = 0;
a2efc822 2021 CALL_PEEP(curop);
cea2e8a9
GS		 2022 pp_pushmark();
2023 CALLRUNOPS(aTHX);
533c011a 2024 PL_op = curop;
cea2e8a9 2025 pp_anonlist();
3280af22 2026 PL_tmps_floor = oldtmps_floor;
79072805
LW		 2027
2028 o->op_type = OP_RV2AV;
22c35a8c 2029 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
fb53bbb2
SG		 2030 o->op_flags &= ~OPf_REF; /* treat \(1..2) like an ordinary list */
2031 o->op_flags |= OPf_PARENS; /* and flatten \(1..2,3) */
2814eb74 2032 o->op_opt = 0; /* needs to be revisited in peep() */
79072805 2033 curop = ((UNOP*)o)->op_first;
3280af22 2034 ((UNOP*)o)->op_first = newSVOP(OP_CONST, 0, SvREFCNT_inc(*PL_stack_sp--));
79072805 2035 op_free(curop);
79072805
LW		 2036 linklist(o);
2037 return list(o);
2038}
2039
2040OP *
864dbfa3 2041Perl_convert(pTHX_ I32 type, I32 flags, OP *o)
79072805 2042{
11343788
MB		 2043 if (!o || o->op_type != OP_LIST)
2044 o = newLISTOP(OP_LIST, 0, o, Nullop);
748a9306 2045 else
5dc0d613 2046 o->op_flags &= ~OPf_WANT;
79072805 2047
22c35a8c 2048 if (!(PL_opargs[type] & OA_MARK))
93c66552 2049 op_null(cLISTOPo->op_first);
8990e307 2050
eb160463 2051 o->op_type = (OPCODE)type;
22c35a8c 2052 o->op_ppaddr = PL_ppaddr[type];
11343788 2053 o->op_flags |= flags;
79072805 2054
11343788
MB		 2055 o = CHECKOP(type, o);
2056 if (o->op_type != type)
2057 return o;
79072805 2058
11343788 2059 return fold_constants(o);
79072805
LW		 2060}
2061
2062/* List constructors */
2063
2064OP *
864dbfa3 2065Perl_append_elem(pTHX_ I32 type, OP *first, OP *last)
79072805
LW		 2066{
2067 if (!first)
2068 return last;
8990e307
LW		 2069
2070 if (!last)
79072805 2071 return first;
8990e307 2072
155aba94
GS		 2073 if (first->op_type != type
2074 || (type == OP_LIST && (first->op_flags & OPf_PARENS)))
2075 {
2076 return newLISTOP(type, 0, first, last);
2077 }
79072805 2078
a0d0e21e
LW		 2079 if (first->op_flags & OPf_KIDS)
2080 ((LISTOP*)first)->op_last->op_sibling = last;
2081 else {
2082 first->op_flags |= OPf_KIDS;
2083 ((LISTOP*)first)->op_first = last;
2084 }
2085 ((LISTOP*)first)->op_last = last;
a0d0e21e 2086 return first;
79072805
LW		 2087}
2088
2089OP *
864dbfa3 2090Perl_append_list(pTHX_ I32 type, LISTOP *first, LISTOP *last)
79072805
LW		 2091{
2092 if (!first)
2093 return (OP*)last;
8990e307
LW		 2094
2095 if (!last)
79072805 2096 return (OP*)first;
8990e307
LW		 2097
2098 if (first->op_type != type)
79072805 2099 return prepend_elem(type, (OP*)first, (OP*)last);
8990e307
LW		 2100
2101 if (last->op_type != type)
79072805
LW		 2102 return append_elem(type, (OP*)first, (OP*)last);
2103
2104 first->op_last->op_sibling = last->op_first;
2105 first->op_last = last->op_last;
117dada2 2106 first->op_flags |= (last->op_flags & OPf_KIDS);
1c846c1f 2107
238a4c30
NIS		 2108 FreeOp(last);
2109
79072805
LW		 2110 return (OP*)first;
2111}
2112
2113OP *
864dbfa3 2114Perl_prepend_elem(pTHX_ I32 type, OP *first, OP *last)
79072805
LW		 2115{
2116 if (!first)
2117 return last;
8990e307
LW		 2118
2119 if (!last)
79072805 2120 return first;
8990e307
LW		 2121
2122 if (last->op_type == type) {
2123 if (type == OP_LIST) { /* already a PUSHMARK there */
2124 first->op_sibling = ((LISTOP*)last)->op_first->op_sibling;
2125 ((LISTOP*)last)->op_first->op_sibling = first;
36a5d4ba
DC		 2126 if (!(first->op_flags & OPf_PARENS))
2127 last->op_flags &= ~OPf_PARENS;
8990e307
LW		 2128 }
2129 else {
2130 if (!(last->op_flags & OPf_KIDS)) {
2131 ((LISTOP*)last)->op_last = first;
2132 last->op_flags |= OPf_KIDS;
2133 }
2134 first->op_sibling = ((LISTOP*)last)->op_first;
2135 ((LISTOP*)last)->op_first = first;
79072805 2136 }
117dada2 2137 last->op_flags |= OPf_KIDS;
79072805
LW		 2138 return last;
2139 }
2140
2141 return newLISTOP(type, 0, first, last);
2142}
2143
2144/* Constructors */
2145
2146OP *
864dbfa3 2147Perl_newNULLLIST(pTHX)
79072805 2148{
8990e307
LW		 2149 return newOP(OP_STUB, 0);
2150}
2151
2152OP *
864dbfa3 2153Perl_force_list(pTHX_ OP *o)
8990e307 2154{
11343788
MB		 2155 if (!o || o->op_type != OP_LIST)
2156 o = newLISTOP(OP_LIST, 0, o, Nullop);
93c66552 2157 op_null(o);
11343788 2158 return o;
79072805
LW		 2159}
2160
2161OP *
864dbfa3 2162Perl_newLISTOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
79072805
LW		 2163{
2164 LISTOP *listop;
2165
b7dc083c 2166 NewOp(1101, listop, 1, LISTOP);
79072805 2167
eb160463 2168 listop->op_type = (OPCODE)type;
22c35a8c 2169 listop->op_ppaddr = PL_ppaddr[type];
117dada2
SM		 2170 if (first || last)
2171 flags |= OPf_KIDS;
eb160463 2172 listop->op_flags = (U8)flags;
79072805
LW		 2173
2174 if (!last && first)
2175 last = first;
2176 else if (!first && last)
2177 first = last;
8990e307
LW		 2178 else if (first)
2179 first->op_sibling = last;
79072805
LW		 2180 listop->op_first = first;
2181 listop->op_last = last;
8990e307
LW		 2182 if (type == OP_LIST) {
2183 OP* pushop;
2184 pushop = newOP(OP_PUSHMARK, 0);
2185 pushop->op_sibling = first;
2186 listop->op_first = pushop;
2187 listop->op_flags |= OPf_KIDS;
2188 if (!last)
2189 listop->op_last = pushop;
2190 }
79072805 2191
463d09e6 2192 return CHECKOP(type, listop);
79072805
LW		 2193}
2194
2195OP *
864dbfa3 2196Perl_newOP(pTHX_ I32 type, I32 flags)
79072805 2197{
11343788 2198 OP *o;
b7dc083c 2199 NewOp(1101, o, 1, OP);
eb160463 2200 o->op_type = (OPCODE)type;
22c35a8c 2201 o->op_ppaddr = PL_ppaddr[type];
eb160463 2202 o->op_flags = (U8)flags;
79072805 2203
11343788 2204 o->op_next = o;
eb160463 2205 o->op_private = (U8)(0 | (flags >> 8));
22c35a8c 2206 if (PL_opargs[type] & OA_RETSCALAR)
11343788 2207 scalar(o);
22c35a8c 2208 if (PL_opargs[type] & OA_TARGET)
11343788
MB		 2209 o->op_targ = pad_alloc(type, SVs_PADTMP);
2210 return CHECKOP(type, o);
79072805
LW		 2211}
2212
2213OP *
864dbfa3 2214Perl_newUNOP(pTHX_ I32 type, I32 flags, OP *first)
79072805
LW		 2215{
2216 UNOP *unop;
2217
93a17b20 2218 if (!first)
aeea060c 2219 first = newOP(OP_STUB, 0);
22c35a8c 2220 if (PL_opargs[type] & OA_MARK)
8990e307 2221 first = force_list(first);
93a17b20 2222
b7dc083c 2223 NewOp(1101, unop, 1, UNOP);
eb160463 2224 unop->op_type = (OPCODE)type;
22c35a8c 2225 unop->op_ppaddr = PL_ppaddr[type];
79072805
LW		 2226 unop->op_first = first;
2227 unop->op_flags = flags | OPf_KIDS;
eb160463 2228 unop->op_private = (U8)(1 | (flags >> 8));
e50aee73 2229 unop = (UNOP*) CHECKOP(type, unop);
79072805
LW		 2230 if (unop->op_next)
2231 return (OP*)unop;
2232
a0d0e21e 2233 return fold_constants((OP *) unop);
79072805
LW		 2234}
2235
2236OP *
864dbfa3 2237Perl_newBINOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
79072805
LW		 2238{
2239 BINOP *binop;
b7dc083c 2240 NewOp(1101, binop, 1, BINOP);
79072805
LW		 2241
2242 if (!first)
2243 first = newOP(OP_NULL, 0);
2244
eb160463 2245 binop->op_type = (OPCODE)type;
22c35a8c 2246 binop->op_ppaddr = PL_ppaddr[type];
79072805
LW		 2247 binop->op_first = first;
2248 binop->op_flags = flags | OPf_KIDS;
2249 if (!last) {
2250 last = first;
eb160463 2251 binop->op_private = (U8)(1 | (flags >> 8));
79072805
LW		 2252 }
2253 else {
eb160463 2254 binop->op_private = (U8)(2 | (flags >> 8));
79072805
LW		 2255 first->op_sibling = last;
2256 }
2257
e50aee73 2258 binop = (BINOP*)CHECKOP(type, binop);
eb160463 2259 if (binop->op_next || binop->op_type != (OPCODE)type)
79072805
LW		 2260 return (OP*)binop;
2261
7284ab6f 2262 binop->op_last = binop->op_first->op_sibling;
79072805 2263
a0d0e21e 2264 return fold_constants((OP *)binop);
79072805
LW		 2265}
2266
a0ed51b3 2267static int
2b9d42f0
NIS		 2268uvcompare(const void *a, const void *b)
2269{
2270 if (*((UV *)a) < (*(UV *)b))
2271 return -1;
2272 if (*((UV *)a) > (*(UV *)b))
2273 return 1;
2274 if (*((UV *)a+1) < (*(UV *)b+1))
2275 return -1;
2276 if (*((UV *)a+1) > (*(UV *)b+1))
2277 return 1;
a0ed51b3
LW		 2278 return 0;
2279}
2280
79072805 2281OP *
864dbfa3 2282Perl_pmtrans(pTHX_ OP *o, OP *expr, OP *repl)
79072805 2283{
79072805
LW		 2284 SV *tstr = ((SVOP*)expr)->op_sv;
2285 SV *rstr = ((SVOP*)repl)->op_sv;
463ee0b2
LW		 2286 STRLEN tlen;
2287 STRLEN rlen;
9b877dbb
IH		 2288 U8 *t = (U8*)SvPV(tstr, tlen);
2289 U8 *r = (U8*)SvPV(rstr, rlen);
79072805
LW		 2290 register I32 i;
2291 register I32 j;
a0ed51b3 2292 I32 del;
79072805 2293 I32 complement;
5d06d08e 2294 I32 squash;
9b877dbb 2295 I32 grows = 0;
79072805
LW		 2296 register short *tbl;
2297
800b4dc4 2298 PL_hints |= HINT_BLOCK_SCOPE;
11343788 2299 complement = o->op_private & OPpTRANS_COMPLEMENT;
a0ed51b3 2300 del = o->op_private & OPpTRANS_DELETE;
5d06d08e 2301 squash = o->op_private & OPpTRANS_SQUASH;
1c846c1f 2302
036b4402
GS		 2303 if (SvUTF8(tstr))
2304 o->op_private |= OPpTRANS_FROM_UTF;
1c846c1f
NIS		 2305
2306 if (SvUTF8(rstr))
036b4402 2307 o->op_private |= OPpTRANS_TO_UTF;
79072805 2308
a0ed51b3 2309 if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
79cb57f6 2310 SV* listsv = newSVpvn("# comment\n",10);
a0ed51b3
LW		 2311 SV* transv = 0;
2312 U8* tend = t + tlen;
2313 U8* rend = r + rlen;
ba210ebe 2314 STRLEN ulen;
84c133a0
RB		 2315 UV tfirst = 1;
2316 UV tlast = 0;
2317 IV tdiff;
2318 UV rfirst = 1;
2319 UV rlast = 0;
2320 IV rdiff;
2321 IV diff;
a0ed51b3
LW		 2322 I32 none = 0;
2323 U32 max = 0;
2324 I32 bits;
a0ed51b3 2325 I32 havefinal = 0;
9c5ffd7c 2326 U32 final = 0;
a0ed51b3
LW		 2327 I32 from_utf = o->op_private & OPpTRANS_FROM_UTF;
2328 I32 to_utf = o->op_private & OPpTRANS_TO_UTF;
bf4a1e57
JH		 2329 U8* tsave = NULL;
2330 U8* rsave = NULL;
2331
2332 if (!from_utf) {
2333 STRLEN len = tlen;
2334 tsave = t = bytes_to_utf8(t, &len);
2335 tend = t + len;
2336 }
2337 if (!to_utf && rlen) {
2338 STRLEN len = rlen;
2339 rsave = r = bytes_to_utf8(r, &len);
2340 rend = r + len;
2341 }
a0ed51b3 2342
2b9d42f0
NIS		 2343/* There are several snags with this code on EBCDIC:
2344 1. 0xFF is a legal UTF-EBCDIC byte (there are no illegal bytes).
2345 2. scan_const() in toke.c has encoded chars in native encoding which makes
2346 ranges at least in EBCDIC 0..255 range the bottom odd.
2347*/
2348
a0ed51b3 2349 if (complement) {
ad391ad9 2350 U8 tmpbuf[UTF8_MAXLEN+1];
2b9d42f0 2351 UV *cp;
a0ed51b3 2352 UV nextmin = 0;
2b9d42f0 2353 New(1109, cp, 2*tlen, UV);
a0ed51b3 2354 i = 0;
79cb57f6 2355 transv = newSVpvn("",0);
a0ed51b3 2356 while (t < tend) {
2b9d42f0
NIS		 2357 cp[2*i] = utf8n_to_uvuni(t, tend-t, &ulen, 0);
2358 t += ulen;
2359 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) {
a0ed51b3 2360 t++;
2b9d42f0
NIS		 2361 cp[2*i+1] = utf8n_to_uvuni(t, tend-t, &ulen, 0);
2362 t += ulen;
a0ed51b3 2363 }
2b9d42f0
NIS		 2364 else {
2365 cp[2*i+1] = cp[2*i];
2366 }
2367 i++;
a0ed51b3 2368 }
2b9d42f0 2369 qsort(cp, i, 2*sizeof(UV), uvcompare);
a0ed51b3 2370 for (j = 0; j < i; j++) {
2b9d42f0 2371 UV val = cp[2*j];
a0ed51b3
LW		 2372 diff = val - nextmin;
2373 if (diff > 0) {
9041c2e3 2374 t = uvuni_to_utf8(tmpbuf,nextmin);
dfe13c55 2375 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
a0ed51b3 2376 if (diff > 1) {
2b9d42f0 2377 U8 range_mark = UTF_TO_NATIVE(0xff);
9041c2e3 2378 t = uvuni_to_utf8(tmpbuf, val - 1);
2b9d42f0 2379 sv_catpvn(transv, (char *)&range_mark, 1);
dfe13c55 2380 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
a0ed51b3
LW		 2381 }
2382 }
2b9d42f0 2383 val = cp[2*j+1];
a0ed51b3
LW		 2384 if (val >= nextmin)
2385 nextmin = val + 1;
2386 }
9041c2e3 2387 t = uvuni_to_utf8(tmpbuf,nextmin);
dfe13c55 2388 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2b9d42f0
NIS		 2389 {
2390 U8 range_mark = UTF_TO_NATIVE(0xff);
2391 sv_catpvn(transv, (char *)&range_mark, 1);
2392 }
b851fbc1
JH		 2393 t = uvuni_to_utf8_flags(tmpbuf, 0x7fffffff,
2394 UNICODE_ALLOW_SUPER);
dfe13c55
GS		 2395 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2396 t = (U8*)SvPVX(transv);
a0ed51b3
LW		 2397 tlen = SvCUR(transv);
2398 tend = t + tlen;
455d824a 2399 Safefree(cp);
a0ed51b3
LW		 2400 }
2401 else if (!rlen && !del) {
2402 r = t; rlen = tlen; rend = tend;
4757a243
LW		 2403 }
2404 if (!squash) {
05d340b8 2405 if ((!rlen && !del) || t == r ||
12ae5dfc 2406 (tlen == rlen && memEQ((char *)t, (char *)r, tlen)))
01ec43d0 2407 {
4757a243 2408 o->op_private |= OPpTRANS_IDENTICAL;
01ec43d0 2409 }
a0ed51b3
LW		 2410 }
2411
2412 while (t < tend || tfirst <= tlast) {
2413 /* see if we need more "t" chars */
2414 if (tfirst > tlast) {
9041c2e3 2415 tfirst = (I32)utf8n_to_uvuni(t, tend - t, &ulen, 0);
a0ed51b3 2416 t += ulen;
2b9d42f0 2417 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) { /* illegal utf8 val indicates range */
ba210ebe 2418 t++;
9041c2e3 2419 tlast = (I32)utf8n_to_uvuni(t, tend - t, &ulen, 0);
a0ed51b3
LW		 2420 t += ulen;
2421 }
2422 else
2423 tlast = tfirst;
2424 }
2425
2426 /* now see if we need more "r" chars */
2427 if (rfirst > rlast) {
2428 if (r < rend) {
9041c2e3 2429 rfirst = (I32)utf8n_to_uvuni(r, rend - r, &ulen, 0);
a0ed51b3 2430 r += ulen;
2b9d42f0 2431 if (r < rend && NATIVE_TO_UTF(*r) == 0xff) { /* illegal utf8 val indicates range */
ba210ebe 2432 r++;
9041c2e3 2433 rlast = (I32)utf8n_to_uvuni(r, rend - r, &ulen, 0);
a0ed51b3
LW		 2434 r += ulen;
2435 }
2436 else
2437 rlast = rfirst;
2438 }
2439 else {
2440 if (!havefinal++)
2441 final = rlast;
2442 rfirst = rlast = 0xffffffff;
2443 }
2444 }
2445
2446 /* now see which range will peter our first, if either. */
2447 tdiff = tlast - tfirst;
2448 rdiff = rlast - rfirst;
2449
2450 if (tdiff <= rdiff)
2451 diff = tdiff;
2452 else
2453 diff = rdiff;
2454
2455 if (rfirst == 0xffffffff) {
2456 diff = tdiff; /* oops, pretend rdiff is infinite */
2457 if (diff > 0)
894356b3
GS		 2458 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\tXXXX\n",
2459 (long)tfirst, (long)tlast);
a0ed51b3 2460 else
894356b3 2461 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\tXXXX\n", (long)tfirst);
a0ed51b3
LW		 2462 }
2463 else {
2464 if (diff > 0)
894356b3
GS		 2465 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\t%04lx\n",
2466 (long)tfirst, (long)(tfirst + diff),
2467 (long)rfirst);
a0ed51b3 2468 else
894356b3
GS		 2469 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\t%04lx\n",
2470 (long)tfirst, (long)rfirst);
a0ed51b3
LW		 2471
2472 if (rfirst + diff > max)
2473 max = rfirst + diff;
9b877dbb 2474 if (!grows)
45005bfb
JH		 2475 grows = (tfirst < rfirst &&
2476 UNISKIP(tfirst) < UNISKIP(rfirst + diff));
2477 rfirst += diff + 1;
a0ed51b3
LW		 2478 }
2479 tfirst += diff + 1;
2480 }
2481
2482 none = ++max;
2483 if (del)
2484 del = ++max;
2485
2486 if (max > 0xffff)
2487 bits = 32;
2488 else if (max > 0xff)
2489 bits = 16;
2490 else
2491 bits = 8;
2492
455d824a 2493 Safefree(cPVOPo->op_pv);
a0ed51b3
LW		 2494 cSVOPo->op_sv = (SV*)swash_init("utf8", "", listsv, bits, none);
2495 SvREFCNT_dec(listsv);
2496 if (transv)
2497 SvREFCNT_dec(transv);
2498
45005bfb 2499 if (!del && havefinal && rlen)
b448e4fe
JH		 2500 (void)hv_store((HV*)SvRV((cSVOPo->op_sv)), "FINAL", 5,
2501 newSVuv((UV)final), 0);
a0ed51b3 2502
9b877dbb 2503 if (grows)
a0ed51b3
LW		 2504 o->op_private |= OPpTRANS_GROWS;
2505
9b877dbb
IH		 2506 if (tsave)
2507 Safefree(tsave);
2508 if (rsave)
2509 Safefree(rsave);
2510
a0ed51b3
LW		 2511 op_free(expr);
2512 op_free(repl);
2513 return o;
2514 }
2515
2516 tbl = (short*)cPVOPo->op_pv;
79072805
LW		 2517 if (complement) {
2518 Zero(tbl, 256, short);
eb160463 2519 for (i = 0; i < (I32)tlen; i++)
ec49126f 2520 tbl[t[i]] = -1;
79072805
LW		 2521 for (i = 0, j = 0; i < 256; i++) {
2522 if (!tbl[i]) {
eb160463 2523 if (j >= (I32)rlen) {
a0ed51b3 2524 if (del)
79072805
LW		 2525 tbl[i] = -2;
2526 else if (rlen)
ec49126f 2527 tbl[i] = r[j-1];
79072805 2528 else
eb160463 2529 tbl[i] = (short)i;
79072805 2530 }
9b877dbb
IH		 2531 else {
2532 if (i < 128 && r[j] >= 128)
2533 grows = 1;
ec49126f 2534 tbl[i] = r[j++];
9b877dbb 2535 }
79072805
LW		 2536 }
2537 }
05d340b8
JH		 2538 if (!del) {
2539 if (!rlen) {
2540 j = rlen;
2541 if (!squash)
2542 o->op_private |= OPpTRANS_IDENTICAL;
2543 }
eb160463 2544 else if (j >= (I32)rlen)
05d340b8
JH		 2545 j = rlen - 1;
2546 else
2547 cPVOPo->op_pv = (char*)Renew(tbl, 0x101+rlen-j, short);
8973db79 2548 tbl[0x100] = rlen - j;
eb160463 2549 for (i=0; i < (I32)rlen - j; i++)
8973db79
JH		 2550 tbl[0x101+i] = r[j+i];
2551 }
79072805
LW		 2552 }
2553 else {
a0ed51b3 2554 if (!rlen && !del) {
79072805 2555 r = t; rlen = tlen;
5d06d08e 2556 if (!squash)
4757a243 2557 o->op_private |= OPpTRANS_IDENTICAL;
79072805 2558 }
94bfe852
RGS		 2559 else if (!squash && rlen == tlen && memEQ((char*)t, (char*)r, tlen)) {
2560 o->op_private |= OPpTRANS_IDENTICAL;
2561 }
79072805
LW		 2562 for (i = 0; i < 256; i++)
2563 tbl[i] = -1;
eb160463
GS		 2564 for (i = 0, j = 0; i < (I32)tlen; i++,j++) {
2565 if (j >= (I32)rlen) {
a0ed51b3 2566 if (del) {
ec49126f 2567 if (tbl[t[i]] == -1)
2568 tbl[t[i]] = -2;
79072805
LW		 2569 continue;
2570 }
2571 --j;
2572 }
9b877dbb
IH		 2573 if (tbl[t[i]] == -1) {
2574 if (t[i] < 128 && r[j] >= 128)
2575 grows = 1;
ec49126f 2576 tbl[t[i]] = r[j];
9b877dbb 2577 }
79072805
LW		 2578 }
2579 }
9b877dbb
IH		 2580 if (grows)
2581 o->op_private |= OPpTRANS_GROWS;
79072805
LW		 2582 op_free(expr);
2583 op_free(repl);
2584
11343788 2585 return o;
79072805
LW		 2586}
2587
2588OP *
864dbfa3 2589Perl_newPMOP(pTHX_ I32 type, I32 flags)
79072805
LW		 2590{
2591 PMOP *pmop;
2592
b7dc083c 2593 NewOp(1101, pmop, 1, PMOP);
eb160463 2594 pmop->op_type = (OPCODE)type;
22c35a8c 2595 pmop->op_ppaddr = PL_ppaddr[type];
eb160463
GS		 2596 pmop->op_flags = (U8)flags;
2597 pmop->op_private = (U8)(0 | (flags >> 8));
79072805 2598
3280af22 2599 if (PL_hints & HINT_RE_TAINT)
b3eb6a9b 2600 pmop->op_pmpermflags |= PMf_RETAINT;
3280af22 2601 if (PL_hints & HINT_LOCALE)
b3eb6a9b
GS		 2602 pmop->op_pmpermflags |= PMf_LOCALE;
2603 pmop->op_pmflags = pmop->op_pmpermflags;
36477c24 2604
debc9467 2605#ifdef USE_ITHREADS
13137afc
AB		 2606 {
2607 SV* repointer;
2608 if(av_len((AV*) PL_regex_pad[0]) > -1) {
2609 repointer = av_pop((AV*)PL_regex_pad[0]);
2610 pmop->op_pmoffset = SvIV(repointer);
1cc8b4c5 2611 SvREPADTMP_off(repointer);
13137afc 2612 sv_setiv(repointer,0);
1eb1540c 2613 } else {
13137afc
AB		 2614 repointer = newSViv(0);
2615 av_push(PL_regex_padav,SvREFCNT_inc(repointer));
2616 pmop->op_pmoffset = av_len(PL_regex_padav);
2617 PL_regex_pad = AvARRAY(PL_regex_padav);
1fcf4c12 2618 }
13137afc 2619 }
debc9467 2620#endif
1eb1540c 2621
1fcf4c12 2622 /* link into pm list */
3280af22
NIS		 2623 if (type != OP_TRANS && PL_curstash) {
2624 pmop->op_pmnext = HvPMROOT(PL_curstash);
2625 HvPMROOT(PL_curstash) = pmop;
cb55de95 2626 PmopSTASH_set(pmop,PL_curstash);
79072805
LW		 2627 }
2628
463d09e6 2629 return CHECKOP(type, pmop);
79072805
LW		 2630}
2631
2632OP *
864dbfa3 2633Perl_pmruntime(pTHX_ OP *o, OP *expr, OP *repl)
79072805
LW		 2634{
2635 PMOP *pm;
2636 LOGOP *rcop;
ce862d02 2637 I32 repl_has_vars = 0;
79072805 2638
11343788
MB		 2639 if (o->op_type == OP_TRANS)
2640 return pmtrans(o, expr, repl);
79072805 2641
3280af22 2642 PL_hints |= HINT_BLOCK_SCOPE;
11343788 2643 pm = (PMOP*)o;
79072805
LW		 2644
2645 if (expr->op_type == OP_CONST) {
463ee0b2 2646 STRLEN plen;
79072805 2647 SV *pat = ((SVOP*)expr)->op_sv;
463ee0b2 2648 char *p = SvPV(pat, plen);
11343788 2649 if ((o->op_flags & OPf_SPECIAL) && strEQ(p, " ")) {
93a17b20 2650 sv_setpvn(pat, "\\s+", 3);
463ee0b2 2651 p = SvPV(pat, plen);
79072805
LW		 2652 pm->op_pmflags |= PMf_SKIPWHITE;
2653 }
5b71a6a7 2654 if (DO_UTF8(pat))
a5961de5 2655 pm->op_pmdynflags |= PMdf_UTF8;
aaa362c4
RS		 2656 PM_SETRE(pm, CALLREGCOMP(aTHX_ p, p + plen, pm));
2657 if (strEQ("\\s+", PM_GETRE(pm)->precomp))
85e6fe83 2658 pm->op_pmflags |= PMf_WHITE;
79072805
LW		 2659 op_free(expr);
2660 }
2661 else {
3280af22 2662 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL))
1c846c1f 2663 expr = newUNOP((!(PL_hints & HINT_RE_EVAL)
2cd61cdb
IZ		 2664 ? OP_REGCRESET
2665 : OP_REGCMAYBE),0,expr);
463ee0b2 2666
b7dc083c 2667 NewOp(1101, rcop, 1, LOGOP);
79072805 2668 rcop->op_type = OP_REGCOMP;
22c35a8c 2669 rcop->op_ppaddr = PL_ppaddr[OP_REGCOMP];
79072805 2670 rcop->op_first = scalar(expr);
1c846c1f 2671 rcop->op_flags |= ((PL_hints & HINT_RE_EVAL)
2cd61cdb
IZ		 2672 ? (OPf_SPECIAL | OPf_KIDS)
2673 : OPf_KIDS);
79072805 2674 rcop->op_private = 1;
11343788 2675 rcop->op_other = o;
b5c19bd7
DM		 2676 /* /$x/ may cause an eval, since $x might be qr/(?{..})/ */
2677 PL_cv_has_eval = 1;
79072805
LW		 2678
2679 /* establish postfix order */
3280af22 2680 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL)) {
463ee0b2
LW		 2681 LINKLIST(expr);
2682 rcop->op_next = expr;
2683 ((UNOP*)expr)->op_first->op_next = (OP*)rcop;
2684 }
2685 else {
2686 rcop->op_next = LINKLIST(expr);
2687 expr->op_next = (OP*)rcop;
2688 }
79072805 2689
11343788 2690 prepend_elem(o->op_type, scalar((OP*)rcop), o);
79072805
LW		 2691 }
2692
2693 if (repl) {
748a9306 2694 OP *curop;
0244c3a4 2695 if (pm->op_pmflags & PMf_EVAL) {
748a9306 2696 curop = 0;
8bafa735 2697 if (CopLINE(PL_curcop) < (line_t)PL_multi_end)
eb160463 2698 CopLINE_set(PL_curcop, (line_t)PL_multi_end);
0244c3a4 2699 }
748a9306
LW		 2700 else if (repl->op_type == OP_CONST)
2701 curop = repl;
79072805 2702 else {
79072805
LW		 2703 OP *lastop = 0;
2704 for (curop = LINKLIST(repl); curop!=repl; curop = LINKLIST(curop)) {
22c35a8c 2705 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
79072805 2706 if (curop->op_type == OP_GV) {
638eceb6 2707 GV *gv = cGVOPx_gv(curop);
ce862d02 2708 repl_has_vars = 1;
f702bf4a 2709 if (strchr("&`'123456789+-\016\022", *GvENAME(gv)))
79072805
LW		 2710 break;
2711 }
2712 else if (curop->op_type == OP_RV2CV)
2713 break;
2714 else if (curop->op_type == OP_RV2SV ||
2715 curop->op_type == OP_RV2AV ||
2716 curop->op_type == OP_RV2HV ||
2717 curop->op_type == OP_RV2GV) {
2718 if (lastop && lastop->op_type != OP_GV) /*funny deref?*/
2719 break;
2720 }
748a9306
LW		 2721 else if (curop->op_type == OP_PADSV ||
2722 curop->op_type == OP_PADAV ||
2723 curop->op_type == OP_PADHV ||
554b3eca 2724 curop->op_type == OP_PADANY) {
ce862d02 2725 repl_has_vars = 1;
748a9306 2726 }
1167e5da
SM		 2727 else if (curop->op_type == OP_PUSHRE)
2728 ; /* Okay here, dangerous in newASSIGNOP */
79072805
LW		 2729 else
2730 break;
2731 }
2732 lastop = curop;
2733 }
748a9306 2734 }
ce862d02 2735 if (curop == repl
1c846c1f 2736 && !(repl_has_vars
aaa362c4
RS		 2737 && (!PM_GETRE(pm)
2738 || PM_GETRE(pm)->reganch & ROPT_EVAL_SEEN))) {
748a9306 2739 pm->op_pmflags |= PMf_CONST; /* const for long enough */
4633a7c4 2740 pm->op_pmpermflags |= PMf_CONST; /* const for long enough */
11343788 2741 prepend_elem(o->op_type, scalar(repl), o);
748a9306
LW		 2742 }
2743 else {
aaa362c4 2744 if (curop == repl && !PM_GETRE(pm)) { /* Has variables. */
ce862d02
IZ		 2745 pm->op_pmflags |= PMf_MAYBE_CONST;
2746 pm->op_pmpermflags |= PMf_MAYBE_CONST;
2747 }
b7dc083c 2748 NewOp(1101, rcop, 1, LOGOP);
748a9306 2749 rcop->op_type = OP_SUBSTCONT;
22c35a8c 2750 rcop->op_ppaddr = PL_ppaddr[OP_SUBSTCONT];
748a9306
LW		 2751 rcop->op_first = scalar(repl);
2752 rcop->op_flags |= OPf_KIDS;
2753 rcop->op_private = 1;
11343788 2754 rcop->op_other = o;
748a9306
LW		 2755
2756 /* establish postfix order */
2757 rcop->op_next = LINKLIST(repl);
2758 repl->op_next = (OP*)rcop;
2759
2760 pm->op_pmreplroot = scalar((OP*)rcop);
2761 pm->op_pmreplstart = LINKLIST(rcop);
2762 rcop->op_next = 0;
79072805
LW		 2763 }
2764 }
2765
2766 return (OP*)pm;
2767}
2768
2769OP *
864dbfa3 2770Perl_newSVOP(pTHX_ I32 type, I32 flags, SV *sv)
79072805
LW		 2771{
2772 SVOP *svop;
b7dc083c 2773 NewOp(1101, svop, 1, SVOP);
eb160463 2774 svop->op_type = (OPCODE)type;
22c35a8c 2775 svop->op_ppaddr = PL_ppaddr[type];
79072805
LW		 2776 svop->op_sv = sv;
2777 svop->op_next = (OP*)svop;
eb160463 2778 svop->op_flags = (U8)flags;
22c35a8c 2779 if (PL_opargs[type] & OA_RETSCALAR)
463ee0b2 2780 scalar((OP*)svop);
22c35a8c 2781 if (PL_opargs[type] & OA_TARGET)
ed6116ce 2782 svop->op_targ = pad_alloc(type, SVs_PADTMP);
e50aee73 2783 return CHECKOP(type, svop);
79072805
LW		 2784}
2785
2786OP *
350de78d
GS		 2787Perl_newPADOP(pTHX_ I32 type, I32 flags, SV *sv)
2788{
2789 PADOP *padop;
2790 NewOp(1101, padop, 1, PADOP);
eb160463 2791 padop->op_type = (OPCODE)type;
350de78d
GS		 2792 padop->op_ppaddr = PL_ppaddr[type];
2793 padop->op_padix = pad_alloc(type, SVs_PADTMP);
dd2155a4
DM		 2794 SvREFCNT_dec(PAD_SVl(padop->op_padix));
2795 PAD_SETSV(padop->op_padix, sv);
ce50c033
AMS		 2796 if (sv)
2797 SvPADTMP_on(sv);
350de78d 2798 padop->op_next = (OP*)padop;
eb160463 2799 padop->op_flags = (U8)flags;
350de78d
GS		 2800 if (PL_opargs[type] & OA_RETSCALAR)
2801 scalar((OP*)padop);
2802 if (PL_opargs[type] & OA_TARGET)
2803 padop->op_targ = pad_alloc(type, SVs_PADTMP);
2804 return CHECKOP(type, padop);
2805}
2806
2807OP *
864dbfa3 2808Perl_newGVOP(pTHX_ I32 type, I32 flags, GV *gv)
79072805 2809{
350de78d 2810#ifdef USE_ITHREADS
ce50c033
AMS		 2811 if (gv)
2812 GvIN_PAD_on(gv);
350de78d
GS		 2813 return newPADOP(type, flags, SvREFCNT_inc(gv));
2814#else
7934575e 2815 return newSVOP(type, flags, SvREFCNT_inc(gv));
350de78d 2816#endif
79072805
LW		 2817}
2818
2819OP *
864dbfa3 2820Perl_newPVOP(pTHX_ I32 type, I32 flags, char *pv)
79072805
LW		 2821{
2822 PVOP *pvop;
b7dc083c 2823 NewOp(1101, pvop, 1, PVOP);
eb160463 2824 pvop->op_type = (OPCODE)type;
22c35a8c 2825 pvop->op_ppaddr = PL_ppaddr[type];
79072805
LW		 2826 pvop->op_pv = pv;
2827 pvop->op_next = (OP*)pvop;
eb160463 2828 pvop->op_flags = (U8)flags;
22c35a8c 2829 if (PL_opargs[type] & OA_RETSCALAR)
463ee0b2 2830 scalar((OP*)pvop);
22c35a8c 2831 if (PL_opargs[type] & OA_TARGET)
ed6116ce 2832 pvop->op_targ = pad_alloc(type, SVs_PADTMP);
e50aee73 2833 return CHECKOP(type, pvop);
79072805
LW		 2834}
2835
79072805 2836void
864dbfa3 2837Perl_package(pTHX_ OP *o)
79072805 2838{
de11ba31
AMS		 2839 char *name;
2840 STRLEN len;
79072805 2841
3280af22
NIS		 2842 save_hptr(&PL_curstash);
2843 save_item(PL_curstname);
de11ba31
AMS		 2844
2845 name = SvPV(cSVOPo->op_sv, len);
2846 PL_curstash = gv_stashpvn(name, len, TRUE);
2847 sv_setpvn(PL_curstname, name, len);
2848 op_free(o);
2849
7ad382f4 2850 PL_hints |= HINT_BLOCK_SCOPE;
3280af22
NIS		 2851 PL_copline = NOLINE;
2852 PL_expect = XSTATE;
79072805
LW		 2853}
2854
85e6fe83 2855void
88d95a4d 2856Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *idop, OP *arg)
85e6fe83 2857{
a0d0e21e 2858 OP *pack;
a0d0e21e 2859 OP *imop;
b1cb66bf 2860 OP *veop;
85e6fe83 2861
88d95a4d 2862 if (idop->op_type != OP_CONST)
cea2e8a9 2863 Perl_croak(aTHX_ "Module name must be constant");
85e6fe83 2864
b1cb66bf 2865 veop = Nullop;
2866
0f79a09d 2867 if (version != Nullop) {
b1cb66bf 2868 SV *vesv = ((SVOP*)version)->op_sv;
2869
44dcb63b 2870 if (arg == Nullop && !SvNIOKp(vesv)) {
b1cb66bf 2871 arg = version;
2872 }
2873 else {
2874 OP *pack;
0f79a09d 2875 SV *meth;
b1cb66bf 2876
44dcb63b 2877 if (version->op_type != OP_CONST || !SvNIOKp(vesv))
cea2e8a9 2878 Perl_croak(aTHX_ "Version number must be constant number");
b1cb66bf 2879
88d95a4d
JH		 2880 /* Make copy of idop so we don't free it twice */
2881 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
b1cb66bf 2882
2883 /* Fake up a method call to VERSION */
0f79a09d
GS		 2884 meth = newSVpvn("VERSION",7);
2885 sv_upgrade(meth, SVt_PVIV);
155aba94 2886 (void)SvIOK_on(meth);
5afd6d42 2887 PERL_HASH(SvUVX(meth), SvPVX(meth), SvCUR(meth));
b1cb66bf 2888 veop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
2889 append_elem(OP_LIST,
0f79a09d
GS		 2890 prepend_elem(OP_LIST, pack, list(version)),
2891 newSVOP(OP_METHOD_NAMED, 0, meth)));
b1cb66bf 2892 }
2893 }
aeea060c 2894
a0d0e21e 2895 /* Fake up an import/unimport */
4633a7c4
LW		 2896 if (arg && arg->op_type == OP_STUB)
2897 imop = arg; /* no import on explicit () */
88d95a4d 2898 else if (SvNIOKp(((SVOP*)idop)->op_sv)) {
b1cb66bf 2899 imop = Nullop; /* use 5.0; */
2900 }
4633a7c4 2901 else {
0f79a09d
GS		 2902 SV *meth;
2903
88d95a4d
JH		 2904 /* Make copy of idop so we don't free it twice */
2905 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
0f79a09d
GS		 2906
2907 /* Fake up a method call to import/unimport */
b47cad08 2908 meth = aver ? newSVpvn("import",6) : newSVpvn("unimport", 8);
ad4c42df 2909 (void)SvUPGRADE(meth, SVt_PVIV);
155aba94 2910 (void)SvIOK_on(meth);
5afd6d42 2911 PERL_HASH(SvUVX(meth), SvPVX(meth), SvCUR(meth));
4633a7c4 2912 imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
0f79a09d
GS		 2913 append_elem(OP_LIST,
2914 prepend_elem(OP_LIST, pack, list(arg)),
2915 newSVOP(OP_METHOD_NAMED, 0, meth)));
4633a7c4
LW		 2916 }
2917
a0d0e21e 2918 /* Fake up the BEGIN {}, which does its thing immediately. */
09bef843 2919 newATTRSUB(floor,
79cb57f6 2920 newSVOP(OP_CONST, 0, newSVpvn("BEGIN", 5)),
4633a7c4 2921 Nullop,
09bef843 2922 Nullop,
a0d0e21e 2923 append_elem(OP_LINESEQ,
b1cb66bf 2924 append_elem(OP_LINESEQ,
88d95a4d 2925 newSTATEOP(0, Nullch, newUNOP(OP_REQUIRE, 0, idop)),
b1cb66bf 2926 newSTATEOP(0, Nullch, veop)),
a0d0e21e 2927 newSTATEOP(0, Nullch, imop) ));
85e6fe83 2928
70f5e4ed
JH		 2929 /* The "did you use incorrect case?" warning used to be here.
2930 * The problem is that on case-insensitive filesystems one
2931 * might get false positives for "use" (and "require"):
2932 * "use Strict" or "require CARP" will work. This causes
2933 * portability problems for the script: in case-strict
2934 * filesystems the script will stop working.
2935 *
2936 * The "incorrect case" warning checked whether "use Foo"
2937 * imported "Foo" to your namespace, but that is wrong, too:
2938 * there is no requirement nor promise in the language that
2939 * a Foo.pm should or would contain anything in package "Foo".
2940 *
2941 * There is very little Configure-wise that can be done, either:
2942 * the case-sensitivity of the build filesystem of Perl does not
2943 * help in guessing the case-sensitivity of the runtime environment.
2944 */
18fc9488 2945
c305c6a0 2946 PL_hints |= HINT_BLOCK_SCOPE;
3280af22
NIS		 2947 PL_copline = NOLINE;
2948 PL_expect = XSTATE;
8ec8fbef 2949 PL_cop_seqmax++; /* Purely for B::*'s benefit */
85e6fe83
LW		 2950}
2951
7d3fb230 2952/*
ccfc67b7
JH		 2953=head1 Embedding Functions
2954
7d3fb230
BS		 2955=for apidoc load_module
2956
2957Loads the module whose name is pointed to by the string part of name.
2958Note that the actual module name, not its filename, should be given.
2959Eg, "Foo::Bar" instead of "Foo/Bar.pm". flags can be any of
2960PERL_LOADMOD_DENY, PERL_LOADMOD_NOIMPORT, or PERL_LOADMOD_IMPORT_OPS
2961(or 0 for no flags). ver, if specified, provides version semantics
2962similar to C<use Foo::Bar VERSION>. The optional trailing SV*
2963arguments can be used to specify arguments to the module's import()
2964method, similar to C<use Foo::Bar VERSION LIST>.
2965
2966=cut */
2967
e4783991
GS		 2968void
2969Perl_load_module(pTHX_ U32 flags, SV *name, SV *ver, ...)
2970{
2971 va_list args;
2972 va_start(args, ver);
2973 vload_module(flags, name, ver, &args);
2974 va_end(args);
2975}
2976
2977#ifdef PERL_IMPLICIT_CONTEXT
2978void
2979Perl_load_module_nocontext(U32 flags, SV *name, SV *ver, ...)
2980{
2981 dTHX;
2982 va_list args;
2983 va_start(args, ver);
2984 vload_module(flags, name, ver, &args);
2985 va_end(args);
2986}
2987#endif
2988
2989void
2990Perl_vload_module(pTHX_ U32 flags, SV *name, SV *ver, va_list *args)
2991{
2992 OP *modname, *veop, *imop;
2993
2994 modname = newSVOP(OP_CONST, 0, name);
2995 modname->op_private |= OPpCONST_BARE;
2996 if (ver) {
2997 veop = newSVOP(OP_CONST, 0, ver);
2998 }
2999 else
3000 veop = Nullop;
3001 if (flags & PERL_LOADMOD_NOIMPORT) {
3002 imop = sawparens(newNULLLIST());
3003 }
3004 else if (flags & PERL_LOADMOD_IMPORT_OPS) {
3005 imop = va_arg(*args, OP*);
3006 }
3007 else {
3008 SV *sv;
3009 imop = Nullop;
3010 sv = va_arg(*args, SV*);
3011 while (sv) {
3012 imop = append_elem(OP_LIST, imop, newSVOP(OP_CONST, 0, sv));
3013 sv = va_arg(*args, SV*);
3014 }
3015 }
81885997
GS		 3016 {
3017 line_t ocopline = PL_copline;
834a3ffa 3018 COP *ocurcop = PL_curcop;
81885997
GS		 3019 int oexpect = PL_expect;
3020
3021 utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(FALSE, 0),
3022 veop, modname, imop);
3023 PL_expect = oexpect;
3024 PL_copline = ocopline;
834a3ffa 3025 PL_curcop = ocurcop;
81885997 3026 }
e4783991
GS		 3027}
3028
79072805 3029OP *
864dbfa3 3030Perl_dofile(pTHX_ OP *term)
78ca652e
GS		 3031{
3032 OP *doop;
3033 GV *gv;
3034
3035 gv = gv_fetchpv("do", FALSE, SVt_PVCV);
b9f751c0 3036 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv)))
78ca652e
GS		 3037 gv = gv_fetchpv("CORE::GLOBAL::do", FALSE, SVt_PVCV);
3038
b9f751c0 3039 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
78ca652e
GS		 3040 doop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
3041 append_elem(OP_LIST, term,
3042 scalar(newUNOP(OP_RV2CV, 0,
3043 newGVOP(OP_GV, 0,
3044 gv))))));
3045 }
3046 else {
3047 doop = newUNOP(OP_DOFILE, 0, scalar(term));
3048 }
3049 return doop;
3050}
3051
3052OP *
864dbfa3 3053Perl_newSLICEOP(pTHX_ I32 flags, OP *subscript, OP *listval)
79072805
LW		 3054{
3055 return newBINOP(OP_LSLICE, flags,
8990e307
LW		 3056 list(force_list(subscript)),
3057 list(force_list(listval)) );
79072805
LW		 3058}
3059
76e3520e 3060STATIC I32
cea2e8a9 3061S_list_assignment(pTHX_ register OP *o)
79072805 3062{
11343788 3063 if (!o)
79072805
LW		 3064 return TRUE;
3065
11343788
MB		 3066 if (o->op_type == OP_NULL && o->op_flags & OPf_KIDS)
3067 o = cUNOPo->op_first;
79072805 3068
11343788 3069 if (o->op_type == OP_COND_EXPR) {
1a67a97c
SM		 3070 I32 t = list_assignment(cLOGOPo->op_first->op_sibling);
3071 I32 f = list_assignment(cLOGOPo->op_first->op_sibling->op_sibling);
79072805
LW		 3072
3073 if (t && f)
3074 return TRUE;
3075 if (t || f)
3076 yyerror("Assignment to both a list and a scalar");
3077 return FALSE;
3078 }
3079
95f0a2f1
SB		 3080 if (o->op_type == OP_LIST &&
3081 (o->op_flags & OPf_WANT) == OPf_WANT_SCALAR &&
3082 o->op_private & OPpLVAL_INTRO)
3083 return FALSE;
3084
11343788
MB		 3085 if (o->op_type == OP_LIST || o->op_flags & OPf_PARENS ||
3086 o->op_type == OP_RV2AV || o->op_type == OP_RV2HV ||
3087 o->op_type == OP_ASLICE || o->op_type == OP_HSLICE)
79072805
LW		 3088 return TRUE;
3089
11343788 3090 if (o->op_type == OP_PADAV || o->op_type == OP_PADHV)
93a17b20
LW		 3091 return TRUE;
3092
11343788 3093 if (o->op_type == OP_RV2SV)
79072805
LW		 3094 return FALSE;
3095
3096 return FALSE;
3097}
3098
3099OP *
864dbfa3 3100Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right)
79072805 3101{
11343788 3102 OP *o;
79072805 3103
a0d0e21e 3104 if (optype) {
c963b151 3105 if (optype == OP_ANDASSIGN || optype == OP_ORASSIGN || optype == OP_DORASSIGN) {
a0d0e21e
LW		 3106 return newLOGOP(optype, 0,
3107 mod(scalar(left), optype),
3108 newUNOP(OP_SASSIGN, 0, scalar(right)));
3109 }
3110 else {
3111 return newBINOP(optype, OPf_STACKED,
3112 mod(scalar(left), optype), scalar(right));
3113 }
3114 }
3115
79072805 3116 if (list_assignment(left)) {
10c8fecd
GS		 3117 OP *curop;
3118
3280af22
NIS		 3119 PL_modcount = 0;
3120 PL_eval_start = right; /* Grandfathering $[ assignment here. Bletch.*/
463ee0b2 3121 left = mod(left, OP_AASSIGN);
3280af22
NIS		 3122 if (PL_eval_start)
3123 PL_eval_start = 0;
748a9306 3124 else {
a0d0e21e
LW		 3125 op_free(left);
3126 op_free(right);
3127 return Nullop;
3128 }
10c8fecd
GS		 3129 curop = list(force_list(left));
3130 o = newBINOP(OP_AASSIGN, flags, list(force_list(right)), curop);
eb160463 3131 o->op_private = (U8)(0 | (flags >> 8));
dd2155a4
DM		 3132
3133 /* PL_generation sorcery:
3134 * an assignment like ($a,$b) = ($c,$d) is easier than
3135 * ($a,$b) = ($c,$a), since there is no need for temporary vars.
3136 * To detect whether there are common vars, the global var
3137 * PL_generation is incremented for each assign op we compile.
3138 * Then, while compiling the assign op, we run through all the
3139 * variables on both sides of the assignment, setting a spare slot
3140 * in each of them to PL_generation. If any of them already have
3141 * that value, we know we've got commonality. We could use a
3142 * single bit marker, but then we'd have to make 2 passes, first
3143 * to clear the flag, then to test and set it. To find somewhere
3144 * to store these values, evil chicanery is done with SvCUR().
3145 */
3146
a0d0e21e 3147 if (!(left->op_private & OPpLVAL_INTRO)) {
11343788 3148 OP *lastop = o;
3280af22 3149 PL_generation++;
11343788 3150 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
22c35a8c 3151 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
79072805 3152 if (curop->op_type == OP_GV) {
638eceb6 3153 GV *gv = cGVOPx_gv(curop);
eb160463 3154 if (gv == PL_defgv || (int)SvCUR(gv) == PL_generation)
79072805 3155 break;
3280af22 3156 SvCUR(gv) = PL_generation;
79072805 3157 }
748a9306
LW		 3158 else if (curop->op_type == OP_PADSV ||
3159 curop->op_type == OP_PADAV ||
3160 curop->op_type == OP_PADHV ||
dd2155a4
DM		 3161 curop->op_type == OP_PADANY)
3162 {
3163 if (PAD_COMPNAME_GEN(curop->op_targ)
92251a1e 3164 == (STRLEN)PL_generation)
748a9306 3165 break;
dd2155a4
DM		 3166 PAD_COMPNAME_GEN(curop->op_targ)
3167 = PL_generation;
3168
748a9306 3169 }
79072805
LW		 3170 else if (curop->op_type == OP_RV2CV)
3171 break;
3172 else if (curop->op_type == OP_RV2SV ||
3173 curop->op_type == OP_RV2AV ||
3174 curop->op_type == OP_RV2HV ||
3175 curop->op_type == OP_RV2GV) {
3176 if (lastop->op_type != OP_GV) /* funny deref? */
3177 break;
3178 }
1167e5da
SM		 3179 else if (curop->op_type == OP_PUSHRE) {
3180 if (((PMOP*)curop)->op_pmreplroot) {
b3f5893f 3181#ifdef USE_ITHREADS
dd2155a4
DM		 3182 GV *gv = (GV*)PAD_SVl(INT2PTR(PADOFFSET,
3183 ((PMOP*)curop)->op_pmreplroot));
b3f5893f 3184#else
1167e5da 3185 GV *gv = (GV*)((PMOP*)curop)->op_pmreplroot;
b3f5893f 3186#endif
eb160463 3187 if (gv == PL_defgv || (int)SvCUR(gv) == PL_generation)
1167e5da 3188 break;
3280af22 3189 SvCUR(gv) = PL_generation;
b2ffa427 3190 }
1167e5da 3191 }
79072805
LW		 3192 else
3193 break;
3194 }
3195 lastop = curop;
3196 }
11343788 3197 if (curop != o)
10c8fecd 3198 o->op_private |= OPpASSIGN_COMMON;
79072805 3199 }
c07a80fd 3200 if (right && right->op_type == OP_SPLIT) {
3201 OP* tmpop;
3202 if ((tmpop = ((LISTOP*)right)->op_first) &&
3203 tmpop->op_type == OP_PUSHRE)
3204 {
3205 PMOP *pm = (PMOP*)tmpop;
3206 if (left->op_type == OP_RV2AV &&
3207 !(left->op_private & OPpLVAL_INTRO) &&
11343788 3208 !(o->op_private & OPpASSIGN_COMMON) )
c07a80fd 3209 {
3210 tmpop = ((UNOP*)left)->op_first;
3211 if (tmpop->op_type == OP_GV && !pm->op_pmreplroot) {
971a9dd3 3212#ifdef USE_ITHREADS
ba89bb6e 3213 pm->op_pmreplroot = INT2PTR(OP*, cPADOPx(tmpop)->op_padix);
971a9dd3
GS		 3214 cPADOPx(tmpop)->op_padix = 0; /* steal it */
3215#else
3216 pm->op_pmreplroot = (OP*)cSVOPx(tmpop)->op_sv;
3217 cSVOPx(tmpop)->op_sv = Nullsv; /* steal it */
3218#endif
c07a80fd 3219 pm->op_pmflags |= PMf_ONCE;
11343788 3220 tmpop = cUNOPo->op_first; /* to list (nulled) */
c07a80fd 3221 tmpop = ((UNOP*)tmpop)->op_first; /* to pushmark */
3222 tmpop->op_sibling = Nullop; /* don't free split */
3223 right->op_next = tmpop->op_next; /* fix starting loc */
11343788 3224 op_free(o); /* blow off assign */
54310121 3225 right->op_flags &= ~OPf_WANT;
a5f75d66 3226 /* "I don't know and I don't care." */
c07a80fd 3227 return right;
3228 }
3229 }
3230 else {
e6438c1a 3231 if (PL_modcount < RETURN_UNLIMITED_NUMBER &&
c07a80fd 3232 ((LISTOP*)right)->op_last->op_type == OP_CONST)
3233 {
3234 SV *sv = ((SVOP*)((LISTOP*)right)->op_last)->op_sv;
3235 if (SvIVX(sv) == 0)
3280af22 3236 sv_setiv(sv, PL_modcount+1);
c07a80fd 3237 }
3238 }
3239 }
3240 }
11343788 3241 return o;
79072805
LW		 3242 }
3243 if (!right)
3244 right = newOP(OP_UNDEF, 0);
3245 if (right->op_type == OP_READLINE) {
3246 right->op_flags |= OPf_STACKED;
463ee0b2 3247 return newBINOP(OP_NULL, flags, mod(scalar(left), OP_SASSIGN), scalar(right));
79072805 3248 }
a0d0e21e 3249 else {
3280af22 3250 PL_eval_start = right; /* Grandfathering $[ assignment here. Bletch.*/
11343788 3251 o = newBINOP(OP_SASSIGN, flags,
463ee0b2 3252 scalar(right), mod(scalar(left), OP_SASSIGN) );
3280af22
NIS		 3253 if (PL_eval_start)
3254 PL_eval_start = 0;
748a9306 3255 else {
11343788 3256 op_free(o);
a0d0e21e
LW		 3257 return Nullop;
3258 }
3259 }
11343788 3260 return o;
79072805
LW		 3261}
3262
3263OP *
864dbfa3 3264Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o)
79072805 3265{
bbce6d69 3266 U32 seq = intro_my();
79072805
LW		 3267 register COP *cop;
3268
b7dc083c 3269 NewOp(1101, cop, 1, COP);
57843af0 3270 if (PERLDB_LINE && CopLINE(PL_curcop) && PL_curstash != PL_debstash) {
8990e307 3271 cop->op_type = OP_DBSTATE;
22c35a8c 3272 cop->op_ppaddr = PL_ppaddr[ OP_DBSTATE ];
8990e307
LW		 3273 }
3274 else {
3275 cop->op_type = OP_NEXTSTATE;
22c35a8c 3276 cop->op_ppaddr = PL_ppaddr[ OP_NEXTSTATE ];
8990e307 3277 }
eb160463
GS		 3278 cop->op_flags = (U8)flags;
3279 cop->op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
ff0cee69 3280#ifdef NATIVE_HINTS
3281 cop->op_private |= NATIVE_HINTS;
3282#endif
e24b16f9 3283 PL_compiling.op_private = cop->op_private;
79072805
LW		 3284 cop->op_next = (OP*)cop;
3285
463ee0b2
LW		 3286 if (label) {
3287 cop->cop_label = label;
3280af22 3288 PL_hints |= HINT_BLOCK_SCOPE;
463ee0b2 3289 }
bbce6d69 3290 cop->cop_seq = seq;
3280af22 3291 cop->cop_arybase = PL_curcop->cop_arybase;
0453d815 3292 if (specialWARN(PL_curcop->cop_warnings))
599cee73 3293 cop->cop_warnings = PL_curcop->cop_warnings ;
1c846c1f 3294 else
599cee73 3295 cop->cop_warnings = newSVsv(PL_curcop->cop_warnings) ;
ac27b0f5
NIS		 3296 if (specialCopIO(PL_curcop->cop_io))
3297 cop->cop_io = PL_curcop->cop_io;
3298 else
3299 cop->cop_io = newSVsv(PL_curcop->cop_io) ;
599cee73 3300
79072805 3301
3280af22 3302 if (PL_copline == NOLINE)
57843af0 3303 CopLINE_set(cop, CopLINE(PL_curcop));
79072805 3304 else {
57843af0 3305 CopLINE_set(cop, PL_copline);
3280af22 3306 PL_copline = NOLINE;
79072805 3307 }
57843af0 3308#ifdef USE_ITHREADS
f4dd75d9 3309 CopFILE_set(cop, CopFILE(PL_curcop)); /* XXX share in a pvtable? */
57843af0 3310#else
f4dd75d9 3311 CopFILEGV_set(cop, CopFILEGV(PL_curcop));
57843af0 3312#endif
11faa288 3313 CopSTASH_set(cop, PL_curstash);
79072805 3314
3280af22 3315 if (PERLDB_LINE && PL_curstash != PL_debstash) {
cc49e20b 3316 SV **svp = av_fetch(CopFILEAV(PL_curcop), (I32)CopLINE(cop), FALSE);
1eb1540c 3317 if (svp && *svp != &PL_sv_undef ) {
0ac0412a 3318 (void)SvIOK_on(*svp);
57b2e452 3319 SvIVX(*svp) = PTR2IV(cop);
1eb1540c 3320 }
93a17b20
LW		 3321 }
3322
722969e2 3323 return prepend_elem(OP_LINESEQ, (OP*)cop, o);
79072805
LW		 3324}
3325
bbce6d69 3326
79072805 3327OP *
864dbfa3 3328Perl_newLOGOP(pTHX_ I32 type, I32 flags, OP *first, OP *other)
79072805 3329{
883ffac3
CS		 3330 return new_logop(type, flags, &first, &other);
3331}
3332
3bd495df 3333STATIC OP *
cea2e8a9 3334S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp)
883ffac3 3335{
79072805 3336 LOGOP *logop;
11343788 3337 OP *o;
883ffac3
CS		 3338 OP *first = *firstp;
3339 OP *other = *otherp;
79072805 3340
a0d0e21e
LW		 3341 if (type == OP_XOR) /* Not short circuit, but here by precedence. */
3342 return newBINOP(type, flags, scalar(first), scalar(other));
3343
8990e307 3344 scalarboolean(first);
79072805
LW		 3345 /* optimize "!a && b" to "a || b", and "!a || b" to "a && b" */
3346 if (first->op_type == OP_NOT && (first->op_flags & OPf_SPECIAL)) {
3347 if (type == OP_AND || type == OP_OR) {
3348 if (type == OP_AND)
3349 type = OP_OR;
3350 else
3351 type = OP_AND;
11343788 3352 o = first;
883ffac3 3353 first = *firstp = cUNOPo->op_first;
11343788
MB		 3354 if (o->op_next)
3355 first->op_next = o->op_next;
3356 cUNOPo->op_first = Nullop;
3357 op_free(o);
79072805
LW		 3358 }
3359 }
3360 if (first->op_type == OP_CONST) {
39a440a3
DM		 3361 if (first->op_private & OPpCONST_STRICT)
3362 no_bareword_allowed(first);
3363 else if (ckWARN(WARN_BAREWORD) && (first->op_private & OPpCONST_BARE))
989dfb19 3364 Perl_warner(aTHX_ packWARN(WARN_BAREWORD), "Bareword found in conditional");
79072805
LW		 3365 if ((type == OP_AND) == (SvTRUE(((SVOP*)first)->op_sv))) {
3366 op_free(first);
883ffac3 3367 *firstp = Nullop;
e7fec78e 3368 other->op_private |= OPpCONST_SHORTCIRCUIT;
79072805
LW		 3369 return other;
3370 }
3371 else {
7921d0f2
DM		 3372 /* check for C<my $x if 0>, or C<my($x,$y) if 0> */
3373 OP *o2 = other;
3374 if ( ! (o2->op_type == OP_LIST
3375 && (( o2 = cUNOPx(o2)->op_first))
3376 && o2->op_type == OP_PUSHMARK
3377 && (( o2 = o2->op_sibling)) )
3378 )
3379 o2 = other;
3380 if ((o2->op_type == OP_PADSV || o2->op_type == OP_PADAV
3381 || o2->op_type == OP_PADHV)
3382 && o2->op_private & OPpLVAL_INTRO
3383 && ckWARN(WARN_DEPRECATED))
3384 {
3385 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
3386 "Deprecated use of my() in false conditional");
3387 }
3388
79072805 3389 op_free(other);
883ffac3 3390 *otherp = Nullop;
e7fec78e 3391 first->op_private |= OPpCONST_SHORTCIRCUIT;
79072805
LW		 3392 return first;
3393 }
3394 }
59e10468
RGS		 3395 else if (ckWARN(WARN_MISC) && (first->op_flags & OPf_KIDS) &&
3396 type != OP_DOR) /* [#24076] Don't warn for <FH> err FOO. */
3397 {
a6006777 3398 OP *k1 = ((UNOP*)first)->op_first;
3399 OP *k2 = k1->op_sibling;
3400 OPCODE warnop = 0;
3401 switch (first->op_type)
3402 {
3403 case OP_NULL:
3404 if (k2 && k2->op_type == OP_READLINE
3405 && (k2->op_flags & OPf_STACKED)
1c846c1f 3406 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
72b16652 3407 {
a6006777 3408 warnop = k2->op_type;
72b16652 3409 }
a6006777 3410 break;
3411
3412 case OP_SASSIGN:
68dc0745 3413 if (k1->op_type == OP_READDIR
3414 || k1->op_type == OP_GLOB
72b16652 3415 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
68dc0745 3416 || k1->op_type == OP_EACH)
72b16652
GS		 3417 {
3418 warnop = ((k1->op_type == OP_NULL)
eb160463 3419 ? (OPCODE)k1->op_targ : k1->op_type);
72b16652 3420 }
a6006777 3421 break;
3422 }
8ebc5c01 3423 if (warnop) {
57843af0
GS		 3424 line_t oldline = CopLINE(PL_curcop);
3425 CopLINE_set(PL_curcop, PL_copline);
9014280d 3426 Perl_warner(aTHX_ packWARN(WARN_MISC),
599cee73 3427 "Value of %s%s can be \"0\"; test with defined()",
22c35a8c 3428 PL_op_desc[warnop],
68dc0745 3429 ((warnop == OP_READLINE || warnop == OP_GLOB)
3430 ? " construct" : "() operator"));
57843af0 3431 CopLINE_set(PL_curcop, oldline);
8ebc5c01 3432 }
a6006777 3433 }
79072805
LW		 3434
3435 if (!other)
3436 return first;
3437
c963b151 3438 if (type == OP_ANDASSIGN || type == OP_ORASSIGN || type == OP_DORASSIGN)
a0d0e21e
LW		 3439 other->op_private |= OPpASSIGN_BACKWARDS; /* other is an OP_SASSIGN */
3440
b7dc083c 3441 NewOp(1101, logop, 1, LOGOP);
79072805 3442
eb160463 3443 logop->op_type = (OPCODE)type;
22c35a8c 3444 logop->op_ppaddr = PL_ppaddr[type];
79072805
LW		 3445 logop->op_first = first;
3446 logop->op_flags = flags | OPf_KIDS;
3447 logop->op_other = LINKLIST(other);
eb160463 3448 logop->op_private = (U8)(1 | (flags >> 8));
79072805
LW		 3449
3450 /* establish postfix order */
3451 logop->op_next = LINKLIST(first);
3452 first->op_next = (OP*)logop;
3453 first->op_sibling = other;
3454
463d09e6
RGS		 3455 CHECKOP(type,logop);
3456
11343788
MB		 3457 o = newUNOP(OP_NULL, 0, (OP*)logop);
3458 other->op_next = o;
79072805 3459
11343788 3460 return o;
79072805
LW		 3461}
3462
3463OP *
864dbfa3 3464Perl_newCONDOP(pTHX_ I32 flags, OP *first, OP *trueop, OP *falseop)
79072805 3465{
1a67a97c
SM		 3466 LOGOP *logop;
3467 OP *start;
11343788 3468 OP *o;
79072805 3469
b1cb66bf 3470 if (!falseop)
3471 return newLOGOP(OP_AND, 0, first, trueop);
3472 if (!trueop)
3473 return newLOGOP(OP_OR, 0, first, falseop);
79072805 3474
8990e307 3475 scalarboolean(first);
79072805 3476 if (first->op_type == OP_CONST) {
2bc6235c
K		 3477 if (first->op_private & OPpCONST_BARE &&
3478 first->op_private & OPpCONST_STRICT) {
3479 no_bareword_allowed(first);
3480 }
79072805
LW		 3481 if (SvTRUE(((SVOP*)first)->op_sv)) {
3482 op_free(first);
b1cb66bf 3483 op_free(falseop);
3484 return trueop;
79072805
LW		 3485 }
3486 else {
3487 op_free(first);
b1cb66bf 3488 op_free(trueop);
3489 return falseop;
79072805
LW		 3490 }
3491 }
1a67a97c
SM		 3492 NewOp(1101, logop, 1, LOGOP);
3493 logop->op_type = OP_COND_EXPR;
3494 logop->op_ppaddr = PL_ppaddr[OP_COND_EXPR];
3495 logop->op_first = first;
3496 logop->op_flags = flags | OPf_KIDS;
eb160463 3497 logop->op_private = (U8)(1 | (flags >> 8));
1a67a97c
SM		 3498 logop->op_other = LINKLIST(trueop);
3499 logop->op_next = LINKLIST(falseop);
79072805 3500
463d09e6
RGS		 3501 CHECKOP(OP_COND_EXPR, /* that's logop->op_type */
3502 logop);
79072805
LW		 3503
3504 /* establish postfix order */
1a67a97c
SM		 3505 start = LINKLIST(first);
3506 first->op_next = (OP*)logop;
79072805 3507
b1cb66bf 3508 first->op_sibling = trueop;
3509 trueop->op_sibling = falseop;
1a67a97c 3510 o = newUNOP(OP_NULL, 0, (OP*)logop);
79072805 3511
1a67a97c 3512 trueop->op_next = falseop->op_next = o;
79072805 3513
1a67a97c 3514 o->op_next = start;
11343788 3515 return o;
79072805
LW		 3516}
3517
3518OP *
864dbfa3 3519Perl_newRANGE(pTHX_ I32 flags, OP *left, OP *right)
79072805 3520{
1a67a97c 3521 LOGOP *range;
79072805
LW		 3522 OP *flip;
3523 OP *flop;
1a67a97c 3524 OP *leftstart;
11343788 3525 OP *o;
79072805 3526
1a67a97c 3527 NewOp(1101, range, 1, LOGOP);
79072805 3528
1a67a97c
SM		 3529 range->op_type = OP_RANGE;
3530 range->op_ppaddr = PL_ppaddr[OP_RANGE];
3531 range->op_first = left;
3532 range->op_flags = OPf_KIDS;
3533 leftstart = LINKLIST(left);
3534 range->op_other = LINKLIST(right);
eb160463 3535 range->op_private = (U8)(1 | (flags >> 8));
79072805
LW		 3536
3537 left->op_sibling = right;
3538
1a67a97c
SM		 3539 range->op_next = (OP*)range;
3540 flip = newUNOP(OP_FLIP, flags, (OP*)range);
79072805 3541 flop = newUNOP(OP_FLOP, 0, flip);
11343788 3542 o = newUNOP(OP_NULL, 0, flop);
79072805 3543 linklist(flop);
1a67a97c 3544 range->op_next = leftstart;
79072805
LW		 3545
3546 left->op_next = flip;
3547 right->op_next = flop;
3548
1a67a97c
SM		 3549 range->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
3550 sv_upgrade(PAD_SV(range->op_targ), SVt_PVNV);
ed6116ce 3551 flip->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
79072805
LW		 3552 sv_upgrade(PAD_SV(flip->op_targ), SVt_PVNV);
3553
3554 flip->op_private = left->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
3555 flop->op_private = right->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
3556
11343788 3557 flip->op_next = o;
79072805 3558 if (!flip->op_private || !flop->op_private)
11343788 3559 linklist(o); /* blow off optimizer unless constant */
79072805 3560
11343788 3561 return o;
79072805
LW		 3562}
3563
3564OP *
864dbfa3 3565Perl_newLOOPOP(pTHX_ I32 flags, I32 debuggable, OP *expr, OP *block)
79072805 3566{
463ee0b2 3567 OP* listop;
11343788 3568 OP* o;
463ee0b2 3569 int once = block && block->op_flags & OPf_SPECIAL &&
a0d0e21e 3570 (block->op_type == OP_ENTERSUB || block->op_type == OP_NULL);
93a17b20 3571
463ee0b2
LW		 3572 if (expr) {
3573 if (once && expr->op_type == OP_CONST && !SvTRUE(((SVOP*)expr)->op_sv))
3574 return block; /* do {} while 0 does once */
fb73857a 3575 if (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
3576 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
774d564b 3577 expr = newUNOP(OP_DEFINED, 0,
54b9620d 3578 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
55d729e4
GS		 3579 } else if (expr->op_flags & OPf_KIDS) {
3580 OP *k1 = ((UNOP*)expr)->op_first;
3581 OP *k2 = (k1) ? k1->op_sibling : NULL;
3582 switch (expr->op_type) {
1c846c1f 3583 case OP_NULL:
55d729e4
GS		 3584 if (k2 && k2->op_type == OP_READLINE
3585 && (k2->op_flags & OPf_STACKED)
1c846c1f 3586 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
55d729e4 3587 expr = newUNOP(OP_DEFINED, 0, expr);
1c846c1f 3588 break;
55d729e4
GS		 3589
3590 case OP_SASSIGN:
3591 if (k1->op_type == OP_READDIR
3592 || k1->op_type == OP_GLOB
6531c3e6 3593 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
55d729e4
GS		 3594 || k1->op_type == OP_EACH)
3595 expr = newUNOP(OP_DEFINED, 0, expr);
3596 break;
3597 }
774d564b 3598 }
463ee0b2 3599 }
93a17b20 3600
e1548254
RGS		 3601 /* if block is null, the next append_elem() would put UNSTACK, a scalar
3602 * op, in listop. This is wrong. [perl #27024] */
3603 if (!block)
3604 block = newOP(OP_NULL, 0);
8990e307 3605 listop = append_elem(OP_LINESEQ, block, newOP(OP_UNSTACK, 0));
883ffac3 3606 o = new_logop(OP_AND, 0, &expr, &listop);
463ee0b2 3607
883ffac3
CS		 3608 if (listop)
3609 ((LISTOP*)listop)->op_last->op_next = LINKLIST(o);
79072805 3610
11343788
MB		 3611 if (once && o != listop)
3612 o->op_next = ((LOGOP*)cUNOPo->op_first)->op_other;
79072805 3613
11343788
MB		 3614 if (o == listop)
3615 o = newUNOP(OP_NULL, 0, o); /* or do {} while 1 loses outer block */
748a9306 3616
11343788
MB		 3617 o->op_flags |= flags;
3618 o = scope(o);
3619 o->op_flags |= OPf_SPECIAL; /* suppress POPBLOCK curpm restoration*/
3620 return o;
79072805
LW		 3621}
3622
3623OP *
864dbfa3 3624Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP *loop, I32 whileline, OP *expr, OP *block, OP *cont)
79072805
LW		 3625{
3626 OP *redo;
3627 OP *next = 0;
3628 OP *listop;
11343788 3629 OP *o;
1ba6ee2b 3630 U8 loopflags = 0;
79072805 3631
fb73857a 3632 if (expr && (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
3633 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB))) {
748a9306 3634 expr = newUNOP(OP_DEFINED, 0,
54b9620d 3635 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
55d729e4
GS		 3636 } else if (expr && (expr->op_flags & OPf_KIDS)) {
3637 OP *k1 = ((UNOP*)expr)->op_first;
3638 OP *k2 = (k1) ? k1->op_sibling : NULL;
3639 switch (expr->op_type) {
1c846c1f 3640 case OP_NULL:
55d729e4
GS		 3641 if (k2 && k2->op_type == OP_READLINE
3642 && (k2->op_flags & OPf_STACKED)
1c846c1f 3643 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
55d729e4 3644 expr = newUNOP(OP_DEFINED, 0, expr);
1c846c1f 3645 break;
55d729e4
GS		 3646
3647 case OP_SASSIGN:
3648 if (k1->op_type == OP_READDIR
3649 || k1->op_type == OP_GLOB
72b16652 3650 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
55d729e4
GS		 3651 || k1->op_type == OP_EACH)
3652 expr = newUNOP(OP_DEFINED, 0, expr);
3653 break;
3654 }
748a9306 3655 }
79072805
LW		 3656
3657 if (!block)
3658 block = newOP(OP_NULL, 0);
87246558
GS		 3659 else if (cont) {
3660 block = scope(block);
3661 }
79072805 3662
1ba6ee2b 3663 if (cont) {
79072805 3664 next = LINKLIST(cont);
1ba6ee2b 3665 }
fb73857a 3666 if (expr) {
85538317
GS		 3667 OP *unstack = newOP(OP_UNSTACK, 0);
3668 if (!next)
3669 next = unstack;
3670 cont = append_elem(OP_LINESEQ, cont, unstack);
fb73857a 3671 }
79072805 3672
463ee0b2 3673 listop = append_list(OP_LINESEQ, (LISTOP*)block, (LISTOP*)cont);
79072805
LW		 3674 redo = LINKLIST(listop);
3675
3676 if (expr) {
eb160463 3677 PL_copline = (line_t)whileline;
883ffac3
CS		 3678 scalar(listop);
3679 o = new_logop(OP_AND, 0, &expr, &listop);
11343788 3680 if (o == expr && o->op_type == OP_CONST && !SvTRUE(cSVOPo->op_sv)) {
85e6fe83 3681 op_free(expr); /* oops, it's a while (0) */
463ee0b2 3682 op_free((OP*)loop);
883ffac3 3683 return Nullop; /* listop already freed by new_logop */
463ee0b2 3684 }
883ffac3 3685 if (listop)
497b47a8 3686 ((LISTOP*)listop)->op_last->op_next =
883ffac3 3687 (o == listop ? redo : LINKLIST(o));
79072805
LW		 3688 }
3689 else
11343788 3690 o = listop;
79072805
LW		 3691
3692 if (!loop) {
b7dc083c 3693 NewOp(1101,loop,1,LOOP);
79072805 3694 loop->op_type = OP_ENTERLOOP;
22c35a8c 3695 loop->op_ppaddr = PL_ppaddr[OP_ENTERLOOP];
79072805
LW		 3696 loop->op_private = 0;
3697 loop->op_next = (OP*)loop;
3698 }
3699
11343788 3700 o = newBINOP(OP_LEAVELOOP, 0, (OP*)loop, o);
79072805
LW		 3701
3702 loop->op_redoop = redo;
11343788 3703 loop->op_lastop = o;
1ba6ee2b 3704 o->op_private |= loopflags;
79072805
LW		 3705
3706 if (next)
3707 loop->op_nextop = next;
3708 else
11343788 3709 loop->op_nextop = o;
79072805 3710
11343788
MB		 3711 o->op_flags |= flags;
3712 o->op_private |= (flags >> 8);
3713 return o;
79072805
LW		 3714}
3715
3716OP *
864dbfa3 3717Perl_newFOROP(pTHX_ I32 flags,char *label,line_t forline,OP *sv,OP *expr,OP *block,OP *cont)
79072805
LW		 3718{
3719 LOOP *loop;
fb73857a 3720 OP *wop;
4bbc6d12 3721 PADOFFSET padoff = 0;
4633a7c4 3722 I32 iterflags = 0;
241416b8 3723 I32 iterpflags = 0;
79072805 3724
79072805 3725 if (sv) {
85e6fe83 3726 if (sv->op_type == OP_RV2SV) { /* symbol table variable */
241416b8 3727 iterpflags = sv->op_private & OPpOUR_INTRO; /* for our $x () */
748a9306 3728 sv->op_type = OP_RV2GV;
22c35a8c 3729 sv->op_ppaddr = PL_ppaddr[OP_RV2GV];
79072805 3730 }
85e6fe83 3731 else if (sv->op_type == OP_PADSV) { /* private variable */
241416b8 3732 iterpflags = sv->op_private & OPpLVAL_INTRO; /* for my $x () */
85e6fe83 3733 padoff = sv->op_targ;
743e66e6 3734 sv->op_targ = 0;
85e6fe83
LW		 3735 op_free(sv);
3736 sv = Nullop;
3737 }
54b9620d
MB		 3738 else if (sv->op_type == OP_THREADSV) { /* per-thread variable */
3739 padoff = sv->op_targ;
743e66e6 3740 sv->op_targ = 0;
54b9620d
MB		 3741 iterflags |= OPf_SPECIAL;
3742 op_free(sv);
3743 sv = Nullop;
3744 }
79072805 3745 else
cea2e8a9 3746 Perl_croak(aTHX_ "Can't use %s for loop variable", PL_op_desc[sv->op_type]);
79072805
LW		 3747 }
3748 else {
aabe9514
RGS		 3749 I32 offset = pad_findmy("$_");
3750 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS(offset) & SVpad_OUR) {
3751 sv = newGVOP(OP_GV, 0, PL_defgv);
3752 }
3753 else {
3754 padoff = offset;
aabe9514 3755 }
79072805 3756 }
5f05dabc 3757 if (expr->op_type == OP_RV2AV || expr->op_type == OP_PADAV) {
89ea2908 3758 expr = mod(force_list(scalar(ref(expr, OP_ITER))), OP_GREPSTART);
4633a7c4
LW		 3759 iterflags |= OPf_STACKED;
3760 }
89ea2908
GA		 3761 else if (expr->op_type == OP_NULL &&
3762 (expr->op_flags & OPf_KIDS) &&
3763 ((BINOP*)expr)->op_first->op_type == OP_FLOP)
3764 {
3765 /* Basically turn for($x..$y) into the same as for($x,$y), but we
3766 * set the STACKED flag to indicate that these values are to be
3767 * treated as min/max values by 'pp_iterinit'.
3768 */
3769 UNOP* flip = (UNOP*)((UNOP*)((BINOP*)expr)->op_first)->op_first;
1a67a97c 3770 LOGOP* range = (LOGOP*) flip->op_first;
89ea2908
GA		 3771 OP* left = range->op_first;
3772 OP* right = left->op_sibling;
5152d7c7 3773 LISTOP* listop;
89ea2908
GA		 3774
3775 range->op_flags &= ~OPf_KIDS;
3776 range->op_first = Nullop;
3777
5152d7c7 3778 listop = (LISTOP*)newLISTOP(OP_LIST, 0, left, right);
1a67a97c
SM		 3779 listop->op_first->op_next = range->op_next;
3780 left->op_next = range->op_other;
5152d7c7
GS		 3781 right->op_next = (OP*)listop;
3782 listop->op_next = listop->op_first;
89ea2908
GA		 3783
3784 op_free(expr);
5152d7c7 3785 expr = (OP*)(listop);
93c66552 3786 op_null(expr);
89ea2908
GA		 3787 iterflags |= OPf_STACKED;
3788 }
3789 else {
3790 expr = mod(force_list(expr), OP_GREPSTART);
3791 }
3792
3793
4633a7c4 3794 loop = (LOOP*)list(convert(OP_ENTERITER, iterflags,
89ea2908 3795 append_elem(OP_LIST, expr, scalar(sv))));
85e6fe83 3796 assert(!loop->op_next);
241416b8 3797 /* for my $x () sets OPpLVAL_INTRO;
14f338dc 3798 * for our $x () sets OPpOUR_INTRO */
c5661c80 3799 loop->op_private = (U8)iterpflags;
b7dc083c 3800#ifdef PL_OP_SLAB_ALLOC
155aba94
GS		 3801 {
3802 LOOP *tmp;
3803 NewOp(1234,tmp,1,LOOP);
3804 Copy(loop,tmp,1,LOOP);
238a4c30 3805 FreeOp(loop);
155aba94
GS		 3806 loop = tmp;
3807 }
b7dc083c 3808#else
85e6fe83 3809 Renew(loop, 1, LOOP);
1c846c1f 3810#endif
85e6fe83 3811 loop->op_targ = padoff;
fb73857a 3812 wop = newWHILEOP(flags, 1, loop, forline, newOP(OP_ITER, 0), block, cont);
3280af22 3813 PL_copline = forline;
fb73857a 3814 return newSTATEOP(0, label, wop);
79072805
LW		 3815}
3816
8990e307 3817OP*
864dbfa3 3818Perl_newLOOPEX(pTHX_ I32 type, OP *label)
8990e307 3819{
11343788 3820 OP *o;
2d8e6c8d
GS		 3821 STRLEN n_a;
3822
8990e307 3823 if (type != OP_GOTO || label->op_type == OP_CONST) {
cdaebead
MB		 3824 /* "last()" means "last" */
3825 if (label->op_type == OP_STUB && (label->op_flags & OPf_PARENS))
3826 o = newOP(type, OPf_SPECIAL);
3827 else {
3828 o = newPVOP(type, 0, savepv(label->op_type == OP_CONST
2d8e6c8d 3829 ? SvPVx(((SVOP*)label)->op_sv, n_a)
cdaebead
MB		 3830 : ""));
3831 }
8990e307
LW		 3832 op_free(label);
3833 }
3834 else {
e3aba57a
RGS		 3835 /* Check whether it's going to be a goto &function */
3836 if (label->op_type == OP_ENTERSUB
3837 && !(label->op_flags & OPf_STACKED))
a0d0e21e 3838 label = newUNOP(OP_REFGEN, 0, mod(label, OP_REFGEN));
11343788 3839 o = newUNOP(type, OPf_STACKED, label);
8990e307 3840 }
3280af22 3841 PL_hints |= HINT_BLOCK_SCOPE;
11343788 3842 return o;
8990e307
LW		 3843}
3844
7dafbf52
DM		 3845/*
3846=for apidoc cv_undef
3847
3848Clear out all the active components of a CV. This can happen either
3849by an explicit C<undef &foo>, or by the reference count going to zero.
3850In the former case, we keep the CvOUTSIDE pointer, so that any anonymous
3851children can still follow the full lexical scope chain.
3852
3853=cut
3854*/
3855
79072805 3856void
864dbfa3 3857Perl_cv_undef(pTHX_ CV *cv)
79072805 3858{
a636914a 3859#ifdef USE_ITHREADS
35f1c1c7
SB		 3860 if (CvFILE(cv) && !CvXSUB(cv)) {
3861 /* for XSUBs CvFILE point directly to static memory; __FILE__ */
a636914a 3862 Safefree(CvFILE(cv));
a636914a 3863 }
f3e31eb5 3864 CvFILE(cv) = 0;
a636914a
RH		 3865#endif
3866
a0d0e21e
LW		 3867 if (!CvXSUB(cv) && CvROOT(cv)) {
3868 if (CvDEPTH(cv))
cea2e8a9 3869 Perl_croak(aTHX_ "Can't undef active subroutine");
8990e307 3870 ENTER;
a0d0e21e 3871
f3548bdc 3872 PAD_SAVE_SETNULLPAD();
a0d0e21e 3873
282f25c9 3874 op_free(CvROOT(cv));
79072805 3875 CvROOT(cv) = Nullop;
8990e307 3876 LEAVE;
79072805 3877 }
1d5db326 3878 SvPOK_off((SV*)cv); /* forget prototype */
8e07c86e 3879 CvGV(cv) = Nullgv;
a3985cdc
DM		 3880
3881 pad_undef(cv);
3882
7dafbf52
DM		 3883 /* remove CvOUTSIDE unless this is an undef rather than a free */
3884 if (!SvREFCNT(cv) && CvOUTSIDE(cv)) {
3885 if (!CvWEAKOUTSIDE(cv))
3886 SvREFCNT_dec(CvOUTSIDE(cv));
3887 CvOUTSIDE(cv) = Nullcv;
3888 }
beab0874
JT		 3889 if (CvCONST(cv)) {
3890 SvREFCNT_dec((SV*)CvXSUBANY(cv).any_ptr);
3891 CvCONST_off(cv);
3892 }
50762d59
DM		 3893 if (CvXSUB(cv)) {
3894 CvXSUB(cv) = 0;
3895 }
7dafbf52
DM		 3896 /* delete all flags except WEAKOUTSIDE */
3897 CvFLAGS(cv) &= CVf_WEAKOUTSIDE;
79072805
LW		 3898}
3899
3fe9a6f1 3900void
864dbfa3 3901Perl_cv_ckproto(pTHX_ CV *cv, GV *gv, char *p)
3fe9a6f1 3902{
e476b1b5 3903 if (((!p != !SvPOK(cv)) || (p && strNE(p, SvPVX(cv)))) && ckWARN_d(WARN_PROTOTYPE)) {
46fc3d4c 3904 SV* msg = sv_newmortal();
3fe9a6f1 3905 SV* name = Nullsv;
3906
3907 if (gv)
46fc3d4c 3908 gv_efullname3(name = sv_newmortal(), gv, Nullch);
3909 sv_setpv(msg, "Prototype mismatch:");
3910 if (name)
894356b3 3911 Perl_sv_catpvf(aTHX_ msg, " sub %"SVf, name);
3fe9a6f1 3912 if (SvPOK(cv))
35c1215d 3913 Perl_sv_catpvf(aTHX_ msg, " (%"SVf")", (SV *)cv);
ebe643b9
RGS		 3914 else
3915 Perl_sv_catpvf(aTHX_ msg, ": none");
46fc3d4c 3916 sv_catpv(msg, " vs ");
3917 if (p)
cea2e8a9 3918 Perl_sv_catpvf(aTHX_ msg, "(%s)", p);
46fc3d4c 3919 else
3920 sv_catpv(msg, "none");
9014280d 3921 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "%"SVf, msg);
3fe9a6f1 3922 }
3923}
3924
35f1c1c7
SB		 3925static void const_sv_xsub(pTHX_ CV* cv);
3926
beab0874 3927/*
ccfc67b7
JH		 3928
3929=head1 Optree Manipulation Functions
3930
beab0874
JT		 3931=for apidoc cv_const_sv
3932
3933If C<cv> is a constant sub eligible for inlining. returns the constant
3934value returned by the sub. Otherwise, returns NULL.
3935
3936Constant subs can be created with C<newCONSTSUB> or as described in
3937L<perlsub/"Constant Functions">.
3938
3939=cut
3940*/
760ac839 3941SV *
864dbfa3 3942Perl_cv_const_sv(pTHX_ CV *cv)
760ac839 3943{
beab0874 3944 if (!cv || !CvCONST(cv))
54310121 3945 return Nullsv;
beab0874 3946 return (SV*)CvXSUBANY(cv).any_ptr;
fe5e78ed 3947}
760ac839 3948
b5c19bd7
DM		 3949/* op_const_sv: examine an optree to determine whether it's in-lineable.
3950 * Can be called in 3 ways:
3951 *
3952 * !cv
3953 * look for a single OP_CONST with attached value: return the value
3954 *
3955 * cv && CvCLONE(cv) && !CvCONST(cv)
3956 *
3957 * examine the clone prototype, and if contains only a single
3958 * OP_CONST referencing a pad const, or a single PADSV referencing
3959 * an outer lexical, return a non-zero value to indicate the CV is
3960 * a candidate for "constizing" at clone time
3961 *
3962 * cv && CvCONST(cv)
3963 *
3964 * We have just cloned an anon prototype that was marked as a const
3965 * candidiate. Try to grab the current value, and in the case of
3966 * PADSV, ignore it if it has multiple references. Return the value.
3967 */
3968
fe5e78ed 3969SV *
864dbfa3 3970Perl_op_const_sv(pTHX_ OP *o, CV *cv)
fe5e78ed
GS		 3971{
3972 SV *sv = Nullsv;
3973
0f79a09d 3974 if (!o)
fe5e78ed 3975 return Nullsv;
1c846c1f
NIS		 3976
3977 if (o->op_type == OP_LINESEQ && cLISTOPo->op_first)
fe5e78ed
GS		 3978 o = cLISTOPo->op_first->op_sibling;
3979
3980 for (; o; o = o->op_next) {
54310121 3981 OPCODE type = o->op_type;
fe5e78ed 3982
1c846c1f 3983 if (sv && o->op_next == o)
fe5e78ed 3984 return sv;
e576b457
JT		 3985 if (o->op_next != o) {
3986 if (type == OP_NEXTSTATE || type == OP_NULL || type == OP_PUSHMARK)
3987 continue;
3988 if (type == OP_DBSTATE)
3989 continue;
3990 }
54310121 3991 if (type == OP_LEAVESUB || type == OP_RETURN)
3992 break;
3993 if (sv)
3994 return Nullsv;
7766f137 3995 if (type == OP_CONST && cSVOPo->op_sv)
5dc0d613 3996 sv = cSVOPo->op_sv;
b5c19bd7 3997 else if (cv && type == OP_CONST) {
dd2155a4 3998 sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
beab0874
JT		 3999 if (!sv)
4000 return Nullsv;
b5c19bd7
DM		 4001 }
4002 else if (cv && type == OP_PADSV) {
4003 if (CvCONST(cv)) { /* newly cloned anon */
4004 sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
4005 /* the candidate should have 1 ref from this pad and 1 ref
4006 * from the parent */
4007 if (!sv || SvREFCNT(sv) != 2)
4008 return Nullsv;
beab0874 4009 sv = newSVsv(sv);
b5c19bd7
DM		 4010 SvREADONLY_on(sv);
4011 return sv;
4012 }
4013 else {
4014 if (PAD_COMPNAME_FLAGS(o->op_targ) & SVf_FAKE)
4015 sv = &PL_sv_undef; /* an arbitrary non-null value */
beab0874 4016 }
760ac839 4017 }
b5c19bd7 4018 else {
54310121 4019 return Nullsv;
b5c19bd7 4020 }
760ac839
LW		 4021 }
4022 return sv;
4023}
4024
09bef843
SB		 4025void
4026Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
4027{
4028 if (o)
4029 SAVEFREEOP(o);
4030 if (proto)
4031 SAVEFREEOP(proto);
4032 if (attrs)
4033 SAVEFREEOP(attrs);
4034 if (block)
4035 SAVEFREEOP(block);
4036 Perl_croak(aTHX_ "\"my sub\" not yet implemented");
4037}
4038
748a9306 4039CV *
864dbfa3 4040Perl_newSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *block)
79072805 4041{
09bef843
SB		 4042 return Perl_newATTRSUB(aTHX_ floor, o, proto, Nullop, block);
4043}
4044
4045CV *
4046Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
4047{
2d8e6c8d 4048 STRLEN n_a;
83ee9e09
GS		 4049 char *name;
4050 char *aname;
4051 GV *gv;
2d8e6c8d 4052 char *ps = proto ? SvPVx(((SVOP*)proto)->op_sv, n_a) : Nullch;
a2008d6d 4053 register CV *cv=0;
beab0874 4054 SV *const_sv;
79072805 4055
83ee9e09
GS		 4056 name = o ? SvPVx(cSVOPo->op_sv, n_a) : Nullch;
4057 if (!name && PERLDB_NAMEANON && CopLINE(PL_curcop)) {
4058 SV *sv = sv_newmortal();
c99da370
JH		 4059 Perl_sv_setpvf(aTHX_ sv, "%s[%s:%"IVdf"]",
4060 PL_curstash ? "__ANON__" : "__ANON__::__ANON__",
83ee9e09
GS		 4061 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
4062 aname = SvPVX(sv);
4063 }
4064 else
4065 aname = Nullch;
c99da370
JH		 4066 gv = gv_fetchpv(name ? name : (aname ? aname :
4067 (PL_curstash ? "__ANON__" : "__ANON__::__ANON__")),
83ee9e09
GS		 4068 GV_ADDMULTI | ((block || attrs) ? 0 : GV_NOINIT),
4069 SVt_PVCV);
4070
11343788 4071 if (o)
5dc0d613 4072 SAVEFREEOP(o);
3fe9a6f1 4073 if (proto)
4074 SAVEFREEOP(proto);
09bef843
SB		 4075 if (attrs)
4076 SAVEFREEOP(attrs);
3fe9a6f1 4077
09bef843 4078 if (SvTYPE(gv) != SVt_PVGV) { /* Maybe prototype now, and had at
55d729e4
GS		 4079 maximum a prototype before. */
4080 if (SvTYPE(gv) > SVt_NULL) {
0453d815 4081 if (!SvPOK((SV*)gv) && !(SvIOK((SV*)gv) && SvIVX((SV*)gv) == -1)
e476b1b5 4082 && ckWARN_d(WARN_PROTOTYPE))
f248d071 4083 {
9014280d 4084 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "Runaway prototype");
f248d071 4085 }
55d729e4
GS		 4086 cv_ckproto((CV*)gv, NULL, ps);
4087 }
4088 if (ps)
4089 sv_setpv((SV*)gv, ps);
4090 else
4091 sv_setiv((SV*)gv, -1);
3280af22
NIS		 4092 SvREFCNT_dec(PL_compcv);
4093 cv = PL_compcv = NULL;
4094 PL_sub_generation++;
beab0874 4095 goto done;
55d729e4
GS		 4096 }
4097
beab0874
JT		 4098 cv = (!name || GvCVGEN(gv)) ? Nullcv : GvCV(gv);
4099
7fb37951
AMS		 4100#ifdef GV_UNIQUE_CHECK
4101 if (cv && GvUNIQUE(gv) && SvREADONLY(cv)) {
4102 Perl_croak(aTHX_ "Can't define subroutine %s (GV is unique)", name);
5bd07a3d
DM		 4103 }
4104#endif
4105
beab0874
JT		 4106 if (!block || !ps || *ps || attrs)
4107 const_sv = Nullsv;
4108 else
4109 const_sv = op_const_sv(block, Nullcv);
4110
4111 if (cv) {
60ed1d8c 4112 bool exists = CvROOT(cv) || CvXSUB(cv);
5bd07a3d 4113
7fb37951
AMS		 4114#ifdef GV_UNIQUE_CHECK
4115 if (exists && GvUNIQUE(gv)) {
4116 Perl_croak(aTHX_ "Can't redefine unique subroutine %s", name);
5bd07a3d
DM		 4117 }
4118#endif
4119
60ed1d8c
GS		 4120 /* if the subroutine doesn't exist and wasn't pre-declared
4121 * with a prototype, assume it will be AUTOLOADed,
4122 * skipping the prototype check
4123 */
4124 if (exists || SvPOK(cv))
01ec43d0 4125 cv_ckproto(cv, gv, ps);
68dc0745 4126 /* already defined (or promised)? */
60ed1d8c 4127 if (exists || GvASSUMECV(gv)) {
09bef843 4128 if (!block && !attrs) {
d3cea301
SB		 4129 if (CvFLAGS(PL_compcv)) {
4130 /* might have had built-in attrs applied */
4131 CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
4132 }
aa689395 4133 /* just a "sub foo;" when &foo is already defined */
3280af22 4134 SAVEFREESV(PL_compcv);
aa689395 4135 goto done;
4136 }
7bac28a0 4137 /* ahem, death to those who redefine active sort subs */
3280af22 4138 if (PL_curstackinfo->si_type == PERLSI_SORT && PL_sortcop == CvSTART(cv))
cea2e8a9 4139 Perl_croak(aTHX_ "Can't redefine active sort subroutine %s", name);
beab0874
JT		 4140 if (block) {
4141 if (ckWARN(WARN_REDEFINE)
4142 || (CvCONST(cv)
4143 && (!const_sv || sv_cmp(cv_const_sv(cv), const_sv))))
4144 {
4145 line_t oldline = CopLINE(PL_curcop);
d8a34499
IK		 4146 if (PL_copline != NOLINE)
4147 CopLINE_set(PL_curcop, PL_copline);
9014280d 4148 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
beab0874
JT		 4149 CvCONST(cv) ? "Constant subroutine %s redefined"
4150 : "Subroutine %s redefined", name);
4151 CopLINE_set(PL_curcop, oldline);
4152 }
4153 SvREFCNT_dec(cv);
4154 cv = Nullcv;
79072805 4155 }
79072805
LW		 4156 }
4157 }
beab0874
JT		 4158 if (const_sv) {
4159 SvREFCNT_inc(const_sv);
4160 if (cv) {
0768512c 4161 assert(!CvROOT(cv) && !CvCONST(cv));
beab0874
JT		 4162 sv_setpv((SV*)cv, ""); /* prototype is "" */
4163 CvXSUBANY(cv).any_ptr = const_sv;
4164 CvXSUB(cv) = const_sv_xsub;
4165 CvCONST_on(cv);
beab0874
JT		 4166 }
4167 else {
4168 GvCV(gv) = Nullcv;
4169 cv = newCONSTSUB(NULL, name, const_sv);
4170 }
4171 op_free(block);
4172 SvREFCNT_dec(PL_compcv);
4173 PL_compcv = NULL;
4174 PL_sub_generation++;
4175 goto done;
4176 }
09bef843
SB		 4177 if (attrs) {
4178 HV *stash;
4179 SV *rcv;
4180
4181 /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>
4182 * before we clobber PL_compcv.
4183 */
4184 if (cv && !block) {
4185 rcv = (SV*)cv;
020f0e03
SB		 4186 /* Might have had built-in attributes applied -- propagate them. */
4187 CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
a9164de8 4188 if (CvGV(cv) && GvSTASH(CvGV(cv)))
09bef843 4189 stash = GvSTASH(CvGV(cv));
a9164de8 4190 else if (CvSTASH(cv))
09bef843
SB		 4191 stash = CvSTASH(cv);
4192 else
4193 stash = PL_curstash;
4194 }
4195 else {
4196 /* possibly about to re-define existing subr -- ignore old cv */
4197 rcv = (SV*)PL_compcv;
a9164de8 4198 if (name && GvSTASH(gv))
09bef843
SB		 4199 stash = GvSTASH(gv);
4200 else
4201 stash = PL_curstash;
4202 }
95f0a2f1 4203 apply_attrs(stash, rcv, attrs, FALSE);
09bef843 4204 }
a0d0e21e 4205 if (cv) { /* must reuse cv if autoloaded */
09bef843
SB		 4206 if (!block) {
4207 /* got here with just attrs -- work done, so bug out */
4208 SAVEFREESV(PL_compcv);
4209 goto done;
4210 }
a3985cdc 4211 /* transfer PL_compcv to cv */
4633a7c4 4212 cv_undef(cv);
3280af22 4213 CvFLAGS(cv) = CvFLAGS(PL_compcv);
5c41a5fa
DM		 4214 if (!CvWEAKOUTSIDE(cv))
4215 SvREFCNT_dec(CvOUTSIDE(cv));
3280af22 4216 CvOUTSIDE(cv) = CvOUTSIDE(PL_compcv);
a3985cdc 4217 CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(PL_compcv);
3280af22
NIS		 4218 CvOUTSIDE(PL_compcv) = 0;
4219 CvPADLIST(cv) = CvPADLIST(PL_compcv);
4220 CvPADLIST(PL_compcv) = 0;
282f25c9 4221 /* inner references to PL_compcv must be fixed up ... */
dd2155a4 4222 pad_fixup_inner_anons(CvPADLIST(cv), PL_compcv, cv);
282f25c9 4223 /* ... before we throw it away */
3280af22 4224 SvREFCNT_dec(PL_compcv);
b5c19bd7 4225 PL_compcv = cv;
a933f601
IZ		 4226 if (PERLDB_INTER)/* Advice debugger on the new sub. */
4227 ++PL_sub_generation;
a0d0e21e
LW		 4228 }
4229 else {
3280af22 4230 cv = PL_compcv;
44a8e56a 4231 if (name) {
4232 GvCV(gv) = cv;
4233 GvCVGEN(gv) = 0;
3280af22 4234 PL_sub_generation++;
44a8e56a 4235 }
a0d0e21e 4236 }
65c50114 4237 CvGV(cv) = gv;
a636914a 4238 CvFILE_set_from_cop(cv, PL_curcop);
3280af22 4239 CvSTASH(cv) = PL_curstash;
8990e307 4240
3fe9a6f1 4241 if (ps)
4242 sv_setpv((SV*)cv, ps);
4633a7c4 4243
3280af22 4244 if (PL_error_count) {
c07a80fd 4245 op_free(block);
4246 block = Nullop;
68dc0745 4247 if (name) {
4248 char *s = strrchr(name, ':');
4249 s = s ? s+1 : name;
6d4c2119
CS		 4250 if (strEQ(s, "BEGIN")) {
4251 char *not_safe =
4252 "BEGIN not safe after errors--compilation aborted";
faef0170 4253 if (PL_in_eval & EVAL_KEEPERR)
cea2e8a9 4254 Perl_croak(aTHX_ not_safe);
6d4c2119
CS		 4255 else {
4256 /* force display of errors found but not reported */
38a03e6e 4257 sv_catpv(ERRSV, not_safe);
35c1215d 4258 Perl_croak(aTHX_ "%"SVf, ERRSV);
6d4c2119
CS		 4259 }
4260 }
68dc0745 4261 }
c07a80fd 4262 }
beab0874
JT		 4263 if (!block)
4264 goto done;
a0d0e21e 4265
7766f137 4266 if (CvLVALUE(cv)) {
78f9721b
SM		 4267 CvROOT(cv) = newUNOP(OP_LEAVESUBLV, 0,
4268 mod(scalarseq(block), OP_LEAVESUBLV));
7766f137
GS		 4269 }
4270 else {
09c2fd24
AE		 4271 /* This makes sub {}; work as expected. */
4272 if (block->op_type == OP_STUB) {
4273 op_free(block);
4274 block = newSTATEOP(0, Nullch, 0);
4275 }
7766f137
GS		 4276 CvROOT(cv) = newUNOP(OP_LEAVESUB, 0, scalarseq(block));
4277 }
4278 CvROOT(cv)->op_private |= OPpREFCOUNTED;
4279 OpREFCNT_set(CvROOT(cv), 1);
4280 CvSTART(cv) = LINKLIST(CvROOT(cv));
4281 CvROOT(cv)->op_next = 0;
a2efc822 4282 CALL_PEEP(CvSTART(cv));
7766f137
GS		 4283
4284 /* now that optimizer has done its work, adjust pad values */
54310121 4285
dd2155a4
DM		 4286 pad_tidy(CvCLONE(cv) ? padtidy_SUBCLONE : padtidy_SUB);
4287
4288 if (CvCLONE(cv)) {
beab0874
JT		 4289 assert(!CvCONST(cv));
4290 if (ps && !*ps && op_const_sv(block, cv))
4291 CvCONST_on(cv);
a0d0e21e 4292 }
79072805 4293
83ee9e09 4294 if (name || aname) {
44a8e56a 4295 char *s;
83ee9e09 4296 char *tname = (name ? name : aname);
44a8e56a 4297
3280af22 4298 if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
46fc3d4c 4299 SV *sv = NEWSV(0,0);
44a8e56a 4300 SV *tmpstr = sv_newmortal();
549bb64a 4301 GV *db_postponed = gv_fetchpv("DB::postponed", GV_ADDMULTI, SVt_PVHV);
83ee9e09 4302 CV *pcv;
44a8e56a 4303 HV *hv;
4304
ed094faf
GS		 4305 Perl_sv_setpvf(aTHX_ sv, "%s:%ld-%ld",
4306 CopFILE(PL_curcop),
cc49e20b 4307 (long)PL_subline, (long)CopLINE(PL_curcop));
44a8e56a 4308 gv_efullname3(tmpstr, gv, Nullch);
3280af22 4309 hv_store(GvHV(PL_DBsub), SvPVX(tmpstr), SvCUR(tmpstr), sv, 0);
44a8e56a 4310 hv = GvHVn(db_postponed);
9607fc9c 4311 if (HvFILL(hv) > 0 && hv_exists(hv, SvPVX(tmpstr), SvCUR(tmpstr))
83ee9e09
GS		 4312 && (pcv = GvCV(db_postponed)))
4313 {
44a8e56a 4314 dSP;
924508f0 4315 PUSHMARK(SP);
44a8e56a 4316 XPUSHs(tmpstr);
4317 PUTBACK;
83ee9e09 4318 call_sv((SV*)pcv, G_DISCARD);
44a8e56a 4319 }
4320 }
79072805 4321
83ee9e09 4322 if ((s = strrchr(tname,':')))
28757baa 4323 s++;
4324 else
83ee9e09 4325 s = tname;
ed094faf 4326
7d30b5c4 4327 if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I')
ed094faf
GS		 4328 goto done;
4329
7678c486 4330 if (strEQ(s, "BEGIN") && !PL_error_count) {
3280af22 4331 I32 oldscope = PL_scopestack_ix;
28757baa 4332 ENTER;
57843af0
GS		 4333 SAVECOPFILE(&PL_compiling);
4334 SAVECOPLINE(&PL_compiling);
28757baa 4335
3280af22
NIS		 4336 if (!PL_beginav)
4337 PL_beginav = newAV();
28757baa 4338 DEBUG_x( dump_sub(gv) );
ea2f84a3
GS		 4339 av_push(PL_beginav, (SV*)cv);
4340 GvCV(gv) = 0; /* cv has been hijacked */
3280af22 4341 call_list(oldscope, PL_beginav);
a6006777 4342
3280af22 4343 PL_curcop = &PL_compiling;
eb160463 4344 PL_compiling.op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
28757baa 4345 LEAVE;
4346 }
3280af22
NIS		 4347 else if (strEQ(s, "END") && !PL_error_count) {
4348 if (!PL_endav)
4349 PL_endav = newAV();
ed094faf 4350 DEBUG_x( dump_sub(gv) );
3280af22 4351 av_unshift(PL_endav, 1);
ea2f84a3
GS		 4352 av_store(PL_endav, 0, (SV*)cv);
4353 GvCV(gv) = 0; /* cv has been hijacked */
28757baa 4354 }
7d30b5c4
GS		 4355 else if (strEQ(s, "CHECK") && !PL_error_count) {
4356 if (!PL_checkav)
4357 PL_checkav = newAV();
ed094faf 4358 DEBUG_x( dump_sub(gv) );
ddda08b7 4359 if (PL_main_start && ckWARN(WARN_VOID))
9014280d 4360 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run CHECK block");
7d30b5c4 4361 av_unshift(PL_checkav, 1);
ea2f84a3
GS		 4362 av_store(PL_checkav, 0, (SV*)cv);
4363 GvCV(gv) = 0; /* cv has been hijacked */
4f25aa18 4364 }
3280af22
NIS		 4365 else if (strEQ(s, "INIT") && !PL_error_count) {
4366 if (!PL_initav)
4367 PL_initav = newAV();
ed094faf 4368 DEBUG_x( dump_sub(gv) );
ddda08b7 4369 if (PL_main_start && ckWARN(WARN_VOID))
9014280d 4370 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run INIT block");
ea2f84a3
GS		 4371 av_push(PL_initav, (SV*)cv);
4372 GvCV(gv) = 0; /* cv has been hijacked */
ae77835f 4373 }
79072805 4374 }
a6006777 4375
aa689395 4376 done:
3280af22 4377 PL_copline = NOLINE;
8990e307 4378 LEAVE_SCOPE(floor);
a0d0e21e 4379 return cv;
79072805
LW		 4380}
4381
b099ddc0 4382/* XXX unsafe for threads if eval_owner isn't held */
954c1994
GS		 4383/*
4384=for apidoc newCONSTSUB
4385
4386Creates a constant sub equivalent to Perl C<sub FOO () { 123 }> which is
4387eligible for inlining at compile-time.
4388
4389=cut
4390*/
4391
beab0874 4392CV *
864dbfa3 4393Perl_newCONSTSUB(pTHX_ HV *stash, char *name, SV *sv)
5476c433 4394{
beab0874 4395 CV* cv;
5476c433 4396
11faa288 4397 ENTER;
11faa288 4398
f4dd75d9 4399 SAVECOPLINE(PL_curcop);
11faa288 4400 CopLINE_set(PL_curcop, PL_copline);
f4dd75d9
GS		 4401
4402 SAVEHINTS();
3280af22 4403 PL_hints &= ~HINT_BLOCK_SCOPE;
11faa288
GS		 4404
4405 if (stash) {
4406 SAVESPTR(PL_curstash);
4407 SAVECOPSTASH(PL_curcop);
4408 PL_curstash = stash;
05ec9bb3 4409 CopSTASH_set(PL_curcop,stash);
11faa288 4410 }
5476c433 4411
91a15d0d 4412 cv = newXS(name, const_sv_xsub, savepv(CopFILE(PL_curcop)));
beab0874
JT		 4413 CvXSUBANY(cv).any_ptr = sv;
4414 CvCONST_on(cv);
4415 sv_setpv((SV*)cv, ""); /* prototype is "" */
5476c433 4416
02f28d44
MHM		 4417 if (stash)
4418 CopSTASH_free(PL_curcop);
4419
11faa288 4420 LEAVE;
beab0874
JT		 4421
4422 return cv;
5476c433
JD		 4423}
4424
954c1994
GS		 4425/*
4426=for apidoc U||newXS
4427
4428Used by C<xsubpp> to hook up XSUBs as Perl subs.
4429
4430=cut
4431*/
4432
57d3b86d 4433CV *
864dbfa3 4434Perl_newXS(pTHX_ char *name, XSUBADDR_t subaddr, char *filename)
a0d0e21e 4435{
c99da370
JH		 4436 GV *gv = gv_fetchpv(name ? name :
4437 (PL_curstash ? "__ANON__" : "__ANON__::__ANON__"),
4438 GV_ADDMULTI, SVt_PVCV);
79072805 4439 register CV *cv;
44a8e56a 4440
1ecdd9a8
HS		 4441 if (!subaddr)
4442 Perl_croak(aTHX_ "panic: no address for '%s' in '%s'", name, filename);
4443
155aba94 4444 if ((cv = (name ? GvCV(gv) : Nullcv))) {
44a8e56a 4445 if (GvCVGEN(gv)) {
4446 /* just a cached method */
4447 SvREFCNT_dec(cv);
4448 cv = 0;
4449 }
4450 else if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) {
4451 /* already defined (or promised) */
599cee73 4452 if (ckWARN(WARN_REDEFINE) && !(CvGV(cv) && GvSTASH(CvGV(cv))
2f34f9d4 4453 && strEQ(HvNAME(GvSTASH(CvGV(cv))), "autouse"))) {
57843af0 4454 line_t oldline = CopLINE(PL_curcop);
51f6edd3 4455 if (PL_copline != NOLINE)
57843af0 4456 CopLINE_set(PL_curcop, PL_copline);
9014280d 4457 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
beab0874
JT		 4458 CvCONST(cv) ? "Constant subroutine %s redefined"
4459 : "Subroutine %s redefined"
4460 ,name);
57843af0 4461 CopLINE_set(PL_curcop, oldline);
a0d0e21e
LW		 4462 }
4463 SvREFCNT_dec(cv);
4464 cv = 0;
79072805 4465 }
79072805 4466 }
44a8e56a 4467
4468 if (cv) /* must reuse cv if autoloaded */
4469 cv_undef(cv);
a0d0e21e
LW		 4470 else {
4471 cv = (CV*)NEWSV(1105,0);
4472 sv_upgrade((SV *)cv, SVt_PVCV);
44a8e56a 4473 if (name) {
4474 GvCV(gv) = cv;
4475 GvCVGEN(gv) = 0;
3280af22 4476 PL_sub_generation++;
44a8e56a 4477 }
a0d0e21e 4478 }
65c50114 4479 CvGV(cv) = gv;
b195d487 4480 (void)gv_fetchfile(filename);
57843af0
GS		 4481 CvFILE(cv) = filename; /* NOTE: not copied, as it is expected to be
4482 an external constant string */
a0d0e21e 4483 CvXSUB(cv) = subaddr;
44a8e56a 4484
28757baa 4485 if (name) {
4486 char *s = strrchr(name,':');
4487 if (s)
4488 s++;
4489 else
4490 s = name;
ed094faf 4491
7d30b5c4 4492 if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I')
ed094faf
GS		 4493 goto done;
4494
28757baa 4495 if (strEQ(s, "BEGIN")) {
3280af22
NIS		 4496 if (!PL_beginav)
4497 PL_beginav = newAV();
ea2f84a3
GS		 4498 av_push(PL_beginav, (SV*)cv);
4499 GvCV(gv) = 0; /* cv has been hijacked */
28757baa 4500 }
4501 else if (strEQ(s, "END")) {
3280af22
NIS		 4502 if (!PL_endav)
4503 PL_endav = newAV();
4504 av_unshift(PL_endav, 1);
ea2f84a3
GS		 4505 av_store(PL_endav, 0, (SV*)cv);
4506 GvCV(gv) = 0; /* cv has been hijacked */
28757baa 4507 }
7d30b5c4
GS		 4508 else if (strEQ(s, "CHECK")) {
4509 if (!PL_checkav)
4510 PL_checkav = newAV();
ddda08b7 4511 if (PL_main_start && ckWARN(WARN_VOID))
9014280d 4512 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run CHECK block");
7d30b5c4 4513 av_unshift(PL_checkav, 1);
ea2f84a3
GS		 4514 av_store(PL_checkav, 0, (SV*)cv);
4515 GvCV(gv) = 0; /* cv has been hijacked */
4f25aa18 4516 }
7d07dbc2 4517 else if (strEQ(s, "INIT")) {
3280af22
NIS		 4518 if (!PL_initav)
4519 PL_initav = newAV();
ddda08b7 4520 if (PL_main_start && ckWARN(WARN_VOID))
9014280d 4521 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run INIT block");
ea2f84a3
GS		 4522 av_push(PL_initav, (SV*)cv);
4523 GvCV(gv) = 0; /* cv has been hijacked */
ae77835f 4524 }
28757baa 4525 }
8990e307 4526 else
a5f75d66 4527 CvANON_on(cv);
44a8e56a 4528
ed094faf 4529done:
a0d0e21e 4530 return cv;
79072805
LW		 4531}
4532
4533void
864dbfa3 4534Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block)
79072805
LW		 4535{
4536 register CV *cv;
4537 char *name;
4538 GV *gv;
2d8e6c8d 4539 STRLEN n_a;
79072805 4540
11343788 4541 if (o)
2d8e6c8d 4542 name = SvPVx(cSVOPo->op_sv, n_a);
79072805
LW		 4543 else
4544 name = "STDOUT";
85e6fe83 4545 gv = gv_fetchpv(name,TRUE, SVt_PVFM);
7fb37951
AMS		 4546#ifdef GV_UNIQUE_CHECK
4547 if (GvUNIQUE(gv)) {
4548 Perl_croak(aTHX_ "Bad symbol for form (GV is unique)");
5bd07a3d
DM		 4549 }
4550#endif
a5f75d66 4551 GvMULTI_on(gv);
155aba94 4552 if ((cv = GvFORM(gv))) {
599cee73 4553 if (ckWARN(WARN_REDEFINE)) {
57843af0 4554 line_t oldline = CopLINE(PL_curcop);
d8a34499
IK		 4555 if (PL_copline != NOLINE)
4556 CopLINE_set(PL_curcop, PL_copline);
9014280d 4557 Perl_warner(aTHX_ packWARN(WARN_REDEFINE), "Format %s redefined",name);
57843af0 4558 CopLINE_set(PL_curcop, oldline);
79072805 4559 }
8990e307 4560 SvREFCNT_dec(cv);
79072805 4561 }
3280af22 4562 cv = PL_compcv;
79072805 4563 GvFORM(gv) = cv;
65c50114 4564 CvGV(cv) = gv;
a636914a 4565 CvFILE_set_from_cop(cv, PL_curcop);
79072805 4566
a0d0e21e 4567
dd2155a4 4568 pad_tidy(padtidy_FORMAT);
79072805 4569 CvROOT(cv) = newUNOP(OP_LEAVEWRITE, 0, scalarseq(block));
7934575e
GS		 4570 CvROOT(cv)->op_private |= OPpREFCOUNTED;
4571 OpREFCNT_set(CvROOT(cv), 1);
79072805
LW		 4572 CvSTART(cv) = LINKLIST(CvROOT(cv));
4573 CvROOT(cv)->op_next = 0;
a2efc822 4574 CALL_PEEP(CvSTART(cv));
11343788 4575 op_free(o);
3280af22 4576 PL_copline = NOLINE;
8990e307 4577 LEAVE_SCOPE(floor);
79072805
LW		 4578}
4579
4580OP *
864dbfa3 4581Perl_newANONLIST(pTHX_ OP *o)
79072805 4582{
93a17b20 4583 return newUNOP(OP_REFGEN, 0,
11343788 4584 mod(list(convert(OP_ANONLIST, 0, o)), OP_REFGEN));
79072805
LW		 4585}
4586
4587OP *
864dbfa3 4588Perl_newANONHASH(pTHX_ OP *o)
79072805 4589{
93a17b20 4590 return newUNOP(OP_REFGEN, 0,
11343788 4591 mod(list(convert(OP_ANONHASH, 0, o)), OP_REFGEN));
a0d0e21e
LW		 4592}
4593
4594OP *
864dbfa3 4595Perl_newANONSUB(pTHX_ I32 floor, OP *proto, OP *block)
a0d0e21e 4596{
09bef843
SB		 4597 return newANONATTRSUB(floor, proto, Nullop, block);
4598}
4599
4600OP *
4601Perl_newANONATTRSUB(pTHX_ I32 floor, OP *proto, OP *attrs, OP *block)
4602{
a0d0e21e 4603 return newUNOP(OP_REFGEN, 0,
09bef843
SB		 4604 newSVOP(OP_ANONCODE, 0,
4605 (SV*)newATTRSUB(floor, 0, proto, attrs, block)));
79072805
LW		 4606}
4607
4608OP *
864dbfa3 4609Perl_oopsAV(pTHX_ OP *o)
79072805 4610{
ed6116ce
LW		 4611 switch (o->op_type) {
4612 case OP_PADSV:
4613 o->op_type = OP_PADAV;
22c35a8c 4614 o->op_ppaddr = PL_ppaddr[OP_PADAV];
51e247a3 4615 return ref(o, OP_RV2AV);
b2ffa427 4616
ed6116ce 4617 case OP_RV2SV:
79072805 4618 o->op_type = OP_RV2AV;
22c35a8c 4619 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
79072805 4620 ref(o, OP_RV2AV);
ed6116ce
LW		 4621 break;
4622
4623 default:
0453d815 4624 if (ckWARN_d(WARN_INTERNAL))
9014280d 4625 Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsAV");
ed6116ce
LW		 4626 break;
4627 }
79072805
LW		 4628 return o;
4629}
4630
4631OP *
864dbfa3 4632Perl_oopsHV(pTHX_ OP *o)
79072805 4633{
ed6116ce
LW		 4634 switch (o->op_type) {
4635 case OP_PADSV:
4636 case OP_PADAV:
4637 o->op_type = OP_PADHV;
22c35a8c 4638 o->op_ppaddr = PL_ppaddr[OP_PADHV];
51e247a3 4639 return ref(o, OP_RV2HV);
ed6116ce
LW		 4640
4641 case OP_RV2SV:
4642 case OP_RV2AV:
79072805 4643 o->op_type = OP_RV2HV;
22c35a8c 4644 o->op_ppaddr = PL_ppaddr[OP_RV2HV];
79072805 4645 ref(o, OP_RV2HV);
ed6116ce
LW		 4646 break;
4647
4648 default:
0453d815 4649 if (ckWARN_d(WARN_INTERNAL))
9014280d 4650 Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsHV");
ed6116ce
LW		 4651 break;
4652 }
79072805
LW		 4653 return o;
4654}
4655
4656OP *
864dbfa3 4657Perl_newAVREF(pTHX_ OP *o)
79072805 4658{
ed6116ce
LW		 4659 if (o->op_type == OP_PADANY) {
4660 o->op_type = OP_PADAV;
22c35a8c 4661 o->op_ppaddr = PL_ppaddr[OP_PADAV];
93a17b20 4662 return o;
ed6116ce 4663 }
a1063b2d 4664 else if ((o->op_type == OP_RV2AV || o->op_type == OP_PADAV)
9014280d
PM		 4665 && ckWARN(WARN_DEPRECATED)) {
4666 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
a1063b2d
RH		 4667 "Using an array as a reference is deprecated");
4668 }
79072805
LW		 4669 return newUNOP(OP_RV2AV, 0, scalar(o));
4670}
4671
4672OP *
864dbfa3 4673Perl_newGVREF(pTHX_ I32 type, OP *o)
79072805 4674{
82092f1d 4675 if (type == OP_MAPSTART || type == OP_GREPSTART || type == OP_SORT)
a0d0e21e 4676 return newUNOP(OP_NULL, 0, o);
748a9306 4677 return ref(newUNOP(OP_RV2GV, OPf_REF, o), type);
79072805
LW		 4678}
4679
4680OP *
864dbfa3 4681Perl_newHVREF(pTHX_ OP *o)
79072805 4682{
ed6116ce
LW		 4683 if (o->op_type == OP_PADANY) {
4684 o->op_type = OP_PADHV;
22c35a8c 4685 o->op_ppaddr = PL_ppaddr[OP_PADHV];
93a17b20 4686 return o;
ed6116ce 4687 }
a1063b2d 4688 else if ((o->op_type == OP_RV2HV || o->op_type == OP_PADHV)
9014280d
PM		 4689 && ckWARN(WARN_DEPRECATED)) {
4690 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
a1063b2d
RH		 4691 "Using a hash as a reference is deprecated");
4692 }
79072805
LW		 4693 return newUNOP(OP_RV2HV, 0, scalar(o));
4694}
4695
4696OP *
864dbfa3 4697Perl_oopsCV(pTHX_ OP *o)
79072805 4698{
cea2e8a9 4699 Perl_croak(aTHX_ "NOT IMPL LINE %d",__LINE__);
79072805
LW		 4700 /* STUB */
4701 return o;
4702}
4703
4704OP *
864dbfa3 4705Perl_newCVREF(pTHX_ I32 flags, OP *o)
79072805 4706{
c07a80fd 4707 return newUNOP(OP_RV2CV, flags, scalar(o));
79072805
LW		 4708}
4709
4710OP *
864dbfa3 4711Perl_newSVREF(pTHX_ OP *o)
79072805 4712{
ed6116ce
LW		 4713 if (o->op_type == OP_PADANY) {
4714 o->op_type = OP_PADSV;
22c35a8c 4715 o->op_ppaddr = PL_ppaddr[OP_PADSV];
93a17b20 4716 return o;
ed6116ce 4717 }
224a4551
MB		 4718 else if (o->op_type == OP_THREADSV && !(o->op_flags & OPpDONE_SVREF)) {
4719 o->op_flags |= OPpDONE_SVREF;
a863c7d1 4720 return o;
224a4551 4721 }
79072805
LW		 4722 return newUNOP(OP_RV2SV, 0, scalar(o));
4723}
4724
4725/* Check routines. */
4726
4727OP *
cea2e8a9 4728Perl_ck_anoncode(pTHX_ OP *o)
5f05dabc 4729{
dd2155a4 4730 cSVOPo->op_targ = pad_add_anon(cSVOPo->op_sv, o->op_type);
5dc0d613 4731 cSVOPo->op_sv = Nullsv;
5dc0d613 4732 return o;
5f05dabc 4733}
4734
4735OP *
cea2e8a9 4736Perl_ck_bitop(pTHX_ OP *o)
55497cff 4737{
276b2a0c
RGS		 4738#define OP_IS_NUMCOMPARE(op) \
4739 ((op) == OP_LT || (op) == OP_I_LT || \
4740 (op) == OP_GT || (op) == OP_I_GT || \
4741 (op) == OP_LE || (op) == OP_I_LE || \
4742 (op) == OP_GE || (op) == OP_I_GE || \
4743 (op) == OP_EQ || (op) == OP_I_EQ || \
4744 (op) == OP_NE || (op) == OP_I_NE || \
4745 (op) == OP_NCMP || (op) == OP_I_NCMP)
eb160463 4746 o->op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
2b84528b
RGS		 4747 if (!(o->op_flags & OPf_STACKED) /* Not an assignment */
4748 && (o->op_type == OP_BIT_OR
4749 || o->op_type == OP_BIT_AND
4750 || o->op_type == OP_BIT_XOR))
276b2a0c 4751 {
96a925ab
YST		 4752 OP * left = cBINOPo->op_first;
4753 OP * right = left->op_sibling;
4754 if ((OP_IS_NUMCOMPARE(left->op_type) &&
4755 (left->op_flags & OPf_PARENS) == 0) ||
4756 (OP_IS_NUMCOMPARE(right->op_type) &&
4757 (right->op_flags & OPf_PARENS) == 0))
276b2a0c
RGS		 4758 if (ckWARN(WARN_PRECEDENCE))
4759 Perl_warner(aTHX_ packWARN(WARN_PRECEDENCE),
4760 "Possible precedence problem on bitwise %c operator",
4761 o->op_type == OP_BIT_OR ? '|'
4762 : o->op_type == OP_BIT_AND ? '&' : '^'
4763 );
4764 }
5dc0d613 4765 return o;
55497cff 4766}
4767
4768OP *
cea2e8a9 4769Perl_ck_concat(pTHX_ OP *o)
79072805 4770{
0165acc7 4771 OP *kid = cUNOPo->op_first;
df91b2c5
AE		 4772 if (kid->op_type == OP_CONCAT && !(kid->op_private & OPpTARGET_MY) &&
4773 !(kUNOP->op_first->op_flags & OPf_MOD))
0165acc7 4774 o->op_flags |= OPf_STACKED;
11343788 4775 return o;
79072805
LW		 4776}
4777
4778OP *
cea2e8a9 4779Perl_ck_spair(pTHX_ OP *o)
79072805 4780{
11343788 4781 if (o->op_flags & OPf_KIDS) {
79072805 4782 OP* newop;
a0d0e21e 4783 OP* kid;
5dc0d613
MB		 4784 OPCODE type = o->op_type;
4785 o = modkids(ck_fun(o), type);
11343788 4786 kid = cUNOPo->op_first;
a0d0e21e
LW		 4787 newop = kUNOP->op_first->op_sibling;
4788 if (newop &&
4789 (newop->op_sibling ||
22c35a8c 4790 !(PL_opargs[newop->op_type] & OA_RETSCALAR) ||
a0d0e21e
LW		 4791 newop->op_type == OP_PADAV || newop->op_type == OP_PADHV ||
4792 newop->op_type == OP_RV2AV || newop->op_type == OP_RV2HV)) {
b2ffa427 4793
11343788 4794 return o;
a0d0e21e
LW		 4795 }
4796 op_free(kUNOP->op_first);
4797 kUNOP->op_first = newop;
4798 }
22c35a8c 4799 o->op_ppaddr = PL_ppaddr[++o->op_type];
11343788 4800 return ck_fun(o);
a0d0e21e
LW		 4801}
4802
4803OP *
cea2e8a9 4804Perl_ck_delete(pTHX_ OP *o)
a0d0e21e 4805{
11343788 4806 o = ck_fun(o);
5dc0d613 4807 o->op_private = 0;
11343788
MB		 4808 if (o->op_flags & OPf_KIDS) {
4809 OP *kid = cUNOPo->op_first;
01020589
GS		 4810 switch (kid->op_type) {
4811 case OP_ASLICE:
4812 o->op_flags |= OPf_SPECIAL;
4813 /* FALL THROUGH */
4814 case OP_HSLICE:
5dc0d613 4815 o->op_private |= OPpSLICE;
01020589
GS		 4816 break;
4817 case OP_AELEM:
4818 o->op_flags |= OPf_SPECIAL;
4819 /* FALL THROUGH */
4820 case OP_HELEM:
4821 break;
4822 default:
4823 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element or slice",
53e06cf0 4824 OP_DESC(o));
01020589 4825 }
93c66552 4826 op_null(kid);
79072805 4827 }
11343788 4828 return o;
79072805
LW		 4829}
4830
4831OP *
96e176bf
CL		 4832Perl_ck_die(pTHX_ OP *o)
4833{
4834#ifdef VMS
4835 if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
4836#endif
4837 return ck_fun(o);
4838}
4839
4840OP *
cea2e8a9 4841Perl_ck_eof(pTHX_ OP *o)
79072805 4842{
11343788 4843 I32 type = o->op_type;
79072805 4844
11343788
MB		 4845 if (o->op_flags & OPf_KIDS) {
4846 if (cLISTOPo->op_first->op_type == OP_STUB) {
4847 op_free(o);
8fde6460 4848 o = newUNOP(type, OPf_SPECIAL, newGVOP(OP_GV, 0, PL_argvgv));
8990e307 4849 }
11343788 4850 return ck_fun(o);
79072805 4851 }
11343788 4852 return o;
79072805
LW		 4853}
4854
4855OP *
cea2e8a9 4856Perl_ck_eval(pTHX_ OP *o)
79072805 4857{
3280af22 4858 PL_hints |= HINT_BLOCK_SCOPE;
11343788
MB		 4859 if (o->op_flags & OPf_KIDS) {
4860 SVOP *kid = (SVOP*)cUNOPo->op_first;
79072805 4861
93a17b20 4862 if (!kid) {
11343788 4863 o->op_flags &= ~OPf_KIDS;
93c66552 4864 op_null(o);
79072805 4865 }
b14574b4 4866 else if (kid->op_type == OP_LINESEQ || kid->op_type == OP_STUB) {
79072805
LW		 4867 LOGOP *enter;
4868
11343788
MB		 4869 cUNOPo->op_first = 0;
4870 op_free(o);
79072805 4871
b7dc083c 4872 NewOp(1101, enter, 1, LOGOP);
79072805 4873 enter->op_type = OP_ENTERTRY;
22c35a8c 4874 enter->op_ppaddr = PL_ppaddr[OP_ENTERTRY];
79072805
LW		 4875 enter->op_private = 0;
4876
4877 /* establish postfix order */
4878 enter->op_next = (OP*)enter;
4879
11343788
MB		 4880 o = prepend_elem(OP_LINESEQ, (OP*)enter, (OP*)kid);
4881 o->op_type = OP_LEAVETRY;
22c35a8c 4882 o->op_ppaddr = PL_ppaddr[OP_LEAVETRY];
11343788
MB		 4883 enter->op_other = o;
4884 return o;
79072805 4885 }
b5c19bd7 4886 else {
473986ff 4887 scalar((OP*)kid);
b5c19bd7
DM		 4888 PL_cv_has_eval = 1;
4889 }
79072805
LW		 4890 }
4891 else {
11343788 4892 op_free(o);
54b9620d 4893 o = newUNOP(OP_ENTEREVAL, 0, newDEFSVOP());
79072805 4894 }
3280af22 4895 o->op_targ = (PADOFFSET)PL_hints;
11343788 4896 return o;
79072805
LW		 4897}
4898
4899OP *
d98f61e7
GS		 4900Perl_ck_exit(pTHX_ OP *o)
4901{
4902#ifdef VMS
4903 HV *table = GvHV(PL_hintgv);
4904 if (table) {
4905 SV **svp = hv_fetch(table, "vmsish_exit", 11, FALSE);
4906 if (svp && *svp && SvTRUE(*svp))
4907 o->op_private |= OPpEXIT_VMSISH;
4908 }
96e176bf 4909 if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
d98f61e7
GS		 4910#endif
4911 return ck_fun(o);
4912}
4913
4914OP *
cea2e8a9 4915Perl_ck_exec(pTHX_ OP *o)
79072805
LW		 4916{
4917 OP *kid;
11343788
MB		 4918 if (o->op_flags & OPf_STACKED) {
4919 o = ck_fun(o);
4920 kid = cUNOPo->op_first->op_sibling;
8990e307 4921 if (kid->op_type == OP_RV2GV)
93c66552 4922 op_null(kid);
79072805 4923 }
463ee0b2 4924 else
11343788
MB		 4925 o = listkids(o);
4926 return o;
79072805
LW		 4927}
4928
4929OP *
cea2e8a9 4930Perl_ck_exists(pTHX_ OP *o)
5f05dabc 4931{
5196be3e
MB		 4932 o = ck_fun(o);
4933 if (o->op_flags & OPf_KIDS) {
4934 OP *kid = cUNOPo->op_first;
afebc493
GS		 4935 if (kid->op_type == OP_ENTERSUB) {
4936 (void) ref(kid, o->op_type);
4937 if (kid->op_type != OP_RV2CV && !PL_error_count)
4938 Perl_croak(aTHX_ "%s argument is not a subroutine name",
53e06cf0 4939 OP_DESC(o));
afebc493
GS		 4940 o->op_private |= OPpEXISTS_SUB;
4941 }
4942 else if (kid->op_type == OP_AELEM)
01020589
GS		 4943 o->op_flags |= OPf_SPECIAL;
4944 else if (kid->op_type != OP_HELEM)
4945 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element",
53e06cf0 4946 OP_DESC(o));
93c66552 4947 op_null(kid);
5f05dabc 4948 }
5196be3e 4949 return o;
5f05dabc 4950}
4951
22c35a8c 4952#if 0
5f05dabc 4953OP *
cea2e8a9 4954Perl_ck_gvconst(pTHX_ register OP *o)
79072805
LW		 4955{
4956 o = fold_constants(o);
4957 if (o->op_type == OP_CONST)
4958 o->op_type = OP_GV;
4959 return o;
4960}
22c35a8c 4961#endif
79072805
LW		 4962
4963OP *
cea2e8a9 4964Perl_ck_rvconst(pTHX_ register OP *o)
79072805 4965{
11343788 4966 SVOP *kid = (SVOP*)cUNOPo->op_first;
85e6fe83 4967
3280af22 4968 o->op_private |= (PL_hints & HINT_STRICT_REFS);
79072805 4969 if (kid->op_type == OP_CONST) {
44a8e56a 4970 char *name;
4971 int iscv;
4972 GV *gv;
779c5bc9 4973 SV *kidsv = kid->op_sv;
2d8e6c8d 4974 STRLEN n_a;
44a8e56a 4975
779c5bc9
GS		 4976 /* Is it a constant from cv_const_sv()? */
4977 if (SvROK(kidsv) && SvREADONLY(kidsv)) {
4978 SV *rsv = SvRV(kidsv);
4979 int svtype = SvTYPE(rsv);
4980 char *badtype = Nullch;
4981
4982 switch (o->op_type) {
4983 case OP_RV2SV:
4984 if (svtype > SVt_PVMG)
4985 badtype = "a SCALAR";
4986 break;
4987 case OP_RV2AV:
4988 if (svtype != SVt_PVAV)
4989 badtype = "an ARRAY";
4990 break;
4991 case OP_RV2HV:
6d822dc4 4992 if (svtype != SVt_PVHV)
779c5bc9 4993 badtype = "a HASH";
779c5bc9
GS		 4994 break;
4995 case OP_RV2CV:
4996 if (svtype != SVt_PVCV)
4997 badtype = "a CODE";
4998 break;
4999 }
5000 if (badtype)
cea2e8a9 5001 Perl_croak(aTHX_ "Constant is not %s reference", badtype);
779c5bc9
GS		 5002 return o;
5003 }
2d8e6c8d 5004 name = SvPV(kidsv, n_a);
3280af22 5005 if ((PL_hints & HINT_STRICT_REFS) && (kid->op_private & OPpCONST_BARE)) {
44a8e56a 5006 char *badthing = Nullch;
5dc0d613 5007 switch (o->op_type) {
44a8e56a 5008 case OP_RV2SV:
5009 badthing = "a SCALAR";
5010 break;
5011 case OP_RV2AV:
5012 badthing = "an ARRAY";
5013 break;
5014 case OP_RV2HV:
5015 badthing = "a HASH";
5016 break;
5017 }
5018 if (badthing)
1c846c1f 5019 Perl_croak(aTHX_
44a8e56a 5020 "Can't use bareword (\"%s\") as %s ref while \"strict refs\" in use",
5021 name, badthing);
5022 }
93233ece
CS		 5023 /*
5024 * This is a little tricky. We only want to add the symbol if we
5025 * didn't add it in the lexer. Otherwise we get duplicate strict
5026 * warnings. But if we didn't add it in the lexer, we must at
5027 * least pretend like we wanted to add it even if it existed before,
5028 * or we get possible typo warnings. OPpCONST_ENTERED says
5029 * whether the lexer already added THIS instance of this symbol.
5030 */
5196be3e 5031 iscv = (o->op_type == OP_RV2CV) * 2;
93233ece 5032 do {
44a8e56a 5033 gv = gv_fetchpv(name,
748a9306 5034 iscv | !(kid->op_private & OPpCONST_ENTERED),
a0d0e21e
LW		 5035 iscv
5036 ? SVt_PVCV
11343788 5037 : o->op_type == OP_RV2SV
a0d0e21e 5038 ? SVt_PV
11343788 5039 : o->op_type == OP_RV2AV
a0d0e21e 5040 ? SVt_PVAV
11343788 5041 : o->op_type == OP_RV2HV
a0d0e21e
LW		 5042 ? SVt_PVHV
5043 : SVt_PVGV);
93233ece
CS		 5044 } while (!gv && !(kid->op_private & OPpCONST_ENTERED) && !iscv++);
5045 if (gv) {
5046 kid->op_type = OP_GV;
5047 SvREFCNT_dec(kid->op_sv);
350de78d 5048#ifdef USE_ITHREADS
638eceb6 5049 /* XXX hack: dependence on sizeof(PADOP) <= sizeof(SVOP) */
350de78d 5050 kPADOP->op_padix = pad_alloc(OP_GV, SVs_PADTMP);
dd2155a4 5051 SvREFCNT_dec(PAD_SVl(kPADOP->op_padix));
743e66e6 5052 GvIN_PAD_on(gv);
dd2155a4 5053 PAD_SETSV(kPADOP->op_padix, (SV*) SvREFCNT_inc(gv));
350de78d 5054#else
93233ece 5055 kid->op_sv = SvREFCNT_inc(gv);
350de78d 5056#endif
23f1ca44 5057 kid->op_private = 0;
76cd736e 5058 kid->op_ppaddr = PL_ppaddr[OP_GV];
a0d0e21e 5059 }
79072805 5060 }
11343788 5061 return o;
79072805
LW		 5062}
5063
5064OP *
cea2e8a9 5065Perl_ck_ftst(pTHX_ OP *o)
79072805 5066{
11343788 5067 I32 type = o->op_type;
79072805 5068
d0dca557
JD		 5069 if (o->op_flags & OPf_REF) {
5070 /* nothing */
5071 }
5072 else if (o->op_flags & OPf_KIDS && cUNOPo->op_first->op_type != OP_STUB) {
11343788 5073 SVOP *kid = (SVOP*)cUNOPo->op_first;
79072805
LW		 5074
5075 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
2d8e6c8d 5076 STRLEN n_a;
a0d0e21e 5077 OP *newop = newGVOP(type, OPf_REF,
2d8e6c8d 5078 gv_fetchpv(SvPVx(kid->op_sv, n_a), TRUE, SVt_PVIO));
11343788 5079 op_free(o);
d0dca557 5080 o = newop;
79072805 5081 }
1af34c76
JH		 5082 else {
5083 if ((PL_hints & HINT_FILETEST_ACCESS) &&
5084 OP_IS_FILETEST_ACCESS(o))
5085 o->op_private |= OPpFT_ACCESS;
5086 }
fbb0b3b3
RGS		 5087 if (PL_check[kid->op_type] == MEMBER_TO_FPTR(Perl_ck_ftst)
5088 && kid->op_type != OP_STAT && kid->op_type != OP_LSTAT)
5089 o->op_private |= OPpFT_STACKED;
79072805
LW		 5090 }
5091 else {
11343788 5092 op_free(o);
79072805 5093 if (type == OP_FTTTY)
8fde6460 5094 o = newGVOP(type, OPf_REF, PL_stdingv);
79072805 5095 else
d0dca557 5096 o = newUNOP(type, 0, newDEFSVOP());
79072805 5097 }
11343788 5098 return o;
79072805
LW		 5099}
5100
5101OP *
cea2e8a9 5102Perl_ck_fun(pTHX_ OP *o)
79072805
LW		 5103{
5104 register OP *kid;
5105 OP **tokid;
5106 OP *sibl;
5107 I32 numargs = 0;
11343788 5108 int type = o->op_type;
22c35a8c 5109 register I32 oa = PL_opargs[type] >> OASHIFT;
aeea060c 5110
11343788 5111 if (o->op_flags & OPf_STACKED) {
79072805
LW		 5112 if ((oa & OA_OPTIONAL) && (oa >> 4) && !((oa >> 4) & OA_OPTIONAL))
5113 oa &= ~OA_OPTIONAL;
5114 else
11343788 5115 return no_fh_allowed(o);
79072805
LW		 5116 }
5117
11343788 5118 if (o->op_flags & OPf_KIDS) {
2d8e6c8d 5119 STRLEN n_a;
11343788
MB		 5120 tokid = &cLISTOPo->op_first;
5121 kid = cLISTOPo->op_first;
8990e307 5122 if (kid->op_type == OP_PUSHMARK ||
155aba94 5123 (kid->op_type == OP_NULL && kid->op_targ == OP_PUSHMARK))
8990e307 5124 {
79072805
LW		 5125 tokid = &kid->op_sibling;
5126 kid = kid->op_sibling;
5127 }
22c35a8c 5128 if (!kid && PL_opargs[type] & OA_DEFGV)
54b9620d 5129 *tokid = kid = newDEFSVOP();
79072805
LW		 5130
5131 while (oa && kid) {
5132 numargs++;
5133 sibl = kid->op_sibling;
5134 switch (oa & 7) {
5135 case OA_SCALAR:
62c18ce2
GS		 5136 /* list seen where single (scalar) arg expected? */
5137 if (numargs == 1 && !(oa >> 4)
5138 && kid->op_type == OP_LIST && type != OP_SCALAR)
5139 {
5140 return too_many_arguments(o,PL_op_desc[type]);
5141 }
79072805
LW		 5142 scalar(kid);
5143 break;
5144 case OA_LIST:
5145 if (oa < 16) {
5146 kid = 0;
5147 continue;
5148 }
5149 else
5150 list(kid);
5151 break;
5152 case OA_AVREF:
936edb8b 5153 if ((type == OP_PUSH || type == OP_UNSHIFT)
f87c3213 5154 && !kid->op_sibling && ckWARN(WARN_SYNTAX))
9014280d 5155 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
de4864e4 5156 "Useless use of %s with no values",
936edb8b 5157 PL_op_desc[type]);
b2ffa427 5158
79072805 5159 if (kid->op_type == OP_CONST &&
62c18ce2
GS		 5160 (kid->op_private & OPpCONST_BARE))
5161 {
2d8e6c8d 5162 char *name = SvPVx(((SVOP*)kid)->op_sv, n_a);
79072805 5163 OP *newop = newAVREF(newGVOP(OP_GV, 0,
85e6fe83 5164 gv_fetchpv(name, TRUE, SVt_PVAV) ));
12bcd1a6
PM		 5165 if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
5166 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
57def98f 5167 "Array @%s missing the @ in argument %"IVdf" of %s()",
cf2093f6 5168 name, (IV)numargs, PL_op_desc[type]);
79072805
LW		 5169 op_free(kid);
5170 kid = newop;
5171 kid->op_sibling = sibl;
5172 *tokid = kid;
5173 }
8990e307 5174 else if (kid->op_type != OP_RV2AV && kid->op_type != OP_PADAV)
35cd451c 5175 bad_type(numargs, "array", PL_op_desc[type], kid);
a0d0e21e 5176 mod(kid, type);
79072805
LW		 5177 break;
5178 case OA_HVREF:
5179 if (kid->op_type == OP_CONST &&
62c18ce2
GS		 5180 (kid->op_private & OPpCONST_BARE))
5181 {
2d8e6c8d 5182 char *name = SvPVx(((SVOP*)kid)->op_sv, n_a);
79072805 5183 OP *newop = newHVREF(newGVOP(OP_GV, 0,
85e6fe83 5184 gv_fetchpv(name, TRUE, SVt_PVHV) ));
12bcd1a6
PM		 5185 if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
5186 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
57def98f 5187 "Hash %%%s missing the %% in argument %"IVdf" of %s()",
cf2093f6 5188 name, (IV)numargs, PL_op_desc[type]);
79072805
LW		 5189 op_free(kid);
5190 kid = newop;
5191 kid->op_sibling = sibl;
5192 *tokid = kid;
5193 }
8990e307 5194 else if (kid->op_type != OP_RV2HV && kid->op_type != OP_PADHV)
35cd451c 5195 bad_type(numargs, "hash", PL_op_desc[type], kid);
a0d0e21e 5196 mod(kid, type);
79072805
LW		 5197 break;
5198 case OA_CVREF:
5199 {
a0d0e21e 5200 OP *newop = newUNOP(OP_NULL, 0, kid);
79072805
LW		 5201 kid->op_sibling = 0;
5202 linklist(kid);
5203 newop->op_next = newop;
5204 kid = newop;
5205 kid->op_sibling = sibl;
5206 *tokid = kid;
5207 }
5208 break;
5209 case OA_FILEREF:
c340be78 5210 if (kid->op_type != OP_GV && kid->op_type != OP_RV2GV) {
79072805 5211 if (kid->op_type == OP_CONST &&
62c18ce2
GS		 5212 (kid->op_private & OPpCONST_BARE))
5213 {
79072805 5214 OP *newop = newGVOP(OP_GV, 0,
2d8e6c8d 5215 gv_fetchpv(SvPVx(((SVOP*)kid)->op_sv, n_a), TRUE,
85e6fe83 5216 SVt_PVIO) );
afbdacea 5217 if (!(o->op_private & 1) && /* if not unop */
8a996ce8 5218 kid == cLISTOPo->op_last)
364daeac 5219 cLISTOPo->op_last = newop;
79072805
LW		 5220 op_free(kid);
5221 kid = newop;
5222 }
1ea32a52
GS		 5223 else if (kid->op_type == OP_READLINE) {
5224 /* neophyte patrol: open(<FH>), close(<FH>) etc. */
53e06cf0 5225 bad_type(numargs, "HANDLE", OP_DESC(o), kid);
1ea32a52 5226 }
79072805 5227 else {
35cd451c 5228 I32 flags = OPf_SPECIAL;
a6c40364 5229 I32 priv = 0;
2c8ac474
GS		 5230 PADOFFSET targ = 0;
5231
35cd451c 5232 /* is this op a FH constructor? */
853846ea 5233 if (is_handle_constructor(o,numargs)) {
2c8ac474 5234 char *name = Nullch;
dd2155a4 5235 STRLEN len = 0;
2c8ac474
GS		 5236
5237 flags = 0;
5238 /* Set a flag to tell rv2gv to vivify
853846ea
NIS		 5239 * need to "prove" flag does not mean something
5240 * else already - NI-S 1999/05/07
2c8ac474
GS		 5241 */
5242 priv = OPpDEREF;
5243 if (kid->op_type == OP_PADSV) {
dd2155a4
DM		 5244 name = PAD_COMPNAME_PV(kid->op_targ);
5245 /* SvCUR of a pad namesv can't be trusted
5246 * (see PL_generation), so calc its length
5247 * manually */
5248 if (name)
5249 len = strlen(name);
5250
2c8ac474
GS		 5251 }
5252 else if (kid->op_type == OP_RV2SV
5253 && kUNOP->op_first->op_type == OP_GV)
5254 {
5255 GV *gv = cGVOPx_gv(kUNOP->op_first);
5256 name = GvNAME(gv);
5257 len = GvNAMELEN(gv);
5258 }
afd1915d
GS		 5259 else if (kid->op_type == OP_AELEM
5260 || kid->op_type == OP_HELEM)
5261 {
0c4b0a3f
JH		 5262 OP *op;
5263
5264 name = 0;
5265 if ((op = ((BINOP*)kid)->op_first)) {
5266 SV *tmpstr = Nullsv;
5267 char *a =
5268 kid->op_type == OP_AELEM ?
5269 "[]" : "{}";
5270 if (((op->op_type == OP_RV2AV) ||
5271 (op->op_type == OP_RV2HV)) &&
5272 (op = ((UNOP*)op)->op_first) &&
5273 (op->op_type == OP_GV)) {
5274 /* packagevar $a[] or $h{} */
5275 GV *gv = cGVOPx_gv(op);
5276 if (gv)
5277 tmpstr =
5278 Perl_newSVpvf(aTHX_
5279 "%s%c...%c",
5280 GvNAME(gv),
5281 a[0], a[1]);
5282 }
5283 else if (op->op_type == OP_PADAV
5284 || op->op_type == OP_PADHV) {
5285 /* lexicalvar $a[] or $h{} */
5286 char *padname =
5287 PAD_COMPNAME_PV(op->op_targ);
5288 if (padname)
5289 tmpstr =
5290 Perl_newSVpvf(aTHX_
5291 "%s%c...%c",
5292 padname + 1,
5293 a[0], a[1]);
5294
5295 }
5296 if (tmpstr) {
2a4f803a 5297 name = SvPV(tmpstr, len);
0c4b0a3f
JH		 5298 sv_2mortal(tmpstr);
5299 }
5300 }
5301 if (!name) {
5302 name = "__ANONIO__";
5303 len = 10;
5304 }
5305 mod(kid, type);
afd1915d 5306 }
2c8ac474
GS		 5307 if (name) {
5308 SV *namesv;
5309 targ = pad_alloc(OP_RV2GV, SVs_PADTMP);
dd2155a4 5310 namesv = PAD_SVl(targ);
155aba94 5311 (void)SvUPGRADE(namesv, SVt_PV);
2c8ac474
GS		 5312 if (*name != '$')
5313 sv_setpvn(namesv, "$", 1);
5314 sv_catpvn(namesv, name, len);
5315 }
853846ea 5316 }
79072805 5317 kid->op_sibling = 0;
35cd451c 5318 kid = newUNOP(OP_RV2GV, flags, scalar(kid));
2c8ac474
GS		 5319 kid->op_targ = targ;
5320 kid->op_private |= priv;
79072805
LW		 5321 }
5322 kid->op_sibling = sibl;
5323 *tokid = kid;
5324 }
5325 scalar(kid);
5326 break;
5327 case OA_SCALARREF:
a0d0e21e 5328 mod(scalar(kid), type);
79072805
LW		 5329 break;
5330 }
5331 oa >>= 4;
5332 tokid = &kid->op_sibling;
5333 kid = kid->op_sibling;
5334 }
11343788 5335 o->op_private |= numargs;
79072805 5336 if (kid)
53e06cf0 5337 return too_many_arguments(o,OP_DESC(o));
11343788 5338 listkids(o);
79072805 5339 }
22c35a8c 5340 else if (PL_opargs[type] & OA_DEFGV) {
11343788 5341 op_free(o);
54b9620d 5342 return newUNOP(type, 0, newDEFSVOP());
a0d0e21e
LW		 5343 }
5344
79072805
LW		 5345 if (oa) {
5346 while (oa & OA_OPTIONAL)
5347 oa >>= 4;
5348 if (oa && oa != OA_LIST)
53e06cf0 5349 return too_few_arguments(o,OP_DESC(o));
79072805 5350 }
11343788 5351 return o;
79072805
LW		 5352}
5353
5354OP *
cea2e8a9 5355Perl_ck_glob(pTHX_ OP *o)
79072805 5356{
fb73857a 5357 GV *gv;
5358
649da076 5359 o = ck_fun(o);
1f2bfc8a 5360 if ((o->op_flags & OPf_KIDS) && !cLISTOPo->op_first->op_sibling)
54b9620d 5361 append_elem(OP_GLOB, o, newDEFSVOP());
fb73857a 5362
b9f751c0
GS		 5363 if (!((gv = gv_fetchpv("glob", FALSE, SVt_PVCV))
5364 && GvCVu(gv) && GvIMPORTED_CV(gv)))
5365 {
fb73857a 5366 gv = gv_fetchpv("CORE::GLOBAL::glob", FALSE, SVt_PVCV);
b9f751c0 5367 }
b1cb66bf 5368
52bb0670 5369#if !defined(PERL_EXTERNAL_GLOB)
72b16652 5370 /* XXX this can be tightened up and made more failsafe. */
f444d496 5371 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
7d3fb230 5372 GV *glob_gv;
72b16652 5373 ENTER;
00ca71c1
NIS		 5374 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
5375 newSVpvn("File::Glob", 10), Nullsv, Nullsv, Nullsv);
72b16652 5376 gv = gv_fetchpv("CORE::GLOBAL::glob", FALSE, SVt_PVCV);
7d3fb230
BS		 5377 glob_gv = gv_fetchpv("File::Glob::csh_glob", FALSE, SVt_PVCV);
5378 GvCV(gv) = GvCV(glob_gv);
445266f0 5379 SvREFCNT_inc((SV*)GvCV(gv));
7d3fb230 5380 GvIMPORTED_CV_on(gv);
72b16652
GS		 5381 LEAVE;
5382 }
52bb0670 5383#endif /* PERL_EXTERNAL_GLOB */
72b16652 5384
b9f751c0 5385 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
5196be3e 5386 append_elem(OP_GLOB, o,
80252599 5387 newSVOP(OP_CONST, 0, newSViv(PL_glob_index++)));
1f2bfc8a 5388 o->op_type = OP_LIST;
22c35a8c 5389 o->op_ppaddr = PL_ppaddr[OP_LIST];
1f2bfc8a 5390 cLISTOPo->op_first->op_type = OP_PUSHMARK;
22c35a8c 5391 cLISTOPo->op_first->op_ppaddr = PL_ppaddr[OP_PUSHMARK];
ad33f57d 5392 cLISTOPo->op_first->op_targ = 0;
1f2bfc8a 5393 o = newUNOP(OP_ENTERSUB, OPf_STACKED,
aeea060c 5394 append_elem(OP_LIST, o,
1f2bfc8a
MB		 5395 scalar(newUNOP(OP_RV2CV, 0,
5396 newGVOP(OP_GV, 0, gv)))));
d58bf5aa
MB		 5397 o = newUNOP(OP_NULL, 0, ck_subr(o));
5398 o->op_targ = OP_GLOB; /* hint at what it used to be */
5399 return o;
b1cb66bf 5400 }
5401 gv = newGVgen("main");
a0d0e21e 5402 gv_IOadd(gv);
11343788
MB		 5403 append_elem(OP_GLOB, o, newGVOP(OP_GV, 0, gv));
5404 scalarkids(o);
649da076 5405 return o;
79072805
LW		 5406}
5407
5408OP *
cea2e8a9 5409Perl_ck_grep(pTHX_ OP *o)
79072805
LW		 5410{
5411 LOGOP *gwop;
5412 OP *kid;
11343788 5413 OPCODE type = o->op_type == OP_GREPSTART ? OP_GREPWHILE : OP_MAPWHILE;
59f00321 5414 I32 offset;
79072805 5415
22c35a8c 5416 o->op_ppaddr = PL_ppaddr[OP_GREPSTART];
b7dc083c 5417 NewOp(1101, gwop, 1, LOGOP);
aeea060c 5418
11343788 5419 if (o->op_flags & OPf_STACKED) {
a0d0e21e 5420 OP* k;
11343788
MB		 5421 o = ck_sort(o);
5422 kid = cLISTOPo->op_first->op_sibling;
5423 for (k = cLISTOPo->op_first->op_sibling->op_next; k; k = k->op_next) {
a0d0e21e
LW		 5424 kid = k;
5425 }
5426 kid->op_next = (OP*)gwop;
11343788 5427 o->op_flags &= ~OPf_STACKED;
93a17b20 5428 }
11343788 5429 kid = cLISTOPo->op_first->op_sibling;
a0d0e21e
LW		 5430 if (type == OP_MAPWHILE)
5431 list(kid);
5432 else
5433 scalar(kid);
11343788 5434 o = ck_fun(o);
3280af22 5435 if (PL_error_count)
11343788 5436 return o;
aeea060c 5437 kid = cLISTOPo->op_first->op_sibling;
79072805 5438 if (kid->op_type != OP_NULL)
cea2e8a9 5439 Perl_croak(aTHX_ "panic: ck_grep");
79072805
LW		 5440 kid = kUNOP->op_first;
5441
a0d0e21e 5442 gwop->op_type = type;
22c35a8c 5443 gwop->op_ppaddr = PL_ppaddr[type];
11343788 5444 gwop->op_first = listkids(o);
79072805 5445 gwop->op_flags |= OPf_KIDS;
79072805 5446 gwop->op_other = LINKLIST(kid);
79072805 5447 kid->op_next = (OP*)gwop;
59f00321
RGS		 5448 offset = pad_findmy("$_");
5449 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS(offset) & SVpad_OUR) {
5450 o->op_private = gwop->op_private = 0;
5451 gwop->op_targ = pad_alloc(type, SVs_PADTMP);
5452 }
5453 else {
5454 o->op_private = gwop->op_private = OPpGREP_LEX;
5455 gwop->op_targ = o->op_targ = offset;
5456 }
79072805 5457
11343788 5458 kid = cLISTOPo->op_first->op_sibling;
a0d0e21e 5459 if (!kid || !kid->op_sibling)
53e06cf0 5460 return too_few_arguments(o,OP_DESC(o));
a0d0e21e
LW		 5461 for (kid = kid->op_sibling; kid; kid = kid->op_sibling)
5462 mod(kid, OP_GREPSTART);
5463
79072805
LW		 5464 return (OP*)gwop;
5465}
5466
5467OP *
cea2e8a9 5468Perl_ck_index(pTHX_ OP *o)
79072805 5469{
11343788
MB		 5470 if (o->op_flags & OPf_KIDS) {
5471 OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
0b71040e
LW		 5472 if (kid)
5473 kid = kid->op_sibling; /* get past "big" */
79072805 5474 if (kid && kid->op_type == OP_CONST)
2779dcf1 5475 fbm_compile(((SVOP*)kid)->op_sv, 0);
79072805 5476 }
11343788 5477 return ck_fun(o);
79072805
LW		 5478}
5479
5480OP *
cea2e8a9 5481Perl_ck_lengthconst(pTHX_ OP *o)
79072805
LW		 5482{
5483 /* XXX length optimization goes here */
11343788 5484 return ck_fun(o);
79072805
LW		 5485}
5486
5487OP *
cea2e8a9 5488Perl_ck_lfun(pTHX_ OP *o)
79072805 5489{
5dc0d613
MB		 5490 OPCODE type = o->op_type;
5491 return modkids(ck_fun(o), type);
79072805
LW		 5492}
5493
5494OP *
cea2e8a9 5495Perl_ck_defined(pTHX_ OP *o) /* 19990527 MJD */
69794302 5496{
12bcd1a6 5497 if ((o->op_flags & OPf_KIDS) && ckWARN2(WARN_DEPRECATED, WARN_SYNTAX)) {
d0334bed
GS		 5498 switch (cUNOPo->op_first->op_type) {
5499 case OP_RV2AV:
a8739d98
JH		 5500 /* This is needed for
5501 if (defined %stash::)
5502 to work. Do not break Tk.
5503 */
1c846c1f 5504 break; /* Globals via GV can be undef */
d0334bed
GS		 5505 case OP_PADAV:
5506 case OP_AASSIGN: /* Is this a good idea? */
12bcd1a6 5507 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
f10b0346 5508 "defined(@array) is deprecated");
12bcd1a6 5509 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
cc507455 5510 "\t(Maybe you should just omit the defined()?)\n");
69794302 5511 break;
d0334bed 5512 case OP_RV2HV:
a8739d98
JH		 5513 /* This is needed for
5514 if (defined %stash::)
5515 to work. Do not break Tk.
5516 */
1c846c1f 5517 break; /* Globals via GV can be undef */
d0334bed 5518 case OP_PADHV:
12bcd1a6 5519 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
894356b3 5520 "defined(%%hash) is deprecated");
12bcd1a6 5521 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
cc507455 5522 "\t(Maybe you should just omit the defined()?)\n");
d0334bed
GS		 5523 break;
5524 default:
5525 /* no warning */
5526 break;
5527 }
69794302
MJD		 5528 }
5529 return ck_rfun(o);
5530}
5531
5532OP *
cea2e8a9 5533Perl_ck_rfun(pTHX_ OP *o)
8990e307 5534{
5dc0d613
MB		 5535 OPCODE type = o->op_type;
5536 return refkids(ck_fun(o), type);
8990e307
LW		 5537}
5538
5539OP *
cea2e8a9 5540Perl_ck_listiob(pTHX_ OP *o)
79072805
LW		 5541{
5542 register OP *kid;
aeea060c 5543
11343788 5544 kid = cLISTOPo->op_first;
79072805 5545 if (!kid) {
11343788
MB		 5546 o = force_list(o);
5547 kid = cLISTOPo->op_first;
79072805
LW		 5548 }
5549 if (kid->op_type == OP_PUSHMARK)
5550 kid = kid->op_sibling;
11343788 5551 if (kid && o->op_flags & OPf_STACKED)
79072805
LW		 5552 kid = kid->op_sibling;
5553 else if (kid && !kid->op_sibling) { /* print HANDLE; */
5554 if (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE) {
11343788 5555 o->op_flags |= OPf_STACKED; /* make it a filehandle */
748a9306 5556 kid = newUNOP(OP_RV2GV, OPf_REF, scalar(kid));
11343788
MB		 5557 cLISTOPo->op_first->op_sibling = kid;
5558 cLISTOPo->op_last = kid;
79072805
LW		 5559 kid = kid->op_sibling;
5560 }
5561 }
b2ffa427 5562
79072805 5563 if (!kid)
54b9620d 5564 append_elem(o->op_type, o, newDEFSVOP());
79072805 5565
2de3dbcc 5566 return listkids(o);
bbce6d69 5567}
5568
5569OP *
b162f9ea
IZ		 5570Perl_ck_sassign(pTHX_ OP *o)
5571{
5572 OP *kid = cLISTOPo->op_first;
5573 /* has a disposable target? */
5574 if ((PL_opargs[kid->op_type] & OA_TARGLEX)
6b66af17
GS		 5575 && !(kid->op_flags & OPf_STACKED)
5576 /* Cannot steal the second time! */
5577 && !(kid->op_private & OPpTARGET_MY))
b162f9ea
IZ		 5578 {
5579 OP *kkid = kid->op_sibling;
5580
5581 /* Can just relocate the target. */
2c2d71f5
JH		 5582 if (kkid && kkid->op_type == OP_PADSV
5583 && !(kkid->op_private & OPpLVAL_INTRO))
5584 {
b162f9ea 5585 kid->op_targ = kkid->op_targ;
743e66e6 5586 kkid->op_targ = 0;
b162f9ea
IZ		 5587 /* Now we do not need PADSV and SASSIGN. */
5588 kid->op_sibling = o->op_sibling; /* NULL */
5589 cLISTOPo->op_first = NULL;
5590 op_free(o);
5591 op_free(kkid);
5592 kid->op_private |= OPpTARGET_MY; /* Used for context settings */
5593 return kid;
5594 }
5595 }
5596 return o;
5597}
5598
5599OP *
cea2e8a9 5600Perl_ck_match(pTHX_ OP *o)
79072805 5601{
59f00321
RGS		 5602 if (o->op_type != OP_QR) {
5603 I32 offset = pad_findmy("$_");
5604 if (offset != NOT_IN_PAD && !(PAD_COMPNAME_FLAGS(offset) & SVpad_OUR)) {
5605 o->op_targ = offset;
5606 o->op_private |= OPpTARGET_MY;
5607 }
5608 }
5609 if (o->op_type == OP_MATCH || o->op_type == OP_QR)
5610 o->op_private |= OPpRUNTIME;
11343788 5611 return o;
79072805
LW		 5612}
5613
5614OP *
f5d5a27c
CS		 5615Perl_ck_method(pTHX_ OP *o)
5616{
5617 OP *kid = cUNOPo->op_first;
5618 if (kid->op_type == OP_CONST) {
5619 SV* sv = kSVOP->op_sv;
5620 if (!(strchr(SvPVX(sv), ':') || strchr(SvPVX(sv), '\''))) {
5621 OP *cmop;
1c846c1f
NIS		 5622 if (!SvREADONLY(sv) || !SvFAKE(sv)) {
5623 sv = newSVpvn_share(SvPVX(sv), SvCUR(sv), 0);
5624 }
5625 else {
5626 kSVOP->op_sv = Nullsv;
5627 }
f5d5a27c 5628 cmop = newSVOP(OP_METHOD_NAMED, 0, sv);
f5d5a27c
CS		 5629 op_free(o);
5630 return cmop;
5631 }
5632 }
5633 return o;
5634}
5635
5636OP *
cea2e8a9 5637Perl_ck_null(pTHX_ OP *o)
79072805 5638{
11343788 5639 return o;
79072805
LW		 5640}
5641
5642OP *
16fe6d59
GS		 5643Perl_ck_open(pTHX_ OP *o)
5644{
5645 HV *table = GvHV(PL_hintgv);
5646 if (table) {
5647 SV **svp;
5648 I32 mode;
5649 svp = hv_fetch(table, "open_IN", 7, FALSE);
5650 if (svp && *svp) {
5651 mode = mode_from_discipline(*svp);
5652 if (mode & O_BINARY)
5653 o->op_private |= OPpOPEN_IN_RAW;
5654 else if (mode & O_TEXT)
5655 o->op_private |= OPpOPEN_IN_CRLF;
5656 }
5657
5658 svp = hv_fetch(table, "open_OUT", 8, FALSE);
5659 if (svp && *svp) {
5660 mode = mode_from_discipline(*svp);
5661 if (mode & O_BINARY)
5662 o->op_private |= OPpOPEN_OUT_RAW;
5663 else if (mode & O_TEXT)
5664 o->op_private |= OPpOPEN_OUT_CRLF;
5665 }
5666 }
5667 if (o->op_type == OP_BACKTICK)
5668 return o;
3b82e551
JH		 5669 {
5670 /* In case of three-arg dup open remove strictness
5671 * from the last arg if it is a bareword. */
5672 OP *first = cLISTOPx(o)->op_first; /* The pushmark. */
5673 OP *last = cLISTOPx(o)->op_last; /* The bareword. */
5674 OP *oa;
5675 char *mode;
5676
5677 if ((last->op_type == OP_CONST) && /* The bareword. */
5678 (last->op_private & OPpCONST_BARE) &&
5679 (last->op_private & OPpCONST_STRICT) &&
5680 (oa = first->op_sibling) && /* The fh. */
5681 (oa = oa->op_sibling) && /* The mode. */
5682 SvPOK(((SVOP*)oa)->op_sv) &&
5683 (mode = SvPVX(((SVOP*)oa)->op_sv)) &&
5684 mode[0] == '>' && mode[1] == '&' && /* A dup open. */
5685 (last == oa->op_sibling)) /* The bareword. */
5686 last->op_private &= ~OPpCONST_STRICT;
5687 }
16fe6d59
GS		 5688 return ck_fun(o);
5689}
5690
5691OP *
cea2e8a9 5692Perl_ck_repeat(pTHX_ OP *o)
79072805 5693{
11343788
MB		 5694 if (cBINOPo->op_first->op_flags & OPf_PARENS) {
5695 o->op_private |= OPpREPEAT_DOLIST;
5696 cBINOPo->op_first = force_list(cBINOPo->op_first);
79072805
LW		 5697 }
5698 else
11343788
MB		 5699 scalar(o);
5700 return o;
79072805
LW		 5701}
5702
5703OP *
cea2e8a9 5704Perl_ck_require(pTHX_ OP *o)
8990e307 5705{
ec4ab249
GA		 5706 GV* gv;
5707
11343788
MB		 5708 if (o->op_flags & OPf_KIDS) { /* Shall we supply missing .pm? */
5709 SVOP *kid = (SVOP*)cUNOPo->op_first;
8990e307
LW		 5710
5711 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
8990e307 5712 char *s;
a0d0e21e
LW		 5713 for (s = SvPVX(kid->op_sv); *s; s++) {
5714 if (*s == ':' && s[1] == ':') {
5715 *s = '/';
1aef975c 5716 Move(s+2, s+1, strlen(s+2)+1, char);
a0d0e21e
LW		 5717 --SvCUR(kid->op_sv);
5718 }
8990e307 5719 }
ce3b816e
GS		 5720 if (SvREADONLY(kid->op_sv)) {
5721 SvREADONLY_off(kid->op_sv);
5722 sv_catpvn(kid->op_sv, ".pm", 3);
5723 SvREADONLY_on(kid->op_sv);
5724 }
5725 else
5726 sv_catpvn(kid->op_sv, ".pm", 3);
8990e307
LW		 5727 }
5728 }
ec4ab249
GA		 5729
5730 /* handle override, if any */
5731 gv = gv_fetchpv("require", FALSE, SVt_PVCV);
b9f751c0 5732 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv)))
ec4ab249
GA		 5733 gv = gv_fetchpv("CORE::GLOBAL::require", FALSE, SVt_PVCV);
5734
b9f751c0 5735 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
ec4ab249
GA		 5736 OP *kid = cUNOPo->op_first;
5737 cUNOPo->op_first = 0;
5738 op_free(o);
5739 return ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
5740 append_elem(OP_LIST, kid,
5741 scalar(newUNOP(OP_RV2CV, 0,
5742 newGVOP(OP_GV, 0,
5743 gv))))));
5744 }
5745
11343788 5746 return ck_fun(o);
8990e307
LW		 5747}
5748
78f9721b
SM		 5749OP *
5750Perl_ck_return(pTHX_ OP *o)
5751{
5752 OP *kid;
5753 if (CvLVALUE(PL_compcv)) {
5754 for (kid = cLISTOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
5755 mod(kid, OP_LEAVESUBLV);
5756 }
5757 return o;
5758}
5759
22c35a8c 5760#if 0
8990e307 5761OP *
cea2e8a9 5762Perl_ck_retarget(pTHX_ OP *o)
79072805 5763{
cea2e8a9 5764 Perl_croak(aTHX_ "NOT IMPL LINE %d",__LINE__);
79072805 5765 /* STUB */
11343788 5766 return o;
79072805 5767}
22c35a8c 5768#endif
79072805
LW		 5769
5770OP *
cea2e8a9 5771Perl_ck_select(pTHX_ OP *o)
79072805 5772{
c07a80fd 5773 OP* kid;
11343788
MB		 5774 if (o->op_flags & OPf_KIDS) {
5775 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
2304df62 5776 if (kid && kid->op_sibling) {
11343788 5777 o->op_type = OP_SSELECT;
22c35a8c 5778 o->op_ppaddr = PL_ppaddr[OP_SSELECT];
11343788
MB		 5779 o = ck_fun(o);
5780 return fold_constants(o);
79072805
LW		 5781 }
5782 }
11343788
MB		 5783 o = ck_fun(o);
5784 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
c07a80fd 5785 if (kid && kid->op_type == OP_RV2GV)
5786 kid->op_private &= ~HINT_STRICT_REFS;
11343788 5787 return o;
79072805
LW		 5788}
5789
5790OP *
cea2e8a9 5791Perl_ck_shift(pTHX_ OP *o)
79072805 5792{
11343788 5793 I32 type = o->op_type;
79072805 5794
11343788 5795 if (!(o->op_flags & OPf_KIDS)) {
6d4ff0d2 5796 OP *argop;
b2ffa427 5797
11343788 5798 op_free(o);
6d4ff0d2 5799 argop = newUNOP(OP_RV2AV, 0,
8fde6460 5800 scalar(newGVOP(OP_GV, 0, CvUNIQUE(PL_compcv) ? PL_argvgv : PL_defgv)));
6d4ff0d2 5801 return newUNOP(type, 0, scalar(argop));
79072805 5802 }
11343788 5803 return scalar(modkids(ck_fun(o), type));
79072805
LW		 5804}
5805
5806OP *
cea2e8a9 5807Perl_ck_sort(pTHX_ OP *o)
79072805 5808{
8e3f9bdf 5809 OP *firstkid;
bbce6d69 5810
9ea6e965 5811 if (o->op_type == OP_SORT && o->op_flags & OPf_STACKED)
51a19bc0 5812 simplify_sort(o);
8e3f9bdf
GS		 5813 firstkid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
5814 if (o->op_flags & OPf_STACKED) { /* may have been cleared */
9c5ffd7c 5815 OP *k = NULL;
8e3f9bdf 5816 OP *kid = cUNOPx(firstkid)->op_first; /* get past null */
79072805 5817
463ee0b2 5818 if (kid->op_type == OP_SCOPE || kid->op_type == OP_LEAVE) {
79072805 5819 linklist(kid);
463ee0b2
LW		 5820 if (kid->op_type == OP_SCOPE) {
5821 k = kid->op_next;
5822 kid->op_next = 0;
79072805 5823 }
463ee0b2 5824 else if (kid->op_type == OP_LEAVE) {
11343788 5825 if (o->op_type == OP_SORT) {
93c66552 5826 op_null(kid); /* wipe out leave */
748a9306 5827 kid->op_next = kid;
463ee0b2 5828
748a9306
LW		 5829 for (k = kLISTOP->op_first->op_next; k; k = k->op_next) {
5830 if (k->op_next == kid)
5831 k->op_next = 0;
71a29c3c
GS		 5832 /* don't descend into loops */
5833 else if (k->op_type == OP_ENTERLOOP
5834 || k->op_type == OP_ENTERITER)
5835 {
5836 k = cLOOPx(k)->op_lastop;
5837 }
748a9306 5838 }
463ee0b2 5839 }
748a9306
LW		 5840 else
5841 kid->op_next = 0; /* just disconnect the leave */
a0d0e21e 5842 k = kLISTOP->op_first;
463ee0b2 5843 }
a2efc822 5844 CALL_PEEP(k);
a0d0e21e 5845
8e3f9bdf
GS		 5846 kid = firstkid;
5847 if (o->op_type == OP_SORT) {
5848 /* provide scalar context for comparison function/block */
5849 kid = scalar(kid);
a0d0e21e 5850 kid->op_next = kid;
8e3f9bdf 5851 }
a0d0e21e
LW		 5852 else
5853 kid->op_next = k;
11343788 5854 o->op_flags |= OPf_SPECIAL;
79072805 5855 }
c6e96bcb 5856 else if (kid->op_type == OP_RV2SV || kid->op_type == OP_PADSV)
93c66552 5857 op_null(firstkid);
8e3f9bdf
GS		 5858
5859 firstkid = firstkid->op_sibling;
79072805 5860 }
bbce6d69 5861
8e3f9bdf
GS		 5862 /* provide list context for arguments */
5863 if (o->op_type == OP_SORT)
5864 list(firstkid);
5865
11343788 5866 return o;
79072805 5867}
bda4119b
GS		 5868
5869STATIC void
cea2e8a9 5870S_simplify_sort(pTHX_ OP *o)
9c007264
JH		 5871{
5872 register OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
5873 OP *k;
5874 int reversed;
350de78d 5875 GV *gv;
9c007264
JH		 5876 if (!(o->op_flags & OPf_STACKED))
5877 return;
1c846c1f
NIS		 5878 GvMULTI_on(gv_fetchpv("a", TRUE, SVt_PV));
5879 GvMULTI_on(gv_fetchpv("b", TRUE, SVt_PV));
82092f1d 5880 kid = kUNOP->op_first; /* get past null */
9c007264
JH		 5881 if (kid->op_type != OP_SCOPE)
5882 return;
5883 kid = kLISTOP->op_last; /* get past scope */
5884 switch(kid->op_type) {
5885 case OP_NCMP:
5886 case OP_I_NCMP:
5887 case OP_SCMP:
5888 break;
5889 default:
5890 return;
5891 }
5892 k = kid; /* remember this node*/
5893 if (kBINOP->op_first->op_type != OP_RV2SV)
5894 return;
5895 kid = kBINOP->op_first; /* get past cmp */
5896 if (kUNOP->op_first->op_type != OP_GV)
5897 return;
5898 kid = kUNOP->op_first; /* get past rv2sv */
638eceb6 5899 gv = kGVOP_gv;
350de78d 5900 if (GvSTASH(gv) != PL_curstash)
9c007264 5901 return;
350de78d 5902 if (strEQ(GvNAME(gv), "a"))
9c007264 5903 reversed = 0;
0f79a09d 5904 else if (strEQ(GvNAME(gv), "b"))
9c007264
JH		 5905 reversed = 1;
5906 else
5907 return;
5908 kid = k; /* back to cmp */
5909 if (kBINOP->op_last->op_type != OP_RV2SV)
5910 return;
5911 kid = kBINOP->op_last; /* down to 2nd arg */
5912 if (kUNOP->op_first->op_type != OP_GV)
5913 return;
5914 kid = kUNOP->op_first; /* get past rv2sv */
638eceb6 5915 gv = kGVOP_gv;
350de78d 5916 if (GvSTASH(gv) != PL_curstash
9c007264 5917 || ( reversed
350de78d
GS		 5918 ? strNE(GvNAME(gv), "a")
5919 : strNE(GvNAME(gv), "b")))
9c007264
JH		 5920 return;
5921 o->op_flags &= ~(OPf_STACKED | OPf_SPECIAL);
5922 if (reversed)
5923 o->op_private |= OPpSORT_REVERSE;
5924 if (k->op_type == OP_NCMP)
5925 o->op_private |= OPpSORT_NUMERIC;
5926 if (k->op_type == OP_I_NCMP)
5927 o->op_private |= OPpSORT_NUMERIC | OPpSORT_INTEGER;
e507f050
SM		 5928 kid = cLISTOPo->op_first->op_sibling;
5929 cLISTOPo->op_first->op_sibling = kid->op_sibling; /* bypass old block */
5930 op_free(kid); /* then delete it */
9c007264 5931}
79072805
LW		 5932
5933OP *
cea2e8a9 5934Perl_ck_split(pTHX_ OP *o)
79072805
LW		 5935{
5936 register OP *kid;
aeea060c 5937
11343788
MB		 5938 if (o->op_flags & OPf_STACKED)
5939 return no_fh_allowed(o);
79072805 5940
11343788 5941 kid = cLISTOPo->op_first;
8990e307 5942 if (kid->op_type != OP_NULL)
cea2e8a9 5943 Perl_croak(aTHX_ "panic: ck_split");
8990e307 5944 kid = kid->op_sibling;
11343788
MB		 5945 op_free(cLISTOPo->op_first);
5946 cLISTOPo->op_first = kid;
85e6fe83 5947 if (!kid) {
79cb57f6 5948 cLISTOPo->op_first = kid = newSVOP(OP_CONST, 0, newSVpvn(" ", 1));
11343788 5949 cLISTOPo->op_last = kid; /* There was only one element previously */
85e6fe83 5950 }
79072805 5951
de4bf5b3 5952 if (kid->op_type != OP_MATCH || kid->op_flags & OPf_STACKED) {
79072805 5953 OP *sibl = kid->op_sibling;
463ee0b2 5954 kid->op_sibling = 0;
79072805 5955 kid = pmruntime( newPMOP(OP_MATCH, OPf_SPECIAL), kid, Nullop);
11343788
MB		 5956 if (cLISTOPo->op_first == cLISTOPo->op_last)
5957 cLISTOPo->op_last = kid;
5958 cLISTOPo->op_first = kid;
79072805
LW		 5959 kid->op_sibling = sibl;
5960 }
5961
5962 kid->op_type = OP_PUSHRE;
22c35a8c 5963 kid->op_ppaddr = PL_ppaddr[OP_PUSHRE];
79072805 5964 scalar(kid);
f34840d8
MJD		 5965 if (ckWARN(WARN_REGEXP) && ((PMOP *)kid)->op_pmflags & PMf_GLOBAL) {
5966 Perl_warner(aTHX_ packWARN(WARN_REGEXP),
5967 "Use of /g modifier is meaningless in split");
5968 }
79072805
LW		 5969
5970 if (!kid->op_sibling)
54b9620d 5971 append_elem(OP_SPLIT, o, newDEFSVOP());
79072805
LW		 5972
5973 kid = kid->op_sibling;
5974 scalar(kid);
5975
5976 if (!kid->op_sibling)
11343788 5977 append_elem(OP_SPLIT, o, newSVOP(OP_CONST, 0, newSViv(0)));
79072805
LW		 5978
5979 kid = kid->op_sibling;
5980 scalar(kid);
5981
5982 if (kid->op_sibling)
53e06cf0 5983 return too_many_arguments(o,OP_DESC(o));
79072805 5984
11343788 5985 return o;
79072805
LW		 5986}
5987
5988OP *
1c846c1f 5989Perl_ck_join(pTHX_ OP *o)
eb6e2d6f
GS		 5990{
5991 if (ckWARN(WARN_SYNTAX)) {
5992 OP *kid = cLISTOPo->op_first->op_sibling;
5993 if (kid && kid->op_type == OP_MATCH) {
5994 char *pmstr = "STRING";
aaa362c4
RS		 5995 if (PM_GETRE(kPMOP))
5996 pmstr = PM_GETRE(kPMOP)->precomp;
9014280d 5997 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
eb6e2d6f
GS		 5998 "/%s/ should probably be written as \"%s\"",
5999 pmstr, pmstr);
6000 }
6001 }
6002 return ck_fun(o);
6003}
6004
6005OP *
cea2e8a9 6006Perl_ck_subr(pTHX_ OP *o)
79072805 6007{
11343788
MB		 6008 OP *prev = ((cUNOPo->op_first->op_sibling)
6009 ? cUNOPo : ((UNOP*)cUNOPo->op_first))->op_first;
6010 OP *o2 = prev->op_sibling;
4633a7c4
LW		 6011 OP *cvop;
6012 char *proto = 0;
6013 CV *cv = 0;
46fc3d4c 6014 GV *namegv = 0;
4633a7c4
LW		 6015 int optional = 0;
6016 I32 arg = 0;
5b794e05 6017 I32 contextclass = 0;
90b7f708 6018 char *e = 0;
2d8e6c8d 6019 STRLEN n_a;
06492da6 6020 bool delete=0;
4633a7c4 6021
d3011074 6022 o->op_private |= OPpENTERSUB_HASTARG;
11343788 6023 for (cvop = o2; cvop->op_sibling; cvop = cvop->op_sibling) ;
4633a7c4
LW		 6024 if (cvop->op_type == OP_RV2CV) {
6025 SVOP* tmpop;
11343788 6026 o->op_private |= (cvop->op_private & OPpENTERSUB_AMPER);
93c66552 6027 op_null(cvop); /* disable rv2cv */
4633a7c4 6028 tmpop = (SVOP*)((UNOP*)cvop)->op_first;
76cd736e 6029 if (tmpop->op_type == OP_GV && !(o->op_private & OPpENTERSUB_AMPER)) {
638eceb6 6030 GV *gv = cGVOPx_gv(tmpop);
350de78d 6031 cv = GvCVu(gv);
76cd736e
GS		 6032 if (!cv)
6033 tmpop->op_private |= OPpEARLY_CV;
06492da6
SF		 6034 else {
6035 if (SvPOK(cv)) {
6036 namegv = CvANON(cv) ? gv : CvGV(cv);
6037 proto = SvPV((SV*)cv, n_a);
6038 }
6039 if (CvASSERTION(cv)) {
6040 if (PL_hints & HINT_ASSERTING) {
6041 if (PERLDB_ASSERTION && PL_curstash != PL_debstash)
6042 o->op_private |= OPpENTERSUB_DB;
6043 }
8fa7688f
SF		 6044 else {
6045 delete=1;
6046 if (ckWARN(WARN_ASSERTIONS) && !(PL_hints & HINT_ASSERTIONSSEEN)) {
6047 Perl_warner(aTHX_ packWARN(WARN_ASSERTIONS),
6048 "Impossible to activate assertion call");
6049 }
6050 }
06492da6 6051 }
46fc3d4c 6052 }
4633a7c4
LW		 6053 }
6054 }
f5d5a27c 6055 else if (cvop->op_type == OP_METHOD || cvop->op_type == OP_METHOD_NAMED) {
7a52d87a
GS		 6056 if (o2->op_type == OP_CONST)
6057 o2->op_private &= ~OPpCONST_STRICT;
58a40671
GS		 6058 else if (o2->op_type == OP_LIST) {
6059 OP *o = ((UNOP*)o2)->op_first->op_sibling;
6060 if (o && o->op_type == OP_CONST)
6061 o->op_private &= ~OPpCONST_STRICT;
6062 }
7a52d87a 6063 }
3280af22
NIS		 6064 o->op_private |= (PL_hints & HINT_STRICT_REFS);
6065 if (PERLDB_SUB && PL_curstash != PL_debstash)
11343788
MB		 6066 o->op_private |= OPpENTERSUB_DB;
6067 while (o2 != cvop) {
4633a7c4
LW		 6068 if (proto) {
6069 switch (*proto) {
6070 case '\0':
5dc0d613 6071 return too_many_arguments(o, gv_ename(namegv));
4633a7c4
LW		 6072 case ';':
6073 optional = 1;
6074 proto++;
6075 continue;
6076 case '$':
6077 proto++;
6078 arg++;
11343788 6079 scalar(o2);
4633a7c4
LW		 6080 break;
6081 case '%':
6082 case '@':
11343788 6083 list(o2);
4633a7c4
LW		 6084 arg++;
6085 break;
6086 case '&':
6087 proto++;
6088 arg++;
11343788 6089 if (o2->op_type != OP_REFGEN && o2->op_type != OP_UNDEF)
75fc29ea
GS		 6090 bad_type(arg,
6091 arg == 1 ? "block or sub {}" : "sub {}",
6092 gv_ename(namegv), o2);
4633a7c4
LW		 6093 break;
6094 case '*':
2ba6ecf4 6095 /* '*' allows any scalar type, including bareword */
4633a7c4
LW		 6096 proto++;
6097 arg++;
11343788 6098 if (o2->op_type == OP_RV2GV)
2ba6ecf4 6099 goto wrapref; /* autoconvert GLOB -> GLOBref */
7a52d87a
GS		 6100 else if (o2->op_type == OP_CONST)
6101 o2->op_private &= ~OPpCONST_STRICT;
9675f7ac
GS		 6102 else if (o2->op_type == OP_ENTERSUB) {
6103 /* accidental subroutine, revert to bareword */
6104 OP *gvop = ((UNOP*)o2)->op_first;
6105 if (gvop && gvop->op_type == OP_NULL) {
6106 gvop = ((UNOP*)gvop)->op_first;
6107 if (gvop) {
6108 for (; gvop->op_sibling; gvop = gvop->op_sibling)
6109 ;
6110 if (gvop &&
6111 (gvop->op_private & OPpENTERSUB_NOPAREN) &&
6112 (gvop = ((UNOP*)gvop)->op_first) &&
6113 gvop->op_type == OP_GV)
6114 {
638eceb6 6115 GV *gv = cGVOPx_gv(gvop);
9675f7ac 6116 OP *sibling = o2->op_sibling;
2692f720 6117 SV *n = newSVpvn("",0);
9675f7ac 6118 op_free(o2);
2692f720
GS		 6119 gv_fullname3(n, gv, "");
6120 if (SvCUR(n)>6 && strnEQ(SvPVX(n),"main::",6))
6121 sv_chop(n, SvPVX(n)+6);
6122 o2 = newSVOP(OP_CONST, 0, n);
9675f7ac
GS		 6123 prev->op_sibling = o2;
6124 o2->op_sibling = sibling;
6125 }
6126 }
6127 }
6128 }
2ba6ecf4
GS		 6129 scalar(o2);
6130 break;
5b794e05
JH		 6131 case '[': case ']':
6132 goto oops;
6133 break;
4633a7c4
LW		 6134 case '\\':
6135 proto++;
6136 arg++;
5b794e05 6137 again:
4633a7c4 6138 switch (*proto++) {
5b794e05
JH		 6139 case '[':
6140 if (contextclass++ == 0) {
841d93c8 6141 e = strchr(proto, ']');
5b794e05
JH		 6142 if (!e || e == proto)
6143 goto oops;
6144 }
6145 else
6146 goto oops;
6147 goto again;
6148 break;
6149 case ']':
466bafcd
RGS		 6150 if (contextclass) {
6151 char *p = proto;
6152 char s = *p;
6153 contextclass = 0;
6154 *p = '\0';
6155 while (*--p != '[');
1eb1540c 6156 bad_type(arg, Perl_form(aTHX_ "one of %s", p),
466bafcd
RGS		 6157 gv_ename(namegv), o2);
6158 *proto = s;
6159 } else
5b794e05
JH		 6160 goto oops;
6161 break;
4633a7c4 6162 case '*':
5b794e05
JH		 6163 if (o2->op_type == OP_RV2GV)
6164 goto wrapref;
6165 if (!contextclass)
6166 bad_type(arg, "symbol", gv_ename(namegv), o2);
6167 break;
4633a7c4 6168 case '&':
5b794e05
JH		 6169 if (o2->op_type == OP_ENTERSUB)
6170 goto wrapref;
6171 if (!contextclass)
6172 bad_type(arg, "subroutine entry", gv_ename(namegv), o2);
6173 break;
4633a7c4 6174 case '$':
5b794e05
JH		 6175 if (o2->op_type == OP_RV2SV ||
6176 o2->op_type == OP_PADSV ||
6177 o2->op_type == OP_HELEM ||
6178 o2->op_type == OP_AELEM ||
6179 o2->op_type == OP_THREADSV)
6180 goto wrapref;
6181 if (!contextclass)
5dc0d613 6182 bad_type(arg, "scalar", gv_ename(namegv), o2);
5b794e05 6183 break;
4633a7c4 6184 case '@':
5b794e05
JH		 6185 if (o2->op_type == OP_RV2AV ||
6186 o2->op_type == OP_PADAV)
6187 goto wrapref;
6188 if (!contextclass)
5dc0d613 6189 bad_type(arg, "array", gv_ename(namegv), o2);
5b794e05 6190 break;
4633a7c4 6191 case '%':
5b794e05
JH		 6192 if (o2->op_type == OP_RV2HV ||
6193 o2->op_type == OP_PADHV)
6194 goto wrapref;
6195 if (!contextclass)
6196 bad_type(arg, "hash", gv_ename(namegv), o2);
6197 break;
6198 wrapref:
4633a7c4 6199 {
11343788 6200 OP* kid = o2;
6fa846a0 6201 OP* sib = kid->op_sibling;
4633a7c4 6202 kid->op_sibling = 0;
6fa846a0
GS		 6203 o2 = newUNOP(OP_REFGEN, 0, kid);
6204 o2->op_sibling = sib;
e858de61 6205 prev->op_sibling = o2;
4633a7c4 6206 }
841d93c8 6207 if (contextclass && e) {
5b794e05
JH		 6208 proto = e + 1;
6209 contextclass = 0;
6210 }
4633a7c4
LW		 6211 break;
6212 default: goto oops;
6213 }
5b794e05
JH		 6214 if (contextclass)
6215 goto again;
4633a7c4 6216 break;
b1cb66bf 6217 case ' ':
6218 proto++;
6219 continue;
4633a7c4
LW		 6220 default:
6221 oops:
35c1215d
NC		 6222 Perl_croak(aTHX_ "Malformed prototype for %s: %"SVf,
6223 gv_ename(namegv), cv);
4633a7c4
LW		 6224 }
6225 }
6226 else
11343788
MB		 6227 list(o2);
6228 mod(o2, OP_ENTERSUB);
6229 prev = o2;
6230 o2 = o2->op_sibling;
4633a7c4 6231 }
fb73857a 6232 if (proto && !optional &&
6233 (*proto && *proto != '@' && *proto != '%' && *proto != ';'))
5dc0d613 6234 return too_few_arguments(o, gv_ename(namegv));
06492da6
SF		 6235 if(delete) {
6236 op_free(o);
6237 o=newSVOP(OP_CONST, 0, newSViv(0));
6238 }
11343788 6239 return o;
79072805
LW		 6240}
6241
6242OP *
cea2e8a9 6243Perl_ck_svconst(pTHX_ OP *o)
8990e307 6244{
11343788
MB		 6245 SvREADONLY_on(cSVOPo->op_sv);
6246 return o;
8990e307
LW		 6247}
6248
6249OP *
cea2e8a9 6250Perl_ck_trunc(pTHX_ OP *o)
79072805 6251{
11343788
MB		 6252 if (o->op_flags & OPf_KIDS) {
6253 SVOP *kid = (SVOP*)cUNOPo->op_first;
79072805 6254
a0d0e21e
LW		 6255 if (kid->op_type == OP_NULL)
6256 kid = (SVOP*)kid->op_sibling;
bb53490d
GS		 6257 if (kid && kid->op_type == OP_CONST &&
6258 (kid->op_private & OPpCONST_BARE))
6259 {
11343788 6260 o->op_flags |= OPf_SPECIAL;
bb53490d
GS		 6261 kid->op_private &= ~OPpCONST_STRICT;
6262 }
79072805 6263 }
11343788 6264 return ck_fun(o);
79072805
LW		 6265}
6266
35fba0d9 6267OP *
bab9c0ac
RGS		 6268Perl_ck_unpack(pTHX_ OP *o)
6269{
6270 OP *kid = cLISTOPo->op_first;
6271 if (kid->op_sibling) {
6272 kid = kid->op_sibling;
6273 if (!kid->op_sibling)
6274 kid->op_sibling = newDEFSVOP();
6275 }
6276 return ck_fun(o);
6277}
6278
6279OP *
35fba0d9
RG		 6280Perl_ck_substr(pTHX_ OP *o)
6281{
6282 o = ck_fun(o);
6283 if ((o->op_flags & OPf_KIDS) && o->op_private == 4) {
6284 OP *kid = cLISTOPo->op_first;
6285
6286 if (kid->op_type == OP_NULL)
6287 kid = kid->op_sibling;
6288 if (kid)
6289 kid->op_flags |= OPf_MOD;
6290
6291 }
6292 return o;
6293}
6294
463ee0b2
LW		 6295/* A peephole optimizer. We visit the ops in the order they're to execute. */
6296
79072805 6297void
864dbfa3 6298Perl_peep(pTHX_ register OP *o)
79072805
LW		 6299{
6300 register OP* oldop = 0;
2d8e6c8d 6301
2814eb74 6302 if (!o || o->op_opt)
79072805 6303 return;
a0d0e21e 6304 ENTER;
462e5cf6 6305 SAVEOP();
7766f137 6306 SAVEVPTR(PL_curcop);
a0d0e21e 6307 for (; o; o = o->op_next) {
2814eb74 6308 if (o->op_opt)
a0d0e21e 6309 break;
533c011a 6310 PL_op = o;
a0d0e21e 6311 switch (o->op_type) {
acb36ea4 6312 case OP_SETSTATE:
a0d0e21e
LW		 6313 case OP_NEXTSTATE:
6314 case OP_DBSTATE:
3280af22 6315 PL_curcop = ((COP*)o); /* for warnings */
2814eb74 6316 o->op_opt = 1;
a0d0e21e
LW		 6317 break;
6318
a0d0e21e 6319 case OP_CONST:
7a52d87a
GS		 6320 if (cSVOPo->op_private & OPpCONST_STRICT)
6321 no_bareword_allowed(o);
7766f137 6322#ifdef USE_ITHREADS
3848b962 6323 case OP_METHOD_NAMED:
7766f137
GS		 6324 /* Relocate sv to the pad for thread safety.
6325 * Despite being a "constant", the SV is written to,
6326 * for reference counts, sv_upgrade() etc. */
6327 if (cSVOP->op_sv) {
6328 PADOFFSET ix = pad_alloc(OP_CONST, SVs_PADTMP);
330e22d5 6329 if (o->op_type == OP_CONST && SvPADTMP(cSVOPo->op_sv)) {
6a7129a1 6330 /* If op_sv is already a PADTMP then it is being used by
9a049f1c 6331 * some pad, so make a copy. */
dd2155a4
DM		 6332 sv_setsv(PAD_SVl(ix),cSVOPo->op_sv);
6333 SvREADONLY_on(PAD_SVl(ix));
6a7129a1
GS		 6334 SvREFCNT_dec(cSVOPo->op_sv);
6335 }
6336 else {
dd2155a4 6337 SvREFCNT_dec(PAD_SVl(ix));
6a7129a1 6338 SvPADTMP_on(cSVOPo->op_sv);
dd2155a4 6339 PAD_SETSV(ix, cSVOPo->op_sv);
9a049f1c 6340 /* XXX I don't know how this isn't readonly already. */
dd2155a4 6341 SvREADONLY_on(PAD_SVl(ix));
6a7129a1 6342 }
7766f137
GS		 6343 cSVOPo->op_sv = Nullsv;
6344 o->op_targ = ix;
6345 }
6346#endif
2814eb74 6347 o->op_opt = 1;
07447971
GS		 6348 break;
6349
df91b2c5
AE		 6350 case OP_CONCAT:
6351 if (o->op_next && o->op_next->op_type == OP_STRINGIFY) {
6352 if (o->op_next->op_private & OPpTARGET_MY) {
6353 if (o->op_flags & OPf_STACKED) /* chained concats */
6354 goto ignore_optimization;
6355 else {
6356 /* assert(PL_opargs[o->op_type] & OA_TARGLEX); */
6357 o->op_targ = o->op_next->op_targ;
6358 o->op_next->op_targ = 0;
6359 o->op_private |= OPpTARGET_MY;
6360 }
6361 }
6362 op_null(o->op_next);
6363 }
6364 ignore_optimization:
2814eb74 6365 o->op_opt = 1;
df91b2c5 6366 break;
8990e307 6367 case OP_STUB:
54310121 6368 if ((o->op_flags & OPf_WANT) != OPf_WANT_LIST) {
2814eb74 6369 o->op_opt = 1;
54310121 6370 break; /* Scalar stub must produce undef. List stub is noop */
8990e307 6371 }
748a9306 6372 goto nothin;
79072805 6373 case OP_NULL:
acb36ea4
GS		 6374 if (o->op_targ == OP_NEXTSTATE
6375 || o->op_targ == OP_DBSTATE
6376 || o->op_targ == OP_SETSTATE)
6377 {
3280af22 6378 PL_curcop = ((COP*)o);
acb36ea4 6379 }
dad75012
AMS		 6380 /* XXX: We avoid setting op_seq here to prevent later calls
6381 to peep() from mistakenly concluding that optimisation
6382 has already occurred. This doesn't fix the real problem,
6383 though (See 20010220.007). AMS 20010719 */
2814eb74 6384 /* op_seq functionality is now replaced by op_opt */
dad75012
AMS		 6385 if (oldop && o->op_next) {
6386 oldop->op_next = o->op_next;
6387 continue;
6388 }
6389 break;
79072805 6390 case OP_SCALAR:
93a17b20 6391 case OP_LINESEQ:
463ee0b2 6392 case OP_SCOPE:
748a9306 6393 nothin:
a0d0e21e
LW		 6394 if (oldop && o->op_next) {
6395 oldop->op_next = o->op_next;
79072805
LW		 6396 continue;
6397 }
2814eb74 6398 o->op_opt = 1;
79072805
LW		 6399 break;
6400
6a077020 6401 case OP_PADAV:
79072805 6402 case OP_GV:
6a077020
DM		 6403 if (o->op_type == OP_PADAV || o->op_next->op_type == OP_RV2AV) {
6404 OP* pop = (o->op_type == OP_PADAV) ?
6405 o->op_next : o->op_next->op_next;
a0d0e21e 6406 IV i;
f9dc862f 6407 if (pop && pop->op_type == OP_CONST &&
533c011a 6408 (PL_op = pop->op_next) &&
8990e307 6409 pop->op_next->op_type == OP_AELEM &&
a0d0e21e 6410 !(pop->op_next->op_private &
78f9721b 6411 (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB)) &&
b0840a2a 6412 (i = SvIV(((SVOP*)pop)->op_sv) - PL_curcop->cop_arybase)
a0d0e21e 6413 <= 255 &&
8990e307
LW		 6414 i >= 0)
6415 {
350de78d 6416 GV *gv;
6a077020
DM		 6417 if (o->op_type == OP_GV)
6418 op_null(o->op_next);
93c66552
DM		 6419 op_null(pop->op_next);
6420 op_null(pop);
a0d0e21e
LW		 6421 o->op_flags |= pop->op_next->op_flags & OPf_MOD;
6422 o->op_next = pop->op_next->op_next;
22c35a8c 6423 o->op_ppaddr = PL_ppaddr[OP_AELEMFAST];
a0d0e21e 6424 o->op_private = (U8)i;
6a077020
DM		 6425 if (o->op_type == OP_GV) {
6426 gv = cGVOPo_gv;
6427 GvAVn(gv);
6428 }
6429 else
6430 o->op_flags |= OPf_SPECIAL;
6431 o->op_type = OP_AELEMFAST;
6432 }
6433 o->op_opt = 1;
6434 break;
6435 }
6436
6437 if (o->op_next->op_type == OP_RV2SV) {
6438 if (!(o->op_next->op_private & OPpDEREF)) {
6439 op_null(o->op_next);
6440 o->op_private |= o->op_next->op_private & (OPpLVAL_INTRO
6441 | OPpOUR_INTRO);
6442 o->op_next = o->op_next->op_next;
6443 o->op_type = OP_GVSV;
6444 o->op_ppaddr = PL_ppaddr[OP_GVSV];
8990e307 6445 }
79072805 6446 }
e476b1b5 6447 else if ((o->op_private & OPpEARLY_CV) && ckWARN(WARN_PROTOTYPE)) {
638eceb6 6448 GV *gv = cGVOPo_gv;
76cd736e
GS		 6449 if (SvTYPE(gv) == SVt_PVGV && GvCV(gv) && SvPVX(GvCV(gv))) {
6450 /* XXX could check prototype here instead of just carping */
6451 SV *sv = sv_newmortal();
6452 gv_efullname3(sv, gv, Nullch);
9014280d 6453 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE),
35c1215d
NC		 6454 "%"SVf"() called too early to check prototype",
6455 sv);
76cd736e
GS		 6456 }
6457 }
89de2904
AMS		 6458 else if (o->op_next->op_type == OP_READLINE
6459 && o->op_next->op_next->op_type == OP_CONCAT
6460 && (o->op_next->op_next->op_flags & OPf_STACKED))
6461 {
d2c45030
AMS		 6462 /* Turn "$a .= <FH>" into an OP_RCATLINE. AMS 20010917 */
6463 o->op_type = OP_RCATLINE;
6464 o->op_flags |= OPf_STACKED;
6465 o->op_ppaddr = PL_ppaddr[OP_RCATLINE];
89de2904 6466 op_null(o->op_next->op_next);
d2c45030 6467 op_null(o->op_next);
89de2904 6468 }
76cd736e 6469
2814eb74 6470 o->op_opt = 1;
79072805
LW		 6471 break;
6472
a0d0e21e 6473 case OP_MAPWHILE:
79072805
LW		 6474 case OP_GREPWHILE:
6475 case OP_AND:
6476 case OP_OR:
c963b151 6477 case OP_DOR:
2c2d71f5
JH		 6478 case OP_ANDASSIGN:
6479 case OP_ORASSIGN:
c963b151 6480 case OP_DORASSIGN:
1a67a97c
SM		 6481 case OP_COND_EXPR:
6482 case OP_RANGE:
2814eb74 6483 o->op_opt = 1;
fd4d1407
IZ		 6484 while (cLOGOP->op_other->op_type == OP_NULL)
6485 cLOGOP->op_other = cLOGOP->op_other->op_next;
a2efc822 6486 peep(cLOGOP->op_other); /* Recursive calls are not replaced by fptr calls */
79072805
LW		 6487 break;
6488
79072805 6489 case OP_ENTERLOOP:
9c2ca71a 6490 case OP_ENTERITER:
2814eb74 6491 o->op_opt = 1;
58cccf98
SM		 6492 while (cLOOP->op_redoop->op_type == OP_NULL)
6493 cLOOP->op_redoop = cLOOP->op_redoop->op_next;
79072805 6494 peep(cLOOP->op_redoop);
58cccf98
SM		 6495 while (cLOOP->op_nextop->op_type == OP_NULL)
6496 cLOOP->op_nextop = cLOOP->op_nextop->op_next;
79072805 6497 peep(cLOOP->op_nextop);
58cccf98
SM		 6498 while (cLOOP->op_lastop->op_type == OP_NULL)
6499 cLOOP->op_lastop = cLOOP->op_lastop->op_next;
79072805
LW		 6500 peep(cLOOP->op_lastop);
6501 break;
6502
8782bef2 6503 case OP_QR:
79072805
LW		 6504 case OP_MATCH:
6505 case OP_SUBST:
2814eb74 6506 o->op_opt = 1;
9041c2e3 6507 while (cPMOP->op_pmreplstart &&
58cccf98
SM		 6508 cPMOP->op_pmreplstart->op_type == OP_NULL)
6509 cPMOP->op_pmreplstart = cPMOP->op_pmreplstart->op_next;
a0d0e21e 6510 peep(cPMOP->op_pmreplstart);
79072805
LW		 6511 break;
6512
a0d0e21e 6513 case OP_EXEC:
2814eb74 6514 o->op_opt = 1;
1c846c1f 6515 if (ckWARN(WARN_SYNTAX) && o->op_next
599cee73 6516 && o->op_next->op_type == OP_NEXTSTATE) {
a0d0e21e 6517 if (o->op_next->op_sibling &&
20408e3c
GS		 6518 o->op_next->op_sibling->op_type != OP_EXIT &&
6519 o->op_next->op_sibling->op_type != OP_WARN &&
a0d0e21e 6520 o->op_next->op_sibling->op_type != OP_DIE) {
57843af0 6521 line_t oldline = CopLINE(PL_curcop);
a0d0e21e 6522
57843af0 6523 CopLINE_set(PL_curcop, CopLINE((COP*)o->op_next));
9014280d 6524 Perl_warner(aTHX_ packWARN(WARN_EXEC),
eeb6a2c9 6525 "Statement unlikely to be reached");
9014280d 6526 Perl_warner(aTHX_ packWARN(WARN_EXEC),
cc507455 6527 "\t(Maybe you meant system() when you said exec()?)\n");
57843af0 6528 CopLINE_set(PL_curcop, oldline);
a0d0e21e
LW		 6529 }
6530 }
6531 break;
b2ffa427 6532
c750a3ec 6533 case OP_HELEM: {
6d822dc4
MS		 6534 SV *lexname;
6535 SV **svp, *sv;
1c846c1f 6536 char *key = NULL;
c750a3ec 6537 STRLEN keylen;
b2ffa427 6538
2814eb74 6539 o->op_opt = 1;
1c846c1f
NIS		 6540
6541 if (((BINOP*)o)->op_last->op_type != OP_CONST)
c750a3ec 6542 break;
1c846c1f
NIS		 6543
6544 /* Make the CONST have a shared SV */
6545 svp = cSVOPx_svp(((BINOP*)o)->op_last);
3049cdab 6546 if ((!SvFAKE(sv = *svp) || !SvREADONLY(sv)) && !IS_PADCONST(sv)) {
1c846c1f 6547 key = SvPV(sv, keylen);
25716404
GS		 6548 lexname = newSVpvn_share(key,
6549 SvUTF8(sv) ? -(I32)keylen : keylen,
6550 0);
1c846c1f
NIS		 6551 SvREFCNT_dec(sv);
6552 *svp = lexname;
6553 }
6d822dc4
MS		 6554 break;
6555 }
c750a3ec 6556
fe1bc4cf
DM		 6557 case OP_SORT: {
6558 /* make @a = sort @a act in-place */
6559
6560 /* will point to RV2AV or PADAV op on LHS/RHS of assign */
6561 OP *oleft, *oright;
6562 OP *o2;
6563
2814eb74 6564 o->op_opt = 1;
fe1bc4cf
DM		 6565
6566 /* check that RHS of sort is a single plain array */
6567 oright = cUNOPo->op_first;
6568 if (!oright || oright->op_type != OP_PUSHMARK)
6569 break;
6570 oright = cUNOPx(oright)->op_sibling;
6571 if (!oright)
6572 break;
6573 if (oright->op_type == OP_NULL) { /* skip sort block/sub */
6574 oright = cUNOPx(oright)->op_sibling;
6575 }
6576
6577 if (!oright ||
6578 (oright->op_type != OP_RV2AV && oright->op_type != OP_PADAV)
6579 || oright->op_next != o
6580 || (oright->op_private & OPpLVAL_INTRO)
6581 )
6582 break;
6583
6584 /* o2 follows the chain of op_nexts through the LHS of the
6585 * assign (if any) to the aassign op itself */
6586 o2 = o->op_next;
6587 if (!o2 || o2->op_type != OP_NULL)
6588 break;
6589 o2 = o2->op_next;
6590 if (!o2 || o2->op_type != OP_PUSHMARK)
6591 break;
6592 o2 = o2->op_next;
6593 if (o2 && o2->op_type == OP_GV)
6594 o2 = o2->op_next;
6595 if (!o2
6596 || (o2->op_type != OP_PADAV && o2->op_type != OP_RV2AV)
6597 || (o2->op_private & OPpLVAL_INTRO)
6598 )
6599 break;
6600 oleft = o2;
6601 o2 = o2->op_next;
6602 if (!o2 || o2->op_type != OP_NULL)
6603 break;
6604 o2 = o2->op_next;
6605 if (!o2 || o2->op_type != OP_AASSIGN
6606 || (o2->op_flags & OPf_WANT) != OPf_WANT_VOID)
6607 break;
6608
6609 /* check the array is the same on both sides */
6610 if (oleft->op_type == OP_RV2AV) {
6611 if (oright->op_type != OP_RV2AV
6612 || !cUNOPx(oright)->op_first
6613 || cUNOPx(oright)->op_first->op_type != OP_GV
6614 || cGVOPx_gv(cUNOPx(oleft)->op_first) !=
6615 cGVOPx_gv(cUNOPx(oright)->op_first)
6616 )
6617 break;
6618 }
6619 else if (oright->op_type != OP_PADAV
6620 || oright->op_targ != oleft->op_targ
6621 )
6622 break;
6623
6624 /* transfer MODishness etc from LHS arg to RHS arg */
6625 oright->op_flags = oleft->op_flags;
6626 o->op_private |= OPpSORT_INPLACE;
6627
6628 /* excise push->gv->rv2av->null->aassign */
6629 o2 = o->op_next->op_next;
6630 op_null(o2); /* PUSHMARK */
6631 o2 = o2->op_next;
6632 if (o2->op_type == OP_GV) {
6633 op_null(o2); /* GV */
6634 o2 = o2->op_next;
6635 }
6636 op_null(o2); /* RV2AV or PADAV */
6637 o2 = o2->op_next->op_next;
6638 op_null(o2); /* AASSIGN */
6639
6640 o->op_next = o2->op_next;
6641
6642 break;
6643 }
6644
6645
6646
79072805 6647 default:
2814eb74 6648 o->op_opt = 1;
79072805
LW		 6649 break;
6650 }
a0d0e21e 6651 oldop = o;
79072805 6652 }
a0d0e21e 6653 LEAVE;
79072805 6654}
beab0874 6655
19e8ce8e
AB		 6656
6657
6658char* Perl_custom_op_name(pTHX_ OP* o)
53e06cf0
SC		 6659{
6660 IV index = PTR2IV(o->op_ppaddr);
6661 SV* keysv;
6662 HE* he;
6663
6664 if (!PL_custom_op_names) /* This probably shouldn't happen */
6665 return PL_op_name[OP_CUSTOM];
6666
6667 keysv = sv_2mortal(newSViv(index));
6668
6669 he = hv_fetch_ent(PL_custom_op_names, keysv, 0, 0);
6670 if (!he)
6671 return PL_op_name[OP_CUSTOM]; /* Don't know who you are */
6672
6673 return SvPV_nolen(HeVAL(he));
6674}
6675
19e8ce8e 6676char* Perl_custom_op_desc(pTHX_ OP* o)
53e06cf0
SC		 6677{
6678 IV index = PTR2IV(o->op_ppaddr);
6679 SV* keysv;
6680 HE* he;
6681
6682 if (!PL_custom_op_descs)
6683 return PL_op_desc[OP_CUSTOM];
6684
6685 keysv = sv_2mortal(newSViv(index));
6686
6687 he = hv_fetch_ent(PL_custom_op_descs, keysv, 0, 0);
6688 if (!he)
6689 return PL_op_desc[OP_CUSTOM];
6690
6691 return SvPV_nolen(HeVAL(he));
6692}
19e8ce8e 6693
53e06cf0 6694
beab0874
JT		 6695#include "XSUB.h"
6696
6697/* Efficient sub that returns a constant scalar value. */
6698static void
acfe0abc 6699const_sv_xsub(pTHX_ CV* cv)
beab0874
JT		 6700{
6701 dXSARGS;
9cbac4c7
DM		 6702 if (items != 0) {
6703#if 0
6704 Perl_croak(aTHX_ "usage: %s::%s()",
6705 HvNAME(GvSTASH(CvGV(cv))), GvNAME(CvGV(cv)));
6706#endif
6707 }
9a049f1c 6708 EXTEND(sp, 1);
0768512c 6709 ST(0) = (SV*)XSANY.any_ptr;
beab0874
JT		 6710 XSRETURN(1);
6711}
Unnamed repository; edit this file 'description' to name the repository.