void
Perl_av_reify(pTHX_ AV *av)
{
- dVAR;
SSize_t key;
PERL_ARGS_ASSERT_AV_REIFY;
void
Perl_av_extend(pTHX_ AV *av, SSize_t key)
{
- dVAR;
MAGIC *mg;
PERL_ARGS_ASSERT_AV_EXTEND;
Perl_av_extend_guts(pTHX_ AV *av, SSize_t key, SSize_t *maxp, SV ***allocp,
SV ***arrayp)
{
- dVAR;
-
PERL_ARGS_ASSERT_AV_EXTEND_GUTS;
+ if (key < -1) /* -1 is legal */
+ Perl_croak(aTHX_
+ "panic: av_extend_guts() negative count (%" IVdf ")", (IV)key);
+
if (key > *maxp) {
SV** ary;
SSize_t tmp;
if (key <= newmax)
goto resized;
#endif
- newmax = key + *maxp / 5;
+ /* overflow-safe version of newmax = key + *maxp/5 */
+ newmax = *maxp / 5;
+ newmax = (key > SSize_t_MAX - newmax)
+ ? 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
- MEM_WRAP_CHECK_1(newmax+1, SV*, oom_array_extend);
+ /* 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_s(newmax, SV*, "Out of memory during array extend");
+ }
+#ifdef STRESS_REALLOC
+ {
+ SV ** const old_alloc = *allocp;
+ Newx(*allocp, newmax+1, SV*);
+ Copy(old_alloc, *allocp, *maxp + 1, SV*);
+ Safefree(old_alloc);
}
+#else
Renew(*allocp,newmax+1, SV*);
+#endif
#ifdef Perl_safesysmalloc_size
resized:
#endif
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
- MEM_WRAP_CHECK_1(newmax+1, SV*, oom_array_extend);
+ /* see comment above about newmax+1*/
+ 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)
{
- dVAR;
+ SSize_t neg;
+ SSize_t size;
PERL_ARGS_ASSERT_AV_FETCH;
assert(SvTYPE(av) == SVt_PVAV);
- if (SvRMAGICAL(av)) {
+ if (UNLIKELY(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)) {
}
}
- if (key < 0) {
- key += AvFILL(av) + 1;
- if (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;
+ goto emptyness;
}
- if (key > AvFILLp(av) || !AvARRAY(av)[key]) {
+ if (!AvARRAY(av)[key]) {
emptyness:
return lval ? av_store(av,key,newSV(0)) : NULL;
}
- if (AvREIFY(av)
- && (!AvARRAY(av)[key] /* eg. @_ could have freed elts */
- || SvIS_FREED(AvARRAY(av)[key]))) {
- AvARRAY(av)[key] = NULL; /* 1/2 reify */
- goto emptyness;
- }
return &AvARRAY(av)[key];
}
=for apidoc av_store
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
+return value will be C<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
+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.
+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.
SV**
Perl_av_store(pTHX_ AV *av, SSize_t key, SV *val)
{
- dVAR;
SV** ary;
PERL_ARGS_ASSERT_AV_STORE;
}
AvFILLp(av) = key;
}
- else if (AvREAL(av))
- SvREFCNT_dec(ary[key]);
+ else if (AvREAL(av) && LIKELY(ary[key] != val))
+ SvREFCNT_dec(ary[key]);
ary[key] = val;
if (SvSMAGICAL(av)) {
const MAGIC *mg = SvMAGIC(av);
=for apidoc av_make
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
+into the array, so they may be freed after the call to C<av_make>. The new AV
will have a reference count of 1.
Perl equivalent: C<my @new_array = ($scalar1, $scalar2, $scalar3...);>
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;
}
/*
=for apidoc av_clear
-Clears an array, making it empty. Does not free the memory the av uses to
-store its list of scalars. If any destructors are triggered as a result,
-the av itself may be freed when this function returns.
+Frees the all the elements of an array, leaving it empty.
+The XS equivalent of C<@array = ()>. See also L</av_undef>.
-Perl equivalent: C<@myarray = ();>.
+Note that it is possible that the actions of a destructor called directly
+or indirectly by freeing an element of the array could cause the reference
+count of the array itself to be reduced (e.g. by deleting an entry in the
+symbol table). So it is a possibility that the AV could have been freed
+(or even reallocated) on return from the call unless you hold a reference
+to it.
=cut
*/
void
Perl_av_clear(pTHX_ AV *av)
{
- dVAR;
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);
+ }
}
/*
=for apidoc av_undef
-Undefines the array. Frees the memory used by the av to store its list of
-scalars. If any destructors are triggered as a result, the av itself may
-be freed.
+Undefines the array. The XS equivalent of C<undef(@array)>.
+
+As well as freeing all the elements of the array (like C<av_clear()>), this
+also frees the memory used by the av to store its list of scalars.
+
+See L</av_clear> for a note about the array possibly being invalid on
+return.
=cut
*/
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);
+ }
}
/*
/*
=for apidoc av_push
-Pushes an SV onto the end of the array. The array will grow automatically
-to accommodate the addition. This takes ownership of one reference count.
+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
*/
void
Perl_av_push(pTHX_ AV *av, SV *val)
{
- dVAR;
MAGIC *mg;
PERL_ARGS_ASSERT_AV_PUSH;
SV *
Perl_av_pop(pTHX_ AV *av)
{
- dVAR;
SV *retval;
MAGIC* mg;
=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: C<unshift @myarray, ( (undef) x $n );>
+Perl equivalent: S<C<unshift @myarray, ((undef) x $num);>>
=cut
*/
void
Perl_av_unshift(pTHX_ AV *av, SSize_t num)
{
- dVAR;
SSize_t i;
MAGIC* mg;
SV *
Perl_av_shift(pTHX_ AV *av)
{
- dVAR;
SV *retval;
MAGIC* mg;
=for apidoc av_top_index
Returns the highest index in the array. The number of elements in the
-array is C<av_top_index(av) + 1>. Returns -1 if the array is empty.
+array is S<C<av_top_index(av) + 1>>. Returns -1 if the array is empty.
The Perl equivalent for this is C<$#myarray>.
=for apidoc av_len
-Same as L</av_top_index>. Returns the highest index in the array. Note that the
-return value is +1 what its name implies it returns; and hence differs in
-meaning from what the similarly named L</sv_len> returns.
+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.
=cut
*/
=for apidoc av_fill
Set the highest index in the array to the given number, equivalent to
-Perl's C<$#array = $fill;>.
+Perl's 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
+The number of elements in the array will be S<C<fill + 1>> after
+C<av_fill()> returns. If the array was previously shorter, then the
additional elements appended are set to NULL. If the array
-was longer, then the excess elements are freed. C<av_fill(av, -1)> is
+was longer, then the excess elements are freed. S<C<av_fill(av, -1)>> is
the same as C<av_clear(av)>.
=cut
void
Perl_av_fill(pTHX_ AV *av, SSize_t fill)
{
- dVAR;
MAGIC *mg;
PERL_ARGS_ASSERT_AV_FILL;
/*
=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: 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.
+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
*/
SV *
Perl_av_delete(pTHX_ AV *av, SSize_t key, I32 flags)
{
- dVAR;
SV *sv;
PERL_ARGS_ASSERT_AV_DELETE;
if (!AvREAL(av) && AvREIFY(av))
av_reify(av);
sv = AvARRAY(av)[key];
+ AvARRAY(av)[key] = NULL;
if (key == AvFILLp(av)) {
- AvARRAY(av)[key] = NULL;
do {
AvFILLp(av)--;
} while (--key >= 0 && !AvARRAY(av)[key]);
}
- else
- AvARRAY(av)[key] = NULL;
if (SvSMAGICAL(av))
mg_set(MUTABLE_SV(av));
}
- if (flags & G_DISCARD) {
- SvREFCNT_dec(sv);
- sv = NULL;
+ if(sv != NULL) {
+ if (flags & G_DISCARD) {
+ SvREFCNT_dec_NN(sv);
+ return NULL;
+ }
+ else if (AvREAL(av))
+ sv_2mortal(sv);
}
- else if (AvREAL(av))
- sv = sv_2mortal(sv);
return sv;
}
Returns true if the element indexed by C<key> has been initialized.
This relies on the fact that uninitialized array elements are set to
-NULL.
+C<NULL>.
Perl equivalent: C<exists($myarray[$key])>.
bool
Perl_av_exists(pTHX_ AV *av, SSize_t key)
{
- dVAR;
PERL_ARGS_ASSERT_AV_EXISTS;
assert(SvTYPE(av) == SVt_PVAV);
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
static MAGIC *
S_get_aux_mg(pTHX_ AV *av) {
- dVAR;
MAGIC *mg;
PERL_ARGS_ASSERT_GET_AUX_MG;
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;
}
/*
- * Local variables:
- * c-indentation-style: bsd
- * c-basic-offset: 4
- * indent-tabs-mode: nil
- * End:
- *
* ex: set ts=8 sts=4 sw=4 et:
*/
https://perl5.git.perl.org / perl5.git / blobdiff