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