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