Add a mention of #p5p to perlhack

[perl5.git] / av.c

diff --git a/av.c b/av.c
index 35748a6..e6b9d22 100644 (file)
--- a/av.c
+++ b/av.c
@@ -9,8 +9,10 @@
  */
 
 /*
  */
 
 /*

- * "...for the Entwives desired order, and plenty, and peace (by which they
- * meant that things should remain where they had set them)." --Treebeard
+ * '...for the Entwives desired order, and plenty, and peace (by which they
+ *  meant that things should remain where they had set them).' --Treebeard
+ *
+ *     [p.476 of _The Lord of the Rings_, III/iv: "Treebeard"]

  */
 
 /*
  */
 
 /*


@@ -33,8 +35,8 @@ Perl_av_reify(pTHX_ AV *av)
     if (AvREAL(av))
        return;
 #ifdef DEBUGGING
     if (AvREAL(av))
        return;
 #ifdef DEBUGGING

-    if (SvTIED_mg((const SV *)av, PERL_MAGIC_tied) && ckWARN_d(WARN_DEBUGGING))
-       Perl_warner(aTHX_ packWARN(WARN_DEBUGGING), "av_reify called on tied array");
+    if (SvTIED_mg((const SV *)av, PERL_MAGIC_tied))
+       Perl_ck_warner_d(aTHX_ packWARN(WARN_DEBUGGING), "av_reify called on tied array");

 #endif
     key = AvMAX(av) + 1;
     while (key > AvFILLp(av) + 1)
 #endif
     key = AvMAX(av) + 1;
     while (key > AvFILLp(av) + 1)


@@ -72,19 +74,10 @@ Perl_av_extend(pTHX_ AV *av, I32 key)
 
     mg = SvTIED_mg((const SV *)av, PERL_MAGIC_tied);
     if (mg) {
 
     mg = SvTIED_mg((const SV *)av, PERL_MAGIC_tied);
     if (mg) {

-       dSP;
-       ENTER;
-       SAVETMPS;
-       PUSHSTACKi(PERLSI_MAGIC);
-       PUSHMARK(SP);
-       EXTEND(SP,2);
-       PUSHs(SvTIED_obj(MUTABLE_SV(av), mg));
-       mPUSHi(key + 1);
-        PUTBACK;
-       call_method("EXTEND", G_SCALAR|G_DISCARD);
-       POPSTACK;
-       FREETMPS;
-       LEAVE;
+       SV *arg1 = sv_newmortal();
+       sv_setiv(arg1, (IV)(key + 1));
+       Perl_magic_methcall(aTHX_ MUTABLE_SV(av), mg, "EXTEND", G_DISCARD, 1,
+                           arg1);

        return;
     }
     if (key > AvMAX(av)) {
        return;
     }
     if (key > AvMAX(av)) {


@@ -157,11 +150,7 @@ Perl_av_extend(pTHX_ AV *av, I32 key)
                assert(newmax >= AvMAX(av));
                Newx(ary, newmax+1, SV*);
                Copy(AvALLOC(av), ary, AvMAX(av)+1, SV*);
                assert(newmax >= AvMAX(av));
                Newx(ary, newmax+1, SV*);
                Copy(AvALLOC(av), ary, AvMAX(av)+1, SV*);

-               if (AvMAX(av) > 64)
-                   offer_nice_chunk(AvALLOC(av),
-                                    (AvMAX(av)+1) * sizeof(const SV *));
-               else
-                   Safefree(AvALLOC(av));
+               Safefree(AvALLOC(av));

                AvALLOC(av) = ary;
 #endif
 #ifdef Perl_safesysmalloc_size
                AvALLOC(av) = ary;
 #endif
 #ifdef Perl_safesysmalloc_size


@@ -198,12 +187,15 @@ Perl_av_extend(pTHX_ AV *av, I32 key)
 =for apidoc av_fetch
 
 Returns the SV at the specified index in the array.  The C<key> is the
 =for apidoc av_fetch
 
 Returns the SV at the specified index in the array.  The C<key> is the

-index.  If C<lval> is set then the fetch will be part of a store.  Check
-that the return value is non-null before dereferencing it to a C<SV*>.
+index.  If lval is true, you are guaranteed to get a real SV back (in case
+it wasn't real before), which you can then modify.  Check that the return
+value is non-null before dereferencing it to a C<SV*>.

 
 See L<perlguts/"Understanding the Magic of Tied Hashes and Arrays"> for
 more information on how to use this function on tied arrays. 
 
 
 See L<perlguts/"Understanding the Magic of Tied Hashes and Arrays"> for
 more information on how to use this function on tied arrays. 
 

+The rough perl equivalent is C<$myarray[$idx]>.
+

 =cut
 */
 
 =cut
 */
 


@@ -243,6 +235,8 @@ Perl_av_fetch(pTHX_ register AV *av, I32 key, I32 lval)
             sv = sv_newmortal();
            sv_upgrade(sv, SVt_PVLV);
            mg_copy(MUTABLE_SV(av), sv, 0, key);
             sv = sv_newmortal();
            sv_upgrade(sv, SVt_PVLV);
            mg_copy(MUTABLE_SV(av), sv, 0, key);

+           if (!tied_magic) /* for regdata, force leavesub to make copies */
+               SvTEMP_off(sv);

            LvTYPE(sv) = 't';
            LvTARG(sv) = sv; /* fake (SV**) */
            return &(LvTARG(sv));
            LvTYPE(sv) = 't';
            LvTARG(sv) = sv; /* fake (SV**) */
            return &(LvTARG(sv));


@@ -281,11 +275,15 @@ Perl_av_fetch(pTHX_ register AV *av, I32 key, I32 lval)
 Stores an SV in an array.  The array index is specified as C<key>.  The
 return value will be NULL if the operation failed or if the value did not
 need to be actually stored within the array (as in the case of tied
 Stores an SV in an array.  The array index is specified as C<key>.  The
 return value will be NULL if the operation failed or if the value did not
 need to be actually stored within the array (as in the case of tied

-arrays). Otherwise it can be dereferenced to get the original C<SV*>.  Note
-that the caller is responsible for suitably incrementing the reference
+arrays). Otherwise, it can be dereferenced to get the C<SV*> that was stored
+there (= C<val>)).
+
+Note that the caller is responsible for suitably incrementing the reference

 count of C<val> before the call, and decrementing it if the function
 returned NULL.
 
 count of C<val> before the call, and decrementing it if the function
 returned NULL.
 

+Approximate Perl equivalent: C<$myarray[$key] = $val;>.
+

 See L<perlguts/"Understanding the Magic of Tied Hashes and Arrays"> for
 more information on how to use this function on tied arrays.
 
 See L<perlguts/"Understanding the Magic of Tied Hashes and Arrays"> for
 more information on how to use this function on tied arrays.
 


@@ -342,7 +340,7 @@ Perl_av_store(pTHX_ register AV *av, I32 key, SV *val)
     }
 
     if (SvREADONLY(av) && key >= AvFILL(av))
     }
 
     if (SvREADONLY(av) && key >= AvFILL(av))

-       Perl_croak(aTHX_ "%s", PL_no_modify);
+       Perl_croak_no_modify(aTHX);

 
     if (!AvREAL(av) && AvREIFY(av))
        av_reify(av);
 
     if (!AvREAL(av) && AvREIFY(av))
        av_reify(av);


@@ -368,7 +366,7 @@ Perl_av_store(pTHX_ register AV *av, I32 key, SV *val)
            sv_magic(val, MUTABLE_SV(av), toLOWER(mg->mg_type), 0, key);
        }
        if (PL_delaymagic && mg->mg_type == PERL_MAGIC_isa)
            sv_magic(val, MUTABLE_SV(av), toLOWER(mg->mg_type), 0, key);
        }
        if (PL_delaymagic && mg->mg_type == PERL_MAGIC_isa)

-           PL_delaymagic |= DM_ARRAY;
+           PL_delaymagic |= DM_ARRAY_ISA;

        else
           mg_set(MUTABLE_SV(av));
     }
        else
           mg_set(MUTABLE_SV(av));
     }


@@ -382,6 +380,8 @@ Creates a new AV and populates it with a list of SVs.  The SVs are copied
 into the array, so they may be freed after the call to av_make.  The new AV
 will have a reference count of 1.
 
 into the array, so they may be freed after the call to av_make.  The new AV
 will have a reference count of 1.
 

+Perl equivalent: C<my @new_array = ($scalar1, $scalar2, $scalar3...);>
+

 =cut
 */
 
 =cut
 */
 


@@ -402,8 +402,14 @@ Perl_av_make(pTHX_ register I32 size, register SV **strp)
        AvFILLp(av) = AvMAX(av) = size - 1;
        for (i = 0; i < size; i++) {
            assert (*strp);
        AvFILLp(av) = AvMAX(av) = size - 1;
        for (i = 0; i < size; i++) {
            assert (*strp);

+
+           /* Don't let sv_setsv swipe, since our source array might
+              have multiple references to the same temp scalar (e.g.
+              from a list slice) */
+

            ary[i] = newSV(0);
            ary[i] = newSV(0);

-           sv_setsv(ary[i], *strp);
+           sv_setsv_flags(ary[i], *strp,
+                          SV_GMAGIC|SV_DO_COW_SVSETSV|SV_NOSTEAL);

            strp++;
        }
     }
            strp++;
        }
     }


@@ -414,7 +420,7 @@ Perl_av_make(pTHX_ register I32 size, register SV **strp)
 =for apidoc av_clear
 
 Clears an array, making it empty.  Does not free the memory used by the
 =for apidoc av_clear
 
 Clears an array, making it empty.  Does not free the memory used by the

-array itself.
+array itself. Perl equivalent: C<@myarray = ();>.

 
 =cut
 */
 
 =cut
 */


@@ -429,19 +435,19 @@ Perl_av_clear(pTHX_ register AV *av)
     assert(SvTYPE(av) == SVt_PVAV);
 
 #ifdef DEBUGGING
     assert(SvTYPE(av) == SVt_PVAV);
 
 #ifdef DEBUGGING

-    if (SvREFCNT(av) == 0 && ckWARN_d(WARN_DEBUGGING)) {
-       Perl_warner(aTHX_ packWARN(WARN_DEBUGGING), "Attempt to clear deleted array");
+    if (SvREFCNT(av) == 0) {
+       Perl_ck_warner_d(aTHX_ packWARN(WARN_DEBUGGING), "Attempt to clear deleted array");

     }
 #endif
 
     if (SvREADONLY(av))
     }
 #endif
 
     if (SvREADONLY(av))

-       Perl_croak(aTHX_ "%s", PL_no_modify);
+       Perl_croak_no_modify(aTHX);

 
     /* Give any tie a chance to cleanup first */
     if (SvRMAGICAL(av)) {
        const MAGIC* const mg = SvMAGIC(av);
        if (PL_delaymagic && mg && mg->mg_type == PERL_MAGIC_isa)
 
     /* Give any tie a chance to cleanup first */
     if (SvRMAGICAL(av)) {
        const MAGIC* const mg = SvMAGIC(av);
        if (PL_delaymagic && mg && mg->mg_type == PERL_MAGIC_isa)

-           PL_delaymagic |= DM_ARRAY;
+           PL_delaymagic |= DM_ARRAY_ISA;

         else
            mg_clear(MUTABLE_SV(av)); 
     }
         else
            mg_clear(MUTABLE_SV(av)); 
     }


@@ -525,7 +531,9 @@ Perl_av_create_and_push(pTHX_ AV **const avp, SV *const val)
 =for apidoc av_push
 
 Pushes an SV onto the end of the array.  The array will grow automatically
 =for apidoc av_push
 
 Pushes an SV onto the end of the array.  The array will grow automatically

-to accommodate the addition.
+to accommodate the addition. This takes ownership of one reference count.
+
+Perl equivalent: C<push @myarray, $elem;>.

 
 =cut
 */
 
 =cut
 */


@@ -540,20 +548,11 @@ Perl_av_push(pTHX_ register AV *av, SV *val)
     assert(SvTYPE(av) == SVt_PVAV);
 
     if (SvREADONLY(av))
     assert(SvTYPE(av) == SVt_PVAV);
 
     if (SvREADONLY(av))

-       Perl_croak(aTHX_ "%s", PL_no_modify);
+       Perl_croak_no_modify(aTHX);

 
     if ((mg = SvTIED_mg((const SV *)av, PERL_MAGIC_tied))) {
 
     if ((mg = SvTIED_mg((const SV *)av, PERL_MAGIC_tied))) {

-       dSP;
-       PUSHSTACKi(PERLSI_MAGIC);
-       PUSHMARK(SP);
-       EXTEND(SP,2);
-       PUSHs(SvTIED_obj(MUTABLE_SV(av), mg));
-       PUSHs(val);
-       PUTBACK;
-       ENTER;
-       call_method("PUSH", G_SCALAR|G_DISCARD);
-       LEAVE;
-       POPSTACK;
+       Perl_magic_methcall(aTHX_ MUTABLE_SV(av), mg, "PUSH", G_DISCARD, 1,
+                           val);

        return;
     }
     av_store(av,AvFILLp(av)+1,val);
        return;
     }
     av_store(av,AvFILLp(av)+1,val);


@@ -565,6 +564,8 @@ Perl_av_push(pTHX_ register AV *av, SV *val)
 Pops an SV off the end of the array.  Returns C<&PL_sv_undef> if the array
 is empty.
 
 Pops an SV off the end of the array.  Returns C<&PL_sv_undef> if the array
 is empty.
 

+Perl equivalent: C<pop(@myarray);>
+

 =cut
 */
 
 =cut
 */
 


@@ -579,21 +580,11 @@ Perl_av_pop(pTHX_ register AV *av)
     assert(SvTYPE(av) == SVt_PVAV);
 
     if (SvREADONLY(av))
     assert(SvTYPE(av) == SVt_PVAV);
 
     if (SvREADONLY(av))

-       Perl_croak(aTHX_ "%s", PL_no_modify);
+       Perl_croak_no_modify(aTHX);

     if ((mg = SvTIED_mg((const SV *)av, PERL_MAGIC_tied))) {
     if ((mg = SvTIED_mg((const SV *)av, PERL_MAGIC_tied))) {

-       dSP;    
-       PUSHSTACKi(PERLSI_MAGIC);
-       PUSHMARK(SP);
-       XPUSHs(SvTIED_obj(MUTABLE_SV(av), mg));
-       PUTBACK;
-       ENTER;
-       if (call_method("POP", G_SCALAR)) {
-           retval = newSVsv(*PL_stack_sp--);    
-       } else {    
-           retval = &PL_sv_undef;
-       }
-       LEAVE;
-       POPSTACK;
+       retval = Perl_magic_methcall(aTHX_ MUTABLE_SV(av), mg, "POP", 0, 0);
+       if (retval)
+           retval = newSVsv(retval);

        return retval;
     }
     if (AvFILL(av) < 0)
        return retval;
     }
     if (AvFILL(av) < 0)


@@ -634,6 +625,8 @@ Unshift the given number of C<undef> values onto the beginning of the
 array.  The array will grow automatically to accommodate the addition.  You
 must then use C<av_store> to assign values to these new elements.
 
 array.  The array will grow automatically to accommodate the addition.  You
 must then use C<av_store> to assign values to these new elements.
 

+Perl equivalent: C<unshift @myarray, ( (undef) x $n );>
+    

 =cut
 */
 
 =cut
 */
 


@@ -648,22 +641,11 @@ Perl_av_unshift(pTHX_ register AV *av, register I32 num)
     assert(SvTYPE(av) == SVt_PVAV);
 
     if (SvREADONLY(av))
     assert(SvTYPE(av) == SVt_PVAV);
 
     if (SvREADONLY(av))

-       Perl_croak(aTHX_ "%s", PL_no_modify);
+       Perl_croak_no_modify(aTHX);

 
     if ((mg = SvTIED_mg((const SV *)av, PERL_MAGIC_tied))) {
 
     if ((mg = SvTIED_mg((const SV *)av, PERL_MAGIC_tied))) {

-       dSP;
-       PUSHSTACKi(PERLSI_MAGIC);
-       PUSHMARK(SP);
-       EXTEND(SP,1+num);
-       PUSHs(SvTIED_obj(MUTABLE_SV(av), mg));
-       while (num-- > 0) {
-           PUSHs(&PL_sv_undef);
-       }
-       PUTBACK;
-       ENTER;
-       call_method("UNSHIFT", G_SCALAR|G_DISCARD);
-       LEAVE;
-       POPSTACK;
+       Perl_magic_methcall(aTHX_ MUTABLE_SV(av), mg, "UNSHIFT",
+                           G_DISCARD | G_UNDEF_FILL, num);

        return;
     }
 
        return;
     }
 


@@ -707,6 +689,8 @@ Perl_av_unshift(pTHX_ register AV *av, register I32 num)
 Shifts an SV off the beginning of the array. Returns C<&PL_sv_undef> if the 
 array is empty.
 
 Shifts an SV off the beginning of the array. Returns C<&PL_sv_undef> if the 
 array is empty.
 

+Perl equivalent: C<shift(@myarray);>
+

 =cut
 */
 
 =cut
 */
 


@@ -721,21 +705,11 @@ Perl_av_shift(pTHX_ register AV *av)
     assert(SvTYPE(av) == SVt_PVAV);
 
     if (SvREADONLY(av))
     assert(SvTYPE(av) == SVt_PVAV);
 
     if (SvREADONLY(av))

-       Perl_croak(aTHX_ "%s", PL_no_modify);
+       Perl_croak_no_modify(aTHX);

     if ((mg = SvTIED_mg((const SV *)av, PERL_MAGIC_tied))) {
     if ((mg = SvTIED_mg((const SV *)av, PERL_MAGIC_tied))) {

-       dSP;
-       PUSHSTACKi(PERLSI_MAGIC);
-       PUSHMARK(SP);
-       XPUSHs(SvTIED_obj(MUTABLE_SV(av), mg));
-       PUTBACK;
-       ENTER;
-       if (call_method("SHIFT", G_SCALAR)) {
-           retval = newSVsv(*PL_stack_sp--);            
-       } else {    
-           retval = &PL_sv_undef;
-       }     
-       LEAVE;
-       POPSTACK;
+       retval = Perl_magic_methcall(aTHX_ MUTABLE_SV(av), mg, "SHIFT", 0, 0);
+       if (retval)
+           retval = newSVsv(retval);

        return retval;
     }
     if (AvFILL(av) < 0)
        return retval;
     }
     if (AvFILL(av) < 0)


@@ -757,6 +731,8 @@ Perl_av_shift(pTHX_ register AV *av)
 Returns the highest index in the array.  The number of elements in the
 array is C<av_len(av) + 1>.  Returns -1 if the array is empty.
 
 Returns the highest index in the array.  The number of elements in the
 array is C<av_len(av) + 1>.  Returns -1 if the array is empty.
 

+The Perl equivalent for this is C<$#myarray>.
+

 =cut
 */
 
 =cut
 */
 


@@ -776,7 +752,7 @@ Set the highest index in the array to the given number, equivalent to
 Perl's C<$#array = $fill;>.
 
 The number of elements in the an array will be C<fill + 1> after
 Perl's C<$#array = $fill;>.
 
 The number of elements in the an array will be C<fill + 1> after

-av_fill() returns.  If the array was previously shorter then the
+av_fill() returns.  If the array was previously shorter, then the

 additional elements appended are set to C<PL_sv_undef>.  If the array
 was longer, then the excess elements are freed.  C<av_fill(av, -1)> is
 the same as C<av_clear(av)>.
 additional elements appended are set to C<PL_sv_undef>.  If the array
 was longer, then the excess elements are freed.  C<av_fill(av, -1)> is
 the same as C<av_clear(av)>.


@@ -795,19 +771,10 @@ Perl_av_fill(pTHX_ register AV *av, I32 fill)
     if (fill < 0)
        fill = -1;
     if ((mg = SvTIED_mg((const SV *)av, PERL_MAGIC_tied))) {
     if (fill < 0)
        fill = -1;
     if ((mg = SvTIED_mg((const SV *)av, PERL_MAGIC_tied))) {

-       dSP;            
-       ENTER;
-       SAVETMPS;
-       PUSHSTACKi(PERLSI_MAGIC);
-       PUSHMARK(SP);
-       EXTEND(SP,2);
-       PUSHs(SvTIED_obj(MUTABLE_SV(av), mg));
-       mPUSHi(fill + 1);
-       PUTBACK;
-       call_method("STORESIZE", G_SCALAR|G_DISCARD);
-       POPSTACK;
-       FREETMPS;
-       LEAVE;
+       SV *arg1 = sv_newmortal();
+       sv_setiv(arg1, (IV)(fill + 1));
+       Perl_magic_methcall(aTHX_ MUTABLE_SV(av), mg, "STORESIZE", G_DISCARD,
+                           1, arg1);

        return;
     }
     if (fill <= AvMAX(av)) {
        return;
     }
     if (fill <= AvMAX(av)) {


@@ -836,9 +803,11 @@ Perl_av_fill(pTHX_ register AV *av, I32 fill)
 /*
 =for apidoc av_delete
 
 /*
 =for apidoc av_delete
 

-Deletes the element indexed by C<key> from the array.  Returns the
-deleted element. If C<flags> equals C<G_DISCARD>, the element is freed
-and null is returned.
+Deletes the element indexed by C<key> from the array, makes the element mortal,
+and returns it.  If C<flags> equals C<G_DISCARD>, the element is freed and null
+is returned.  Perl equivalent: C<my $elem = delete($myarray[$idx]);> for the
+non-C<G_DISCARD> version and a void-context C<delete($myarray[$idx]);> for the
+C<G_DISCARD> version.

 
 =cut
 */
 
 =cut
 */


@@ -852,7 +821,7 @@ Perl_av_delete(pTHX_ AV *av, I32 key, I32 flags)
     assert(SvTYPE(av) == SVt_PVAV);
 
     if (SvREADONLY(av))
     assert(SvTYPE(av) == SVt_PVAV);
 
     if (SvREADONLY(av))

-       Perl_croak(aTHX_ "%s", PL_no_modify);
+       Perl_croak_no_modify(aTHX);

 
     if (SvRMAGICAL(av)) {
         const MAGIC * const tied_magic
 
     if (SvRMAGICAL(av)) {
         const MAGIC * const tied_magic


@@ -930,6 +899,8 @@ Returns true if the element indexed by C<key> has been initialized.
 This relies on the fact that uninitialized array elements are set to
 C<&PL_sv_undef>.
 
 This relies on the fact that uninitialized array elements are set to
 C<&PL_sv_undef>.
 

+Perl equivalent: C<exists($myarray[$key])>.
+

 =cut
 */
 bool
 =cut
 */
 bool


@@ -942,7 +913,9 @@ Perl_av_exists(pTHX_ AV *av, I32 key)
     if (SvRMAGICAL(av)) {
         const MAGIC * const tied_magic
            = mg_find((const SV *)av, PERL_MAGIC_tied);
     if (SvRMAGICAL(av)) {
         const MAGIC * const tied_magic
            = mg_find((const SV *)av, PERL_MAGIC_tied);

-        if (tied_magic || mg_find((const SV *)av, PERL_MAGIC_regdata)) {
+        const MAGIC * const regdata_magic
+            = mg_find((const SV *)av, PERL_MAGIC_regdata);
+        if (tied_magic || regdata_magic) {

            SV * const sv = sv_newmortal();
             MAGIC *mg;
             /* Handle negative array indices 20020222 MJD */
            SV * const sv = sv_newmortal();
             MAGIC *mg;
             /* Handle negative array indices 20020222 MJD */


@@ -961,14 +934,23 @@ Perl_av_exists(pTHX_ AV *av, I32 key)
                     key += AvFILL(av) + 1;
                     if (key < 0)
                         return FALSE;
                     key += AvFILL(av) + 1;
                     if (key < 0)
                         return FALSE;

+                    else
+                        return TRUE;

                 }
             }
 
                 }
             }
 

+            if(key >= 0 && regdata_magic) {
+                if (key <= AvFILL(av))
+                    return TRUE;
+                else
+                    return FALSE;
+            }
+

             mg_copy(MUTABLE_SV(av), sv, 0, key);
             mg = mg_find(sv, PERL_MAGIC_tiedelem);
             if (mg) {
                 magic_existspack(sv, mg);
             mg_copy(MUTABLE_SV(av), sv, 0, key);
             mg = mg_find(sv, PERL_MAGIC_tiedelem);
             if (mg) {
                 magic_existspack(sv, mg);

-                return (bool)SvTRUE(sv);
+                return cBOOL(SvTRUE(sv));

             }
 
         }
             }
 
         }