*/
/*
-=head1 Array Manipulation Functions
+=for apidoc_section AV Handling
*/
#include "EXTERN.h"
/*
=for apidoc av_extend
-Pre-extend an array. The C<key> is the index to which the array should be
-extended.
+Pre-extend an array so that it is capable of storing values at indexes
+C<0..key>. Thus C<av_extend(av,99)> guarantees that the array can store 100
+elements, i.e. that C<av_store(av, 0, sv)> through C<av_store(av, 99, sv)>
+on a plain array will work without any further memory allocation.
+
+If the av argument is a tied array then will call the C<EXTEND> tied
+array method with an argument of C<(key+1)>.
=cut
*/
mg = SvTIED_mg((const SV *)av, PERL_MAGIC_tied);
if (mg) {
SV *arg1 = sv_newmortal();
+ /* NOTE: the API for av_extend() is NOT the same as the tie method EXTEND.
+ *
+ * The C function takes an *index* (assumes 0 indexed arrays) and ensures
+ * that the array is at least as large as the index provided.
+ *
+ * The tied array method EXTEND takes a *count* and ensures that the array
+ * is at least that many elements large. Thus we have to +1 the key when
+ * we call the tied method.
+ */
sv_setiv(arg1, (IV)(key + 1));
Perl_magic_methcall(aTHX_ MUTABLE_SV(av), mg, SV_CONST(EXTEND), G_DISCARD, 1,
arg1);
if (key < -1) /* -1 is legal */
Perl_croak(aTHX_
- "panic: av_extend_guts() negative count (%"IVdf")", (IV)key);
+ "panic: av_extend_guts() negative count (%" IVdf ")", (IV)key);
if (key > *maxp) {
SV** ary;
? SSize_t_MAX : key + newmax;
resize:
{
-#ifdef PERL_MALLOC_WRAP /* Duplicated in pp_hot.c */
- static const char oom_array_extend[] =
- "Out of memory during array extend";
-#endif
/* it should really be newmax+1 here, but if newmax
* happens to equal SSize_t_MAX, then newmax+1 is
* undefined. This means technically we croak one
* index lower than we should in theory; in practice
* its unlikely the system has SSize_t_MAX/sizeof(SV*)
* bytes to spare! */
- MEM_WRAP_CHECK_1(newmax, SV*, oom_array_extend);
+ MEM_WRAP_CHECK_s(newmax, SV*, "Out of memory during array extend");
}
#ifdef STRESS_REALLOC
{
else {
newmax = key < 3 ? 3 : key;
{
-#ifdef PERL_MALLOC_WRAP /* Duplicated in pp_hot.c */
- static const char oom_array_extend[] =
- "Out of memory during array extend";
-#endif
/* see comment above about newmax+1*/
- MEM_WRAP_CHECK_1(newmax, SV*, oom_array_extend);
+ MEM_WRAP_CHECK_s(newmax, SV*, "Out of memory during array extend");
}
Newx(*allocp, newmax+1, SV*);
ary = *allocp + 1;
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]>.
+The rough perl equivalent is C<$myarray[$key]>.
=cut
*/
SV**
Perl_av_fetch(pTHX_ AV *av, SSize_t key, I32 lval)
{
+ SSize_t neg;
+ SSize_t size;
+
PERL_ARGS_ASSERT_AV_FETCH;
assert(SvTYPE(av) == SVt_PVAV);
}
}
- if (key < 0) {
- key += AvFILLp(av) + 1;
- if (UNLIKELY(key < 0))
+ neg = (key < 0);
+ size = AvFILLp(av) + 1;
+ key += neg * size; /* handle negative index without using branch */
+
+ /* the cast from SSize_t to Size_t allows both (key < 0) and (key >= size)
+ * to be tested as a single condition */
+ if ((Size_t)key >= (Size_t)size) {
+ if (UNLIKELY(neg))
return NULL;
- assert(key <= AvFILLp(av));
- if (!AvARRAY(av)[key])
- goto emptyness;
+ goto emptyness;
}
- else if (key > AvFILLp(av) || !AvARRAY(av)[key]) {
+
+ if (!AvARRAY(av)[key]) {
emptyness:
return lval ? av_store(av,key,newSV(0)) : NULL;
}
- if (UNLIKELY(AvREIFY(av) && SvIS_FREED(AvARRAY(av)[key]))) {
- /* eg. @_ could have freed elts */
- AvARRAY(av)[key] = NULL; /* 1/2 reify */
- goto emptyness;
- }
return &AvARRAY(av)[key];
}
count of C<val> before the call, and decrementing it if the function
returned C<NULL>.
-Approximate Perl equivalent: C<$myarray[$key] = $val;>.
+Approximate Perl equivalent: C<splice(@myarray, $key, 1, $val)>.
See L<perlguts/"Understanding the Magic of Tied Hashes and Arrays"> for
more information on how to use this function on tied arrays.
if (size) { /* "defined" was returning undef for size==0 anyway. */
SV** ary;
SSize_t i;
+ SSize_t orig_ix;
+
Newx(ary,size,SV*);
AvALLOC(av) = ary;
AvARRAY(av) = ary;
AvMAX(av) = size - 1;
AvFILLp(av) = -1;
- ENTER;
- SAVEFREESV(av);
+ /* avoid av being leaked if croak when calling magic below */
+ EXTEND_MORTAL(1);
+ PL_tmps_stack[++PL_tmps_ix] = (SV*)av;
+ orig_ix = PL_tmps_ix;
+
for (i = 0; i < size; i++) {
assert (*strp);
SV_DO_COW_SVSETSV|SV_NOSTEAL);
strp++;
}
- SvREFCNT_inc_simple_void_NN(av);
- LEAVE;
+ /* disarm av's leak guard */
+ if (LIKELY(PL_tmps_ix == orig_ix))
+ PL_tmps_ix--;
+ else
+ PL_tmps_stack[orig_ix] = &PL_sv_undef;
}
return av;
}
{
SSize_t extra;
bool real;
+ SSize_t orig_ix = 0;
PERL_ARGS_ASSERT_AV_CLEAR;
assert(SvTYPE(av) == SVt_PVAV);
if (AvMAX(av) < 0)
return;
- if ((real = !!AvREAL(av))) {
+ if ((real = cBOOL(AvREAL(av)))) {
SV** const ary = AvARRAY(av);
SSize_t index = AvFILLp(av) + 1;
- ENTER;
- SAVEFREESV(SvREFCNT_inc_simple_NN(av));
+
+ /* avoid av being freed when calling destructors below */
+ EXTEND_MORTAL(1);
+ PL_tmps_stack[++PL_tmps_ix] = SvREFCNT_inc_simple_NN(av);
+ orig_ix = PL_tmps_ix;
+
while (index) {
SV * const sv = ary[--index];
/* undef the slot before freeing the value, because a
AvARRAY(av) = AvALLOC(av);
}
AvFILLp(av) = -1;
- if (real) LEAVE;
+ if (real) {
+ /* disarm av's premature free guard */
+ if (LIKELY(PL_tmps_ix == orig_ix))
+ PL_tmps_ix--;
+ else
+ PL_tmps_stack[orig_ix] = &PL_sv_undef;
+ SvREFCNT_dec_NN(av);
+ }
}
/*
Perl_av_undef(pTHX_ AV *av)
{
bool real;
+ SSize_t orig_ix = PL_tmps_ix; /* silence bogus warning about possible unitialized use */
PERL_ARGS_ASSERT_AV_UNDEF;
assert(SvTYPE(av) == SVt_PVAV);
if (SvTIED_mg((const SV *)av, PERL_MAGIC_tied))
av_fill(av, -1);
- if ((real = !!AvREAL(av))) {
+ real = cBOOL(AvREAL(av));
+ if (real) {
SSize_t key = AvFILLp(av) + 1;
- ENTER;
- SAVEFREESV(SvREFCNT_inc_simple_NN(av));
+
+ /* avoid av being freed when calling destructors below */
+ EXTEND_MORTAL(1);
+ PL_tmps_stack[++PL_tmps_ix] = SvREFCNT_inc_simple_NN(av);
+ orig_ix = PL_tmps_ix;
+
while (key)
SvREFCNT_dec(AvARRAY(av)[--key]);
}
AvMAX(av) = AvFILLp(av) = -1;
if(SvRMAGICAL(av)) mg_clear(MUTABLE_SV(av));
- if(real) LEAVE;
+ if (real) {
+ /* disarm av's premature free guard */
+ if (LIKELY(PL_tmps_ix == orig_ix))
+ PL_tmps_ix--;
+ else
+ PL_tmps_stack[orig_ix] = &PL_sv_undef;
+ SvREFCNT_dec_NN(av);
+ }
}
/*
Pushes an SV (transferring control of one reference count) onto the end of the
array. The array will grow automatically to accommodate the addition.
-Perl equivalent: C<push @myarray, $elem;>.
+Perl equivalent: C<push @myarray, $val;>.
=cut
*/
=for apidoc av_unshift
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.
-Perl equivalent: S<C<unshift @myarray, ( (undef) x $n );>>
+Perl equivalent: S<C<unshift @myarray, ((undef) x $num);>>
=cut
*/
}
/*
-=for apidoc av_top_index
+=for apidoc av_tindex
+=for apidoc_item av_top_index
-Returns the highest index in the array. The number of elements in the
-array is S<C<av_top_index(av) + 1>>. Returns -1 if the array is empty.
+These behave identically.
+If the array C<av> is empty, these return -1; otherwise they return the maximum
+value of the indices of all the array elements which are currently defined in
+C<av>.
-The Perl equivalent for this is C<$#myarray>.
+They process 'get' magic.
-(A slightly shorter form is C<av_tindex>.)
+The Perl equivalent for these is C<$#av>.
+
+Use C<L</av_count>> to get the number of elements in an array.
=for apidoc av_len
Same as L</av_top_index>. Note that, unlike what the name implies, it returns
-the highest index in the array, so to get the size of the array you need to use
-S<C<av_len(av) + 1>>. This is unlike L</sv_len>, which returns what you would
-expect.
+the maximum index in the array. This is unlike L</sv_len>, which returns what
+you would expect.
+
+B<To get the true number of elements in the array, instead use C<L</av_count>>>.
=cut
*/
/*
=for apidoc av_delete
-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: S<C<my $elem = delete($myarray[$idx]);>> for the
-non-C<G_DISCARD> version and a void-context S<C<delete($myarray[$idx]);>> for the
-C<G_DISCARD> version.
+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. NULL is also returned if C<key> is out of
+range.
+
+Perl equivalent: S<C<splice(@myarray, $key, 1, undef)>> (with the
+C<splice> in void context if C<G_DISCARD> is present).
=cut
*/
if (key <= AvFILLp(av) && AvARRAY(av)[key])
{
+ if (SvSMAGICAL(AvARRAY(av)[key])
+ && mg_find(AvARRAY(av)[key], PERL_MAGIC_nonelem))
+ return FALSE;
return TRUE;
}
else
PERL_ARGS_ASSERT_AV_ITER_P;
assert(SvTYPE(av) == SVt_PVAV);
-#if IVSIZE == I32SIZE
- return (IV *)&(mg->mg_len);
-#else
- if (!mg->mg_ptr) {
- IV *temp;
- mg->mg_len = IVSIZE;
- Newxz(temp, 1, IV);
- mg->mg_ptr = (char *) temp;
+ if (sizeof(IV) == sizeof(SSize_t)) {
+ return (IV *)&(mg->mg_len);
+ } else {
+ if (!mg->mg_ptr) {
+ IV *temp;
+ mg->mg_len = IVSIZE;
+ Newxz(temp, 1, IV);
+ mg->mg_ptr = (char *) temp;
+ }
+ return (IV *)mg->mg_ptr;
}
- return (IV *)mg->mg_ptr;
-#endif
+}
+
+SV *
+Perl_av_nonelem(pTHX_ AV *av, SSize_t ix) {
+ SV * const sv = newSV(0);
+ PERL_ARGS_ASSERT_AV_NONELEM;
+ if (!av_store(av,ix,sv))
+ return sv_2mortal(sv); /* has tie magic */
+ sv_magic(sv, NULL, PERL_MAGIC_nonelem, NULL, 0);
+ return sv;
}
/*
https://perl5.git.perl.org / perl5.git / blobdiff