This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Abolish cop_arybase. Signal a non zero $[ with a hint flag, and store
authorNicholas Clark <nick@ccl4.org>
Sat, 20 May 2006 11:29:26 +0000 (11:29 +0000)
committerNicholas Clark <nick@ccl4.org>
Sat, 20 May 2006 11:29:26 +0000 (11:29 +0000)
the value in the hints structure used for %^H.

p4raw-id: //depot/perl@28250

cop.h
embed.fnc
embed.h
global.sym
hv.c
op.c
perl.h
proto.h

diff --git a/cop.h b/cop.h
index ed6151e..749b128 100644 (file)
--- a/cop.h
+++ b/cop.h
@@ -144,7 +144,6 @@ struct cop {
     GV *       cop_filegv;     /* file the following line # is from */
 #endif
     U32                cop_seq;        /* parse sequence number */
-    I32                cop_arybase;    /* array base this line was compiled with */
     line_t      cop_line;       /* line # of this command */
     /* Beware. mg.c and warnings.pl assume the type of this is STRLEN *:  */
     STRLEN *   cop_warnings;   /* lexical warnings bitmask */
@@ -230,10 +229,26 @@ struct cop {
 #  define OutCopFILE(c) CopFILE(c)
 #endif
 
-/* CopARYBASE is likely to be removed soon.  */
-#define CopARYBASE(c)          ((c)->cop_arybase)
-#define CopARYBASE_get(c)      ((c)->cop_arybase + 0)
-#define CopARYBASE_set(c, b)   STMT_START { (c)->cop_arybase = (b); } STMT_END
+/* If $[ is non-zero, it's stored in cop_hints under the key "$[", and
+   HINT_ARYBASE is set to indicate this.
+   Setting it is ineficient due to the need to create 2 mortal SVs, but as
+   using $[ is highly discouraged, no sane Perl code will be using it.  */
+#define CopARYBASE_get(c)      \
+       ((CopHINTS_get(c) & HINT_ARYBASE)                               \
+        ? SvIV(Perl_refcounted_he_fetch(aTHX_ (c)->cop_hints, 0, "$[", 2, 0, \
+                                        0))                            \
+        : 0)
+#define CopARYBASE_set(c, b) STMT_START { \
+       if (b || ((c)->op_private & HINT_ARYBASE)) {                    \
+           (c)->op_private |= HINT_ARYBASE;                            \
+           if ((c) == &PL_compiling)                                   \
+               PL_hints |= HINT_LOCALIZE_HH | HINT_ARYBASE;            \
+           (c)->cop_hints                                              \
+              = Perl_refcounted_he_new(aTHX_ (c)->cop_hints,           \
+                                       sv_2mortal(newSVpvs("$[")),     \
+                                       sv_2mortal(newSViv(b)));        \
+       }                                                               \
+    } STMT_END
 
 /* FIXME NATIVE_HINTS if this is changed from op_private (see perl.h)  */
 #define CopHINTS_get(c)                ((c)->op_private + 0)
index dac19c7..097023f 100644 (file)
--- a/embed.fnc
+++ b/embed.fnc
@@ -308,6 +308,9 @@ ApdR        |SV*    |hv_iterval     |NN HV* tb|NN HE* entry
 Ap     |void   |hv_ksplit      |NN HV* hv|IV newmax
 Apdbm  |void   |hv_magic       |NN HV* hv|NULLOK GV* gv|int how
 dpoM   |HV *   |refcounted_he_chain_2hv|NULLOK const struct refcounted_he *c
+XEpoM  |SV *   |refcounted_he_fetch|NN const struct refcounted_he *chain \
+                               |NULLOK SV *keysv|NULLOK const char *key \
+                               |STRLEN klen, int flags, U32 hash
 dpoM   |void   |refcounted_he_free|NULLOK struct refcounted_he *he
 dpoM   |struct refcounted_he *|refcounted_he_new \
                                |NULLOK struct refcounted_he *const parent \
@@ -1094,6 +1097,7 @@ sM        |SV*    |hv_delete_common|NULLOK HV* tb|NULLOK SV* keysv|NULLOK const char* key
 sM     |HE*    |hv_fetch_common|NULLOK HV* tb|NULLOK SV* keysv|NULLOK const char* key \
                |STRLEN klen|int flags|int action|NULLOK SV* val|U32 hash
 sM     |void   |clear_placeholders     |NN HV* hb|U32 items
+sM     |SV *   |refcounted_he_value    |NN const struct refcounted_he *he
 #endif
 
 #if defined(PERL_IN_MG_C) || defined(PERL_DECL_PROT)
diff --git a/embed.h b/embed.h
index 2d1e719..df7750c 100644 (file)
--- a/embed.h
+++ b/embed.h
 #define hv_delete_common       S_hv_delete_common
 #define hv_fetch_common                S_hv_fetch_common
 #define clear_placeholders     S_clear_placeholders
+#define refcounted_he_value    S_refcounted_he_value
 #endif
 #endif
 #if defined(PERL_IN_MG_C) || defined(PERL_DECL_PROT)
 #define hv_ksplit(a,b)         Perl_hv_ksplit(aTHX_ a,b)
 #ifdef PERL_CORE
 #endif
+#if defined(PERL_CORE) || defined(PERL_EXT)
+#endif
+#ifdef PERL_CORE
+#endif
 #define hv_store(a,b,c,d,e)    Perl_hv_store(aTHX_ a,b,c,d,e)
 #define hv_store_ent(a,b,c,d)  Perl_hv_store_ent(aTHX_ a,b,c,d)
 #define hv_store_flags(a,b,c,d,e,f)    Perl_hv_store_flags(aTHX_ a,b,c,d,e,f)
 #define hv_delete_common(a,b,c,d,e,f,g)        S_hv_delete_common(aTHX_ a,b,c,d,e,f,g)
 #define hv_fetch_common(a,b,c,d,e,f,g,h)       S_hv_fetch_common(aTHX_ a,b,c,d,e,f,g,h)
 #define clear_placeholders(a,b)        S_clear_placeholders(aTHX_ a,b)
+#define refcounted_he_value(a) S_refcounted_he_value(aTHX_ a)
 #endif
 #endif
 #if defined(PERL_IN_MG_C) || defined(PERL_DECL_PROT)
index dfe7eda..88fdd63 100644 (file)
@@ -164,6 +164,7 @@ Perl_hv_iternext_flags
 Perl_hv_iterval
 Perl_hv_ksplit
 Perl_hv_magic
+Perl_refcounted_he_fetch
 Perl_hv_store
 Perl_hv_store_ent
 Perl_hv_store_flags
diff --git a/hv.c b/hv.c
index b6bc29e..04a9ab3 100644 (file)
--- a/hv.c
+++ b/hv.c
@@ -2552,6 +2552,51 @@ Perl_hv_placeholders_set(pTHX_ HV *hv, I32 ph)
     /* else we don't need to add magic to record 0 placeholders.  */
 }
 
+SV *
+S_refcounted_he_value(pTHX_ const struct refcounted_he *he)
+{
+    SV *value;
+    switch(he->refcounted_he_data[0] & HVrhek_typemask) {
+    case HVrhek_undef:
+       value = newSV(0);
+       break;
+    case HVrhek_delete:
+       value = &PL_sv_placeholder;
+       break;
+    case HVrhek_IV:
+       value = (he->refcounted_he_data[0] & HVrhek_UV)
+           ? newSVuv(he->refcounted_he_val.refcounted_he_u_iv)
+           : newSViv(he->refcounted_he_val.refcounted_he_u_uv);
+       break;
+    case HVrhek_PV:
+       /* Create a string SV that directly points to the bytes in our
+          structure.  */
+       value = newSV(0);
+       sv_upgrade(value, SVt_PV);
+       SvPV_set(value, (char *) he->refcounted_he_data + 1);
+       SvCUR_set(value, he->refcounted_he_val.refcounted_he_u_len);
+       /* This stops anything trying to free it  */
+       SvLEN_set(value, 0);
+       SvPOK_on(value);
+       SvREADONLY_on(value);
+       if (he->refcounted_he_data[0] & HVrhek_UTF8)
+           SvUTF8_on(value);
+       break;
+    default:
+       Perl_croak(aTHX_ "panic: refcounted_he_value bad flags %x",
+                  he->refcounted_he_data[0]);
+    }
+    return value;
+}
+
+#ifdef USE_ITHREADS
+/* A big expression to find the key offset */
+#define REF_HE_KEY(chain) \
+       ((((chain->refcounted_he_data[0] & HVrhek_typemask) == HVrhek_PV) \
+           ? chain->refcounted_he_val.refcounted_he_u_len + 1 : 0)       \
+        + 1 + chain->refcounted_he_data)
+#endif
+
 /*
 =for apidoc refcounted_he_chain_2hv
 
@@ -2597,11 +2642,7 @@ Perl_refcounted_he_chain_2hv(pTHX_ const struct refcounted_he *chain)
 
 #ifdef USE_ITHREADS
        HeKEY_hek(entry)
-           = share_hek_flags(/* A big expression to find the key offset */
-                             (((chain->refcounted_he_data[0]
-                                & HVrhek_typemask) == HVrhek_PV)
-                              ? chain->refcounted_he_val.refcounted_he_u_len
-                              + 1 : 0) + 1 + chain->refcounted_he_data,
+           = share_hek_flags(REF_HE_KEY(chain),
                              chain->refcounted_he_keylen,
                              chain->refcounted_he_hash,
                              (chain->refcounted_he_data[0]
@@ -2609,38 +2650,9 @@ Perl_refcounted_he_chain_2hv(pTHX_ const struct refcounted_he *chain)
 #else
        HeKEY_hek(entry) = share_hek_hek(chain->refcounted_he_hek);
 #endif
-
-       switch(chain->refcounted_he_data[0] & HVrhek_typemask) {
-       case HVrhek_undef:
-           value = newSV(0);
-           break;
-       case HVrhek_delete:
-           value = &PL_sv_placeholder;
+       value = refcounted_he_value(chain);
+       if (value == &PL_sv_placeholder)
            placeholders++;
-           break;
-       case HVrhek_IV:
-           value = (chain->refcounted_he_data[0] & HVrhek_UV)
-               ? newSVuv(chain->refcounted_he_val.refcounted_he_u_iv)
-               : newSViv(chain->refcounted_he_val.refcounted_he_u_uv);
-           break;
-       case HVrhek_PV:
-           /* Create a string SV that directly points to the bytes in our
-              structure.  */
-           value = newSV(0);
-           sv_upgrade(value, SVt_PV);
-           SvPV_set(value, (char *) chain->refcounted_he_data + 1);
-           SvCUR_set(value, chain->refcounted_he_val.refcounted_he_u_len);
-           /* This stops anything trying to free it  */
-           SvLEN_set(value, 0);
-           SvPOK_on(value);
-           SvREADONLY_on(value);
-           if (chain->refcounted_he_data[0] & HVrhek_UTF8)
-               SvUTF8_on(value);
-           break;
-       default:
-           Perl_croak(aTHX_ "panic: refcounted_he_chain_2hv bad flags %x",
-                      chain->refcounted_he_data[0]);
-       }
        HeVAL(entry) = value;
 
        /* Link it into the chain.  */
@@ -2671,6 +2683,60 @@ Perl_refcounted_he_chain_2hv(pTHX_ const struct refcounted_he *chain)
     return hv;
 }
 
+SV *
+Perl_refcounted_he_fetch(pTHX_ const struct refcounted_he *chain, SV *keysv,
+                        const char *key, STRLEN klen, int flags, U32 hash)
+{
+    /* Just to be awkward, if you're using this interface the UTF-8-or-not-ness
+       of your key has to exactly match that which is stored.  */
+    SV *value = &PL_sv_placeholder;
+    bool is_utf8;
+
+    if (keysv) {
+       if (flags & HVhek_FREEKEY)
+           Safefree(key);
+       key = SvPV_const(keysv, klen);
+       flags = 0;
+       is_utf8 = (SvUTF8(keysv) != 0);
+    } else {
+       is_utf8 = ((flags & HVhek_UTF8) ? TRUE : FALSE);
+    }
+
+    if (!hash) {
+       if (keysv && (SvIsCOW_shared_hash(keysv))) {
+            hash = SvSHARED_HASH(keysv);
+        } else {
+            PERL_HASH(hash, key, klen);
+        }
+    }
+
+    for (; chain; chain = chain->refcounted_he_next) {
+#ifdef USE_ITHREADS
+       if (hash != chain->refcounted_he_hash)
+           continue;
+       if (klen != chain->refcounted_he_keylen)
+           continue;
+       if (memNE(REF_HE_KEY(chain),key,klen))
+           continue;
+#else
+       if (hash != HEK_HASH(chain->refcounted_he_hek))
+           continue;
+       if (klen != HEK_LEN(chain->refcounted_he_hek))
+           continue;
+       if (memNE(HEK_KEY(chain->refcounted_he_hek),key,klen))
+           continue;
+#endif
+
+       value = sv_2mortal(refcounted_he_value(chain));
+       break;
+    }
+
+    if (flags & HVhek_FREEKEY)
+       Safefree(key);
+
+    return value;
+}
+
 /*
 =for apidoc refcounted_he_new
 
diff --git a/op.c b/op.c
index f5e24fc..c86c184 100644 (file)
--- a/op.c
+++ b/op.c
@@ -3946,7 +3946,8 @@ Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o)
        PL_hints |= HINT_BLOCK_SCOPE;
     }
     cop->cop_seq = seq;
-    CopARYBASE_set(cop, CopARYBASE_get(PL_curcop));
+    /* CopARYBASE is now "virtual", in that it's stored as a flag bit in
+       CopHINTS and a possible value in cop_hints, so no need to copy it.  */
     cop->cop_warnings = DUP_WARNINGS(PL_curcop->cop_warnings);
     if (specialCopIO(PL_curcop->cop_io))
         cop->cop_io = PL_curcop->cop_io;
diff --git a/perl.h b/perl.h
index 5b4dbdd..f438ca0 100644 (file)
--- a/perl.h
+++ b/perl.h
@@ -4215,7 +4215,7 @@ enum {            /* pass one of these to get_vtbl */
 #define HINT_STRICT_REFS       0x00000002 /* strict pragma */
 #define HINT_LOCALE            0x00000004 /* locale pragma */
 #define HINT_BYTES             0x00000008 /* bytes pragma */
-/* #define HINT_notused10      0x00000010 */
+#define HINT_ARYBASE           0x00000010 /* $[ is non-zero */
                                /* Note: 20,40,80 used for NATIVE_HINTS */
                                /* currently defined by vms/vmsish.h */
 
diff --git a/proto.h b/proto.h
index 0d8d7b1..609341f 100644 (file)
--- a/proto.h
+++ b/proto.h
@@ -731,6 +731,9 @@ PERL_CALLCONV void  Perl_hv_ksplit(pTHX_ HV* hv, IV newmax)
                        __attribute__nonnull__(pTHX_1); */
 
 PERL_CALLCONV HV *     Perl_refcounted_he_chain_2hv(pTHX_ const struct refcounted_he *c);
+PERL_CALLCONV SV *     Perl_refcounted_he_fetch(pTHX_ const struct refcounted_he *chain, SV *keysv, const char *key, STRLEN klen, int flags, U32 hash)
+                       __attribute__nonnull__(pTHX_1);
+
 PERL_CALLCONV void     Perl_refcounted_he_free(pTHX_ struct refcounted_he *he);
 PERL_CALLCONV struct refcounted_he *   Perl_refcounted_he_new(pTHX_ struct refcounted_he *const parent, SV *const key, SV *const value);
 PERL_CALLCONV SV**     Perl_hv_store(pTHX_ HV* tb, const char* key, I32 klen, SV* val, U32 hash);
@@ -2955,6 +2958,9 @@ STATIC HE*        S_hv_fetch_common(pTHX_ HV* tb, SV* keysv, const char* key, STRLEN kl
 STATIC void    S_clear_placeholders(pTHX_ HV* hb, U32 items)
                        __attribute__nonnull__(pTHX_1);
 
+STATIC SV *    S_refcounted_he_value(pTHX_ const struct refcounted_he *he)
+                       __attribute__nonnull__(pTHX_1);
+
 #endif
 
 #if defined(PERL_IN_MG_C) || defined(PERL_DECL_PROT)