perlfunc.pod use documentation (5.6.0)

[p5sagit/p5-mst-13.2.git] / op.c

diff --git a/op.c b/op.c
index affb597..86bd419 100644 (file)
--- a/op.c
+++ b/op.c
@@ -1851,6 +1851,37 @@ S_apply_attrs(pTHX_ HV *stash, SV *target, OP *attrs)
     LEAVE;
 }
 
+void
+Perl_apply_attrs_string(pTHX_ char *stashpv, CV *cv,
+                        char *attrstr, STRLEN len)
+{
+    OP *attrs = Nullop;
+
+    if (!len) {
+        len = strlen(attrstr);
+    }
+
+    while (len) {
+        for (; isSPACE(*attrstr) && len; --len, ++attrstr) ;
+        if (len) {
+            char *sstr = attrstr;
+            for (; !isSPACE(*attrstr) && len; --len, ++attrstr) ;
+            attrs = append_elem(OP_LIST, attrs,
+                                newSVOP(OP_CONST, 0,
+                                        newSVpvn(sstr, attrstr-sstr)));
+        }
+    }
+
+    Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
+                     newSVpvn(ATTRSMODULE, sizeof(ATTRSMODULE)-1),
+                     Nullsv, prepend_elem(OP_LIST,
+                                 newSVOP(OP_CONST, 0, newSVpv(stashpv,0)),
+                                 prepend_elem(OP_LIST,
+                                              newSVOP(OP_CONST, 0,
+                                                      newRV((SV*)cv)),
+                                               attrs)));
+}
+
 STATIC OP *
 S_my_kid(pTHX_ OP *o, OP *attrs)
 {
@@ -1952,11 +1983,14 @@ Perl_bind_match(pTHX_ I32 type, OP *left, OP *right)
              desc, sample, sample);
     }
 
-    if (right->op_type == OP_MATCH ||
+    if (!(right->op_flags & OPf_STACKED) &&
+       (right->op_type == OP_MATCH ||
        right->op_type == OP_SUBST ||
-       right->op_type == OP_TRANS) {
+       right->op_type == OP_TRANS)) {
        right->op_flags |= OPf_STACKED;
-       if (right->op_type != OP_MATCH)
+       if (right->op_type != OP_MATCH &&
+            ! (right->op_type == OP_TRANS &&
+               right->op_private & OPpTRANS_IDENTICAL))
            left = mod(left, right->op_type);
        if (right->op_type == OP_TRANS)
            o = newBINOP(OP_NULL, OPf_STACKED, scalar(left), right);
@@ -2574,6 +2608,12 @@ Perl_pmtrans(pTHX_ OP *o, OP *expr, OP *repl)
     complement = o->op_private & OPpTRANS_COMPLEMENT;
     del                = o->op_private & OPpTRANS_DELETE;
     squash     = o->op_private & OPpTRANS_SQUASH;
+    
+    if (SvUTF8(tstr))
+        o->op_private |= OPpTRANS_FROM_UTF;
+    
+    if (SvUTF8(rstr)) 
+        o->op_private |= OPpTRANS_TO_UTF;
 
     if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
        SV* listsv = newSVpvn("# comment\n",10);
@@ -2645,15 +2685,11 @@ Perl_pmtrans(pTHX_ OP *o, OP *expr, OP *repl)
            r = t; rlen = tlen; rend = tend;
        }
        if (!squash) {
-           if (to_utf && from_utf) {   /* only counting characters */
-               if (t == r || (tlen == rlen && memEQ(t, r, tlen)))
-                   o->op_private |= OPpTRANS_IDENTICAL;
-           }
-           else {      /* straight latin-1 translation */
-               if (tlen == 4 && memEQ(t, "\0\377\303\277", 4) &&
-                   rlen == 4 && memEQ(r, "\0\377\303\277", 4))
+               if (t == r ||
+                   (tlen == rlen && memEQ((char *)t, (char *)r, tlen)))
+               {
                    o->op_private |= OPpTRANS_IDENTICAL;
-           }
+               }
        }
 
        while (t < tend || tfirst <= tlast) {
@@ -4430,9 +4466,15 @@ Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
     if (!name || GvCVGEN(gv))
        cv = Nullcv;
     else if ((cv = GvCV(gv))) {
-       cv_ckproto(cv, gv, ps);
+        bool exists = CvROOT(cv) || CvXSUB(cv);
+        /* if the subroutine doesn't exist and wasn't pre-declared
+         * with a prototype, assume it will be AUTOLOADed,
+         * skipping the prototype check
+         */
+        if (exists || SvPOK(cv))
+           cv_ckproto(cv, gv, ps);
        /* already defined (or promised)? */
-       if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) {
+       if (exists || GvASSUMECV(gv)) {
            SV* const_sv;
            bool const_changed = TRUE;
            if (!block && !attrs) {
@@ -4447,7 +4489,7 @@ Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
                goto withattrs;
            if ((const_sv = cv_const_sv(cv)))
                const_changed = sv_cmp(const_sv, op_const_sv(block, Nullcv));
-           if ((const_sv || const_changed) && ckWARN(WARN_REDEFINE))
+            if ((const_sv && const_changed) || ckWARN(WARN_REDEFINE))
            {
                line_t oldline = CopLINE(PL_curcop);
                CopLINE_set(PL_curcop, PL_copline);
@@ -5339,6 +5381,7 @@ Perl_ck_rvconst(pTHX_ register OP *o)
 #ifdef USE_ITHREADS
            /* XXX hack: dependence on sizeof(PADOP) <= sizeof(SVOP) */
            kPADOP->op_padix = pad_alloc(OP_GV, SVs_PADTMP);
+           SvREFCNT_dec(PL_curpad[kPADOP->op_padix]);
            GvIN_PAD_on(gv);
            PL_curpad[kPADOP->op_padix] = SvREFCNT_inc(gv);
 #else
@@ -6159,7 +6202,7 @@ Perl_ck_split(pTHX_ OP *o)
        cLISTOPo->op_last = kid; /* There was only one element previously */
     }
 
-    if (kid->op_type != OP_MATCH) {
+    if (kid->op_type != OP_MATCH || kid->op_flags & OPf_STACKED) {
        OP *sibl = kid->op_sibling;
        kid->op_sibling = 0;
        kid = pmruntime( newPMOP(OP_MATCH, OPf_SPECIAL), kid, Nullop);