3 * Copyright (c) 1991-2003, Larry Wall
5 * You may distribute under the terms of either the GNU General Public
6 * License or the Artistic License, as specified in the README file.
11 * "You see: Mr. Drogo, he married poor Miss Primula Brandybuck. She was
12 * our Mr. Bilbo's first cousin on the mother's side (her mother being the
13 * youngest of the Old Took's daughters); and Mr. Drogo was his second
14 * cousin. So Mr. Frodo is his first *and* second cousin, once removed
15 * either way, as the saying is, if you follow me." --the Gaffer
24 #define CALL_PEEP(o) CALL_FPTR(PL_peepp)(aTHX_ o)
26 #if defined(PL_OP_SLAB_ALLOC)
28 #ifndef PERL_SLAB_SIZE
29 #define PERL_SLAB_SIZE 2048
32 #define NewOp(m,var,c,type) \
33 STMT_START { var = (type *) Slab_Alloc(m,c*sizeof(type)); } STMT_END
35 #define FreeOp(p) Slab_Free(p)
38 S_Slab_Alloc(pTHX_ int m, size_t sz)
41 * To make incrementing use count easy PL_OpSlab is an I32 *
42 * To make inserting the link to slab PL_OpPtr is I32 **
43 * So compute size in units of sizeof(I32 *) as that is how Pl_OpPtr increments
44 * Add an overhead for pointer to slab and round up as a number of pointers
46 sz = (sz + 2*sizeof(I32 *) -1)/sizeof(I32 *);
47 if ((PL_OpSpace -= sz) < 0) {
48 PL_OpPtr = (I32 **) PerlMemShared_malloc(PERL_SLAB_SIZE*sizeof(I32*));
52 Zero(PL_OpPtr,PERL_SLAB_SIZE,I32 **);
53 /* We reserve the 0'th I32 sized chunk as a use count */
54 PL_OpSlab = (I32 *) PL_OpPtr;
55 /* Reduce size by the use count word, and by the size we need.
56 * Latter is to mimic the '-=' in the if() above
58 PL_OpSpace = PERL_SLAB_SIZE - (sizeof(I32)+sizeof(I32 **)-1)/sizeof(I32 **) - sz;
59 /* Allocation pointer starts at the top.
60 Theory: because we build leaves before trunk allocating at end
61 means that at run time access is cache friendly upward
63 PL_OpPtr += PERL_SLAB_SIZE;
65 assert( PL_OpSpace >= 0 );
66 /* Move the allocation pointer down */
68 assert( PL_OpPtr > (I32 **) PL_OpSlab );
69 *PL_OpPtr = PL_OpSlab; /* Note which slab it belongs to */
70 (*PL_OpSlab)++; /* Increment use count of slab */
71 assert( PL_OpPtr+sz <= ((I32 **) PL_OpSlab + PERL_SLAB_SIZE) );
72 assert( *PL_OpSlab > 0 );
73 return (void *)(PL_OpPtr + 1);
77 S_Slab_Free(pTHX_ void *op)
79 I32 **ptr = (I32 **) op;
81 assert( ptr-1 > (I32 **) slab );
82 assert( ptr < ( (I32 **) slab + PERL_SLAB_SIZE) );
86 #define PerlMemShared PerlMem
89 PerlMemShared_free(slab);
90 if (slab == PL_OpSlab) {
97 #define NewOp(m, var, c, type) Newz(m, var, c, type)
98 #define FreeOp(p) Safefree(p)
101 * In the following definition, the ", Nullop" is just to make the compiler
102 * think the expression is of the right type: croak actually does a Siglongjmp.
104 #define CHECKOP(type,o) \
105 ((PL_op_mask && PL_op_mask[type]) \
106 ? ( op_free((OP*)o), \
107 Perl_croak(aTHX_ "'%s' trapped by operation mask", PL_op_desc[type]), \
109 : CALL_FPTR(PL_check[type])(aTHX_ (OP*)o))
111 #define RETURN_UNLIMITED_NUMBER (PERL_INT_MAX / 2)
114 S_gv_ename(pTHX_ GV *gv)
117 SV* tmpsv = sv_newmortal();
118 gv_efullname3(tmpsv, gv, Nullch);
119 return SvPV(tmpsv,n_a);
123 S_no_fh_allowed(pTHX_ OP *o)
125 yyerror(Perl_form(aTHX_ "Missing comma after first argument to %s function",
131 S_too_few_arguments(pTHX_ OP *o, char *name)
133 yyerror(Perl_form(aTHX_ "Not enough arguments for %s", name));
138 S_too_many_arguments(pTHX_ OP *o, char *name)
140 yyerror(Perl_form(aTHX_ "Too many arguments for %s", name));
145 S_bad_type(pTHX_ I32 n, char *t, char *name, OP *kid)
147 yyerror(Perl_form(aTHX_ "Type of arg %d to %s must be %s (not %s)",
148 (int)n, name, t, OP_DESC(kid)));
152 S_no_bareword_allowed(pTHX_ OP *o)
154 qerror(Perl_mess(aTHX_
155 "Bareword \"%"SVf"\" not allowed while \"strict subs\" in use",
159 /* "register" allocation */
162 Perl_allocmy(pTHX_ char *name)
166 /* complain about "my $_" etc etc */
167 if (!(PL_in_my == KEY_our ||
169 (USE_UTF8_IN_NAMES && UTF8_IS_START(name[1])) ||
170 (name[1] == '_' && (int)strlen(name) > 2)))
172 if (!isPRINT(name[1]) || strchr("\t\n\r\f", name[1])) {
173 /* 1999-02-27 mjd@plover.com */
175 p = strchr(name, '\0');
176 /* The next block assumes the buffer is at least 205 chars
177 long. At present, it's always at least 256 chars. */
179 strcpy(name+200, "...");
185 /* Move everything else down one character */
186 for (; p-name > 2; p--)
188 name[2] = toCTRL(name[1]);
191 yyerror(Perl_form(aTHX_ "Can't use global %s in \"my\"",name));
194 /* check for duplicate declaration */
197 (PL_curstash ? PL_curstash : PL_defstash)
200 if (PL_in_my_stash && *name != '$') {
201 yyerror(Perl_form(aTHX_
202 "Can't declare class for non-scalar %s in \"%s\"",
203 name, PL_in_my == KEY_our ? "our" : "my"));
206 /* allocate a spare slot and store the name in that slot */
208 off = pad_add_name(name,
211 ? (PL_curstash ? PL_curstash : PL_defstash)
222 Perl_op_free(pTHX_ OP *o)
224 register OP *kid, *nextkid;
227 if (!o || o->op_seq == (U16)-1)
230 if (o->op_private & OPpREFCOUNTED) {
231 switch (o->op_type) {
239 if (OpREFCNT_dec(o)) {
250 if (o->op_flags & OPf_KIDS) {
251 for (kid = cUNOPo->op_first; kid; kid = nextkid) {
252 nextkid = kid->op_sibling; /* Get before next freeing kid */
258 type = (OPCODE)o->op_targ;
260 /* COP* is not cleared by op_clear() so that we may track line
261 * numbers etc even after null() */
262 if (type == OP_NEXTSTATE || type == OP_SETSTATE || type == OP_DBSTATE)
270 Perl_op_clear(pTHX_ OP *o)
273 switch (o->op_type) {
274 case OP_NULL: /* Was holding old type, if any. */
275 case OP_ENTEREVAL: /* Was holding hints. */
279 if (!(o->op_flags & OPf_REF)
280 || (PL_check[o->op_type] != MEMBER_TO_FPTR(Perl_ck_ftst)))
287 if (cPADOPo->op_padix > 0) {
288 /* No GvIN_PAD_off(cGVOPo_gv) here, because other references
289 * may still exist on the pad */
290 pad_swipe(cPADOPo->op_padix, TRUE);
291 cPADOPo->op_padix = 0;
294 SvREFCNT_dec(cSVOPo->op_sv);
295 cSVOPo->op_sv = Nullsv;
298 case OP_METHOD_NAMED:
300 SvREFCNT_dec(cSVOPo->op_sv);
301 cSVOPo->op_sv = Nullsv;
307 if (o->op_flags & (OPf_SPECIAL|OPf_STACKED|OPf_KIDS))
311 if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
312 SvREFCNT_dec(cSVOPo->op_sv);
313 cSVOPo->op_sv = Nullsv;
316 Safefree(cPVOPo->op_pv);
317 cPVOPo->op_pv = Nullch;
321 op_free(cPMOPo->op_pmreplroot);
325 if (INT2PTR(PADOFFSET, cPMOPo->op_pmreplroot)) {
326 /* No GvIN_PAD_off here, because other references may still
327 * exist on the pad */
328 pad_swipe(INT2PTR(PADOFFSET, cPMOPo->op_pmreplroot), TRUE);
331 SvREFCNT_dec((SV*)cPMOPo->op_pmreplroot);
338 HV *pmstash = PmopSTASH(cPMOPo);
339 if (pmstash && SvREFCNT(pmstash)) {
340 PMOP *pmop = HvPMROOT(pmstash);
341 PMOP *lastpmop = NULL;
343 if (cPMOPo == pmop) {
345 lastpmop->op_pmnext = pmop->op_pmnext;
347 HvPMROOT(pmstash) = pmop->op_pmnext;
351 pmop = pmop->op_pmnext;
354 PmopSTASH_free(cPMOPo);
356 cPMOPo->op_pmreplroot = Nullop;
357 /* we use the "SAFE" version of the PM_ macros here
358 * since sv_clean_all might release some PMOPs
359 * after PL_regex_padav has been cleared
360 * and the clearing of PL_regex_padav needs to
361 * happen before sv_clean_all
363 ReREFCNT_dec(PM_GETRE_SAFE(cPMOPo));
364 PM_SETRE_SAFE(cPMOPo, (REGEXP*)NULL);
366 if(PL_regex_pad) { /* We could be in destruction */
367 av_push((AV*) PL_regex_pad[0],(SV*) PL_regex_pad[(cPMOPo)->op_pmoffset]);
368 SvREPADTMP_on(PL_regex_pad[(cPMOPo)->op_pmoffset]);
369 PM_SETRE(cPMOPo, (cPMOPo)->op_pmoffset);
376 if (o->op_targ > 0) {
377 pad_free(o->op_targ);
383 S_cop_free(pTHX_ COP* cop)
385 Safefree(cop->cop_label); /* FIXME: treaddead ??? */
388 if (! specialWARN(cop->cop_warnings))
389 SvREFCNT_dec(cop->cop_warnings);
390 if (! specialCopIO(cop->cop_io)) {
394 char *s = SvPV(cop->cop_io,len);
395 Perl_warn(aTHX_ "io='%.*s'",(int) len,s); /* ??? --jhi */
398 SvREFCNT_dec(cop->cop_io);
404 Perl_op_null(pTHX_ OP *o)
406 if (o->op_type == OP_NULL)
409 o->op_targ = o->op_type;
410 o->op_type = OP_NULL;
411 o->op_ppaddr = PL_ppaddr[OP_NULL];
414 /* Contextualizers */
416 #define LINKLIST(o) ((o)->op_next ? (o)->op_next : linklist((OP*)o))
419 Perl_linklist(pTHX_ OP *o)
426 /* establish postfix order */
427 if (cUNOPo->op_first) {
428 o->op_next = LINKLIST(cUNOPo->op_first);
429 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
431 kid->op_next = LINKLIST(kid->op_sibling);
443 Perl_scalarkids(pTHX_ OP *o)
446 if (o && o->op_flags & OPf_KIDS) {
447 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
454 S_scalarboolean(pTHX_ OP *o)
456 if (o->op_type == OP_SASSIGN && cBINOPo->op_first->op_type == OP_CONST) {
457 if (ckWARN(WARN_SYNTAX)) {
458 line_t oldline = CopLINE(PL_curcop);
460 if (PL_copline != NOLINE)
461 CopLINE_set(PL_curcop, PL_copline);
462 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Found = in conditional, should be ==");
463 CopLINE_set(PL_curcop, oldline);
470 Perl_scalar(pTHX_ OP *o)
474 /* assumes no premature commitment */
475 if (!o || (o->op_flags & OPf_WANT) || PL_error_count
476 || o->op_type == OP_RETURN)
481 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_SCALAR;
483 switch (o->op_type) {
485 scalar(cBINOPo->op_first);
490 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
494 if ((kid = cLISTOPo->op_first) && kid->op_type == OP_PUSHRE) {
495 if (!kPMOP->op_pmreplroot)
496 deprecate_old("implicit split to @_");
504 if (o->op_flags & OPf_KIDS) {
505 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling)
511 kid = cLISTOPo->op_first;
513 while ((kid = kid->op_sibling)) {
519 WITH_THR(PL_curcop = &PL_compiling);
524 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
530 WITH_THR(PL_curcop = &PL_compiling);
533 if (ckWARN(WARN_VOID))
534 Perl_warner(aTHX_ packWARN(WARN_VOID), "Useless use of sort in scalar context");
540 Perl_scalarvoid(pTHX_ OP *o)
547 if (o->op_type == OP_NEXTSTATE
548 || o->op_type == OP_SETSTATE
549 || o->op_type == OP_DBSTATE
550 || (o->op_type == OP_NULL && (o->op_targ == OP_NEXTSTATE
551 || o->op_targ == OP_SETSTATE
552 || o->op_targ == OP_DBSTATE)))
553 PL_curcop = (COP*)o; /* for warning below */
555 /* assumes no premature commitment */
556 want = o->op_flags & OPf_WANT;
557 if ((want && want != OPf_WANT_SCALAR) || PL_error_count
558 || o->op_type == OP_RETURN)
563 if ((o->op_private & OPpTARGET_MY)
564 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
566 return scalar(o); /* As if inside SASSIGN */
569 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
571 switch (o->op_type) {
573 if (!(PL_opargs[o->op_type] & OA_FOLDCONST))
577 if (o->op_flags & OPf_STACKED)
581 if (o->op_private == 4)
653 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)))
654 useless = OP_DESC(o);
661 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)) &&
662 (!o->op_sibling || o->op_sibling->op_type != OP_READLINE))
663 useless = "a variable";
668 if (cSVOPo->op_private & OPpCONST_STRICT)
669 no_bareword_allowed(o);
671 if (ckWARN(WARN_VOID)) {
672 useless = "a constant";
673 /* the constants 0 and 1 are permitted as they are
674 conventionally used as dummies in constructs like
675 1 while some_condition_with_side_effects; */
676 if (SvNIOK(sv) && (SvNV(sv) == 0.0 || SvNV(sv) == 1.0))
678 else if (SvPOK(sv)) {
679 /* perl4's way of mixing documentation and code
680 (before the invention of POD) was based on a
681 trick to mix nroff and perl code. The trick was
682 built upon these three nroff macros being used in
683 void context. The pink camel has the details in
684 the script wrapman near page 319. */
685 if (strnEQ(SvPVX(sv), "di", 2) ||
686 strnEQ(SvPVX(sv), "ds", 2) ||
687 strnEQ(SvPVX(sv), "ig", 2))
692 op_null(o); /* don't execute or even remember it */
696 o->op_type = OP_PREINC; /* pre-increment is faster */
697 o->op_ppaddr = PL_ppaddr[OP_PREINC];
701 o->op_type = OP_PREDEC; /* pre-decrement is faster */
702 o->op_ppaddr = PL_ppaddr[OP_PREDEC];
709 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
714 if (o->op_flags & OPf_STACKED)
721 if (!(o->op_flags & OPf_KIDS))
730 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
737 /* all requires must return a boolean value */
738 o->op_flags &= ~OPf_WANT;
743 if ((kid = cLISTOPo->op_first) && kid->op_type == OP_PUSHRE) {
744 if (!kPMOP->op_pmreplroot)
745 deprecate_old("implicit split to @_");
749 if (useless && ckWARN(WARN_VOID))
750 Perl_warner(aTHX_ packWARN(WARN_VOID), "Useless use of %s in void context", useless);
755 Perl_listkids(pTHX_ OP *o)
758 if (o && o->op_flags & OPf_KIDS) {
759 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
766 Perl_list(pTHX_ OP *o)
770 /* assumes no premature commitment */
771 if (!o || (o->op_flags & OPf_WANT) || PL_error_count
772 || o->op_type == OP_RETURN)
777 if ((o->op_private & OPpTARGET_MY)
778 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
780 return o; /* As if inside SASSIGN */
783 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_LIST;
785 switch (o->op_type) {
788 list(cBINOPo->op_first);
793 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
801 if (!(o->op_flags & OPf_KIDS))
803 if (!o->op_next && cUNOPo->op_first->op_type == OP_FLOP) {
804 list(cBINOPo->op_first);
805 return gen_constant_list(o);
812 kid = cLISTOPo->op_first;
814 while ((kid = kid->op_sibling)) {
820 WITH_THR(PL_curcop = &PL_compiling);
824 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
830 WITH_THR(PL_curcop = &PL_compiling);
833 /* all requires must return a boolean value */
834 o->op_flags &= ~OPf_WANT;
841 Perl_scalarseq(pTHX_ OP *o)
846 if (o->op_type == OP_LINESEQ ||
847 o->op_type == OP_SCOPE ||
848 o->op_type == OP_LEAVE ||
849 o->op_type == OP_LEAVETRY)
851 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
852 if (kid->op_sibling) {
856 PL_curcop = &PL_compiling;
858 o->op_flags &= ~OPf_PARENS;
859 if (PL_hints & HINT_BLOCK_SCOPE)
860 o->op_flags |= OPf_PARENS;
863 o = newOP(OP_STUB, 0);
868 S_modkids(pTHX_ OP *o, I32 type)
871 if (o && o->op_flags & OPf_KIDS) {
872 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
879 Perl_mod(pTHX_ OP *o, I32 type)
883 if (!o || PL_error_count)
886 if ((o->op_private & OPpTARGET_MY)
887 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
892 switch (o->op_type) {
897 if (!(o->op_private & (OPpCONST_ARYBASE)))
899 if (PL_eval_start && PL_eval_start->op_type == OP_CONST) {
900 PL_compiling.cop_arybase = (I32)SvIV(cSVOPx(PL_eval_start)->op_sv);
904 SAVEI32(PL_compiling.cop_arybase);
905 PL_compiling.cop_arybase = 0;
907 else if (type == OP_REFGEN)
910 Perl_croak(aTHX_ "That use of $[ is unsupported");
913 if (o->op_flags & OPf_PARENS)
917 if ((type == OP_UNDEF || type == OP_REFGEN) &&
918 !(o->op_flags & OPf_STACKED)) {
919 o->op_type = OP_RV2CV; /* entersub => rv2cv */
920 o->op_ppaddr = PL_ppaddr[OP_RV2CV];
921 assert(cUNOPo->op_first->op_type == OP_NULL);
922 op_null(((LISTOP*)cUNOPo->op_first)->op_first);/* disable pushmark */
925 else if (o->op_private & OPpENTERSUB_NOMOD)
927 else { /* lvalue subroutine call */
928 o->op_private |= OPpLVAL_INTRO;
929 PL_modcount = RETURN_UNLIMITED_NUMBER;
930 if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN) {
931 /* Backward compatibility mode: */
932 o->op_private |= OPpENTERSUB_INARGS;
935 else { /* Compile-time error message: */
936 OP *kid = cUNOPo->op_first;
940 if (kid->op_type == OP_PUSHMARK)
942 if (kid->op_type != OP_NULL || kid->op_targ != OP_LIST)
944 "panic: unexpected lvalue entersub "
945 "args: type/targ %ld:%"UVuf,
946 (long)kid->op_type, (UV)kid->op_targ);
947 kid = kLISTOP->op_first;
949 while (kid->op_sibling)
950 kid = kid->op_sibling;
951 if (!(kid->op_type == OP_NULL && kid->op_targ == OP_RV2CV)) {
953 if (kid->op_type == OP_METHOD_NAMED
954 || kid->op_type == OP_METHOD)
958 NewOp(1101, newop, 1, UNOP);
959 newop->op_type = OP_RV2CV;
960 newop->op_ppaddr = PL_ppaddr[OP_RV2CV];
961 newop->op_first = Nullop;
962 newop->op_next = (OP*)newop;
963 kid->op_sibling = (OP*)newop;
964 newop->op_private |= OPpLVAL_INTRO;
968 if (kid->op_type != OP_RV2CV)
970 "panic: unexpected lvalue entersub "
971 "entry via type/targ %ld:%"UVuf,
972 (long)kid->op_type, (UV)kid->op_targ);
973 kid->op_private |= OPpLVAL_INTRO;
974 break; /* Postpone until runtime */
978 kid = kUNOP->op_first;
979 if (kid->op_type == OP_NULL && kid->op_targ == OP_RV2SV)
980 kid = kUNOP->op_first;
981 if (kid->op_type == OP_NULL)
983 "Unexpected constant lvalue entersub "
984 "entry via type/targ %ld:%"UVuf,
985 (long)kid->op_type, (UV)kid->op_targ);
986 if (kid->op_type != OP_GV) {
987 /* Restore RV2CV to check lvalueness */
989 if (kid->op_next && kid->op_next != kid) { /* Happens? */
990 okid->op_next = kid->op_next;
994 okid->op_next = Nullop;
995 okid->op_type = OP_RV2CV;
997 okid->op_ppaddr = PL_ppaddr[OP_RV2CV];
998 okid->op_private |= OPpLVAL_INTRO;
1002 cv = GvCV(kGVOP_gv);
1012 /* grep, foreach, subcalls, refgen */
1013 if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN)
1015 yyerror(Perl_form(aTHX_ "Can't modify %s in %s",
1016 (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)
1018 : (o->op_type == OP_ENTERSUB
1019 ? "non-lvalue subroutine call"
1021 type ? PL_op_desc[type] : "local"));
1035 case OP_RIGHT_SHIFT:
1044 if (!(o->op_flags & OPf_STACKED))
1050 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1056 if (type == OP_REFGEN && o->op_flags & OPf_PARENS) {
1057 PL_modcount = RETURN_UNLIMITED_NUMBER;
1058 return o; /* Treat \(@foo) like ordinary list. */
1062 if (scalar_mod_type(o, type))
1064 ref(cUNOPo->op_first, o->op_type);
1068 if (type == OP_LEAVESUBLV)
1069 o->op_private |= OPpMAYBE_LVSUB;
1074 PL_modcount = RETURN_UNLIMITED_NUMBER;
1077 ref(cUNOPo->op_first, o->op_type);
1081 PL_hints |= HINT_BLOCK_SCOPE;
1092 PL_modcount = RETURN_UNLIMITED_NUMBER;
1093 if (type == OP_REFGEN && o->op_flags & OPf_PARENS)
1094 return o; /* Treat \(@foo) like ordinary list. */
1095 if (scalar_mod_type(o, type))
1097 if (type == OP_LEAVESUBLV)
1098 o->op_private |= OPpMAYBE_LVSUB;
1103 { /* XXX DAPM 2002.08.25 tmp assert test */
1104 /* XXX */ assert(av_fetch(PL_comppad_name, (o->op_targ), FALSE));
1105 /* XXX */ assert(*av_fetch(PL_comppad_name, (o->op_targ), FALSE));
1107 Perl_croak(aTHX_ "Can't localize lexical variable %s",
1108 PAD_COMPNAME_PV(o->op_targ));
1116 if (type != OP_SASSIGN)
1120 if (o->op_private == 4) /* don't allow 4 arg substr as lvalue */
1125 if (type == OP_LEAVESUBLV)
1126 o->op_private |= OPpMAYBE_LVSUB;
1128 pad_free(o->op_targ);
1129 o->op_targ = pad_alloc(o->op_type, SVs_PADMY);
1130 assert(SvTYPE(PAD_SV(o->op_targ)) == SVt_NULL);
1131 if (o->op_flags & OPf_KIDS)
1132 mod(cBINOPo->op_first->op_sibling, type);
1137 ref(cBINOPo->op_first, o->op_type);
1138 if (type == OP_ENTERSUB &&
1139 !(o->op_private & (OPpLVAL_INTRO | OPpDEREF)))
1140 o->op_private |= OPpLVAL_DEFER;
1141 if (type == OP_LEAVESUBLV)
1142 o->op_private |= OPpMAYBE_LVSUB;
1150 if (o->op_flags & OPf_KIDS)
1151 mod(cLISTOPo->op_last, type);
1155 if (o->op_flags & OPf_SPECIAL) /* do BLOCK */
1157 else if (!(o->op_flags & OPf_KIDS))
1159 if (o->op_targ != OP_LIST) {
1160 mod(cBINOPo->op_first, type);
1165 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1170 if (type != OP_LEAVESUBLV)
1172 break; /* mod()ing was handled by ck_return() */
1175 /* [20011101.069] File test operators interpret OPf_REF to mean that
1176 their argument is a filehandle; thus \stat(".") should not set
1178 if (type == OP_REFGEN &&
1179 PL_check[o->op_type] == MEMBER_TO_FPTR(Perl_ck_ftst))
1182 if (type != OP_LEAVESUBLV)
1183 o->op_flags |= OPf_MOD;
1185 if (type == OP_AASSIGN || type == OP_SASSIGN)
1186 o->op_flags |= OPf_SPECIAL|OPf_REF;
1188 o->op_private |= OPpLVAL_INTRO;
1189 o->op_flags &= ~OPf_SPECIAL;
1190 PL_hints |= HINT_BLOCK_SCOPE;
1192 else if (type != OP_GREPSTART && type != OP_ENTERSUB
1193 && type != OP_LEAVESUBLV)
1194 o->op_flags |= OPf_REF;
1199 S_scalar_mod_type(pTHX_ OP *o, I32 type)
1203 if (o->op_type == OP_RV2GV)
1227 case OP_RIGHT_SHIFT:
1246 S_is_handle_constructor(pTHX_ OP *o, I32 argnum)
1248 switch (o->op_type) {
1256 case OP_SELECT: /* XXX c.f. SelectSaver.pm */
1269 Perl_refkids(pTHX_ OP *o, I32 type)
1272 if (o && o->op_flags & OPf_KIDS) {
1273 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1280 Perl_ref(pTHX_ OP *o, I32 type)
1284 if (!o || PL_error_count)
1287 switch (o->op_type) {
1289 if ((type == OP_EXISTS || type == OP_DEFINED || type == OP_LOCK) &&
1290 !(o->op_flags & OPf_STACKED)) {
1291 o->op_type = OP_RV2CV; /* entersub => rv2cv */
1292 o->op_ppaddr = PL_ppaddr[OP_RV2CV];
1293 assert(cUNOPo->op_first->op_type == OP_NULL);
1294 op_null(((LISTOP*)cUNOPo->op_first)->op_first); /* disable pushmark */
1295 o->op_flags |= OPf_SPECIAL;
1300 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1304 if (type == OP_DEFINED)
1305 o->op_flags |= OPf_SPECIAL; /* don't create GV */
1306 ref(cUNOPo->op_first, o->op_type);
1309 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
1310 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
1311 : type == OP_RV2HV ? OPpDEREF_HV
1313 o->op_flags |= OPf_MOD;
1318 o->op_flags |= OPf_MOD; /* XXX ??? */
1323 o->op_flags |= OPf_REF;
1326 if (type == OP_DEFINED)
1327 o->op_flags |= OPf_SPECIAL; /* don't create GV */
1328 ref(cUNOPo->op_first, o->op_type);
1333 o->op_flags |= OPf_REF;
1338 if (!(o->op_flags & OPf_KIDS))
1340 ref(cBINOPo->op_first, type);
1344 ref(cBINOPo->op_first, o->op_type);
1345 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
1346 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
1347 : type == OP_RV2HV ? OPpDEREF_HV
1349 o->op_flags |= OPf_MOD;
1357 if (!(o->op_flags & OPf_KIDS))
1359 ref(cLISTOPo->op_last, type);
1369 S_dup_attrlist(pTHX_ OP *o)
1373 /* An attrlist is either a simple OP_CONST or an OP_LIST with kids,
1374 * where the first kid is OP_PUSHMARK and the remaining ones
1375 * are OP_CONST. We need to push the OP_CONST values.
1377 if (o->op_type == OP_CONST)
1378 rop = newSVOP(OP_CONST, o->op_flags, SvREFCNT_inc(cSVOPo->op_sv));
1380 assert((o->op_type == OP_LIST) && (o->op_flags & OPf_KIDS));
1381 for (o = cLISTOPo->op_first; o; o=o->op_sibling) {
1382 if (o->op_type == OP_CONST)
1383 rop = append_elem(OP_LIST, rop,
1384 newSVOP(OP_CONST, o->op_flags,
1385 SvREFCNT_inc(cSVOPo->op_sv)));
1392 S_apply_attrs(pTHX_ HV *stash, SV *target, OP *attrs, bool for_my)
1396 /* fake up C<use attributes $pkg,$rv,@attrs> */
1397 ENTER; /* need to protect against side-effects of 'use' */
1400 stashsv = newSVpv(HvNAME(stash), 0);
1402 stashsv = &PL_sv_no;
1404 #define ATTRSMODULE "attributes"
1405 #define ATTRSMODULE_PM "attributes.pm"
1409 /* Don't force the C<use> if we don't need it. */
1410 svp = hv_fetch(GvHVn(PL_incgv), ATTRSMODULE_PM,
1411 sizeof(ATTRSMODULE_PM)-1, 0);
1412 if (svp && *svp != &PL_sv_undef)
1413 ; /* already in %INC */
1415 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
1416 newSVpvn(ATTRSMODULE, sizeof(ATTRSMODULE)-1),
1420 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
1421 newSVpvn(ATTRSMODULE, sizeof(ATTRSMODULE)-1),
1423 prepend_elem(OP_LIST,
1424 newSVOP(OP_CONST, 0, stashsv),
1425 prepend_elem(OP_LIST,
1426 newSVOP(OP_CONST, 0,
1428 dup_attrlist(attrs))));
1434 S_apply_attrs_my(pTHX_ HV *stash, OP *target, OP *attrs, OP **imopsp)
1436 OP *pack, *imop, *arg;
1442 assert(target->op_type == OP_PADSV ||
1443 target->op_type == OP_PADHV ||
1444 target->op_type == OP_PADAV);
1446 /* Ensure that attributes.pm is loaded. */
1447 apply_attrs(stash, PAD_SV(target->op_targ), attrs, TRUE);
1449 /* Need package name for method call. */
1450 pack = newSVOP(OP_CONST, 0, newSVpvn(ATTRSMODULE, sizeof(ATTRSMODULE)-1));
1452 /* Build up the real arg-list. */
1454 stashsv = newSVpv(HvNAME(stash), 0);
1456 stashsv = &PL_sv_no;
1457 arg = newOP(OP_PADSV, 0);
1458 arg->op_targ = target->op_targ;
1459 arg = prepend_elem(OP_LIST,
1460 newSVOP(OP_CONST, 0, stashsv),
1461 prepend_elem(OP_LIST,
1462 newUNOP(OP_REFGEN, 0,
1463 mod(arg, OP_REFGEN)),
1464 dup_attrlist(attrs)));
1466 /* Fake up a method call to import */
1467 meth = newSVpvn("import", 6);
1468 (void)SvUPGRADE(meth, SVt_PVIV);
1469 (void)SvIOK_on(meth);
1470 PERL_HASH(SvUVX(meth), SvPVX(meth), SvCUR(meth));
1471 imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL|OPf_WANT_VOID,
1472 append_elem(OP_LIST,
1473 prepend_elem(OP_LIST, pack, list(arg)),
1474 newSVOP(OP_METHOD_NAMED, 0, meth)));
1475 imop->op_private |= OPpENTERSUB_NOMOD;
1477 /* Combine the ops. */
1478 *imopsp = append_elem(OP_LIST, *imopsp, imop);
1482 =notfor apidoc apply_attrs_string
1484 Attempts to apply a list of attributes specified by the C<attrstr> and
1485 C<len> arguments to the subroutine identified by the C<cv> argument which
1486 is expected to be associated with the package identified by the C<stashpv>
1487 argument (see L<attributes>). It gets this wrong, though, in that it
1488 does not correctly identify the boundaries of the individual attribute
1489 specifications within C<attrstr>. This is not really intended for the
1490 public API, but has to be listed here for systems such as AIX which
1491 need an explicit export list for symbols. (It's called from XS code
1492 in support of the C<ATTRS:> keyword from F<xsubpp>.) Patches to fix it
1493 to respect attribute syntax properly would be welcome.
1499 Perl_apply_attrs_string(pTHX_ char *stashpv, CV *cv,
1500 char *attrstr, STRLEN len)
1505 len = strlen(attrstr);
1509 for (; isSPACE(*attrstr) && len; --len, ++attrstr) ;
1511 char *sstr = attrstr;
1512 for (; !isSPACE(*attrstr) && len; --len, ++attrstr) ;
1513 attrs = append_elem(OP_LIST, attrs,
1514 newSVOP(OP_CONST, 0,
1515 newSVpvn(sstr, attrstr-sstr)));
1519 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
1520 newSVpvn(ATTRSMODULE, sizeof(ATTRSMODULE)-1),
1521 Nullsv, prepend_elem(OP_LIST,
1522 newSVOP(OP_CONST, 0, newSVpv(stashpv,0)),
1523 prepend_elem(OP_LIST,
1524 newSVOP(OP_CONST, 0,
1530 S_my_kid(pTHX_ OP *o, OP *attrs, OP **imopsp)
1535 if (!o || PL_error_count)
1539 if (type == OP_LIST) {
1540 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1541 my_kid(kid, attrs, imopsp);
1542 } else if (type == OP_UNDEF) {
1544 } else if (type == OP_RV2SV || /* "our" declaration */
1546 type == OP_RV2HV) { /* XXX does this let anything illegal in? */
1547 if (cUNOPo->op_first->op_type != OP_GV) { /* MJD 20011224 */
1548 yyerror(Perl_form(aTHX_ "Can't declare %s in %s",
1549 OP_DESC(o), PL_in_my == KEY_our ? "our" : "my"));
1551 GV *gv = cGVOPx_gv(cUNOPo->op_first);
1553 PL_in_my_stash = Nullhv;
1554 apply_attrs(GvSTASH(gv),
1555 (type == OP_RV2SV ? GvSV(gv) :
1556 type == OP_RV2AV ? (SV*)GvAV(gv) :
1557 type == OP_RV2HV ? (SV*)GvHV(gv) : (SV*)gv),
1560 o->op_private |= OPpOUR_INTRO;
1563 else if (type != OP_PADSV &&
1566 type != OP_PUSHMARK)
1568 yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"",
1570 PL_in_my == KEY_our ? "our" : "my"));
1573 else if (attrs && type != OP_PUSHMARK) {
1577 PL_in_my_stash = Nullhv;
1579 /* check for C<my Dog $spot> when deciding package */
1580 stash = PAD_COMPNAME_TYPE(o->op_targ);
1582 stash = PL_curstash;
1583 apply_attrs_my(stash, o, attrs, imopsp);
1585 o->op_flags |= OPf_MOD;
1586 o->op_private |= OPpLVAL_INTRO;
1591 Perl_my_attrs(pTHX_ OP *o, OP *attrs)
1594 int maybe_scalar = 0;
1596 /* [perl #17376]: this appears to be premature, and results in code such as
1597 C< our(%x); > executing in list mode rather than void mode */
1599 if (o->op_flags & OPf_PARENS)
1608 o = my_kid(o, attrs, &rops);
1610 if (maybe_scalar && o->op_type == OP_PADSV) {
1611 o = scalar(append_list(OP_LIST, (LISTOP*)rops, (LISTOP*)o));
1612 o->op_private |= OPpLVAL_INTRO;
1615 o = append_list(OP_LIST, (LISTOP*)o, (LISTOP*)rops);
1618 PL_in_my_stash = Nullhv;
1623 Perl_my(pTHX_ OP *o)
1625 return my_attrs(o, Nullop);
1629 Perl_sawparens(pTHX_ OP *o)
1632 o->op_flags |= OPf_PARENS;
1637 Perl_bind_match(pTHX_ I32 type, OP *left, OP *right)
1641 if (ckWARN(WARN_MISC) &&
1642 (left->op_type == OP_RV2AV ||
1643 left->op_type == OP_RV2HV ||
1644 left->op_type == OP_PADAV ||
1645 left->op_type == OP_PADHV)) {
1646 char *desc = PL_op_desc[(right->op_type == OP_SUBST ||
1647 right->op_type == OP_TRANS)
1648 ? right->op_type : OP_MATCH];
1649 const char *sample = ((left->op_type == OP_RV2AV ||
1650 left->op_type == OP_PADAV)
1651 ? "@array" : "%hash");
1652 Perl_warner(aTHX_ packWARN(WARN_MISC),
1653 "Applying %s to %s will act on scalar(%s)",
1654 desc, sample, sample);
1657 if (right->op_type == OP_CONST &&
1658 cSVOPx(right)->op_private & OPpCONST_BARE &&
1659 cSVOPx(right)->op_private & OPpCONST_STRICT)
1661 no_bareword_allowed(right);
1664 if (!(right->op_flags & OPf_STACKED) &&
1665 (right->op_type == OP_MATCH ||
1666 right->op_type == OP_SUBST ||
1667 right->op_type == OP_TRANS)) {
1668 right->op_flags |= OPf_STACKED;
1669 if (right->op_type != OP_MATCH &&
1670 ! (right->op_type == OP_TRANS &&
1671 right->op_private & OPpTRANS_IDENTICAL))
1672 left = mod(left, right->op_type);
1673 if (right->op_type == OP_TRANS)
1674 o = newBINOP(OP_NULL, OPf_STACKED, scalar(left), right);
1676 o = prepend_elem(right->op_type, scalar(left), right);
1678 return newUNOP(OP_NOT, 0, scalar(o));
1682 return bind_match(type, left,
1683 pmruntime(newPMOP(OP_MATCH, 0), right, Nullop));
1687 Perl_invert(pTHX_ OP *o)
1691 /* XXX need to optimize away NOT NOT here? Or do we let optimizer do it? */
1692 return newUNOP(OP_NOT, OPf_SPECIAL, scalar(o));
1696 Perl_scope(pTHX_ OP *o)
1699 if (o->op_flags & OPf_PARENS || PERLDB_NOOPT || PL_tainting) {
1700 o = prepend_elem(OP_LINESEQ, newOP(OP_ENTER, 0), o);
1701 o->op_type = OP_LEAVE;
1702 o->op_ppaddr = PL_ppaddr[OP_LEAVE];
1704 else if (o->op_type == OP_LINESEQ) {
1706 o->op_type = OP_SCOPE;
1707 o->op_ppaddr = PL_ppaddr[OP_SCOPE];
1708 kid = ((LISTOP*)o)->op_first;
1709 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE)
1713 o = newLISTOP(OP_SCOPE, 0, o, Nullop);
1719 Perl_save_hints(pTHX)
1722 SAVESPTR(GvHV(PL_hintgv));
1723 GvHV(PL_hintgv) = newHVhv(GvHV(PL_hintgv));
1724 SAVEFREESV(GvHV(PL_hintgv));
1728 Perl_block_start(pTHX_ int full)
1730 int retval = PL_savestack_ix;
1731 /* If there were syntax errors, don't try to start a block */
1732 if (PL_yynerrs) return retval;
1734 pad_block_start(full);
1736 PL_hints &= ~HINT_BLOCK_SCOPE;
1737 SAVESPTR(PL_compiling.cop_warnings);
1738 if (! specialWARN(PL_compiling.cop_warnings)) {
1739 PL_compiling.cop_warnings = newSVsv(PL_compiling.cop_warnings) ;
1740 SAVEFREESV(PL_compiling.cop_warnings) ;
1742 SAVESPTR(PL_compiling.cop_io);
1743 if (! specialCopIO(PL_compiling.cop_io)) {
1744 PL_compiling.cop_io = newSVsv(PL_compiling.cop_io) ;
1745 SAVEFREESV(PL_compiling.cop_io) ;
1751 Perl_block_end(pTHX_ I32 floor, OP *seq)
1753 int needblockscope = PL_hints & HINT_BLOCK_SCOPE;
1754 OP* retval = scalarseq(seq);
1755 /* If there were syntax errors, don't try to close a block */
1756 if (PL_yynerrs) return retval;
1758 PL_compiling.op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
1760 PL_hints |= HINT_BLOCK_SCOPE; /* propagate out */
1768 return newSVREF(newGVOP(OP_GV, 0, PL_defgv));
1772 Perl_newPROG(pTHX_ OP *o)
1777 PL_eval_root = newUNOP(OP_LEAVEEVAL,
1778 ((PL_in_eval & EVAL_KEEPERR)
1779 ? OPf_SPECIAL : 0), o);
1780 PL_eval_start = linklist(PL_eval_root);
1781 PL_eval_root->op_private |= OPpREFCOUNTED;
1782 OpREFCNT_set(PL_eval_root, 1);
1783 PL_eval_root->op_next = 0;
1784 CALL_PEEP(PL_eval_start);
1789 PL_main_root = scope(sawparens(scalarvoid(o)));
1790 PL_curcop = &PL_compiling;
1791 PL_main_start = LINKLIST(PL_main_root);
1792 PL_main_root->op_private |= OPpREFCOUNTED;
1793 OpREFCNT_set(PL_main_root, 1);
1794 PL_main_root->op_next = 0;
1795 CALL_PEEP(PL_main_start);
1798 /* Register with debugger */
1800 CV *cv = get_cv("DB::postponed", FALSE);
1804 XPUSHs((SV*)CopFILEGV(&PL_compiling));
1806 call_sv((SV*)cv, G_DISCARD);
1813 Perl_localize(pTHX_ OP *o, I32 lex)
1815 if (o->op_flags & OPf_PARENS)
1816 /* [perl #17376]: this appears to be premature, and results in code such as
1817 C< our(%x); > executing in list mode rather than void mode */
1824 if (ckWARN(WARN_PARENTHESIS)
1825 && PL_bufptr > PL_oldbufptr && PL_bufptr[-1] == ',')
1827 char *s = PL_bufptr;
1829 while (*s && (isALNUM(*s) || UTF8_IS_CONTINUED(*s) || strchr("@$%, ", *s)))
1832 if (*s == ';' || *s == '=')
1833 Perl_warner(aTHX_ packWARN(WARN_PARENTHESIS),
1834 "Parentheses missing around \"%s\" list",
1835 lex ? (PL_in_my == KEY_our ? "our" : "my") : "local");
1841 o = mod(o, OP_NULL); /* a bit kludgey */
1843 PL_in_my_stash = Nullhv;
1848 Perl_jmaybe(pTHX_ OP *o)
1850 if (o->op_type == OP_LIST) {
1852 o2 = newSVREF(newGVOP(OP_GV, 0, gv_fetchpv(";", TRUE, SVt_PV))),
1853 o = convert(OP_JOIN, 0, prepend_elem(OP_LIST, o2, o));
1859 Perl_fold_constants(pTHX_ register OP *o)
1862 I32 type = o->op_type;
1865 if (PL_opargs[type] & OA_RETSCALAR)
1867 if (PL_opargs[type] & OA_TARGET && !o->op_targ)
1868 o->op_targ = pad_alloc(type, SVs_PADTMP);
1870 /* integerize op, unless it happens to be C<-foo>.
1871 * XXX should pp_i_negate() do magic string negation instead? */
1872 if ((PL_opargs[type] & OA_OTHERINT) && (PL_hints & HINT_INTEGER)
1873 && !(type == OP_NEGATE && cUNOPo->op_first->op_type == OP_CONST
1874 && (cUNOPo->op_first->op_private & OPpCONST_BARE)))
1876 o->op_ppaddr = PL_ppaddr[type = ++(o->op_type)];
1879 if (!(PL_opargs[type] & OA_FOLDCONST))
1884 /* XXX might want a ck_negate() for this */
1885 cUNOPo->op_first->op_private &= ~OPpCONST_STRICT;
1897 /* XXX what about the numeric ops? */
1898 if (PL_hints & HINT_LOCALE)
1903 goto nope; /* Don't try to run w/ errors */
1905 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
1906 if ((curop->op_type != OP_CONST ||
1907 (curop->op_private & OPpCONST_BARE)) &&
1908 curop->op_type != OP_LIST &&
1909 curop->op_type != OP_SCALAR &&
1910 curop->op_type != OP_NULL &&
1911 curop->op_type != OP_PUSHMARK)
1917 curop = LINKLIST(o);
1921 sv = *(PL_stack_sp--);
1922 if (o->op_targ && sv == PAD_SV(o->op_targ)) /* grab pad temp? */
1923 pad_swipe(o->op_targ, FALSE);
1924 else if (SvTEMP(sv)) { /* grab mortal temp? */
1925 (void)SvREFCNT_inc(sv);
1929 if (type == OP_RV2GV)
1930 return newGVOP(OP_GV, 0, (GV*)sv);
1931 return newSVOP(OP_CONST, 0, sv);
1938 Perl_gen_constant_list(pTHX_ register OP *o)
1941 I32 oldtmps_floor = PL_tmps_floor;
1945 return o; /* Don't attempt to run with errors */
1947 PL_op = curop = LINKLIST(o);
1954 PL_tmps_floor = oldtmps_floor;
1956 o->op_type = OP_RV2AV;
1957 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
1958 o->op_seq = 0; /* needs to be revisited in peep() */
1959 curop = ((UNOP*)o)->op_first;
1960 ((UNOP*)o)->op_first = newSVOP(OP_CONST, 0, SvREFCNT_inc(*PL_stack_sp--));
1967 Perl_convert(pTHX_ I32 type, I32 flags, OP *o)
1969 if (!o || o->op_type != OP_LIST)
1970 o = newLISTOP(OP_LIST, 0, o, Nullop);
1972 o->op_flags &= ~OPf_WANT;
1974 if (!(PL_opargs[type] & OA_MARK))
1975 op_null(cLISTOPo->op_first);
1977 o->op_type = (OPCODE)type;
1978 o->op_ppaddr = PL_ppaddr[type];
1979 o->op_flags |= flags;
1981 o = CHECKOP(type, o);
1982 if (o->op_type != type)
1985 return fold_constants(o);
1988 /* List constructors */
1991 Perl_append_elem(pTHX_ I32 type, OP *first, OP *last)
1999 if (first->op_type != type
2000 || (type == OP_LIST && (first->op_flags & OPf_PARENS)))
2002 return newLISTOP(type, 0, first, last);
2005 if (first->op_flags & OPf_KIDS)
2006 ((LISTOP*)first)->op_last->op_sibling = last;
2008 first->op_flags |= OPf_KIDS;
2009 ((LISTOP*)first)->op_first = last;
2011 ((LISTOP*)first)->op_last = last;
2016 Perl_append_list(pTHX_ I32 type, LISTOP *first, LISTOP *last)
2024 if (first->op_type != type)
2025 return prepend_elem(type, (OP*)first, (OP*)last);
2027 if (last->op_type != type)
2028 return append_elem(type, (OP*)first, (OP*)last);
2030 first->op_last->op_sibling = last->op_first;
2031 first->op_last = last->op_last;
2032 first->op_flags |= (last->op_flags & OPf_KIDS);
2040 Perl_prepend_elem(pTHX_ I32 type, OP *first, OP *last)
2048 if (last->op_type == type) {
2049 if (type == OP_LIST) { /* already a PUSHMARK there */
2050 first->op_sibling = ((LISTOP*)last)->op_first->op_sibling;
2051 ((LISTOP*)last)->op_first->op_sibling = first;
2052 if (!(first->op_flags & OPf_PARENS))
2053 last->op_flags &= ~OPf_PARENS;
2056 if (!(last->op_flags & OPf_KIDS)) {
2057 ((LISTOP*)last)->op_last = first;
2058 last->op_flags |= OPf_KIDS;
2060 first->op_sibling = ((LISTOP*)last)->op_first;
2061 ((LISTOP*)last)->op_first = first;
2063 last->op_flags |= OPf_KIDS;
2067 return newLISTOP(type, 0, first, last);
2073 Perl_newNULLLIST(pTHX)
2075 return newOP(OP_STUB, 0);
2079 Perl_force_list(pTHX_ OP *o)
2081 if (!o || o->op_type != OP_LIST)
2082 o = newLISTOP(OP_LIST, 0, o, Nullop);
2088 Perl_newLISTOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
2092 NewOp(1101, listop, 1, LISTOP);
2094 listop->op_type = (OPCODE)type;
2095 listop->op_ppaddr = PL_ppaddr[type];
2098 listop->op_flags = (U8)flags;
2102 else if (!first && last)
2105 first->op_sibling = last;
2106 listop->op_first = first;
2107 listop->op_last = last;
2108 if (type == OP_LIST) {
2110 pushop = newOP(OP_PUSHMARK, 0);
2111 pushop->op_sibling = first;
2112 listop->op_first = pushop;
2113 listop->op_flags |= OPf_KIDS;
2115 listop->op_last = pushop;
2122 Perl_newOP(pTHX_ I32 type, I32 flags)
2125 NewOp(1101, o, 1, OP);
2126 o->op_type = (OPCODE)type;
2127 o->op_ppaddr = PL_ppaddr[type];
2128 o->op_flags = (U8)flags;
2131 o->op_private = (U8)(0 | (flags >> 8));
2132 if (PL_opargs[type] & OA_RETSCALAR)
2134 if (PL_opargs[type] & OA_TARGET)
2135 o->op_targ = pad_alloc(type, SVs_PADTMP);
2136 return CHECKOP(type, o);
2140 Perl_newUNOP(pTHX_ I32 type, I32 flags, OP *first)
2145 first = newOP(OP_STUB, 0);
2146 if (PL_opargs[type] & OA_MARK)
2147 first = force_list(first);
2149 NewOp(1101, unop, 1, UNOP);
2150 unop->op_type = (OPCODE)type;
2151 unop->op_ppaddr = PL_ppaddr[type];
2152 unop->op_first = first;
2153 unop->op_flags = flags | OPf_KIDS;
2154 unop->op_private = (U8)(1 | (flags >> 8));
2155 unop = (UNOP*) CHECKOP(type, unop);
2159 return fold_constants((OP *) unop);
2163 Perl_newBINOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
2166 NewOp(1101, binop, 1, BINOP);
2169 first = newOP(OP_NULL, 0);
2171 binop->op_type = (OPCODE)type;
2172 binop->op_ppaddr = PL_ppaddr[type];
2173 binop->op_first = first;
2174 binop->op_flags = flags | OPf_KIDS;
2177 binop->op_private = (U8)(1 | (flags >> 8));
2180 binop->op_private = (U8)(2 | (flags >> 8));
2181 first->op_sibling = last;
2184 binop = (BINOP*)CHECKOP(type, binop);
2185 if (binop->op_next || binop->op_type != (OPCODE)type)
2188 binop->op_last = binop->op_first->op_sibling;
2190 return fold_constants((OP *)binop);
2194 uvcompare(const void *a, const void *b)
2196 if (*((UV *)a) < (*(UV *)b))
2198 if (*((UV *)a) > (*(UV *)b))
2200 if (*((UV *)a+1) < (*(UV *)b+1))
2202 if (*((UV *)a+1) > (*(UV *)b+1))
2208 Perl_pmtrans(pTHX_ OP *o, OP *expr, OP *repl)
2210 SV *tstr = ((SVOP*)expr)->op_sv;
2211 SV *rstr = ((SVOP*)repl)->op_sv;
2214 U8 *t = (U8*)SvPV(tstr, tlen);
2215 U8 *r = (U8*)SvPV(rstr, rlen);
2222 register short *tbl;
2224 PL_hints |= HINT_BLOCK_SCOPE;
2225 complement = o->op_private & OPpTRANS_COMPLEMENT;
2226 del = o->op_private & OPpTRANS_DELETE;
2227 squash = o->op_private & OPpTRANS_SQUASH;
2230 o->op_private |= OPpTRANS_FROM_UTF;
2233 o->op_private |= OPpTRANS_TO_UTF;
2235 if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
2236 SV* listsv = newSVpvn("# comment\n",10);
2238 U8* tend = t + tlen;
2239 U8* rend = r + rlen;
2253 I32 from_utf = o->op_private & OPpTRANS_FROM_UTF;
2254 I32 to_utf = o->op_private & OPpTRANS_TO_UTF;
2260 tsave = t = bytes_to_utf8(t, &len);
2263 if (!to_utf && rlen) {
2265 rsave = r = bytes_to_utf8(r, &len);
2269 /* There are several snags with this code on EBCDIC:
2270 1. 0xFF is a legal UTF-EBCDIC byte (there are no illegal bytes).
2271 2. scan_const() in toke.c has encoded chars in native encoding which makes
2272 ranges at least in EBCDIC 0..255 range the bottom odd.
2276 U8 tmpbuf[UTF8_MAXLEN+1];
2279 New(1109, cp, 2*tlen, UV);
2281 transv = newSVpvn("",0);
2283 cp[2*i] = utf8n_to_uvuni(t, tend-t, &ulen, 0);
2285 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) {
2287 cp[2*i+1] = utf8n_to_uvuni(t, tend-t, &ulen, 0);
2291 cp[2*i+1] = cp[2*i];
2295 qsort(cp, i, 2*sizeof(UV), uvcompare);
2296 for (j = 0; j < i; j++) {
2298 diff = val - nextmin;
2300 t = uvuni_to_utf8(tmpbuf,nextmin);
2301 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2303 U8 range_mark = UTF_TO_NATIVE(0xff);
2304 t = uvuni_to_utf8(tmpbuf, val - 1);
2305 sv_catpvn(transv, (char *)&range_mark, 1);
2306 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2313 t = uvuni_to_utf8(tmpbuf,nextmin);
2314 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2316 U8 range_mark = UTF_TO_NATIVE(0xff);
2317 sv_catpvn(transv, (char *)&range_mark, 1);
2319 t = uvuni_to_utf8_flags(tmpbuf, 0x7fffffff,
2320 UNICODE_ALLOW_SUPER);
2321 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2322 t = (U8*)SvPVX(transv);
2323 tlen = SvCUR(transv);
2327 else if (!rlen && !del) {
2328 r = t; rlen = tlen; rend = tend;
2331 if ((!rlen && !del) || t == r ||
2332 (tlen == rlen && memEQ((char *)t, (char *)r, tlen)))
2334 o->op_private |= OPpTRANS_IDENTICAL;
2338 while (t < tend || tfirst <= tlast) {
2339 /* see if we need more "t" chars */
2340 if (tfirst > tlast) {
2341 tfirst = (I32)utf8n_to_uvuni(t, tend - t, &ulen, 0);
2343 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) { /* illegal utf8 val indicates range */
2345 tlast = (I32)utf8n_to_uvuni(t, tend - t, &ulen, 0);
2352 /* now see if we need more "r" chars */
2353 if (rfirst > rlast) {
2355 rfirst = (I32)utf8n_to_uvuni(r, rend - r, &ulen, 0);
2357 if (r < rend && NATIVE_TO_UTF(*r) == 0xff) { /* illegal utf8 val indicates range */
2359 rlast = (I32)utf8n_to_uvuni(r, rend - r, &ulen, 0);
2368 rfirst = rlast = 0xffffffff;
2372 /* now see which range will peter our first, if either. */
2373 tdiff = tlast - tfirst;
2374 rdiff = rlast - rfirst;
2381 if (rfirst == 0xffffffff) {
2382 diff = tdiff; /* oops, pretend rdiff is infinite */
2384 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\tXXXX\n",
2385 (long)tfirst, (long)tlast);
2387 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\tXXXX\n", (long)tfirst);
2391 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\t%04lx\n",
2392 (long)tfirst, (long)(tfirst + diff),
2395 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\t%04lx\n",
2396 (long)tfirst, (long)rfirst);
2398 if (rfirst + diff > max)
2399 max = rfirst + diff;
2401 grows = (tfirst < rfirst &&
2402 UNISKIP(tfirst) < UNISKIP(rfirst + diff));
2414 else if (max > 0xff)
2419 Safefree(cPVOPo->op_pv);
2420 cSVOPo->op_sv = (SV*)swash_init("utf8", "", listsv, bits, none);
2421 SvREFCNT_dec(listsv);
2423 SvREFCNT_dec(transv);
2425 if (!del && havefinal && rlen)
2426 (void)hv_store((HV*)SvRV((cSVOPo->op_sv)), "FINAL", 5,
2427 newSVuv((UV)final), 0);
2430 o->op_private |= OPpTRANS_GROWS;
2442 tbl = (short*)cPVOPo->op_pv;
2444 Zero(tbl, 256, short);
2445 for (i = 0; i < (I32)tlen; i++)
2447 for (i = 0, j = 0; i < 256; i++) {
2449 if (j >= (I32)rlen) {
2458 if (i < 128 && r[j] >= 128)
2468 o->op_private |= OPpTRANS_IDENTICAL;
2470 else if (j >= (I32)rlen)
2473 cPVOPo->op_pv = (char*)Renew(tbl, 0x101+rlen-j, short);
2474 tbl[0x100] = rlen - j;
2475 for (i=0; i < (I32)rlen - j; i++)
2476 tbl[0x101+i] = r[j+i];
2480 if (!rlen && !del) {
2483 o->op_private |= OPpTRANS_IDENTICAL;
2485 else if (!squash && rlen == tlen && memEQ((char*)t, (char*)r, tlen)) {
2486 o->op_private |= OPpTRANS_IDENTICAL;
2488 for (i = 0; i < 256; i++)
2490 for (i = 0, j = 0; i < (I32)tlen; i++,j++) {
2491 if (j >= (I32)rlen) {
2493 if (tbl[t[i]] == -1)
2499 if (tbl[t[i]] == -1) {
2500 if (t[i] < 128 && r[j] >= 128)
2507 o->op_private |= OPpTRANS_GROWS;
2515 Perl_newPMOP(pTHX_ I32 type, I32 flags)
2519 NewOp(1101, pmop, 1, PMOP);
2520 pmop->op_type = (OPCODE)type;
2521 pmop->op_ppaddr = PL_ppaddr[type];
2522 pmop->op_flags = (U8)flags;
2523 pmop->op_private = (U8)(0 | (flags >> 8));
2525 if (PL_hints & HINT_RE_TAINT)
2526 pmop->op_pmpermflags |= PMf_RETAINT;
2527 if (PL_hints & HINT_LOCALE)
2528 pmop->op_pmpermflags |= PMf_LOCALE;
2529 pmop->op_pmflags = pmop->op_pmpermflags;
2534 if(av_len((AV*) PL_regex_pad[0]) > -1) {
2535 repointer = av_pop((AV*)PL_regex_pad[0]);
2536 pmop->op_pmoffset = SvIV(repointer);
2537 SvREPADTMP_off(repointer);
2538 sv_setiv(repointer,0);
2540 repointer = newSViv(0);
2541 av_push(PL_regex_padav,SvREFCNT_inc(repointer));
2542 pmop->op_pmoffset = av_len(PL_regex_padav);
2543 PL_regex_pad = AvARRAY(PL_regex_padav);
2548 /* link into pm list */
2549 if (type != OP_TRANS && PL_curstash) {
2550 pmop->op_pmnext = HvPMROOT(PL_curstash);
2551 HvPMROOT(PL_curstash) = pmop;
2552 PmopSTASH_set(pmop,PL_curstash);
2559 Perl_pmruntime(pTHX_ OP *o, OP *expr, OP *repl)
2563 I32 repl_has_vars = 0;
2565 if (o->op_type == OP_TRANS)
2566 return pmtrans(o, expr, repl);
2568 PL_hints |= HINT_BLOCK_SCOPE;
2571 if (expr->op_type == OP_CONST) {
2573 SV *pat = ((SVOP*)expr)->op_sv;
2574 char *p = SvPV(pat, plen);
2575 if ((o->op_flags & OPf_SPECIAL) && strEQ(p, " ")) {
2576 sv_setpvn(pat, "\\s+", 3);
2577 p = SvPV(pat, plen);
2578 pm->op_pmflags |= PMf_SKIPWHITE;
2581 pm->op_pmdynflags |= PMdf_UTF8;
2582 PM_SETRE(pm, CALLREGCOMP(aTHX_ p, p + plen, pm));
2583 if (strEQ("\\s+", PM_GETRE(pm)->precomp))
2584 pm->op_pmflags |= PMf_WHITE;
2588 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL))
2589 expr = newUNOP((!(PL_hints & HINT_RE_EVAL)
2591 : OP_REGCMAYBE),0,expr);
2593 NewOp(1101, rcop, 1, LOGOP);
2594 rcop->op_type = OP_REGCOMP;
2595 rcop->op_ppaddr = PL_ppaddr[OP_REGCOMP];
2596 rcop->op_first = scalar(expr);
2597 rcop->op_flags |= ((PL_hints & HINT_RE_EVAL)
2598 ? (OPf_SPECIAL | OPf_KIDS)
2600 rcop->op_private = 1;
2603 /* establish postfix order */
2604 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL)) {
2606 rcop->op_next = expr;
2607 ((UNOP*)expr)->op_first->op_next = (OP*)rcop;
2610 rcop->op_next = LINKLIST(expr);
2611 expr->op_next = (OP*)rcop;
2614 prepend_elem(o->op_type, scalar((OP*)rcop), o);
2619 if (pm->op_pmflags & PMf_EVAL) {
2621 if (CopLINE(PL_curcop) < PL_multi_end)
2622 CopLINE_set(PL_curcop, (line_t)PL_multi_end);
2624 else if (repl->op_type == OP_CONST)
2628 for (curop = LINKLIST(repl); curop!=repl; curop = LINKLIST(curop)) {
2629 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
2630 if (curop->op_type == OP_GV) {
2631 GV *gv = cGVOPx_gv(curop);
2633 if (strchr("&`'123456789+-\016\022", *GvENAME(gv)))
2636 else if (curop->op_type == OP_RV2CV)
2638 else if (curop->op_type == OP_RV2SV ||
2639 curop->op_type == OP_RV2AV ||
2640 curop->op_type == OP_RV2HV ||
2641 curop->op_type == OP_RV2GV) {
2642 if (lastop && lastop->op_type != OP_GV) /*funny deref?*/
2645 else if (curop->op_type == OP_PADSV ||
2646 curop->op_type == OP_PADAV ||
2647 curop->op_type == OP_PADHV ||
2648 curop->op_type == OP_PADANY) {
2651 else if (curop->op_type == OP_PUSHRE)
2652 ; /* Okay here, dangerous in newASSIGNOP */
2662 || PM_GETRE(pm)->reganch & ROPT_EVAL_SEEN))) {
2663 pm->op_pmflags |= PMf_CONST; /* const for long enough */
2664 pm->op_pmpermflags |= PMf_CONST; /* const for long enough */
2665 prepend_elem(o->op_type, scalar(repl), o);
2668 if (curop == repl && !PM_GETRE(pm)) { /* Has variables. */
2669 pm->op_pmflags |= PMf_MAYBE_CONST;
2670 pm->op_pmpermflags |= PMf_MAYBE_CONST;
2672 NewOp(1101, rcop, 1, LOGOP);
2673 rcop->op_type = OP_SUBSTCONT;
2674 rcop->op_ppaddr = PL_ppaddr[OP_SUBSTCONT];
2675 rcop->op_first = scalar(repl);
2676 rcop->op_flags |= OPf_KIDS;
2677 rcop->op_private = 1;
2680 /* establish postfix order */
2681 rcop->op_next = LINKLIST(repl);
2682 repl->op_next = (OP*)rcop;
2684 pm->op_pmreplroot = scalar((OP*)rcop);
2685 pm->op_pmreplstart = LINKLIST(rcop);
2694 Perl_newSVOP(pTHX_ I32 type, I32 flags, SV *sv)
2697 NewOp(1101, svop, 1, SVOP);
2698 svop->op_type = (OPCODE)type;
2699 svop->op_ppaddr = PL_ppaddr[type];
2701 svop->op_next = (OP*)svop;
2702 svop->op_flags = (U8)flags;
2703 if (PL_opargs[type] & OA_RETSCALAR)
2705 if (PL_opargs[type] & OA_TARGET)
2706 svop->op_targ = pad_alloc(type, SVs_PADTMP);
2707 return CHECKOP(type, svop);
2711 Perl_newPADOP(pTHX_ I32 type, I32 flags, SV *sv)
2714 NewOp(1101, padop, 1, PADOP);
2715 padop->op_type = (OPCODE)type;
2716 padop->op_ppaddr = PL_ppaddr[type];
2717 padop->op_padix = pad_alloc(type, SVs_PADTMP);
2718 SvREFCNT_dec(PAD_SVl(padop->op_padix));
2719 PAD_SETSV(padop->op_padix, sv);
2722 padop->op_next = (OP*)padop;
2723 padop->op_flags = (U8)flags;
2724 if (PL_opargs[type] & OA_RETSCALAR)
2726 if (PL_opargs[type] & OA_TARGET)
2727 padop->op_targ = pad_alloc(type, SVs_PADTMP);
2728 return CHECKOP(type, padop);
2732 Perl_newGVOP(pTHX_ I32 type, I32 flags, GV *gv)
2737 return newPADOP(type, flags, SvREFCNT_inc(gv));
2739 return newSVOP(type, flags, SvREFCNT_inc(gv));
2744 Perl_newPVOP(pTHX_ I32 type, I32 flags, char *pv)
2747 NewOp(1101, pvop, 1, PVOP);
2748 pvop->op_type = (OPCODE)type;
2749 pvop->op_ppaddr = PL_ppaddr[type];
2751 pvop->op_next = (OP*)pvop;
2752 pvop->op_flags = (U8)flags;
2753 if (PL_opargs[type] & OA_RETSCALAR)
2755 if (PL_opargs[type] & OA_TARGET)
2756 pvop->op_targ = pad_alloc(type, SVs_PADTMP);
2757 return CHECKOP(type, pvop);
2761 Perl_package(pTHX_ OP *o)
2766 save_hptr(&PL_curstash);
2767 save_item(PL_curstname);
2769 name = SvPV(cSVOPo->op_sv, len);
2770 PL_curstash = gv_stashpvn(name, len, TRUE);
2771 sv_setpvn(PL_curstname, name, len);
2774 PL_hints |= HINT_BLOCK_SCOPE;
2775 PL_copline = NOLINE;
2780 Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *id, OP *arg)
2786 if (id->op_type != OP_CONST)
2787 Perl_croak(aTHX_ "Module name must be constant");
2791 if (version != Nullop) {
2792 SV *vesv = ((SVOP*)version)->op_sv;
2794 if (arg == Nullop && !SvNIOKp(vesv)) {
2801 if (version->op_type != OP_CONST || !SvNIOKp(vesv))
2802 Perl_croak(aTHX_ "Version number must be constant number");
2804 /* Make copy of id so we don't free it twice */
2805 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)id)->op_sv));
2807 /* Fake up a method call to VERSION */
2808 meth = newSVpvn("VERSION",7);
2809 sv_upgrade(meth, SVt_PVIV);
2810 (void)SvIOK_on(meth);
2811 PERL_HASH(SvUVX(meth), SvPVX(meth), SvCUR(meth));
2812 veop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
2813 append_elem(OP_LIST,
2814 prepend_elem(OP_LIST, pack, list(version)),
2815 newSVOP(OP_METHOD_NAMED, 0, meth)));
2819 /* Fake up an import/unimport */
2820 if (arg && arg->op_type == OP_STUB)
2821 imop = arg; /* no import on explicit () */
2822 else if (SvNIOKp(((SVOP*)id)->op_sv)) {
2823 imop = Nullop; /* use 5.0; */
2828 /* Make copy of id so we don't free it twice */
2829 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)id)->op_sv));
2831 /* Fake up a method call to import/unimport */
2832 meth = aver ? newSVpvn("import",6) : newSVpvn("unimport", 8);
2833 (void)SvUPGRADE(meth, SVt_PVIV);
2834 (void)SvIOK_on(meth);
2835 PERL_HASH(SvUVX(meth), SvPVX(meth), SvCUR(meth));
2836 imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
2837 append_elem(OP_LIST,
2838 prepend_elem(OP_LIST, pack, list(arg)),
2839 newSVOP(OP_METHOD_NAMED, 0, meth)));
2842 /* Fake up the BEGIN {}, which does its thing immediately. */
2844 newSVOP(OP_CONST, 0, newSVpvn("BEGIN", 5)),
2847 append_elem(OP_LINESEQ,
2848 append_elem(OP_LINESEQ,
2849 newSTATEOP(0, Nullch, newUNOP(OP_REQUIRE, 0, id)),
2850 newSTATEOP(0, Nullch, veop)),
2851 newSTATEOP(0, Nullch, imop) ));
2853 /* The "did you use incorrect case?" warning used to be here.
2854 * The problem is that on case-insensitive filesystems one
2855 * might get false positives for "use" (and "require"):
2856 * "use Strict" or "require CARP" will work. This causes
2857 * portability problems for the script: in case-strict
2858 * filesystems the script will stop working.
2860 * The "incorrect case" warning checked whether "use Foo"
2861 * imported "Foo" to your namespace, but that is wrong, too:
2862 * there is no requirement nor promise in the language that
2863 * a Foo.pm should or would contain anything in package "Foo".
2865 * There is very little Configure-wise that can be done, either:
2866 * the case-sensitivity of the build filesystem of Perl does not
2867 * help in guessing the case-sensitivity of the runtime environment.
2870 PL_hints |= HINT_BLOCK_SCOPE;
2871 PL_copline = NOLINE;
2876 =head1 Embedding Functions
2878 =for apidoc load_module
2880 Loads the module whose name is pointed to by the string part of name.
2881 Note that the actual module name, not its filename, should be given.
2882 Eg, "Foo::Bar" instead of "Foo/Bar.pm". flags can be any of
2883 PERL_LOADMOD_DENY, PERL_LOADMOD_NOIMPORT, or PERL_LOADMOD_IMPORT_OPS
2884 (or 0 for no flags). ver, if specified, provides version semantics
2885 similar to C<use Foo::Bar VERSION>. The optional trailing SV*
2886 arguments can be used to specify arguments to the module's import()
2887 method, similar to C<use Foo::Bar VERSION LIST>.
2892 Perl_load_module(pTHX_ U32 flags, SV *name, SV *ver, ...)
2895 va_start(args, ver);
2896 vload_module(flags, name, ver, &args);
2900 #ifdef PERL_IMPLICIT_CONTEXT
2902 Perl_load_module_nocontext(U32 flags, SV *name, SV *ver, ...)
2906 va_start(args, ver);
2907 vload_module(flags, name, ver, &args);
2913 Perl_vload_module(pTHX_ U32 flags, SV *name, SV *ver, va_list *args)
2915 OP *modname, *veop, *imop;
2917 modname = newSVOP(OP_CONST, 0, name);
2918 modname->op_private |= OPpCONST_BARE;
2920 veop = newSVOP(OP_CONST, 0, ver);
2924 if (flags & PERL_LOADMOD_NOIMPORT) {
2925 imop = sawparens(newNULLLIST());
2927 else if (flags & PERL_LOADMOD_IMPORT_OPS) {
2928 imop = va_arg(*args, OP*);
2933 sv = va_arg(*args, SV*);
2935 imop = append_elem(OP_LIST, imop, newSVOP(OP_CONST, 0, sv));
2936 sv = va_arg(*args, SV*);
2940 line_t ocopline = PL_copline;
2941 COP *ocurcop = PL_curcop;
2942 int oexpect = PL_expect;
2944 utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(FALSE, 0),
2945 veop, modname, imop);
2946 PL_expect = oexpect;
2947 PL_copline = ocopline;
2948 PL_curcop = ocurcop;
2953 Perl_dofile(pTHX_ OP *term)
2958 gv = gv_fetchpv("do", FALSE, SVt_PVCV);
2959 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv)))
2960 gv = gv_fetchpv("CORE::GLOBAL::do", FALSE, SVt_PVCV);
2962 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
2963 doop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
2964 append_elem(OP_LIST, term,
2965 scalar(newUNOP(OP_RV2CV, 0,
2970 doop = newUNOP(OP_DOFILE, 0, scalar(term));
2976 Perl_newSLICEOP(pTHX_ I32 flags, OP *subscript, OP *listval)
2978 return newBINOP(OP_LSLICE, flags,
2979 list(force_list(subscript)),
2980 list(force_list(listval)) );
2984 S_list_assignment(pTHX_ register OP *o)
2989 if (o->op_type == OP_NULL && o->op_flags & OPf_KIDS)
2990 o = cUNOPo->op_first;
2992 if (o->op_type == OP_COND_EXPR) {
2993 I32 t = list_assignment(cLOGOPo->op_first->op_sibling);
2994 I32 f = list_assignment(cLOGOPo->op_first->op_sibling->op_sibling);
2999 yyerror("Assignment to both a list and a scalar");
3003 if (o->op_type == OP_LIST &&
3004 (o->op_flags & OPf_WANT) == OPf_WANT_SCALAR &&
3005 o->op_private & OPpLVAL_INTRO)
3008 if (o->op_type == OP_LIST || o->op_flags & OPf_PARENS ||
3009 o->op_type == OP_RV2AV || o->op_type == OP_RV2HV ||
3010 o->op_type == OP_ASLICE || o->op_type == OP_HSLICE)
3013 if (o->op_type == OP_PADAV || o->op_type == OP_PADHV)
3016 if (o->op_type == OP_RV2SV)
3023 Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right)
3028 if (optype == OP_ANDASSIGN || optype == OP_ORASSIGN || optype == OP_DORASSIGN) {
3029 return newLOGOP(optype, 0,
3030 mod(scalar(left), optype),
3031 newUNOP(OP_SASSIGN, 0, scalar(right)));
3034 return newBINOP(optype, OPf_STACKED,
3035 mod(scalar(left), optype), scalar(right));
3039 if (list_assignment(left)) {
3043 PL_eval_start = right; /* Grandfathering $[ assignment here. Bletch.*/
3044 left = mod(left, OP_AASSIGN);
3052 curop = list(force_list(left));
3053 o = newBINOP(OP_AASSIGN, flags, list(force_list(right)), curop);
3054 o->op_private = (U8)(0 | (flags >> 8));
3056 /* PL_generation sorcery:
3057 * an assignment like ($a,$b) = ($c,$d) is easier than
3058 * ($a,$b) = ($c,$a), since there is no need for temporary vars.
3059 * To detect whether there are common vars, the global var
3060 * PL_generation is incremented for each assign op we compile.
3061 * Then, while compiling the assign op, we run through all the
3062 * variables on both sides of the assignment, setting a spare slot
3063 * in each of them to PL_generation. If any of them already have
3064 * that value, we know we've got commonality. We could use a
3065 * single bit marker, but then we'd have to make 2 passes, first
3066 * to clear the flag, then to test and set it. To find somewhere
3067 * to store these values, evil chicanery is done with SvCUR().
3070 if (!(left->op_private & OPpLVAL_INTRO)) {
3073 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
3074 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
3075 if (curop->op_type == OP_GV) {
3076 GV *gv = cGVOPx_gv(curop);
3077 if (gv == PL_defgv || (int)SvCUR(gv) == PL_generation)
3079 SvCUR(gv) = PL_generation;
3081 else if (curop->op_type == OP_PADSV ||
3082 curop->op_type == OP_PADAV ||
3083 curop->op_type == OP_PADHV ||
3084 curop->op_type == OP_PADANY)
3086 if (PAD_COMPNAME_GEN(curop->op_targ)
3087 == (STRLEN)PL_generation)
3089 PAD_COMPNAME_GEN(curop->op_targ)
3093 else if (curop->op_type == OP_RV2CV)
3095 else if (curop->op_type == OP_RV2SV ||
3096 curop->op_type == OP_RV2AV ||
3097 curop->op_type == OP_RV2HV ||
3098 curop->op_type == OP_RV2GV) {
3099 if (lastop->op_type != OP_GV) /* funny deref? */
3102 else if (curop->op_type == OP_PUSHRE) {
3103 if (((PMOP*)curop)->op_pmreplroot) {
3105 GV *gv = (GV*)PAD_SVl(INT2PTR(PADOFFSET,
3106 ((PMOP*)curop)->op_pmreplroot));
3108 GV *gv = (GV*)((PMOP*)curop)->op_pmreplroot;
3110 if (gv == PL_defgv || (int)SvCUR(gv) == PL_generation)
3112 SvCUR(gv) = PL_generation;
3121 o->op_private |= OPpASSIGN_COMMON;
3123 if (right && right->op_type == OP_SPLIT) {
3125 if ((tmpop = ((LISTOP*)right)->op_first) &&
3126 tmpop->op_type == OP_PUSHRE)
3128 PMOP *pm = (PMOP*)tmpop;
3129 if (left->op_type == OP_RV2AV &&
3130 !(left->op_private & OPpLVAL_INTRO) &&
3131 !(o->op_private & OPpASSIGN_COMMON) )
3133 tmpop = ((UNOP*)left)->op_first;
3134 if (tmpop->op_type == OP_GV && !pm->op_pmreplroot) {
3136 pm->op_pmreplroot = INT2PTR(OP*, cPADOPx(tmpop)->op_padix);
3137 cPADOPx(tmpop)->op_padix = 0; /* steal it */
3139 pm->op_pmreplroot = (OP*)cSVOPx(tmpop)->op_sv;
3140 cSVOPx(tmpop)->op_sv = Nullsv; /* steal it */
3142 pm->op_pmflags |= PMf_ONCE;
3143 tmpop = cUNOPo->op_first; /* to list (nulled) */
3144 tmpop = ((UNOP*)tmpop)->op_first; /* to pushmark */
3145 tmpop->op_sibling = Nullop; /* don't free split */
3146 right->op_next = tmpop->op_next; /* fix starting loc */
3147 op_free(o); /* blow off assign */
3148 right->op_flags &= ~OPf_WANT;
3149 /* "I don't know and I don't care." */
3154 if (PL_modcount < RETURN_UNLIMITED_NUMBER &&
3155 ((LISTOP*)right)->op_last->op_type == OP_CONST)
3157 SV *sv = ((SVOP*)((LISTOP*)right)->op_last)->op_sv;
3159 sv_setiv(sv, PL_modcount+1);
3167 right = newOP(OP_UNDEF, 0);
3168 if (right->op_type == OP_READLINE) {
3169 right->op_flags |= OPf_STACKED;
3170 return newBINOP(OP_NULL, flags, mod(scalar(left), OP_SASSIGN), scalar(right));
3173 PL_eval_start = right; /* Grandfathering $[ assignment here. Bletch.*/
3174 o = newBINOP(OP_SASSIGN, flags,
3175 scalar(right), mod(scalar(left), OP_SASSIGN) );
3187 Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o)
3189 U32 seq = intro_my();
3192 NewOp(1101, cop, 1, COP);
3193 if (PERLDB_LINE && CopLINE(PL_curcop) && PL_curstash != PL_debstash) {
3194 cop->op_type = OP_DBSTATE;
3195 cop->op_ppaddr = PL_ppaddr[ OP_DBSTATE ];
3198 cop->op_type = OP_NEXTSTATE;
3199 cop->op_ppaddr = PL_ppaddr[ OP_NEXTSTATE ];
3201 cop->op_flags = (U8)flags;
3202 cop->op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
3204 cop->op_private |= NATIVE_HINTS;
3206 PL_compiling.op_private = cop->op_private;
3207 cop->op_next = (OP*)cop;
3210 cop->cop_label = label;
3211 PL_hints |= HINT_BLOCK_SCOPE;
3214 cop->cop_arybase = PL_curcop->cop_arybase;
3215 if (specialWARN(PL_curcop->cop_warnings))
3216 cop->cop_warnings = PL_curcop->cop_warnings ;
3218 cop->cop_warnings = newSVsv(PL_curcop->cop_warnings) ;
3219 if (specialCopIO(PL_curcop->cop_io))
3220 cop->cop_io = PL_curcop->cop_io;
3222 cop->cop_io = newSVsv(PL_curcop->cop_io) ;
3225 if (PL_copline == NOLINE)
3226 CopLINE_set(cop, CopLINE(PL_curcop));
3228 CopLINE_set(cop, PL_copline);
3229 PL_copline = NOLINE;
3232 CopFILE_set(cop, CopFILE(PL_curcop)); /* XXX share in a pvtable? */
3234 CopFILEGV_set(cop, CopFILEGV(PL_curcop));
3236 CopSTASH_set(cop, PL_curstash);
3238 if (PERLDB_LINE && PL_curstash != PL_debstash) {
3239 SV **svp = av_fetch(CopFILEAV(PL_curcop), (I32)CopLINE(cop), FALSE);
3240 if (svp && *svp != &PL_sv_undef ) {
3241 (void)SvIOK_on(*svp);
3242 SvIVX(*svp) = PTR2IV(cop);
3246 return prepend_elem(OP_LINESEQ, (OP*)cop, o);
3251 Perl_newLOGOP(pTHX_ I32 type, I32 flags, OP *first, OP *other)
3253 return new_logop(type, flags, &first, &other);
3257 S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp)
3261 OP *first = *firstp;
3262 OP *other = *otherp;
3264 if (type == OP_XOR) /* Not short circuit, but here by precedence. */
3265 return newBINOP(type, flags, scalar(first), scalar(other));
3267 scalarboolean(first);
3268 /* optimize "!a && b" to "a || b", and "!a || b" to "a && b" */
3269 if (first->op_type == OP_NOT && (first->op_flags & OPf_SPECIAL)) {
3270 if (type == OP_AND || type == OP_OR) {
3276 first = *firstp = cUNOPo->op_first;
3278 first->op_next = o->op_next;
3279 cUNOPo->op_first = Nullop;
3283 if (first->op_type == OP_CONST) {
3284 if (ckWARN(WARN_BAREWORD) && (first->op_private & OPpCONST_BARE)) {
3285 if (first->op_private & OPpCONST_STRICT)
3286 no_bareword_allowed(first);
3288 Perl_warner(aTHX_ packWARN(WARN_BAREWORD), "Bareword found in conditional");
3290 if ((type == OP_AND) == (SvTRUE(((SVOP*)first)->op_sv))) {
3301 else if (ckWARN(WARN_MISC) && (first->op_flags & OPf_KIDS)) {
3302 OP *k1 = ((UNOP*)first)->op_first;
3303 OP *k2 = k1->op_sibling;
3305 switch (first->op_type)
3308 if (k2 && k2->op_type == OP_READLINE
3309 && (k2->op_flags & OPf_STACKED)
3310 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
3312 warnop = k2->op_type;
3317 if (k1->op_type == OP_READDIR
3318 || k1->op_type == OP_GLOB
3319 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
3320 || k1->op_type == OP_EACH)
3322 warnop = ((k1->op_type == OP_NULL)
3323 ? (OPCODE)k1->op_targ : k1->op_type);
3328 line_t oldline = CopLINE(PL_curcop);
3329 CopLINE_set(PL_curcop, PL_copline);
3330 Perl_warner(aTHX_ packWARN(WARN_MISC),
3331 "Value of %s%s can be \"0\"; test with defined()",
3333 ((warnop == OP_READLINE || warnop == OP_GLOB)
3334 ? " construct" : "() operator"));
3335 CopLINE_set(PL_curcop, oldline);
3342 if (type == OP_ANDASSIGN || type == OP_ORASSIGN || type == OP_DORASSIGN)
3343 other->op_private |= OPpASSIGN_BACKWARDS; /* other is an OP_SASSIGN */
3345 NewOp(1101, logop, 1, LOGOP);
3347 logop->op_type = (OPCODE)type;
3348 logop->op_ppaddr = PL_ppaddr[type];
3349 logop->op_first = first;
3350 logop->op_flags = flags | OPf_KIDS;
3351 logop->op_other = LINKLIST(other);
3352 logop->op_private = (U8)(1 | (flags >> 8));
3354 /* establish postfix order */
3355 logop->op_next = LINKLIST(first);
3356 first->op_next = (OP*)logop;
3357 first->op_sibling = other;
3359 o = newUNOP(OP_NULL, 0, (OP*)logop);
3366 Perl_newCONDOP(pTHX_ I32 flags, OP *first, OP *trueop, OP *falseop)
3373 return newLOGOP(OP_AND, 0, first, trueop);
3375 return newLOGOP(OP_OR, 0, first, falseop);
3377 scalarboolean(first);
3378 if (first->op_type == OP_CONST) {
3379 if (first->op_private & OPpCONST_BARE &&
3380 first->op_private & OPpCONST_STRICT) {
3381 no_bareword_allowed(first);
3383 if (SvTRUE(((SVOP*)first)->op_sv)) {
3394 NewOp(1101, logop, 1, LOGOP);
3395 logop->op_type = OP_COND_EXPR;
3396 logop->op_ppaddr = PL_ppaddr[OP_COND_EXPR];
3397 logop->op_first = first;
3398 logop->op_flags = flags | OPf_KIDS;
3399 logop->op_private = (U8)(1 | (flags >> 8));
3400 logop->op_other = LINKLIST(trueop);
3401 logop->op_next = LINKLIST(falseop);
3404 /* establish postfix order */
3405 start = LINKLIST(first);
3406 first->op_next = (OP*)logop;
3408 first->op_sibling = trueop;
3409 trueop->op_sibling = falseop;
3410 o = newUNOP(OP_NULL, 0, (OP*)logop);
3412 trueop->op_next = falseop->op_next = o;
3419 Perl_newRANGE(pTHX_ I32 flags, OP *left, OP *right)
3427 NewOp(1101, range, 1, LOGOP);
3429 range->op_type = OP_RANGE;
3430 range->op_ppaddr = PL_ppaddr[OP_RANGE];
3431 range->op_first = left;
3432 range->op_flags = OPf_KIDS;
3433 leftstart = LINKLIST(left);
3434 range->op_other = LINKLIST(right);
3435 range->op_private = (U8)(1 | (flags >> 8));
3437 left->op_sibling = right;
3439 range->op_next = (OP*)range;
3440 flip = newUNOP(OP_FLIP, flags, (OP*)range);
3441 flop = newUNOP(OP_FLOP, 0, flip);
3442 o = newUNOP(OP_NULL, 0, flop);
3444 range->op_next = leftstart;
3446 left->op_next = flip;
3447 right->op_next = flop;
3449 range->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
3450 sv_upgrade(PAD_SV(range->op_targ), SVt_PVNV);
3451 flip->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
3452 sv_upgrade(PAD_SV(flip->op_targ), SVt_PVNV);
3454 flip->op_private = left->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
3455 flop->op_private = right->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
3458 if (!flip->op_private || !flop->op_private)
3459 linklist(o); /* blow off optimizer unless constant */
3465 Perl_newLOOPOP(pTHX_ I32 flags, I32 debuggable, OP *expr, OP *block)
3469 int once = block && block->op_flags & OPf_SPECIAL &&
3470 (block->op_type == OP_ENTERSUB || block->op_type == OP_NULL);
3473 if (once && expr->op_type == OP_CONST && !SvTRUE(((SVOP*)expr)->op_sv))
3474 return block; /* do {} while 0 does once */
3475 if (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
3476 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
3477 expr = newUNOP(OP_DEFINED, 0,
3478 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
3479 } else if (expr->op_flags & OPf_KIDS) {
3480 OP *k1 = ((UNOP*)expr)->op_first;
3481 OP *k2 = (k1) ? k1->op_sibling : NULL;
3482 switch (expr->op_type) {
3484 if (k2 && k2->op_type == OP_READLINE
3485 && (k2->op_flags & OPf_STACKED)
3486 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
3487 expr = newUNOP(OP_DEFINED, 0, expr);
3491 if (k1->op_type == OP_READDIR
3492 || k1->op_type == OP_GLOB
3493 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
3494 || k1->op_type == OP_EACH)
3495 expr = newUNOP(OP_DEFINED, 0, expr);
3501 listop = append_elem(OP_LINESEQ, block, newOP(OP_UNSTACK, 0));
3502 o = new_logop(OP_AND, 0, &expr, &listop);
3505 ((LISTOP*)listop)->op_last->op_next = LINKLIST(o);
3507 if (once && o != listop)
3508 o->op_next = ((LOGOP*)cUNOPo->op_first)->op_other;
3511 o = newUNOP(OP_NULL, 0, o); /* or do {} while 1 loses outer block */
3513 o->op_flags |= flags;
3515 o->op_flags |= OPf_SPECIAL; /* suppress POPBLOCK curpm restoration*/
3520 Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP *loop, I32 whileline, OP *expr, OP *block, OP *cont)
3528 if (expr && (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
3529 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB))) {
3530 expr = newUNOP(OP_DEFINED, 0,
3531 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
3532 } else if (expr && (expr->op_flags & OPf_KIDS)) {
3533 OP *k1 = ((UNOP*)expr)->op_first;
3534 OP *k2 = (k1) ? k1->op_sibling : NULL;
3535 switch (expr->op_type) {
3537 if (k2 && k2->op_type == OP_READLINE
3538 && (k2->op_flags & OPf_STACKED)
3539 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
3540 expr = newUNOP(OP_DEFINED, 0, expr);
3544 if (k1->op_type == OP_READDIR
3545 || k1->op_type == OP_GLOB
3546 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
3547 || k1->op_type == OP_EACH)
3548 expr = newUNOP(OP_DEFINED, 0, expr);
3554 block = newOP(OP_NULL, 0);
3556 block = scope(block);
3560 next = LINKLIST(cont);
3563 OP *unstack = newOP(OP_UNSTACK, 0);
3566 cont = append_elem(OP_LINESEQ, cont, unstack);
3567 if ((line_t)whileline != NOLINE) {
3568 PL_copline = (line_t)whileline;
3569 cont = append_elem(OP_LINESEQ, cont,
3570 newSTATEOP(0, Nullch, Nullop));
3574 listop = append_list(OP_LINESEQ, (LISTOP*)block, (LISTOP*)cont);
3575 redo = LINKLIST(listop);
3578 PL_copline = (line_t)whileline;
3580 o = new_logop(OP_AND, 0, &expr, &listop);
3581 if (o == expr && o->op_type == OP_CONST && !SvTRUE(cSVOPo->op_sv)) {
3582 op_free(expr); /* oops, it's a while (0) */
3584 return Nullop; /* listop already freed by new_logop */
3587 ((LISTOP*)listop)->op_last->op_next =
3588 (o == listop ? redo : LINKLIST(o));
3594 NewOp(1101,loop,1,LOOP);
3595 loop->op_type = OP_ENTERLOOP;
3596 loop->op_ppaddr = PL_ppaddr[OP_ENTERLOOP];
3597 loop->op_private = 0;
3598 loop->op_next = (OP*)loop;
3601 o = newBINOP(OP_LEAVELOOP, 0, (OP*)loop, o);
3603 loop->op_redoop = redo;
3604 loop->op_lastop = o;
3605 o->op_private |= loopflags;
3608 loop->op_nextop = next;
3610 loop->op_nextop = o;
3612 o->op_flags |= flags;
3613 o->op_private |= (flags >> 8);
3618 Perl_newFOROP(pTHX_ I32 flags,char *label,line_t forline,OP *sv,OP *expr,OP *block,OP *cont)
3622 PADOFFSET padoff = 0;
3626 if (sv->op_type == OP_RV2SV) { /* symbol table variable */
3627 sv->op_type = OP_RV2GV;
3628 sv->op_ppaddr = PL_ppaddr[OP_RV2GV];
3630 else if (sv->op_type == OP_PADSV) { /* private variable */
3631 padoff = sv->op_targ;
3636 else if (sv->op_type == OP_THREADSV) { /* per-thread variable */
3637 padoff = sv->op_targ;
3639 iterflags |= OPf_SPECIAL;
3644 Perl_croak(aTHX_ "Can't use %s for loop variable", PL_op_desc[sv->op_type]);
3647 sv = newGVOP(OP_GV, 0, PL_defgv);
3649 if (expr->op_type == OP_RV2AV || expr->op_type == OP_PADAV) {
3650 expr = mod(force_list(scalar(ref(expr, OP_ITER))), OP_GREPSTART);
3651 iterflags |= OPf_STACKED;
3653 else if (expr->op_type == OP_NULL &&
3654 (expr->op_flags & OPf_KIDS) &&
3655 ((BINOP*)expr)->op_first->op_type == OP_FLOP)
3657 /* Basically turn for($x..$y) into the same as for($x,$y), but we
3658 * set the STACKED flag to indicate that these values are to be
3659 * treated as min/max values by 'pp_iterinit'.
3661 UNOP* flip = (UNOP*)((UNOP*)((BINOP*)expr)->op_first)->op_first;
3662 LOGOP* range = (LOGOP*) flip->op_first;
3663 OP* left = range->op_first;
3664 OP* right = left->op_sibling;
3667 range->op_flags &= ~OPf_KIDS;
3668 range->op_first = Nullop;
3670 listop = (LISTOP*)newLISTOP(OP_LIST, 0, left, right);
3671 listop->op_first->op_next = range->op_next;
3672 left->op_next = range->op_other;
3673 right->op_next = (OP*)listop;
3674 listop->op_next = listop->op_first;
3677 expr = (OP*)(listop);
3679 iterflags |= OPf_STACKED;
3682 expr = mod(force_list(expr), OP_GREPSTART);
3686 loop = (LOOP*)list(convert(OP_ENTERITER, iterflags,
3687 append_elem(OP_LIST, expr, scalar(sv))));
3688 assert(!loop->op_next);
3689 #ifdef PL_OP_SLAB_ALLOC
3692 NewOp(1234,tmp,1,LOOP);
3693 Copy(loop,tmp,1,LOOP);
3698 Renew(loop, 1, LOOP);
3700 loop->op_targ = padoff;
3701 wop = newWHILEOP(flags, 1, loop, forline, newOP(OP_ITER, 0), block, cont);
3702 PL_copline = forline;
3703 return newSTATEOP(0, label, wop);
3707 Perl_newLOOPEX(pTHX_ I32 type, OP *label)
3712 if (type != OP_GOTO || label->op_type == OP_CONST) {
3713 /* "last()" means "last" */
3714 if (label->op_type == OP_STUB && (label->op_flags & OPf_PARENS))
3715 o = newOP(type, OPf_SPECIAL);
3717 o = newPVOP(type, 0, savepv(label->op_type == OP_CONST
3718 ? SvPVx(((SVOP*)label)->op_sv, n_a)
3724 if (label->op_type == OP_ENTERSUB)
3725 label = newUNOP(OP_REFGEN, 0, mod(label, OP_REFGEN));
3726 o = newUNOP(type, OPf_STACKED, label);
3728 PL_hints |= HINT_BLOCK_SCOPE;
3733 =for apidoc cv_undef
3735 Clear out all the active components of a CV. This can happen either
3736 by an explicit C<undef &foo>, or by the reference count going to zero.
3737 In the former case, we keep the CvOUTSIDE pointer, so that any anonymous
3738 children can still follow the full lexical scope chain.
3744 Perl_cv_undef(pTHX_ CV *cv)
3747 if (CvFILE(cv) && !CvXSUB(cv)) {
3748 /* for XSUBs CvFILE point directly to static memory; __FILE__ */
3749 Safefree(CvFILE(cv));
3754 if (!CvXSUB(cv) && CvROOT(cv)) {
3756 Perl_croak(aTHX_ "Can't undef active subroutine");
3759 PAD_SAVE_SETNULLPAD();
3761 op_free(CvROOT(cv));
3762 CvROOT(cv) = Nullop;
3765 SvPOK_off((SV*)cv); /* forget prototype */
3770 /* remove CvOUTSIDE unless this is an undef rather than a free */
3771 if (!SvREFCNT(cv) && CvOUTSIDE(cv)) {
3772 if (!CvWEAKOUTSIDE(cv))
3773 SvREFCNT_dec(CvOUTSIDE(cv));
3774 CvOUTSIDE(cv) = Nullcv;
3777 SvREFCNT_dec((SV*)CvXSUBANY(cv).any_ptr);
3783 /* delete all flags except WEAKOUTSIDE */
3784 CvFLAGS(cv) &= CVf_WEAKOUTSIDE;
3788 Perl_cv_ckproto(pTHX_ CV *cv, GV *gv, char *p)
3790 if (((!p != !SvPOK(cv)) || (p && strNE(p, SvPVX(cv)))) && ckWARN_d(WARN_PROTOTYPE)) {
3791 SV* msg = sv_newmortal();
3795 gv_efullname3(name = sv_newmortal(), gv, Nullch);
3796 sv_setpv(msg, "Prototype mismatch:");
3798 Perl_sv_catpvf(aTHX_ msg, " sub %"SVf, name);
3800 Perl_sv_catpvf(aTHX_ msg, " (%"SVf")", (SV *)cv);
3801 sv_catpv(msg, " vs ");
3803 Perl_sv_catpvf(aTHX_ msg, "(%s)", p);
3805 sv_catpv(msg, "none");
3806 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "%"SVf, msg);
3810 static void const_sv_xsub(pTHX_ CV* cv);
3814 =head1 Optree Manipulation Functions
3816 =for apidoc cv_const_sv
3818 If C<cv> is a constant sub eligible for inlining. returns the constant
3819 value returned by the sub. Otherwise, returns NULL.
3821 Constant subs can be created with C<newCONSTSUB> or as described in
3822 L<perlsub/"Constant Functions">.
3827 Perl_cv_const_sv(pTHX_ CV *cv)
3829 if (!cv || !CvCONST(cv))
3831 return (SV*)CvXSUBANY(cv).any_ptr;
3835 Perl_op_const_sv(pTHX_ OP *o, CV *cv)
3842 if (o->op_type == OP_LINESEQ && cLISTOPo->op_first)
3843 o = cLISTOPo->op_first->op_sibling;
3845 for (; o; o = o->op_next) {
3846 OPCODE type = o->op_type;
3848 if (sv && o->op_next == o)
3850 if (o->op_next != o) {
3851 if (type == OP_NEXTSTATE || type == OP_NULL || type == OP_PUSHMARK)
3853 if (type == OP_DBSTATE)
3856 if (type == OP_LEAVESUB || type == OP_RETURN)
3860 if (type == OP_CONST && cSVOPo->op_sv)
3862 else if ((type == OP_PADSV || type == OP_CONST) && cv) {
3863 sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
3867 /* We get here only from cv_clone2() while creating a closure.
3868 Copy the const value here instead of in cv_clone2 so that
3869 SvREADONLY_on doesn't lead to problems when leaving
3874 if (!SvREADONLY(sv) && SvREFCNT(sv) > 1)
3886 Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
3896 Perl_croak(aTHX_ "\"my sub\" not yet implemented");
3900 Perl_newSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *block)
3902 return Perl_newATTRSUB(aTHX_ floor, o, proto, Nullop, block);
3906 Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
3912 char *ps = proto ? SvPVx(((SVOP*)proto)->op_sv, n_a) : Nullch;
3916 name = o ? SvPVx(cSVOPo->op_sv, n_a) : Nullch;
3917 if (!name && PERLDB_NAMEANON && CopLINE(PL_curcop)) {
3918 SV *sv = sv_newmortal();
3919 Perl_sv_setpvf(aTHX_ sv, "%s[%s:%"IVdf"]",
3920 PL_curstash ? "__ANON__" : "__ANON__::__ANON__",
3921 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
3926 gv = gv_fetchpv(name ? name : (aname ? aname :
3927 (PL_curstash ? "__ANON__" : "__ANON__::__ANON__")),
3928 GV_ADDMULTI | ((block || attrs) ? 0 : GV_NOINIT),
3938 if (SvTYPE(gv) != SVt_PVGV) { /* Maybe prototype now, and had at
3939 maximum a prototype before. */
3940 if (SvTYPE(gv) > SVt_NULL) {
3941 if (!SvPOK((SV*)gv) && !(SvIOK((SV*)gv) && SvIVX((SV*)gv) == -1)
3942 && ckWARN_d(WARN_PROTOTYPE))
3944 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "Runaway prototype");
3946 cv_ckproto((CV*)gv, NULL, ps);
3949 sv_setpv((SV*)gv, ps);
3951 sv_setiv((SV*)gv, -1);
3952 SvREFCNT_dec(PL_compcv);
3953 cv = PL_compcv = NULL;
3954 PL_sub_generation++;
3958 cv = (!name || GvCVGEN(gv)) ? Nullcv : GvCV(gv);
3960 #ifdef GV_UNIQUE_CHECK
3961 if (cv && GvUNIQUE(gv) && SvREADONLY(cv)) {
3962 Perl_croak(aTHX_ "Can't define subroutine %s (GV is unique)", name);
3966 if (!block || !ps || *ps || attrs)
3969 const_sv = op_const_sv(block, Nullcv);
3972 bool exists = CvROOT(cv) || CvXSUB(cv);
3974 #ifdef GV_UNIQUE_CHECK
3975 if (exists && GvUNIQUE(gv)) {
3976 Perl_croak(aTHX_ "Can't redefine unique subroutine %s", name);
3980 /* if the subroutine doesn't exist and wasn't pre-declared
3981 * with a prototype, assume it will be AUTOLOADed,
3982 * skipping the prototype check
3984 if (exists || SvPOK(cv))
3985 cv_ckproto(cv, gv, ps);
3986 /* already defined (or promised)? */
3987 if (exists || GvASSUMECV(gv)) {
3988 if (!block && !attrs) {
3989 if (CvFLAGS(PL_compcv)) {
3990 /* might have had built-in attrs applied */
3991 CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
3993 /* just a "sub foo;" when &foo is already defined */
3994 SAVEFREESV(PL_compcv);
3997 /* ahem, death to those who redefine active sort subs */
3998 if (PL_curstackinfo->si_type == PERLSI_SORT && PL_sortcop == CvSTART(cv))
3999 Perl_croak(aTHX_ "Can't redefine active sort subroutine %s", name);
4001 if (ckWARN(WARN_REDEFINE)
4003 && (!const_sv || sv_cmp(cv_const_sv(cv), const_sv))))
4005 line_t oldline = CopLINE(PL_curcop);
4006 if (PL_copline != NOLINE)
4007 CopLINE_set(PL_curcop, PL_copline);
4008 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
4009 CvCONST(cv) ? "Constant subroutine %s redefined"
4010 : "Subroutine %s redefined", name);
4011 CopLINE_set(PL_curcop, oldline);
4019 SvREFCNT_inc(const_sv);
4021 assert(!CvROOT(cv) && !CvCONST(cv));
4022 sv_setpv((SV*)cv, ""); /* prototype is "" */
4023 CvXSUBANY(cv).any_ptr = const_sv;
4024 CvXSUB(cv) = const_sv_xsub;
4029 cv = newCONSTSUB(NULL, name, const_sv);
4032 SvREFCNT_dec(PL_compcv);
4034 PL_sub_generation++;
4041 /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>
4042 * before we clobber PL_compcv.
4046 /* Might have had built-in attributes applied -- propagate them. */
4047 CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
4048 if (CvGV(cv) && GvSTASH(CvGV(cv)))
4049 stash = GvSTASH(CvGV(cv));
4050 else if (CvSTASH(cv))
4051 stash = CvSTASH(cv);
4053 stash = PL_curstash;
4056 /* possibly about to re-define existing subr -- ignore old cv */
4057 rcv = (SV*)PL_compcv;
4058 if (name && GvSTASH(gv))
4059 stash = GvSTASH(gv);
4061 stash = PL_curstash;
4063 apply_attrs(stash, rcv, attrs, FALSE);
4065 if (cv) { /* must reuse cv if autoloaded */
4067 /* got here with just attrs -- work done, so bug out */
4068 SAVEFREESV(PL_compcv);
4071 /* transfer PL_compcv to cv */
4073 CvFLAGS(cv) = CvFLAGS(PL_compcv);
4074 CvOUTSIDE(cv) = CvOUTSIDE(PL_compcv);
4075 CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(PL_compcv);
4076 CvOUTSIDE(PL_compcv) = 0;
4077 CvPADLIST(cv) = CvPADLIST(PL_compcv);
4078 CvPADLIST(PL_compcv) = 0;
4079 /* inner references to PL_compcv must be fixed up ... */
4080 pad_fixup_inner_anons(CvPADLIST(cv), PL_compcv, cv);
4081 /* ... before we throw it away */
4082 SvREFCNT_dec(PL_compcv);
4083 if (PERLDB_INTER)/* Advice debugger on the new sub. */
4084 ++PL_sub_generation;
4091 PL_sub_generation++;
4095 CvFILE_set_from_cop(cv, PL_curcop);
4096 CvSTASH(cv) = PL_curstash;
4099 sv_setpv((SV*)cv, ps);
4101 if (PL_error_count) {
4105 char *s = strrchr(name, ':');
4107 if (strEQ(s, "BEGIN")) {
4109 "BEGIN not safe after errors--compilation aborted";
4110 if (PL_in_eval & EVAL_KEEPERR)
4111 Perl_croak(aTHX_ not_safe);
4113 /* force display of errors found but not reported */
4114 sv_catpv(ERRSV, not_safe);
4115 Perl_croak(aTHX_ "%"SVf, ERRSV);
4124 CvROOT(cv) = newUNOP(OP_LEAVESUBLV, 0,
4125 mod(scalarseq(block), OP_LEAVESUBLV));
4128 CvROOT(cv) = newUNOP(OP_LEAVESUB, 0, scalarseq(block));
4130 CvROOT(cv)->op_private |= OPpREFCOUNTED;
4131 OpREFCNT_set(CvROOT(cv), 1);
4132 CvSTART(cv) = LINKLIST(CvROOT(cv));
4133 CvROOT(cv)->op_next = 0;
4134 CALL_PEEP(CvSTART(cv));
4136 /* now that optimizer has done its work, adjust pad values */
4138 pad_tidy(CvCLONE(cv) ? padtidy_SUBCLONE : padtidy_SUB);
4141 assert(!CvCONST(cv));
4142 if (ps && !*ps && op_const_sv(block, cv))
4146 if (name || aname) {
4148 char *tname = (name ? name : aname);
4150 if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
4151 SV *sv = NEWSV(0,0);
4152 SV *tmpstr = sv_newmortal();
4153 GV *db_postponed = gv_fetchpv("DB::postponed", GV_ADDMULTI, SVt_PVHV);
4157 Perl_sv_setpvf(aTHX_ sv, "%s:%ld-%ld",
4159 (long)PL_subline, (long)CopLINE(PL_curcop));
4160 gv_efullname3(tmpstr, gv, Nullch);
4161 hv_store(GvHV(PL_DBsub), SvPVX(tmpstr), SvCUR(tmpstr), sv, 0);
4162 hv = GvHVn(db_postponed);
4163 if (HvFILL(hv) > 0 && hv_exists(hv, SvPVX(tmpstr), SvCUR(tmpstr))
4164 && (pcv = GvCV(db_postponed)))
4170 call_sv((SV*)pcv, G_DISCARD);
4174 if ((s = strrchr(tname,':')))
4179 if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I')
4182 if (strEQ(s, "BEGIN")) {
4183 I32 oldscope = PL_scopestack_ix;
4185 SAVECOPFILE(&PL_compiling);
4186 SAVECOPLINE(&PL_compiling);
4189 PL_beginav = newAV();
4190 DEBUG_x( dump_sub(gv) );
4191 av_push(PL_beginav, (SV*)cv);
4192 GvCV(gv) = 0; /* cv has been hijacked */
4193 call_list(oldscope, PL_beginav);
4195 PL_curcop = &PL_compiling;
4196 PL_compiling.op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
4199 else if (strEQ(s, "END") && !PL_error_count) {
4202 DEBUG_x( dump_sub(gv) );
4203 av_unshift(PL_endav, 1);
4204 av_store(PL_endav, 0, (SV*)cv);
4205 GvCV(gv) = 0; /* cv has been hijacked */
4207 else if (strEQ(s, "CHECK") && !PL_error_count) {
4209 PL_checkav = newAV();
4210 DEBUG_x( dump_sub(gv) );
4211 if (PL_main_start && ckWARN(WARN_VOID))
4212 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run CHECK block");
4213 av_unshift(PL_checkav, 1);
4214 av_store(PL_checkav, 0, (SV*)cv);
4215 GvCV(gv) = 0; /* cv has been hijacked */
4217 else if (strEQ(s, "INIT") && !PL_error_count) {
4219 PL_initav = newAV();
4220 DEBUG_x( dump_sub(gv) );
4221 if (PL_main_start && ckWARN(WARN_VOID))
4222 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run INIT block");
4223 av_push(PL_initav, (SV*)cv);
4224 GvCV(gv) = 0; /* cv has been hijacked */
4229 PL_copline = NOLINE;
4234 /* XXX unsafe for threads if eval_owner isn't held */
4236 =for apidoc newCONSTSUB
4238 Creates a constant sub equivalent to Perl C<sub FOO () { 123 }> which is
4239 eligible for inlining at compile-time.
4245 Perl_newCONSTSUB(pTHX_ HV *stash, char *name, SV *sv)
4251 SAVECOPLINE(PL_curcop);
4252 CopLINE_set(PL_curcop, PL_copline);
4255 PL_hints &= ~HINT_BLOCK_SCOPE;
4258 SAVESPTR(PL_curstash);
4259 SAVECOPSTASH(PL_curcop);
4260 PL_curstash = stash;
4261 CopSTASH_set(PL_curcop,stash);
4264 cv = newXS(name, const_sv_xsub, __FILE__);
4265 CvXSUBANY(cv).any_ptr = sv;
4267 sv_setpv((SV*)cv, ""); /* prototype is "" */
4275 =for apidoc U||newXS
4277 Used by C<xsubpp> to hook up XSUBs as Perl subs.
4283 Perl_newXS(pTHX_ char *name, XSUBADDR_t subaddr, char *filename)
4285 GV *gv = gv_fetchpv(name ? name :
4286 (PL_curstash ? "__ANON__" : "__ANON__::__ANON__"),
4287 GV_ADDMULTI, SVt_PVCV);
4291 Perl_croak(aTHX_ "panic: no address for '%s' in '%s'", name, filename);
4293 if ((cv = (name ? GvCV(gv) : Nullcv))) {
4295 /* just a cached method */
4299 else if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) {
4300 /* already defined (or promised) */
4301 if (ckWARN(WARN_REDEFINE) && !(CvGV(cv) && GvSTASH(CvGV(cv))
4302 && strEQ(HvNAME(GvSTASH(CvGV(cv))), "autouse"))) {
4303 line_t oldline = CopLINE(PL_curcop);
4304 if (PL_copline != NOLINE)
4305 CopLINE_set(PL_curcop, PL_copline);
4306 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
4307 CvCONST(cv) ? "Constant subroutine %s redefined"
4308 : "Subroutine %s redefined"
4310 CopLINE_set(PL_curcop, oldline);
4317 if (cv) /* must reuse cv if autoloaded */
4320 cv = (CV*)NEWSV(1105,0);
4321 sv_upgrade((SV *)cv, SVt_PVCV);
4325 PL_sub_generation++;
4329 (void)gv_fetchfile(filename);
4330 CvFILE(cv) = filename; /* NOTE: not copied, as it is expected to be
4331 an external constant string */
4332 CvXSUB(cv) = subaddr;
4335 char *s = strrchr(name,':');
4341 if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I')
4344 if (strEQ(s, "BEGIN")) {
4346 PL_beginav = newAV();
4347 av_push(PL_beginav, (SV*)cv);
4348 GvCV(gv) = 0; /* cv has been hijacked */
4350 else if (strEQ(s, "END")) {
4353 av_unshift(PL_endav, 1);
4354 av_store(PL_endav, 0, (SV*)cv);
4355 GvCV(gv) = 0; /* cv has been hijacked */
4357 else if (strEQ(s, "CHECK")) {
4359 PL_checkav = newAV();
4360 if (PL_main_start && ckWARN(WARN_VOID))
4361 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run CHECK block");
4362 av_unshift(PL_checkav, 1);
4363 av_store(PL_checkav, 0, (SV*)cv);
4364 GvCV(gv) = 0; /* cv has been hijacked */
4366 else if (strEQ(s, "INIT")) {
4368 PL_initav = newAV();
4369 if (PL_main_start && ckWARN(WARN_VOID))
4370 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run INIT block");
4371 av_push(PL_initav, (SV*)cv);
4372 GvCV(gv) = 0; /* cv has been hijacked */
4383 Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block)
4391 name = SvPVx(cSVOPo->op_sv, n_a);
4394 gv = gv_fetchpv(name,TRUE, SVt_PVFM);
4395 #ifdef GV_UNIQUE_CHECK
4397 Perl_croak(aTHX_ "Bad symbol for form (GV is unique)");
4401 if ((cv = GvFORM(gv))) {
4402 if (ckWARN(WARN_REDEFINE)) {
4403 line_t oldline = CopLINE(PL_curcop);
4404 if (PL_copline != NOLINE)
4405 CopLINE_set(PL_curcop, PL_copline);
4406 Perl_warner(aTHX_ packWARN(WARN_REDEFINE), "Format %s redefined",name);
4407 CopLINE_set(PL_curcop, oldline);
4414 CvFILE_set_from_cop(cv, PL_curcop);
4417 pad_tidy(padtidy_FORMAT);
4418 CvROOT(cv) = newUNOP(OP_LEAVEWRITE, 0, scalarseq(block));
4419 CvROOT(cv)->op_private |= OPpREFCOUNTED;
4420 OpREFCNT_set(CvROOT(cv), 1);
4421 CvSTART(cv) = LINKLIST(CvROOT(cv));
4422 CvROOT(cv)->op_next = 0;
4423 CALL_PEEP(CvSTART(cv));
4425 PL_copline = NOLINE;
4430 Perl_newANONLIST(pTHX_ OP *o)
4432 return newUNOP(OP_REFGEN, 0,
4433 mod(list(convert(OP_ANONLIST, 0, o)), OP_REFGEN));
4437 Perl_newANONHASH(pTHX_ OP *o)
4439 return newUNOP(OP_REFGEN, 0,
4440 mod(list(convert(OP_ANONHASH, 0, o)), OP_REFGEN));
4444 Perl_newANONSUB(pTHX_ I32 floor, OP *proto, OP *block)
4446 return newANONATTRSUB(floor, proto, Nullop, block);
4450 Perl_newANONATTRSUB(pTHX_ I32 floor, OP *proto, OP *attrs, OP *block)
4452 return newUNOP(OP_REFGEN, 0,
4453 newSVOP(OP_ANONCODE, 0,
4454 (SV*)newATTRSUB(floor, 0, proto, attrs, block)));
4458 Perl_oopsAV(pTHX_ OP *o)
4460 switch (o->op_type) {
4462 o->op_type = OP_PADAV;
4463 o->op_ppaddr = PL_ppaddr[OP_PADAV];
4464 return ref(o, OP_RV2AV);
4467 o->op_type = OP_RV2AV;
4468 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
4473 if (ckWARN_d(WARN_INTERNAL))
4474 Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsAV");
4481 Perl_oopsHV(pTHX_ OP *o)
4483 switch (o->op_type) {
4486 o->op_type = OP_PADHV;
4487 o->op_ppaddr = PL_ppaddr[OP_PADHV];
4488 return ref(o, OP_RV2HV);
4492 o->op_type = OP_RV2HV;
4493 o->op_ppaddr = PL_ppaddr[OP_RV2HV];
4498 if (ckWARN_d(WARN_INTERNAL))
4499 Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsHV");
4506 Perl_newAVREF(pTHX_ OP *o)
4508 if (o->op_type == OP_PADANY) {
4509 o->op_type = OP_PADAV;
4510 o->op_ppaddr = PL_ppaddr[OP_PADAV];
4513 else if ((o->op_type == OP_RV2AV || o->op_type == OP_PADAV)
4514 && ckWARN(WARN_DEPRECATED)) {
4515 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
4516 "Using an array as a reference is deprecated");
4518 return newUNOP(OP_RV2AV, 0, scalar(o));
4522 Perl_newGVREF(pTHX_ I32 type, OP *o)
4524 if (type == OP_MAPSTART || type == OP_GREPSTART || type == OP_SORT)
4525 return newUNOP(OP_NULL, 0, o);
4526 return ref(newUNOP(OP_RV2GV, OPf_REF, o), type);
4530 Perl_newHVREF(pTHX_ OP *o)
4532 if (o->op_type == OP_PADANY) {
4533 o->op_type = OP_PADHV;
4534 o->op_ppaddr = PL_ppaddr[OP_PADHV];
4537 else if ((o->op_type == OP_RV2HV || o->op_type == OP_PADHV)
4538 && ckWARN(WARN_DEPRECATED)) {
4539 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
4540 "Using a hash as a reference is deprecated");
4542 return newUNOP(OP_RV2HV, 0, scalar(o));
4546 Perl_oopsCV(pTHX_ OP *o)
4548 Perl_croak(aTHX_ "NOT IMPL LINE %d",__LINE__);
4554 Perl_newCVREF(pTHX_ I32 flags, OP *o)
4556 return newUNOP(OP_RV2CV, flags, scalar(o));
4560 Perl_newSVREF(pTHX_ OP *o)
4562 if (o->op_type == OP_PADANY) {
4563 o->op_type = OP_PADSV;
4564 o->op_ppaddr = PL_ppaddr[OP_PADSV];
4567 else if (o->op_type == OP_THREADSV && !(o->op_flags & OPpDONE_SVREF)) {
4568 o->op_flags |= OPpDONE_SVREF;
4571 return newUNOP(OP_RV2SV, 0, scalar(o));
4574 /* Check routines. */
4577 Perl_ck_anoncode(pTHX_ OP *o)
4579 cSVOPo->op_targ = pad_add_anon(cSVOPo->op_sv, o->op_type);
4580 cSVOPo->op_sv = Nullsv;
4585 Perl_ck_bitop(pTHX_ OP *o)
4587 #define OP_IS_NUMCOMPARE(op) \
4588 ((op) == OP_LT || (op) == OP_I_LT || \
4589 (op) == OP_GT || (op) == OP_I_GT || \
4590 (op) == OP_LE || (op) == OP_I_LE || \
4591 (op) == OP_GE || (op) == OP_I_GE || \
4592 (op) == OP_EQ || (op) == OP_I_EQ || \
4593 (op) == OP_NE || (op) == OP_I_NE || \
4594 (op) == OP_NCMP || (op) == OP_I_NCMP)
4595 o->op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
4596 if (o->op_type == OP_BIT_OR
4597 || o->op_type == OP_BIT_AND
4598 || o->op_type == OP_BIT_XOR)
4600 OPCODE typfirst = cBINOPo->op_first->op_type;
4601 OPCODE typlast = cBINOPo->op_first->op_sibling->op_type;
4602 if (OP_IS_NUMCOMPARE(typfirst) || OP_IS_NUMCOMPARE(typlast))
4603 if (ckWARN(WARN_PRECEDENCE))
4604 Perl_warner(aTHX_ packWARN(WARN_PRECEDENCE),
4605 "Possible precedence problem on bitwise %c operator",
4606 o->op_type == OP_BIT_OR ? '|'
4607 : o->op_type == OP_BIT_AND ? '&' : '^'
4614 Perl_ck_concat(pTHX_ OP *o)
4616 if (cUNOPo->op_first->op_type == OP_CONCAT)
4617 o->op_flags |= OPf_STACKED;
4622 Perl_ck_spair(pTHX_ OP *o)
4624 if (o->op_flags & OPf_KIDS) {
4627 OPCODE type = o->op_type;
4628 o = modkids(ck_fun(o), type);
4629 kid = cUNOPo->op_first;
4630 newop = kUNOP->op_first->op_sibling;
4632 (newop->op_sibling ||
4633 !(PL_opargs[newop->op_type] & OA_RETSCALAR) ||
4634 newop->op_type == OP_PADAV || newop->op_type == OP_PADHV ||
4635 newop->op_type == OP_RV2AV || newop->op_type == OP_RV2HV)) {
4639 op_free(kUNOP->op_first);
4640 kUNOP->op_first = newop;
4642 o->op_ppaddr = PL_ppaddr[++o->op_type];
4647 Perl_ck_delete(pTHX_ OP *o)
4651 if (o->op_flags & OPf_KIDS) {
4652 OP *kid = cUNOPo->op_first;
4653 switch (kid->op_type) {
4655 o->op_flags |= OPf_SPECIAL;
4658 o->op_private |= OPpSLICE;
4661 o->op_flags |= OPf_SPECIAL;
4666 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element or slice",
4675 Perl_ck_die(pTHX_ OP *o)
4678 if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
4684 Perl_ck_eof(pTHX_ OP *o)
4686 I32 type = o->op_type;
4688 if (o->op_flags & OPf_KIDS) {
4689 if (cLISTOPo->op_first->op_type == OP_STUB) {
4691 o = newUNOP(type, OPf_SPECIAL, newGVOP(OP_GV, 0, PL_argvgv));
4699 Perl_ck_eval(pTHX_ OP *o)
4701 PL_hints |= HINT_BLOCK_SCOPE;
4702 if (o->op_flags & OPf_KIDS) {
4703 SVOP *kid = (SVOP*)cUNOPo->op_first;
4706 o->op_flags &= ~OPf_KIDS;
4709 else if (kid->op_type == OP_LINESEQ) {
4712 kid->op_next = o->op_next;
4713 cUNOPo->op_first = 0;
4716 NewOp(1101, enter, 1, LOGOP);
4717 enter->op_type = OP_ENTERTRY;
4718 enter->op_ppaddr = PL_ppaddr[OP_ENTERTRY];
4719 enter->op_private = 0;
4721 /* establish postfix order */
4722 enter->op_next = (OP*)enter;
4724 o = prepend_elem(OP_LINESEQ, (OP*)enter, (OP*)kid);
4725 o->op_type = OP_LEAVETRY;
4726 o->op_ppaddr = PL_ppaddr[OP_LEAVETRY];
4727 enter->op_other = o;
4735 o = newUNOP(OP_ENTEREVAL, 0, newDEFSVOP());
4737 o->op_targ = (PADOFFSET)PL_hints;
4742 Perl_ck_exit(pTHX_ OP *o)
4745 HV *table = GvHV(PL_hintgv);
4747 SV **svp = hv_fetch(table, "vmsish_exit", 11, FALSE);
4748 if (svp && *svp && SvTRUE(*svp))
4749 o->op_private |= OPpEXIT_VMSISH;
4751 if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
4757 Perl_ck_exec(pTHX_ OP *o)
4760 if (o->op_flags & OPf_STACKED) {
4762 kid = cUNOPo->op_first->op_sibling;
4763 if (kid->op_type == OP_RV2GV)
4772 Perl_ck_exists(pTHX_ OP *o)
4775 if (o->op_flags & OPf_KIDS) {
4776 OP *kid = cUNOPo->op_first;
4777 if (kid->op_type == OP_ENTERSUB) {
4778 (void) ref(kid, o->op_type);
4779 if (kid->op_type != OP_RV2CV && !PL_error_count)
4780 Perl_croak(aTHX_ "%s argument is not a subroutine name",
4782 o->op_private |= OPpEXISTS_SUB;
4784 else if (kid->op_type == OP_AELEM)
4785 o->op_flags |= OPf_SPECIAL;
4786 else if (kid->op_type != OP_HELEM)
4787 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element",
4796 Perl_ck_gvconst(pTHX_ register OP *o)
4798 o = fold_constants(o);
4799 if (o->op_type == OP_CONST)
4806 Perl_ck_rvconst(pTHX_ register OP *o)
4808 SVOP *kid = (SVOP*)cUNOPo->op_first;
4810 o->op_private |= (PL_hints & HINT_STRICT_REFS);
4811 if (kid->op_type == OP_CONST) {
4815 SV *kidsv = kid->op_sv;
4818 /* Is it a constant from cv_const_sv()? */
4819 if (SvROK(kidsv) && SvREADONLY(kidsv)) {
4820 SV *rsv = SvRV(kidsv);
4821 int svtype = SvTYPE(rsv);
4822 char *badtype = Nullch;
4824 switch (o->op_type) {
4826 if (svtype > SVt_PVMG)
4827 badtype = "a SCALAR";
4830 if (svtype != SVt_PVAV)
4831 badtype = "an ARRAY";
4834 if (svtype != SVt_PVHV)
4838 if (svtype != SVt_PVCV)
4843 Perl_croak(aTHX_ "Constant is not %s reference", badtype);
4846 name = SvPV(kidsv, n_a);
4847 if ((PL_hints & HINT_STRICT_REFS) && (kid->op_private & OPpCONST_BARE)) {
4848 char *badthing = Nullch;
4849 switch (o->op_type) {
4851 badthing = "a SCALAR";
4854 badthing = "an ARRAY";
4857 badthing = "a HASH";
4862 "Can't use bareword (\"%s\") as %s ref while \"strict refs\" in use",
4866 * This is a little tricky. We only want to add the symbol if we
4867 * didn't add it in the lexer. Otherwise we get duplicate strict
4868 * warnings. But if we didn't add it in the lexer, we must at
4869 * least pretend like we wanted to add it even if it existed before,
4870 * or we get possible typo warnings. OPpCONST_ENTERED says
4871 * whether the lexer already added THIS instance of this symbol.
4873 iscv = (o->op_type == OP_RV2CV) * 2;
4875 gv = gv_fetchpv(name,
4876 iscv | !(kid->op_private & OPpCONST_ENTERED),
4879 : o->op_type == OP_RV2SV
4881 : o->op_type == OP_RV2AV
4883 : o->op_type == OP_RV2HV
4886 } while (!gv && !(kid->op_private & OPpCONST_ENTERED) && !iscv++);
4888 kid->op_type = OP_GV;
4889 SvREFCNT_dec(kid->op_sv);
4891 /* XXX hack: dependence on sizeof(PADOP) <= sizeof(SVOP) */
4892 kPADOP->op_padix = pad_alloc(OP_GV, SVs_PADTMP);
4893 SvREFCNT_dec(PAD_SVl(kPADOP->op_padix));
4895 PAD_SETSV(kPADOP->op_padix, (SV*) SvREFCNT_inc(gv));
4897 kid->op_sv = SvREFCNT_inc(gv);
4899 kid->op_private = 0;
4900 kid->op_ppaddr = PL_ppaddr[OP_GV];
4907 Perl_ck_ftst(pTHX_ OP *o)
4909 I32 type = o->op_type;
4911 if (o->op_flags & OPf_REF) {
4914 else if (o->op_flags & OPf_KIDS && cUNOPo->op_first->op_type != OP_STUB) {
4915 SVOP *kid = (SVOP*)cUNOPo->op_first;
4917 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
4919 OP *newop = newGVOP(type, OPf_REF,
4920 gv_fetchpv(SvPVx(kid->op_sv, n_a), TRUE, SVt_PVIO));
4927 if (type == OP_FTTTY)
4928 o = newGVOP(type, OPf_REF, PL_stdingv);
4930 o = newUNOP(type, 0, newDEFSVOP());
4936 Perl_ck_fun(pTHX_ OP *o)
4942 int type = o->op_type;
4943 register I32 oa = PL_opargs[type] >> OASHIFT;
4945 if (o->op_flags & OPf_STACKED) {
4946 if ((oa & OA_OPTIONAL) && (oa >> 4) && !((oa >> 4) & OA_OPTIONAL))
4949 return no_fh_allowed(o);
4952 if (o->op_flags & OPf_KIDS) {
4954 tokid = &cLISTOPo->op_first;
4955 kid = cLISTOPo->op_first;
4956 if (kid->op_type == OP_PUSHMARK ||
4957 (kid->op_type == OP_NULL && kid->op_targ == OP_PUSHMARK))
4959 tokid = &kid->op_sibling;
4960 kid = kid->op_sibling;
4962 if (!kid && PL_opargs[type] & OA_DEFGV)
4963 *tokid = kid = newDEFSVOP();
4967 sibl = kid->op_sibling;
4970 /* list seen where single (scalar) arg expected? */
4971 if (numargs == 1 && !(oa >> 4)
4972 && kid->op_type == OP_LIST && type != OP_SCALAR)
4974 return too_many_arguments(o,PL_op_desc[type]);
4987 if ((type == OP_PUSH || type == OP_UNSHIFT)
4988 && !kid->op_sibling && ckWARN(WARN_SYNTAX))
4989 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
4990 "Useless use of %s with no values",
4993 if (kid->op_type == OP_CONST &&
4994 (kid->op_private & OPpCONST_BARE))
4996 char *name = SvPVx(((SVOP*)kid)->op_sv, n_a);
4997 OP *newop = newAVREF(newGVOP(OP_GV, 0,
4998 gv_fetchpv(name, TRUE, SVt_PVAV) ));
4999 if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
5000 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5001 "Array @%s missing the @ in argument %"IVdf" of %s()",
5002 name, (IV)numargs, PL_op_desc[type]);
5005 kid->op_sibling = sibl;
5008 else if (kid->op_type != OP_RV2AV && kid->op_type != OP_PADAV)
5009 bad_type(numargs, "array", PL_op_desc[type], kid);
5013 if (kid->op_type == OP_CONST &&
5014 (kid->op_private & OPpCONST_BARE))
5016 char *name = SvPVx(((SVOP*)kid)->op_sv, n_a);
5017 OP *newop = newHVREF(newGVOP(OP_GV, 0,
5018 gv_fetchpv(name, TRUE, SVt_PVHV) ));
5019 if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
5020 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5021 "Hash %%%s missing the %% in argument %"IVdf" of %s()",
5022 name, (IV)numargs, PL_op_desc[type]);
5025 kid->op_sibling = sibl;
5028 else if (kid->op_type != OP_RV2HV && kid->op_type != OP_PADHV)
5029 bad_type(numargs, "hash", PL_op_desc[type], kid);
5034 OP *newop = newUNOP(OP_NULL, 0, kid);
5035 kid->op_sibling = 0;
5037 newop->op_next = newop;
5039 kid->op_sibling = sibl;
5044 if (kid->op_type != OP_GV && kid->op_type != OP_RV2GV) {
5045 if (kid->op_type == OP_CONST &&
5046 (kid->op_private & OPpCONST_BARE))
5048 OP *newop = newGVOP(OP_GV, 0,
5049 gv_fetchpv(SvPVx(((SVOP*)kid)->op_sv, n_a), TRUE,
5051 if (!(o->op_private & 1) && /* if not unop */
5052 kid == cLISTOPo->op_last)
5053 cLISTOPo->op_last = newop;
5057 else if (kid->op_type == OP_READLINE) {
5058 /* neophyte patrol: open(<FH>), close(<FH>) etc. */
5059 bad_type(numargs, "HANDLE", OP_DESC(o), kid);
5062 I32 flags = OPf_SPECIAL;
5066 /* is this op a FH constructor? */
5067 if (is_handle_constructor(o,numargs)) {
5068 char *name = Nullch;
5072 /* Set a flag to tell rv2gv to vivify
5073 * need to "prove" flag does not mean something
5074 * else already - NI-S 1999/05/07
5077 if (kid->op_type == OP_PADSV) {
5078 /*XXX DAPM 2002.08.25 tmp assert test */
5079 /*XXX*/ assert(av_fetch(PL_comppad_name, (kid->op_targ), FALSE));
5080 /*XXX*/ assert(*av_fetch(PL_comppad_name, (kid->op_targ), FALSE));
5082 name = PAD_COMPNAME_PV(kid->op_targ);
5083 /* SvCUR of a pad namesv can't be trusted
5084 * (see PL_generation), so calc its length
5090 else if (kid->op_type == OP_RV2SV
5091 && kUNOP->op_first->op_type == OP_GV)
5093 GV *gv = cGVOPx_gv(kUNOP->op_first);
5095 len = GvNAMELEN(gv);
5097 else if (kid->op_type == OP_AELEM
5098 || kid->op_type == OP_HELEM)
5100 name = "__ANONIO__";
5106 targ = pad_alloc(OP_RV2GV, SVs_PADTMP);
5107 namesv = PAD_SVl(targ);
5108 (void)SvUPGRADE(namesv, SVt_PV);
5110 sv_setpvn(namesv, "$", 1);
5111 sv_catpvn(namesv, name, len);
5114 kid->op_sibling = 0;
5115 kid = newUNOP(OP_RV2GV, flags, scalar(kid));
5116 kid->op_targ = targ;
5117 kid->op_private |= priv;
5119 kid->op_sibling = sibl;
5125 mod(scalar(kid), type);
5129 tokid = &kid->op_sibling;
5130 kid = kid->op_sibling;
5132 o->op_private |= numargs;
5134 return too_many_arguments(o,OP_DESC(o));
5137 else if (PL_opargs[type] & OA_DEFGV) {
5139 return newUNOP(type, 0, newDEFSVOP());
5143 while (oa & OA_OPTIONAL)
5145 if (oa && oa != OA_LIST)
5146 return too_few_arguments(o,OP_DESC(o));
5152 Perl_ck_glob(pTHX_ OP *o)
5157 if ((o->op_flags & OPf_KIDS) && !cLISTOPo->op_first->op_sibling)
5158 append_elem(OP_GLOB, o, newDEFSVOP());
5160 if (!((gv = gv_fetchpv("glob", FALSE, SVt_PVCV))
5161 && GvCVu(gv) && GvIMPORTED_CV(gv)))
5163 gv = gv_fetchpv("CORE::GLOBAL::glob", FALSE, SVt_PVCV);
5166 #if !defined(PERL_EXTERNAL_GLOB)
5167 /* XXX this can be tightened up and made more failsafe. */
5171 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
5172 newSVpvn("File::Glob", 10), Nullsv, Nullsv, Nullsv);
5173 gv = gv_fetchpv("CORE::GLOBAL::glob", FALSE, SVt_PVCV);
5174 glob_gv = gv_fetchpv("File::Glob::csh_glob", FALSE, SVt_PVCV);
5175 GvCV(gv) = GvCV(glob_gv);
5176 SvREFCNT_inc((SV*)GvCV(gv));
5177 GvIMPORTED_CV_on(gv);
5180 #endif /* PERL_EXTERNAL_GLOB */
5182 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
5183 append_elem(OP_GLOB, o,
5184 newSVOP(OP_CONST, 0, newSViv(PL_glob_index++)));
5185 o->op_type = OP_LIST;
5186 o->op_ppaddr = PL_ppaddr[OP_LIST];
5187 cLISTOPo->op_first->op_type = OP_PUSHMARK;
5188 cLISTOPo->op_first->op_ppaddr = PL_ppaddr[OP_PUSHMARK];
5189 o = newUNOP(OP_ENTERSUB, OPf_STACKED,
5190 append_elem(OP_LIST, o,
5191 scalar(newUNOP(OP_RV2CV, 0,
5192 newGVOP(OP_GV, 0, gv)))));
5193 o = newUNOP(OP_NULL, 0, ck_subr(o));
5194 o->op_targ = OP_GLOB; /* hint at what it used to be */
5197 gv = newGVgen("main");
5199 append_elem(OP_GLOB, o, newGVOP(OP_GV, 0, gv));
5205 Perl_ck_grep(pTHX_ OP *o)
5209 OPCODE type = o->op_type == OP_GREPSTART ? OP_GREPWHILE : OP_MAPWHILE;
5211 o->op_ppaddr = PL_ppaddr[OP_GREPSTART];
5212 NewOp(1101, gwop, 1, LOGOP);
5214 if (o->op_flags & OPf_STACKED) {
5217 kid = cLISTOPo->op_first->op_sibling;
5218 for (k = cLISTOPo->op_first->op_sibling->op_next; k; k = k->op_next) {
5221 kid->op_next = (OP*)gwop;
5222 o->op_flags &= ~OPf_STACKED;
5224 kid = cLISTOPo->op_first->op_sibling;
5225 if (type == OP_MAPWHILE)
5232 kid = cLISTOPo->op_first->op_sibling;
5233 if (kid->op_type != OP_NULL)
5234 Perl_croak(aTHX_ "panic: ck_grep");
5235 kid = kUNOP->op_first;
5237 gwop->op_type = type;
5238 gwop->op_ppaddr = PL_ppaddr[type];
5239 gwop->op_first = listkids(o);
5240 gwop->op_flags |= OPf_KIDS;
5241 gwop->op_private = 1;
5242 gwop->op_other = LINKLIST(kid);
5243 gwop->op_targ = pad_alloc(type, SVs_PADTMP);
5244 kid->op_next = (OP*)gwop;
5246 kid = cLISTOPo->op_first->op_sibling;
5247 if (!kid || !kid->op_sibling)
5248 return too_few_arguments(o,OP_DESC(o));
5249 for (kid = kid->op_sibling; kid; kid = kid->op_sibling)
5250 mod(kid, OP_GREPSTART);
5256 Perl_ck_index(pTHX_ OP *o)
5258 if (o->op_flags & OPf_KIDS) {
5259 OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
5261 kid = kid->op_sibling; /* get past "big" */
5262 if (kid && kid->op_type == OP_CONST)
5263 fbm_compile(((SVOP*)kid)->op_sv, 0);
5269 Perl_ck_lengthconst(pTHX_ OP *o)
5271 /* XXX length optimization goes here */
5276 Perl_ck_lfun(pTHX_ OP *o)
5278 OPCODE type = o->op_type;
5279 return modkids(ck_fun(o), type);
5283 Perl_ck_defined(pTHX_ OP *o) /* 19990527 MJD */
5285 if ((o->op_flags & OPf_KIDS) && ckWARN2(WARN_DEPRECATED, WARN_SYNTAX)) {
5286 switch (cUNOPo->op_first->op_type) {
5288 /* This is needed for
5289 if (defined %stash::)
5290 to work. Do not break Tk.
5292 break; /* Globals via GV can be undef */
5294 case OP_AASSIGN: /* Is this a good idea? */
5295 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5296 "defined(@array) is deprecated");
5297 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5298 "\t(Maybe you should just omit the defined()?)\n");
5301 /* This is needed for
5302 if (defined %stash::)
5303 to work. Do not break Tk.
5305 break; /* Globals via GV can be undef */
5307 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5308 "defined(%%hash) is deprecated");
5309 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5310 "\t(Maybe you should just omit the defined()?)\n");
5321 Perl_ck_rfun(pTHX_ OP *o)
5323 OPCODE type = o->op_type;
5324 return refkids(ck_fun(o), type);
5328 Perl_ck_listiob(pTHX_ OP *o)
5332 kid = cLISTOPo->op_first;
5335 kid = cLISTOPo->op_first;
5337 if (kid->op_type == OP_PUSHMARK)
5338 kid = kid->op_sibling;
5339 if (kid && o->op_flags & OPf_STACKED)
5340 kid = kid->op_sibling;
5341 else if (kid && !kid->op_sibling) { /* print HANDLE; */
5342 if (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE) {
5343 o->op_flags |= OPf_STACKED; /* make it a filehandle */
5344 kid = newUNOP(OP_RV2GV, OPf_REF, scalar(kid));
5345 cLISTOPo->op_first->op_sibling = kid;
5346 cLISTOPo->op_last = kid;
5347 kid = kid->op_sibling;
5352 append_elem(o->op_type, o, newDEFSVOP());
5358 Perl_ck_sassign(pTHX_ OP *o)
5360 OP *kid = cLISTOPo->op_first;
5361 /* has a disposable target? */
5362 if ((PL_opargs[kid->op_type] & OA_TARGLEX)
5363 && !(kid->op_flags & OPf_STACKED)
5364 /* Cannot steal the second time! */
5365 && !(kid->op_private & OPpTARGET_MY))
5367 OP *kkid = kid->op_sibling;
5369 /* Can just relocate the target. */
5370 if (kkid && kkid->op_type == OP_PADSV
5371 && !(kkid->op_private & OPpLVAL_INTRO))
5373 kid->op_targ = kkid->op_targ;
5375 /* Now we do not need PADSV and SASSIGN. */
5376 kid->op_sibling = o->op_sibling; /* NULL */
5377 cLISTOPo->op_first = NULL;
5380 kid->op_private |= OPpTARGET_MY; /* Used for context settings */
5388 Perl_ck_match(pTHX_ OP *o)
5390 o->op_private |= OPpRUNTIME;
5395 Perl_ck_method(pTHX_ OP *o)
5397 OP *kid = cUNOPo->op_first;
5398 if (kid->op_type == OP_CONST) {
5399 SV* sv = kSVOP->op_sv;
5400 if (!(strchr(SvPVX(sv), ':') || strchr(SvPVX(sv), '\''))) {
5402 if (!SvREADONLY(sv) || !SvFAKE(sv)) {
5403 sv = newSVpvn_share(SvPVX(sv), SvCUR(sv), 0);
5406 kSVOP->op_sv = Nullsv;
5408 cmop = newSVOP(OP_METHOD_NAMED, 0, sv);
5417 Perl_ck_null(pTHX_ OP *o)
5423 Perl_ck_open(pTHX_ OP *o)
5425 HV *table = GvHV(PL_hintgv);
5429 svp = hv_fetch(table, "open_IN", 7, FALSE);
5431 mode = mode_from_discipline(*svp);
5432 if (mode & O_BINARY)
5433 o->op_private |= OPpOPEN_IN_RAW;
5434 else if (mode & O_TEXT)
5435 o->op_private |= OPpOPEN_IN_CRLF;
5438 svp = hv_fetch(table, "open_OUT", 8, FALSE);
5440 mode = mode_from_discipline(*svp);
5441 if (mode & O_BINARY)
5442 o->op_private |= OPpOPEN_OUT_RAW;
5443 else if (mode & O_TEXT)
5444 o->op_private |= OPpOPEN_OUT_CRLF;
5447 if (o->op_type == OP_BACKTICK)
5453 Perl_ck_repeat(pTHX_ OP *o)
5455 if (cBINOPo->op_first->op_flags & OPf_PARENS) {
5456 o->op_private |= OPpREPEAT_DOLIST;
5457 cBINOPo->op_first = force_list(cBINOPo->op_first);
5465 Perl_ck_require(pTHX_ OP *o)
5469 if (o->op_flags & OPf_KIDS) { /* Shall we supply missing .pm? */
5470 SVOP *kid = (SVOP*)cUNOPo->op_first;
5472 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
5474 for (s = SvPVX(kid->op_sv); *s; s++) {
5475 if (*s == ':' && s[1] == ':') {
5477 Move(s+2, s+1, strlen(s+2)+1, char);
5478 --SvCUR(kid->op_sv);
5481 if (SvREADONLY(kid->op_sv)) {
5482 SvREADONLY_off(kid->op_sv);
5483 sv_catpvn(kid->op_sv, ".pm", 3);
5484 SvREADONLY_on(kid->op_sv);
5487 sv_catpvn(kid->op_sv, ".pm", 3);
5491 /* handle override, if any */
5492 gv = gv_fetchpv("require", FALSE, SVt_PVCV);
5493 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv)))
5494 gv = gv_fetchpv("CORE::GLOBAL::require", FALSE, SVt_PVCV);
5496 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
5497 OP *kid = cUNOPo->op_first;
5498 cUNOPo->op_first = 0;
5500 return ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
5501 append_elem(OP_LIST, kid,
5502 scalar(newUNOP(OP_RV2CV, 0,
5511 Perl_ck_return(pTHX_ OP *o)
5514 if (CvLVALUE(PL_compcv)) {
5515 for (kid = cLISTOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
5516 mod(kid, OP_LEAVESUBLV);
5523 Perl_ck_retarget(pTHX_ OP *o)
5525 Perl_croak(aTHX_ "NOT IMPL LINE %d",__LINE__);
5532 Perl_ck_select(pTHX_ OP *o)
5535 if (o->op_flags & OPf_KIDS) {
5536 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
5537 if (kid && kid->op_sibling) {
5538 o->op_type = OP_SSELECT;
5539 o->op_ppaddr = PL_ppaddr[OP_SSELECT];
5541 return fold_constants(o);
5545 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
5546 if (kid && kid->op_type == OP_RV2GV)
5547 kid->op_private &= ~HINT_STRICT_REFS;
5552 Perl_ck_shift(pTHX_ OP *o)
5554 I32 type = o->op_type;
5556 if (!(o->op_flags & OPf_KIDS)) {
5560 argop = newUNOP(OP_RV2AV, 0,
5561 scalar(newGVOP(OP_GV, 0, CvUNIQUE(PL_compcv) ? PL_argvgv : PL_defgv)));
5562 return newUNOP(type, 0, scalar(argop));
5564 return scalar(modkids(ck_fun(o), type));
5568 Perl_ck_sort(pTHX_ OP *o)
5572 if (o->op_type == OP_SORT && o->op_flags & OPf_STACKED)
5574 firstkid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
5575 if (o->op_flags & OPf_STACKED) { /* may have been cleared */
5577 OP *kid = cUNOPx(firstkid)->op_first; /* get past null */
5579 if (kid->op_type == OP_SCOPE || kid->op_type == OP_LEAVE) {
5581 if (kid->op_type == OP_SCOPE) {
5585 else if (kid->op_type == OP_LEAVE) {
5586 if (o->op_type == OP_SORT) {
5587 op_null(kid); /* wipe out leave */
5590 for (k = kLISTOP->op_first->op_next; k; k = k->op_next) {
5591 if (k->op_next == kid)
5593 /* don't descend into loops */
5594 else if (k->op_type == OP_ENTERLOOP
5595 || k->op_type == OP_ENTERITER)
5597 k = cLOOPx(k)->op_lastop;
5602 kid->op_next = 0; /* just disconnect the leave */
5603 k = kLISTOP->op_first;
5608 if (o->op_type == OP_SORT) {
5609 /* provide scalar context for comparison function/block */
5615 o->op_flags |= OPf_SPECIAL;
5617 else if (kid->op_type == OP_RV2SV || kid->op_type == OP_PADSV)
5620 firstkid = firstkid->op_sibling;
5623 /* provide list context for arguments */
5624 if (o->op_type == OP_SORT)
5631 S_simplify_sort(pTHX_ OP *o)
5633 register OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
5637 if (!(o->op_flags & OPf_STACKED))
5639 GvMULTI_on(gv_fetchpv("a", TRUE, SVt_PV));
5640 GvMULTI_on(gv_fetchpv("b", TRUE, SVt_PV));
5641 kid = kUNOP->op_first; /* get past null */
5642 if (kid->op_type != OP_SCOPE)
5644 kid = kLISTOP->op_last; /* get past scope */
5645 switch(kid->op_type) {
5653 k = kid; /* remember this node*/
5654 if (kBINOP->op_first->op_type != OP_RV2SV)
5656 kid = kBINOP->op_first; /* get past cmp */
5657 if (kUNOP->op_first->op_type != OP_GV)
5659 kid = kUNOP->op_first; /* get past rv2sv */
5661 if (GvSTASH(gv) != PL_curstash)
5663 if (strEQ(GvNAME(gv), "a"))
5665 else if (strEQ(GvNAME(gv), "b"))
5669 kid = k; /* back to cmp */
5670 if (kBINOP->op_last->op_type != OP_RV2SV)
5672 kid = kBINOP->op_last; /* down to 2nd arg */
5673 if (kUNOP->op_first->op_type != OP_GV)
5675 kid = kUNOP->op_first; /* get past rv2sv */
5677 if (GvSTASH(gv) != PL_curstash
5679 ? strNE(GvNAME(gv), "a")
5680 : strNE(GvNAME(gv), "b")))
5682 o->op_flags &= ~(OPf_STACKED | OPf_SPECIAL);
5684 o->op_private |= OPpSORT_REVERSE;
5685 if (k->op_type == OP_NCMP)
5686 o->op_private |= OPpSORT_NUMERIC;
5687 if (k->op_type == OP_I_NCMP)
5688 o->op_private |= OPpSORT_NUMERIC | OPpSORT_INTEGER;
5689 kid = cLISTOPo->op_first->op_sibling;
5690 cLISTOPo->op_first->op_sibling = kid->op_sibling; /* bypass old block */
5691 op_free(kid); /* then delete it */
5695 Perl_ck_split(pTHX_ OP *o)
5699 if (o->op_flags & OPf_STACKED)
5700 return no_fh_allowed(o);
5702 kid = cLISTOPo->op_first;
5703 if (kid->op_type != OP_NULL)
5704 Perl_croak(aTHX_ "panic: ck_split");
5705 kid = kid->op_sibling;
5706 op_free(cLISTOPo->op_first);
5707 cLISTOPo->op_first = kid;
5709 cLISTOPo->op_first = kid = newSVOP(OP_CONST, 0, newSVpvn(" ", 1));
5710 cLISTOPo->op_last = kid; /* There was only one element previously */
5713 if (kid->op_type != OP_MATCH || kid->op_flags & OPf_STACKED) {
5714 OP *sibl = kid->op_sibling;
5715 kid->op_sibling = 0;
5716 kid = pmruntime( newPMOP(OP_MATCH, OPf_SPECIAL), kid, Nullop);
5717 if (cLISTOPo->op_first == cLISTOPo->op_last)
5718 cLISTOPo->op_last = kid;
5719 cLISTOPo->op_first = kid;
5720 kid->op_sibling = sibl;
5723 kid->op_type = OP_PUSHRE;
5724 kid->op_ppaddr = PL_ppaddr[OP_PUSHRE];
5726 if (ckWARN(WARN_REGEXP) && ((PMOP *)kid)->op_pmflags & PMf_GLOBAL) {
5727 Perl_warner(aTHX_ packWARN(WARN_REGEXP),
5728 "Use of /g modifier is meaningless in split");
5731 if (!kid->op_sibling)
5732 append_elem(OP_SPLIT, o, newDEFSVOP());
5734 kid = kid->op_sibling;
5737 if (!kid->op_sibling)
5738 append_elem(OP_SPLIT, o, newSVOP(OP_CONST, 0, newSViv(0)));
5740 kid = kid->op_sibling;
5743 if (kid->op_sibling)
5744 return too_many_arguments(o,OP_DESC(o));
5750 Perl_ck_join(pTHX_ OP *o)
5752 if (ckWARN(WARN_SYNTAX)) {
5753 OP *kid = cLISTOPo->op_first->op_sibling;
5754 if (kid && kid->op_type == OP_MATCH) {
5755 char *pmstr = "STRING";
5756 if (PM_GETRE(kPMOP))
5757 pmstr = PM_GETRE(kPMOP)->precomp;
5758 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
5759 "/%s/ should probably be written as \"%s\"",
5767 Perl_ck_subr(pTHX_ OP *o)
5769 OP *prev = ((cUNOPo->op_first->op_sibling)
5770 ? cUNOPo : ((UNOP*)cUNOPo->op_first))->op_first;
5771 OP *o2 = prev->op_sibling;
5778 I32 contextclass = 0;
5783 o->op_private |= OPpENTERSUB_HASTARG;
5784 for (cvop = o2; cvop->op_sibling; cvop = cvop->op_sibling) ;
5785 if (cvop->op_type == OP_RV2CV) {
5787 o->op_private |= (cvop->op_private & OPpENTERSUB_AMPER);
5788 op_null(cvop); /* disable rv2cv */
5789 tmpop = (SVOP*)((UNOP*)cvop)->op_first;
5790 if (tmpop->op_type == OP_GV && !(o->op_private & OPpENTERSUB_AMPER)) {
5791 GV *gv = cGVOPx_gv(tmpop);
5794 tmpop->op_private |= OPpEARLY_CV;
5797 namegv = CvANON(cv) ? gv : CvGV(cv);
5798 proto = SvPV((SV*)cv, n_a);
5800 if (CvASSERTION(cv)) {
5801 if (PL_hints & HINT_ASSERTING) {
5802 if (PERLDB_ASSERTION && PL_curstash != PL_debstash)
5803 o->op_private |= OPpENTERSUB_DB;
5810 else if (cvop->op_type == OP_METHOD || cvop->op_type == OP_METHOD_NAMED) {
5811 if (o2->op_type == OP_CONST)
5812 o2->op_private &= ~OPpCONST_STRICT;
5813 else if (o2->op_type == OP_LIST) {
5814 OP *o = ((UNOP*)o2)->op_first->op_sibling;
5815 if (o && o->op_type == OP_CONST)
5816 o->op_private &= ~OPpCONST_STRICT;
5819 o->op_private |= (PL_hints & HINT_STRICT_REFS);
5820 if (PERLDB_SUB && PL_curstash != PL_debstash)
5821 o->op_private |= OPpENTERSUB_DB;
5822 while (o2 != cvop) {
5826 return too_many_arguments(o, gv_ename(namegv));
5844 if (o2->op_type != OP_REFGEN && o2->op_type != OP_UNDEF)
5846 arg == 1 ? "block or sub {}" : "sub {}",
5847 gv_ename(namegv), o2);
5850 /* '*' allows any scalar type, including bareword */
5853 if (o2->op_type == OP_RV2GV)
5854 goto wrapref; /* autoconvert GLOB -> GLOBref */
5855 else if (o2->op_type == OP_CONST)
5856 o2->op_private &= ~OPpCONST_STRICT;
5857 else if (o2->op_type == OP_ENTERSUB) {
5858 /* accidental subroutine, revert to bareword */
5859 OP *gvop = ((UNOP*)o2)->op_first;
5860 if (gvop && gvop->op_type == OP_NULL) {
5861 gvop = ((UNOP*)gvop)->op_first;
5863 for (; gvop->op_sibling; gvop = gvop->op_sibling)
5866 (gvop->op_private & OPpENTERSUB_NOPAREN) &&
5867 (gvop = ((UNOP*)gvop)->op_first) &&
5868 gvop->op_type == OP_GV)
5870 GV *gv = cGVOPx_gv(gvop);
5871 OP *sibling = o2->op_sibling;
5872 SV *n = newSVpvn("",0);
5874 gv_fullname3(n, gv, "");
5875 if (SvCUR(n)>6 && strnEQ(SvPVX(n),"main::",6))
5876 sv_chop(n, SvPVX(n)+6);
5877 o2 = newSVOP(OP_CONST, 0, n);
5878 prev->op_sibling = o2;
5879 o2->op_sibling = sibling;
5895 if (contextclass++ == 0) {
5896 e = strchr(proto, ']');
5897 if (!e || e == proto)
5910 while (*--p != '[');
5911 bad_type(arg, Perl_form(aTHX_ "one of %s", p),
5912 gv_ename(namegv), o2);
5918 if (o2->op_type == OP_RV2GV)
5921 bad_type(arg, "symbol", gv_ename(namegv), o2);
5924 if (o2->op_type == OP_ENTERSUB)
5927 bad_type(arg, "subroutine entry", gv_ename(namegv), o2);
5930 if (o2->op_type == OP_RV2SV ||
5931 o2->op_type == OP_PADSV ||
5932 o2->op_type == OP_HELEM ||
5933 o2->op_type == OP_AELEM ||
5934 o2->op_type == OP_THREADSV)
5937 bad_type(arg, "scalar", gv_ename(namegv), o2);
5940 if (o2->op_type == OP_RV2AV ||
5941 o2->op_type == OP_PADAV)
5944 bad_type(arg, "array", gv_ename(namegv), o2);
5947 if (o2->op_type == OP_RV2HV ||
5948 o2->op_type == OP_PADHV)
5951 bad_type(arg, "hash", gv_ename(namegv), o2);
5956 OP* sib = kid->op_sibling;
5957 kid->op_sibling = 0;
5958 o2 = newUNOP(OP_REFGEN, 0, kid);
5959 o2->op_sibling = sib;
5960 prev->op_sibling = o2;
5962 if (contextclass && e) {
5977 Perl_croak(aTHX_ "Malformed prototype for %s: %"SVf,
5978 gv_ename(namegv), cv);
5983 mod(o2, OP_ENTERSUB);
5985 o2 = o2->op_sibling;
5987 if (proto && !optional &&
5988 (*proto && *proto != '@' && *proto != '%' && *proto != ';'))
5989 return too_few_arguments(o, gv_ename(namegv));
5992 o=newSVOP(OP_CONST, 0, newSViv(0));
5998 Perl_ck_svconst(pTHX_ OP *o)
6000 SvREADONLY_on(cSVOPo->op_sv);
6005 Perl_ck_trunc(pTHX_ OP *o)
6007 if (o->op_flags & OPf_KIDS) {
6008 SVOP *kid = (SVOP*)cUNOPo->op_first;
6010 if (kid->op_type == OP_NULL)
6011 kid = (SVOP*)kid->op_sibling;
6012 if (kid && kid->op_type == OP_CONST &&
6013 (kid->op_private & OPpCONST_BARE))
6015 o->op_flags |= OPf_SPECIAL;
6016 kid->op_private &= ~OPpCONST_STRICT;
6023 Perl_ck_substr(pTHX_ OP *o)
6026 if ((o->op_flags & OPf_KIDS) && o->op_private == 4) {
6027 OP *kid = cLISTOPo->op_first;
6029 if (kid->op_type == OP_NULL)
6030 kid = kid->op_sibling;
6032 kid->op_flags |= OPf_MOD;
6038 /* A peephole optimizer. We visit the ops in the order they're to execute. */
6041 Perl_peep(pTHX_ register OP *o)
6043 register OP* oldop = 0;
6045 if (!o || o->op_seq)
6049 SAVEVPTR(PL_curcop);
6050 for (; o; o = o->op_next) {
6053 /* The special value -1 is used by the B::C compiler backend to indicate
6054 * that an op is statically defined and should not be freed */
6055 if (!PL_op_seqmax || PL_op_seqmax == (U16)-1)
6058 switch (o->op_type) {
6062 PL_curcop = ((COP*)o); /* for warnings */
6063 o->op_seq = PL_op_seqmax++;
6067 if (cSVOPo->op_private & OPpCONST_STRICT)
6068 no_bareword_allowed(o);
6070 case OP_METHOD_NAMED:
6071 /* Relocate sv to the pad for thread safety.
6072 * Despite being a "constant", the SV is written to,
6073 * for reference counts, sv_upgrade() etc. */
6075 PADOFFSET ix = pad_alloc(OP_CONST, SVs_PADTMP);
6076 if (o->op_type == OP_CONST && SvPADTMP(cSVOPo->op_sv)) {
6077 /* If op_sv is already a PADTMP then it is being used by
6078 * some pad, so make a copy. */
6079 sv_setsv(PAD_SVl(ix),cSVOPo->op_sv);
6080 SvREADONLY_on(PAD_SVl(ix));
6081 SvREFCNT_dec(cSVOPo->op_sv);
6084 SvREFCNT_dec(PAD_SVl(ix));
6085 SvPADTMP_on(cSVOPo->op_sv);
6086 PAD_SETSV(ix, cSVOPo->op_sv);
6087 /* XXX I don't know how this isn't readonly already. */
6088 SvREADONLY_on(PAD_SVl(ix));
6090 cSVOPo->op_sv = Nullsv;
6094 o->op_seq = PL_op_seqmax++;
6098 if (o->op_next && o->op_next->op_type == OP_STRINGIFY) {
6099 if (o->op_next->op_private & OPpTARGET_MY) {
6100 if (o->op_flags & OPf_STACKED) /* chained concats */
6101 goto ignore_optimization;
6103 /* assert(PL_opargs[o->op_type] & OA_TARGLEX); */
6104 o->op_targ = o->op_next->op_targ;
6105 o->op_next->op_targ = 0;
6106 o->op_private |= OPpTARGET_MY;
6109 op_null(o->op_next);
6111 ignore_optimization:
6112 o->op_seq = PL_op_seqmax++;
6115 if ((o->op_flags & OPf_WANT) != OPf_WANT_LIST) {
6116 o->op_seq = PL_op_seqmax++;
6117 break; /* Scalar stub must produce undef. List stub is noop */
6121 if (o->op_targ == OP_NEXTSTATE
6122 || o->op_targ == OP_DBSTATE
6123 || o->op_targ == OP_SETSTATE)
6125 PL_curcop = ((COP*)o);
6127 /* XXX: We avoid setting op_seq here to prevent later calls
6128 to peep() from mistakenly concluding that optimisation
6129 has already occurred. This doesn't fix the real problem,
6130 though (See 20010220.007). AMS 20010719 */
6131 if (oldop && o->op_next) {
6132 oldop->op_next = o->op_next;
6140 if (oldop && o->op_next) {
6141 oldop->op_next = o->op_next;
6144 o->op_seq = PL_op_seqmax++;
6148 if (o->op_next->op_type == OP_RV2SV) {
6149 if (!(o->op_next->op_private & OPpDEREF)) {
6150 op_null(o->op_next);
6151 o->op_private |= o->op_next->op_private & (OPpLVAL_INTRO
6153 o->op_next = o->op_next->op_next;
6154 o->op_type = OP_GVSV;
6155 o->op_ppaddr = PL_ppaddr[OP_GVSV];
6158 else if (o->op_next->op_type == OP_RV2AV) {
6159 OP* pop = o->op_next->op_next;
6161 if (pop && pop->op_type == OP_CONST &&
6162 (PL_op = pop->op_next) &&
6163 pop->op_next->op_type == OP_AELEM &&
6164 !(pop->op_next->op_private &
6165 (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB)) &&
6166 (i = SvIV(((SVOP*)pop)->op_sv) - PL_curcop->cop_arybase)
6171 op_null(o->op_next);
6172 op_null(pop->op_next);
6174 o->op_flags |= pop->op_next->op_flags & OPf_MOD;
6175 o->op_next = pop->op_next->op_next;
6176 o->op_type = OP_AELEMFAST;
6177 o->op_ppaddr = PL_ppaddr[OP_AELEMFAST];
6178 o->op_private = (U8)i;
6183 else if ((o->op_private & OPpEARLY_CV) && ckWARN(WARN_PROTOTYPE)) {
6185 if (SvTYPE(gv) == SVt_PVGV && GvCV(gv) && SvPVX(GvCV(gv))) {
6186 /* XXX could check prototype here instead of just carping */
6187 SV *sv = sv_newmortal();
6188 gv_efullname3(sv, gv, Nullch);
6189 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE),
6190 "%"SVf"() called too early to check prototype",
6194 else if (o->op_next->op_type == OP_READLINE
6195 && o->op_next->op_next->op_type == OP_CONCAT
6196 && (o->op_next->op_next->op_flags & OPf_STACKED))
6198 /* Turn "$a .= <FH>" into an OP_RCATLINE. AMS 20010917 */
6199 o->op_type = OP_RCATLINE;
6200 o->op_flags |= OPf_STACKED;
6201 o->op_ppaddr = PL_ppaddr[OP_RCATLINE];
6202 op_null(o->op_next->op_next);
6203 op_null(o->op_next);
6206 o->op_seq = PL_op_seqmax++;
6219 o->op_seq = PL_op_seqmax++;
6220 while (cLOGOP->op_other->op_type == OP_NULL)
6221 cLOGOP->op_other = cLOGOP->op_other->op_next;
6222 peep(cLOGOP->op_other); /* Recursive calls are not replaced by fptr calls */
6227 o->op_seq = PL_op_seqmax++;
6228 while (cLOOP->op_redoop->op_type == OP_NULL)
6229 cLOOP->op_redoop = cLOOP->op_redoop->op_next;
6230 peep(cLOOP->op_redoop);
6231 while (cLOOP->op_nextop->op_type == OP_NULL)
6232 cLOOP->op_nextop = cLOOP->op_nextop->op_next;
6233 peep(cLOOP->op_nextop);
6234 while (cLOOP->op_lastop->op_type == OP_NULL)
6235 cLOOP->op_lastop = cLOOP->op_lastop->op_next;
6236 peep(cLOOP->op_lastop);
6242 o->op_seq = PL_op_seqmax++;
6243 while (cPMOP->op_pmreplstart &&
6244 cPMOP->op_pmreplstart->op_type == OP_NULL)
6245 cPMOP->op_pmreplstart = cPMOP->op_pmreplstart->op_next;
6246 peep(cPMOP->op_pmreplstart);
6250 o->op_seq = PL_op_seqmax++;
6251 if (ckWARN(WARN_SYNTAX) && o->op_next
6252 && o->op_next->op_type == OP_NEXTSTATE) {
6253 if (o->op_next->op_sibling &&
6254 o->op_next->op_sibling->op_type != OP_EXIT &&
6255 o->op_next->op_sibling->op_type != OP_WARN &&
6256 o->op_next->op_sibling->op_type != OP_DIE) {
6257 line_t oldline = CopLINE(PL_curcop);
6259 CopLINE_set(PL_curcop, CopLINE((COP*)o->op_next));
6260 Perl_warner(aTHX_ packWARN(WARN_EXEC),
6261 "Statement unlikely to be reached");
6262 Perl_warner(aTHX_ packWARN(WARN_EXEC),
6263 "\t(Maybe you meant system() when you said exec()?)\n");
6264 CopLINE_set(PL_curcop, oldline);
6275 o->op_seq = PL_op_seqmax++;
6277 if (((BINOP*)o)->op_last->op_type != OP_CONST)
6280 /* Make the CONST have a shared SV */
6281 svp = cSVOPx_svp(((BINOP*)o)->op_last);
6282 if ((!SvFAKE(sv = *svp) || !SvREADONLY(sv)) && !IS_PADCONST(sv)) {
6283 key = SvPV(sv, keylen);
6284 lexname = newSVpvn_share(key,
6285 SvUTF8(sv) ? -(I32)keylen : keylen,
6294 o->op_seq = PL_op_seqmax++;
6304 char* Perl_custom_op_name(pTHX_ OP* o)
6306 IV index = PTR2IV(o->op_ppaddr);
6310 if (!PL_custom_op_names) /* This probably shouldn't happen */
6311 return PL_op_name[OP_CUSTOM];
6313 keysv = sv_2mortal(newSViv(index));
6315 he = hv_fetch_ent(PL_custom_op_names, keysv, 0, 0);
6317 return PL_op_name[OP_CUSTOM]; /* Don't know who you are */
6319 return SvPV_nolen(HeVAL(he));
6322 char* Perl_custom_op_desc(pTHX_ OP* o)
6324 IV index = PTR2IV(o->op_ppaddr);
6328 if (!PL_custom_op_descs)
6329 return PL_op_desc[OP_CUSTOM];
6331 keysv = sv_2mortal(newSViv(index));
6333 he = hv_fetch_ent(PL_custom_op_descs, keysv, 0, 0);
6335 return PL_op_desc[OP_CUSTOM];
6337 return SvPV_nolen(HeVAL(he));
6343 /* Efficient sub that returns a constant scalar value. */
6345 const_sv_xsub(pTHX_ CV* cv)
6350 Perl_croak(aTHX_ "usage: %s::%s()",
6351 HvNAME(GvSTASH(CvGV(cv))), GvNAME(CvGV(cv)));
6355 ST(0) = (SV*)XSANY.any_ptr;