* [p.476 of _The Lord of the Rings_, III/iv: "Treebeard"]
*/
-/*
-=head1 Array Manipulation Functions
-*/
-
#include "EXTERN.h"
#define PERL_IN_AV_C
#include "perl.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);
}
/* The guts of av_extend. *Not* for general use! */
+/* Also called directly from pp_assign, padlist_store, padnamelist_store */
void
Perl_av_extend_guts(pTHX_ AV *av, SSize_t key, SSize_t *maxp, SV ***allocp,
- SV ***arrayp)
+ SV ***arrayp)
{
PERL_ARGS_ASSERT_AV_EXTEND_GUTS;
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 tmp;
- SSize_t newmax;
-
- if (av && *allocp != *arrayp) {
- ary = *allocp + AvFILLp(av) + 1;
- tmp = *arrayp - *allocp;
- Move(*arrayp, *allocp, AvFILLp(av)+1, SV*);
- *maxp += tmp;
- *arrayp = *allocp;
- if (AvREAL(av)) {
- while (tmp)
- ary[--tmp] = NULL;
- }
- if (key > *maxp - 10) {
- newmax = key + *maxp;
- goto resize;
- }
- }
- else {
- if (*allocp) {
+ SSize_t ary_offset = *maxp + 1;
+ SSize_t to_null = 0;
+ SSize_t newmax = 0;
+
+ if (av && *allocp != *arrayp) { /* a shifted SV* array exists */
+ to_null = *arrayp - *allocp;
+ *maxp += to_null;
+
+ Move(*arrayp, *allocp, AvFILLp(av)+1, SV*);
+
+ if (key > *maxp - 10) {
+ newmax = key + *maxp;
+ goto resize;
+ }
+ } else if (*allocp) { /* a full SV* array exists */
#ifdef Perl_safesysmalloc_size
- /* Whilst it would be quite possible to move this logic around
- (as I did in the SV code), so as to set AvMAX(av) early,
- based on calling Perl_safesysmalloc_size() immediately after
- allocation, I'm not convinced that it is a great idea here.
- In an array we have to loop round setting everything to
- NULL, which means writing to memory, potentially lots
- of it, whereas for the SV buffer case we don't touch the
- "bonus" memory. So there there is no cost in telling the
- world about it, whereas here we have to do work before we can
- tell the world about it, and that work involves writing to
- memory that might never be read. So, I feel, better to keep
- the current lazy system of only writing to it if our caller
- has a need for more space. NWC */
- newmax = Perl_safesysmalloc_size((void*)*allocp) /
- sizeof(const SV *) - 1;
-
- if (key <= newmax)
- goto resized;
+ /* Whilst it would be quite possible to move this logic around
+ (as I did in the SV code), so as to set AvMAX(av) early,
+ based on calling Perl_safesysmalloc_size() immediately after
+ allocation, I'm not convinced that it is a great idea here.
+ In an array we have to loop round setting everything to
+ NULL, which means writing to memory, potentially lots
+ of it, whereas for the SV buffer case we don't touch the
+ "bonus" memory. So there there is no cost in telling the
+ world about it, whereas here we have to do work before we can
+ tell the world about it, and that work involves writing to
+ memory that might never be read. So, I feel, better to keep
+ the current lazy system of only writing to it if our caller
+ has a need for more space. NWC */
+ newmax = Perl_safesysmalloc_size((void*)*allocp) /
+ sizeof(const SV *) - 1;
+
+ if (key <= newmax)
+ goto resized;
#endif
- /* 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
- /* 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);
- }
+ /* overflow-safe version of newmax = key + *maxp/5 */
+ newmax = *maxp / 5;
+ newmax = (key > SSize_t_MAX - newmax)
+ ? SSize_t_MAX : key + newmax;
+ resize:
+ {
+ /* 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);
- }
+ {
+ 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*);
+ Renew(*allocp,newmax+1, SV*);
#endif
#ifdef Perl_safesysmalloc_size
- resized:
+ resized:
#endif
- ary = *allocp + *maxp + 1;
- tmp = newmax - *maxp;
- if (av == PL_curstack) { /* Oops, grew stack (via av_store()?) */
- PL_stack_sp = *allocp + (PL_stack_sp - PL_stack_base);
- PL_stack_base = *allocp;
- PL_stack_max = PL_stack_base + newmax;
- }
- }
- 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);
- }
- Newx(*allocp, newmax+1, SV*);
- ary = *allocp + 1;
- tmp = newmax;
- *allocp[0] = NULL; /* For the stacks */
- }
- if (av && AvREAL(av)) {
- while (tmp)
- ary[--tmp] = NULL;
- }
-
- *arrayp = *allocp;
- *maxp = newmax;
- }
+ to_null += newmax - *maxp;
+ *maxp = newmax;
+
+ /* See GH#18014 for discussion of when this might be needed: */
+ if (av == PL_curstack) { /* Oops, grew stack (via av_store()?) */
+ PL_stack_sp = *allocp + (PL_stack_sp - PL_stack_base);
+ PL_stack_base = *allocp;
+ PL_stack_max = PL_stack_base + newmax;
+ }
+ } else { /* there is no SV* array yet */
+ *maxp = key < 3 ? 3 : key;
+ {
+ /* see comment above about newmax+1*/
+ MEM_WRAP_CHECK_s(*maxp, SV*,
+ "Out of memory during array extend");
+ }
+ /* Newxz isn't used below because testing showed it to be slower
+ * than Newx+Zero (also slower than Newx + the previous while
+ * loop) for small arrays, which are very common in perl. */
+ Newx(*allocp, *maxp+1, SV*);
+ /* Stacks require only the first element to be &PL_sv_undef
+ * (set elsewhere). However, since non-stack AVs are likely
+ * to dominate in modern production applications, stacks
+ * don't get any special treatment here. */
+ ary_offset = 0;
+ to_null = *maxp+1;
+ goto zero;
+ }
+
+ if (av && AvREAL(av)) {
+ zero:
+ Zero(*allocp + ary_offset,to_null,SV*);
+ }
+
+ *arrayp = *allocp;
}
}
AV *
Perl_av_make(pTHX_ SSize_t size, SV **strp)
{
- AV * const av = MUTABLE_AV(newSV_type(SVt_PVAV));
+ AV * const av = newAV();
/* sv_upgrade does AvREAL_only() */
PERL_ARGS_ASSERT_AV_MAKE;
assert(SvTYPE(av) == SVt_PVAV);
AvALLOC(av) = ary;
AvARRAY(av) = ary;
AvMAX(av) = size - 1;
- AvFILLp(av) = -1;
/* avoid av being leaked if croak when calling magic below */
EXTEND_MORTAL(1);
PL_tmps_stack[++PL_tmps_ix] = (SV*)av;
/*
=for apidoc av_clear
-Frees the all the elements of an array, leaving it empty.
+Frees all the elements of an array, leaving it empty.
The XS equivalent of C<@array = ()>. See also L</av_undef>.
Note that it is possible that the actions of a destructor called directly
Perl_av_undef(pTHX_ AV *av)
{
bool real;
- SSize_t orig_ix;
+ 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 = cBOOL(AvREAL(av)))) {
+ real = cBOOL(AvREAL(av));
+ if (real) {
SSize_t key = AvFILLp(av) + 1;
/* avoid av being freed when calling destructors below */
}
/*
-=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
*/
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;
}
/*