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