This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Revert "av_create_and_push/unshift_one: faster create via newAV_alloc_xz"
[perl5.git] / av.c
CommitLineData
a0d0e21e 1/* av.c
79072805 2 *
1129b882
NC
3 * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000,
4 * 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008 by Larry Wall and others
79072805
LW
5 *
6 * You may distribute under the terms of either the GNU General Public
7 * License or the Artistic License, as specified in the README file.
8 *
a0d0e21e
LW
9 */
10
11/*
4ac71550
TC
12 * '...for the Entwives desired order, and plenty, and peace (by which they
13 * meant that things should remain where they had set them).' --Treebeard
14 *
15 * [p.476 of _The Lord of the Rings_, III/iv: "Treebeard"]
79072805
LW
16 */
17
18#include "EXTERN.h"
864dbfa3 19#define PERL_IN_AV_C
79072805
LW
20#include "perl.h"
21
fb73857a 22void
864dbfa3 23Perl_av_reify(pTHX_ AV *av)
a0d0e21e 24{
c70927a6 25 SSize_t key;
fb73857a 26
7918f24d 27 PERL_ARGS_ASSERT_AV_REIFY;
2fed2a1b 28 assert(SvTYPE(av) == SVt_PVAV);
ba5d1d60 29
3c78fafa 30 if (AvREAL(av))
1604cfb0 31 return;
93965878 32#ifdef DEBUGGING
9b387841 33 if (SvTIED_mg((const SV *)av, PERL_MAGIC_tied))
1604cfb0 34 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEBUGGING), "av_reify called on tied array");
93965878 35#endif
a0d0e21e 36 key = AvMAX(av) + 1;
93965878 37 while (key > AvFILLp(av) + 1)
1604cfb0 38 AvARRAY(av)[--key] = NULL;
a0d0e21e 39 while (key) {
1604cfb0
MS
40 SV * const sv = AvARRAY(av)[--key];
41 if (sv != &PL_sv_undef)
42 SvREFCNT_inc_simple_void(sv);
a0d0e21e 43 }
29de640a
CS
44 key = AvARRAY(av) - AvALLOC(av);
45 while (key)
1604cfb0 46 AvALLOC(av)[--key] = NULL;
62b1ebc2 47 AvREIFY_off(av);
a0d0e21e
LW
48 AvREAL_on(av);
49}
50
cb50131a
CB
51/*
52=for apidoc av_extend
53
2b301921
YO
54Pre-extend an array so that it is capable of storing values at indexes
55C<0..key>. Thus C<av_extend(av,99)> guarantees that the array can store 100
56elements, i.e. that C<av_store(av, 0, sv)> through C<av_store(av, 99, sv)>
57on a plain array will work without any further memory allocation.
58
59If the av argument is a tied array then will call the C<EXTEND> tied
60array method with an argument of C<(key+1)>.
cb50131a
CB
61
62=cut
63*/
64
a0d0e21e 65void
fc16c392 66Perl_av_extend(pTHX_ AV *av, SSize_t key)
a0d0e21e 67{
7a5b473e
AL
68 MAGIC *mg;
69
7918f24d 70 PERL_ARGS_ASSERT_AV_EXTEND;
2fed2a1b 71 assert(SvTYPE(av) == SVt_PVAV);
ba5d1d60 72
ad64d0ec 73 mg = SvTIED_mg((const SV *)av, PERL_MAGIC_tied);
823a54a3 74 if (mg) {
1604cfb0 75 SV *arg1 = sv_newmortal();
2b301921
YO
76 /* NOTE: the API for av_extend() is NOT the same as the tie method EXTEND.
77 *
78 * The C function takes an *index* (assumes 0 indexed arrays) and ensures
79 * that the array is at least as large as the index provided.
80 *
81 * The tied array method EXTEND takes a *count* and ensures that the array
82 * is at least that many elements large. Thus we have to +1 the key when
83 * we call the tied method.
84 */
1604cfb0
MS
85 sv_setiv(arg1, (IV)(key + 1));
86 Perl_magic_methcall(aTHX_ MUTABLE_SV(av), mg, SV_CONST(EXTEND), G_DISCARD, 1,
87 arg1);
88 return;
93965878 89 }
7261499d
FC
90 av_extend_guts(av,key,&AvMAX(av),&AvALLOC(av),&AvARRAY(av));
91}
92
93/* The guts of av_extend. *Not* for general use! */
399fef93 94/* Also called directly from pp_assign, padlist_store, padnamelist_store */
7261499d 95void
fc16c392 96Perl_av_extend_guts(pTHX_ AV *av, SSize_t key, SSize_t *maxp, SV ***allocp,
440c1856 97 SV ***arrayp)
7261499d 98{
7261499d
FC
99 PERL_ARGS_ASSERT_AV_EXTEND_GUTS;
100
6768377c
DM
101 if (key < -1) /* -1 is legal */
102 Perl_croak(aTHX_
147e3846 103 "panic: av_extend_guts() negative count (%" IVdf ")", (IV)key);
6768377c 104
7261499d 105 if (key > *maxp) {
399fef93
RL
106 SSize_t ary_offset = *maxp + 1;
107 SSize_t to_null = 0;
108 SSize_t newmax = 0;
109
110 if (av && *allocp != *arrayp) { /* a shifted SV* array exists */
111 to_null = *arrayp - *allocp;
112 *maxp += to_null;
ce9f3c9c 113 ary_offset = AvFILLp(av) + 1;
440c1856 114
440c1856 115 Move(*arrayp, *allocp, AvFILLp(av)+1, SV*);
399fef93 116
440c1856
RL
117 if (key > *maxp - 10) {
118 newmax = key + *maxp;
119 goto resize;
120 }
399fef93 121 } else if (*allocp) { /* a full SV* array exists */
4633a7c4 122
ca7c1a29 123#ifdef Perl_safesysmalloc_size
440c1856
RL
124 /* Whilst it would be quite possible to move this logic around
125 (as I did in the SV code), so as to set AvMAX(av) early,
126 based on calling Perl_safesysmalloc_size() immediately after
127 allocation, I'm not convinced that it is a great idea here.
128 In an array we have to loop round setting everything to
129 NULL, which means writing to memory, potentially lots
130 of it, whereas for the SV buffer case we don't touch the
131 "bonus" memory. So there there is no cost in telling the
132 world about it, whereas here we have to do work before we can
133 tell the world about it, and that work involves writing to
134 memory that might never be read. So, I feel, better to keep
135 the current lazy system of only writing to it if our caller
136 has a need for more space. NWC */
137 newmax = Perl_safesysmalloc_size((void*)*allocp) /
138 sizeof(const SV *) - 1;
139
140 if (key <= newmax)
141 goto resized;
8d6dde3e 142#endif
440c1856
RL
143 /* overflow-safe version of newmax = key + *maxp/5 */
144 newmax = *maxp / 5;
145 newmax = (key > SSize_t_MAX - newmax)
146 ? SSize_t_MAX : key + newmax;
147 resize:
399fef93
RL
148 {
149 /* it should really be newmax+1 here, but if newmax
150 * happens to equal SSize_t_MAX, then newmax+1 is
151 * undefined. This means technically we croak one
152 * index lower than we should in theory; in practice
153 * its unlikely the system has SSize_t_MAX/sizeof(SV*)
154 * bytes to spare! */
155 MEM_WRAP_CHECK_s(newmax, SV*, "Out of memory during array extend");
156 }
865e3ae0 157#ifdef STRESS_REALLOC
440c1856
RL
158 {
159 SV ** const old_alloc = *allocp;
160 Newx(*allocp, newmax+1, SV*);
161 Copy(old_alloc, *allocp, *maxp + 1, SV*);
162 Safefree(old_alloc);
163 }
865e3ae0 164#else
440c1856 165 Renew(*allocp,newmax+1, SV*);
865e3ae0 166#endif
ca7c1a29 167#ifdef Perl_safesysmalloc_size
440c1856 168 resized:
9c5ffd7c 169#endif
399fef93
RL
170 to_null += newmax - *maxp;
171 *maxp = newmax;
172
173 /* See GH#18014 for discussion of when this might be needed: */
174 if (av == PL_curstack) { /* Oops, grew stack (via av_store()?) */
440c1856
RL
175 PL_stack_sp = *allocp + (PL_stack_sp - PL_stack_base);
176 PL_stack_base = *allocp;
177 PL_stack_max = PL_stack_base + newmax;
178 }
399fef93
RL
179 } else { /* there is no SV* array yet */
180 *maxp = key < 3 ? 3 : key;
440c1856
RL
181 {
182 /* see comment above about newmax+1*/
399fef93
RL
183 MEM_WRAP_CHECK_s(*maxp, SV*,
184 "Out of memory during array extend");
440c1856 185 }
399fef93
RL
186 /* Newxz isn't used below because testing showed it to be slower
187 * than Newx+Zero (also slower than Newx + the previous while
188 * loop) for small arrays, which are very common in perl. */
189 Newx(*allocp, *maxp+1, SV*);
190 /* Stacks require only the first element to be &PL_sv_undef
191 * (set elsewhere). However, since non-stack AVs are likely
192 * to dominate in modern production applications, stacks
60eec70f
HS
193 * don't get any special treatment here.
194 * See https://github.com/Perl/perl5/pull/18690 for more detail */
399fef93
RL
195 ary_offset = 0;
196 to_null = *maxp+1;
197 goto zero;
440c1856 198 }
399fef93 199
440c1856 200 if (av && AvREAL(av)) {
399fef93
RL
201 zero:
202 Zero(*allocp + ary_offset,to_null,SV*);
440c1856
RL
203 }
204
205 *arrayp = *allocp;
a0d0e21e
LW
206 }
207}
208
cb50131a
CB
209/*
210=for apidoc av_fetch
211
212Returns the SV at the specified index in the array. The C<key> is the
1a328862
SF
213index. If lval is true, you are guaranteed to get a real SV back (in case
214it wasn't real before), which you can then modify. Check that the return
215value is non-null before dereferencing it to a C<SV*>.
cb50131a
CB
216
217See L<perlguts/"Understanding the Magic of Tied Hashes and Arrays"> for
218more information on how to use this function on tied arrays.
219
17b0bd77 220The rough perl equivalent is C<$myarray[$key]>.
3347919d 221
cb50131a
CB
222=cut
223*/
224
ac9f75b5 225static bool
c70927a6 226S_adjust_index(pTHX_ AV *av, const MAGIC *mg, SSize_t *keyp)
ac9f75b5
FC
227{
228 bool adjust_index = 1;
229 if (mg) {
1604cfb0
MS
230 /* Handle negative array indices 20020222 MJD */
231 SV * const ref = SvTIED_obj(MUTABLE_SV(av), mg);
232 SvGETMAGIC(ref);
233 if (SvROK(ref) && SvOBJECT(SvRV(ref))) {
234 SV * const * const negative_indices_glob =
235 hv_fetchs(SvSTASH(SvRV(ref)), NEGATIVE_INDICES_VAR, 0);
236
237 if (negative_indices_glob && isGV(*negative_indices_glob)
238 && SvTRUE(GvSV(*negative_indices_glob)))
239 adjust_index = 0;
240 }
ac9f75b5
FC
241 }
242
243 if (adjust_index) {
1604cfb0
MS
244 *keyp += AvFILL(av) + 1;
245 if (*keyp < 0)
246 return FALSE;
ac9f75b5
FC
247 }
248 return TRUE;
249}
250
79072805 251SV**
c70927a6 252Perl_av_fetch(pTHX_ AV *av, SSize_t key, I32 lval)
79072805 253{
f4d8be8b
DM
254 SSize_t neg;
255 SSize_t size;
256
7918f24d 257 PERL_ARGS_ASSERT_AV_FETCH;
2fed2a1b 258 assert(SvTYPE(av) == SVt_PVAV);
a0d0e21e 259
11b62bc4 260 if (UNLIKELY(SvRMAGICAL(av))) {
ad64d0ec 261 const MAGIC * const tied_magic
1604cfb0 262 = mg_find((const SV *)av, PERL_MAGIC_tied);
ad64d0ec 263 if (tied_magic || mg_find((const SV *)av, PERL_MAGIC_regdata)) {
1604cfb0
MS
264 SV *sv;
265 if (key < 0) {
266 if (!S_adjust_index(aTHX_ av, tied_magic, &key))
267 return NULL;
268 }
6f12eb6d
MJD
269
270 sv = sv_newmortal();
1604cfb0
MS
271 sv_upgrade(sv, SVt_PVLV);
272 mg_copy(MUTABLE_SV(av), sv, 0, key);
273 if (!tied_magic) /* for regdata, force leavesub to make copies */
274 SvTEMP_off(sv);
275 LvTYPE(sv) = 't';
276 LvTARG(sv) = sv; /* fake (SV**) */
277 return &(LvTARG(sv));
6f12eb6d
MJD
278 }
279 }
280
f4d8be8b 281 neg = (key < 0);
25cf9644 282 size = AvFILLp(av) + 1;
f4d8be8b
DM
283 key += neg * size; /* handle negative index without using branch */
284
285 /* the cast from SSize_t to Size_t allows both (key < 0) and (key >= size)
286 * to be tested as a single condition */
287 if ((Size_t)key >= (Size_t)size) {
1604cfb0
MS
288 if (UNLIKELY(neg))
289 return NULL;
f4d8be8b 290 goto emptyness;
93965878 291 }
f4d8be8b
DM
292
293 if (!AvARRAY(av)[key]) {
55d3f3e5 294 emptyness:
1604cfb0 295 return lval ? av_store(av,key,newSV(0)) : NULL;
79072805 296 }
55d3f3e5 297
463ee0b2 298 return &AvARRAY(av)[key];
79072805
LW
299}
300
cb50131a
CB
301/*
302=for apidoc av_store
303
304Stores an SV in an array. The array index is specified as C<key>. The
796b6530 305return value will be C<NULL> if the operation failed or if the value did not
cb50131a 306need to be actually stored within the array (as in the case of tied
72d33970 307arrays). Otherwise, it can be dereferenced
4f540dd3 308to get the C<SV*> that was stored
f0b90de1
SF
309there (= C<val>)).
310
311Note that the caller is responsible for suitably incrementing the reference
cb50131a 312count of C<val> before the call, and decrementing it if the function
796b6530 313returned C<NULL>.
cb50131a 314
17b0bd77 315Approximate Perl equivalent: C<splice(@myarray, $key, 1, $val)>.
f0b90de1 316
cb50131a
CB
317See L<perlguts/"Understanding the Magic of Tied Hashes and Arrays"> for
318more information on how to use this function on tied arrays.
319
320=cut
321*/
322
79072805 323SV**
c70927a6 324Perl_av_store(pTHX_ AV *av, SSize_t key, SV *val)
79072805 325{
79072805
LW
326 SV** ary;
327
7918f24d 328 PERL_ARGS_ASSERT_AV_STORE;
2fed2a1b 329 assert(SvTYPE(av) == SVt_PVAV);
ba5d1d60 330
725ac12f
NC
331 /* S_regclass relies on being able to pass in a NULL sv
332 (unicode_alternate may be NULL).
333 */
334
6f12eb6d 335 if (SvRMAGICAL(av)) {
ad64d0ec 336 const MAGIC * const tied_magic = mg_find((const SV *)av, PERL_MAGIC_tied);
6f12eb6d 337 if (tied_magic) {
6f12eb6d 338 if (key < 0) {
1604cfb0 339 if (!S_adjust_index(aTHX_ av, tied_magic, &key))
6f12eb6d 340 return 0;
6f12eb6d 341 }
1604cfb0
MS
342 if (val) {
343 mg_copy(MUTABLE_SV(av), val, 0, key);
344 }
345 return NULL;
6f12eb6d
MJD
346 }
347 }
348
349
a0d0e21e 350 if (key < 0) {
1604cfb0
MS
351 key += AvFILL(av) + 1;
352 if (key < 0)
353 return NULL;
79072805 354 }
93965878 355
43fcc5d2 356 if (SvREADONLY(av) && key >= AvFILL(av))
1604cfb0 357 Perl_croak_no_modify();
93965878 358
49beac48 359 if (!AvREAL(av) && AvREIFY(av))
1604cfb0 360 av_reify(av);
a0d0e21e 361 if (key > AvMAX(av))
1604cfb0 362 av_extend(av,key);
463ee0b2 363 ary = AvARRAY(av);
93965878 364 if (AvFILLp(av) < key) {
1604cfb0
MS
365 if (!AvREAL(av)) {
366 if (av == PL_curstack && key > PL_stack_sp - PL_stack_base)
367 PL_stack_sp = PL_stack_base + key; /* XPUSH in disguise */
368 do {
369 ary[++AvFILLp(av)] = NULL;
370 } while (AvFILLp(av) < key);
371 }
372 AvFILLp(av) = key;
79072805 373 }
811f8a24 374 else if (AvREAL(av))
1604cfb0 375 SvREFCNT_dec(ary[key]);
79072805 376 ary[key] = val;
8990e307 377 if (SvSMAGICAL(av)) {
1604cfb0
MS
378 const MAGIC *mg = SvMAGIC(av);
379 bool set = TRUE;
380 for (; mg; mg = mg->mg_moremagic) {
381 if (!isUPPER(mg->mg_type)) continue;
382 if (val) {
383 sv_magic(val, MUTABLE_SV(av), toLOWER(mg->mg_type), 0, key);
384 }
385 if (PL_delaymagic && mg->mg_type == PERL_MAGIC_isa) {
386 PL_delaymagic |= DM_ARRAY_ISA;
387 set = FALSE;
388 }
389 }
390 if (set)
391 mg_set(MUTABLE_SV(av));
463ee0b2 392 }
79072805
LW
393 return &ary[key];
394}
395
cb50131a 396/*
0b1c19ab
RL
397=for apidoc av_new_alloc
398
399Creates a new AV and allocates its SV* array.
400
401This is similar to but more efficient than doing:
402
403 AV *av = newAV();
404 av_extend(av, key);
405
158b05f8
RL
406The size parameter is used to pre-allocate a SV* array large enough to
407hold at least elements 0..(size-1). size must be at least 1.
0b1c19ab 408
158b05f8 409The zeroflag parameter controls whether the array is NULL initialized.
0b1c19ab
RL
410
411=cut
412*/
413
414AV *
415Perl_av_new_alloc(pTHX_ SSize_t size, bool zeroflag)
416{
417 AV * const av = newAV();
418 SV** ary;
419 PERL_ARGS_ASSERT_AV_NEW_ALLOC;
420 assert(size > 0);
421
422 Newx(ary, size, SV*); /* Newx performs the memwrap check */
423 AvALLOC(av) = ary;
424 AvARRAY(av) = ary;
425 AvMAX(av) = size - 1;
426
427 if (zeroflag)
428 Zero(ary, size, SV*);
429
430 return av;
431}
432
433/*
cb50131a
CB
434=for apidoc av_make
435
436Creates a new AV and populates it with a list of SVs. The SVs are copied
796b6530 437into the array, so they may be freed after the call to C<av_make>. The new AV
cb50131a
CB
438will have a reference count of 1.
439
775f1d61
SF
440Perl equivalent: C<my @new_array = ($scalar1, $scalar2, $scalar3...);>
441
cb50131a
CB
442=cut
443*/
444
79072805 445AV *
c70927a6 446Perl_av_make(pTHX_ SSize_t size, SV **strp)
79072805 447{
f73391e4 448 AV * const av = newAV();
a7f5e44d 449 /* sv_upgrade does AvREAL_only() */
7918f24d 450 PERL_ARGS_ASSERT_AV_MAKE;
2fed2a1b
NC
451 assert(SvTYPE(av) == SVt_PVAV);
452
a0288114 453 if (size) { /* "defined" was returning undef for size==0 anyway. */
eb578fdb 454 SV** ary;
c70927a6 455 SSize_t i;
be988557
DM
456 SSize_t orig_ix;
457
1604cfb0
MS
458 Newx(ary,size,SV*);
459 AvALLOC(av) = ary;
460 AvARRAY(av) = ary;
461 AvMAX(av) = size - 1;
be988557
DM
462 /* avoid av being leaked if croak when calling magic below */
463 EXTEND_MORTAL(1);
464 PL_tmps_stack[++PL_tmps_ix] = (SV*)av;
465 orig_ix = PL_tmps_ix;
466
1604cfb0
MS
467 for (i = 0; i < size; i++) {
468 assert (*strp);
2b676593 469
1604cfb0
MS
470 /* Don't let sv_setsv swipe, since our source array might
471 have multiple references to the same temp scalar (e.g.
472 from a list slice) */
2b676593 473
1604cfb0
MS
474 SvGETMAGIC(*strp); /* before newSV, in case it dies */
475 AvFILLp(av)++;
476 ary[i] = newSV(0);
477 sv_setsv_flags(ary[i], *strp,
478 SV_DO_COW_SVSETSV|SV_NOSTEAL);
479 strp++;
480 }
be988557
DM
481 /* disarm av's leak guard */
482 if (LIKELY(PL_tmps_ix == orig_ix))
483 PL_tmps_ix--;
484 else
485 PL_tmps_stack[orig_ix] = &PL_sv_undef;
79072805 486 }
463ee0b2 487 return av;
79072805
LW
488}
489
cb50131a
CB
490/*
491=for apidoc av_clear
492
bb8005f7 493Frees all the elements of an array, leaving it empty.
a4395eba 494The XS equivalent of C<@array = ()>. See also L</av_undef>.
8b9a1153 495
a4395eba
DM
496Note that it is possible that the actions of a destructor called directly
497or indirectly by freeing an element of the array could cause the reference
498count of the array itself to be reduced (e.g. by deleting an entry in the
499symbol table). So it is a possibility that the AV could have been freed
500(or even reallocated) on return from the call unless you hold a reference
501to it.
cb50131a
CB
502
503=cut
504*/
505
79072805 506void
5aaab254 507Perl_av_clear(pTHX_ AV *av)
79072805 508{
c70927a6 509 SSize_t extra;
60edcf09 510 bool real;
be988557 511 SSize_t orig_ix = 0;
79072805 512
7918f24d 513 PERL_ARGS_ASSERT_AV_CLEAR;
2fed2a1b
NC
514 assert(SvTYPE(av) == SVt_PVAV);
515
7d55f622 516#ifdef DEBUGGING
9b387841 517 if (SvREFCNT(av) == 0) {
1604cfb0 518 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEBUGGING), "Attempt to clear deleted array");
7d55f622
PP
519 }
520#endif
a0d0e21e 521
39caa665 522 if (SvREADONLY(av))
1604cfb0 523 Perl_croak_no_modify();
39caa665 524
93965878 525 /* Give any tie a chance to cleanup first */
89c14e2e 526 if (SvRMAGICAL(av)) {
1604cfb0
MS
527 const MAGIC* const mg = SvMAGIC(av);
528 if (PL_delaymagic && mg && mg->mg_type == PERL_MAGIC_isa)
529 PL_delaymagic |= DM_ARRAY_ISA;
89c14e2e 530 else
1604cfb0 531 mg_clear(MUTABLE_SV(av));
89c14e2e 532 }
93965878 533
a60c0954 534 if (AvMAX(av) < 0)
1604cfb0 535 return;
a60c0954 536
be988557 537 if ((real = cBOOL(AvREAL(av)))) {
1604cfb0
MS
538 SV** const ary = AvARRAY(av);
539 SSize_t index = AvFILLp(av) + 1;
be988557
DM
540
541 /* avoid av being freed when calling destructors below */
542 EXTEND_MORTAL(1);
543 PL_tmps_stack[++PL_tmps_ix] = SvREFCNT_inc_simple_NN(av);
544 orig_ix = PL_tmps_ix;
545
1604cfb0
MS
546 while (index) {
547 SV * const sv = ary[--index];
548 /* undef the slot before freeing the value, because a
549 * destructor might try to modify this array */
550 ary[index] = NULL;
551 SvREFCNT_dec(sv);
552 }
a0d0e21e 553 }
e2d306cb
AL
554 extra = AvARRAY(av) - AvALLOC(av);
555 if (extra) {
1604cfb0
MS
556 AvMAX(av) += extra;
557 AvARRAY(av) = AvALLOC(av);
79072805 558 }
93965878 559 AvFILLp(av) = -1;
be988557
DM
560 if (real) {
561 /* disarm av's premature free guard */
562 if (LIKELY(PL_tmps_ix == orig_ix))
563 PL_tmps_ix--;
564 else
565 PL_tmps_stack[orig_ix] = &PL_sv_undef;
566 SvREFCNT_dec_NN(av);
567 }
79072805
LW
568}
569
cb50131a
CB
570/*
571=for apidoc av_undef
572
a4395eba
DM
573Undefines the array. The XS equivalent of C<undef(@array)>.
574
575As well as freeing all the elements of the array (like C<av_clear()>), this
576also frees the memory used by the av to store its list of scalars.
577
578See L</av_clear> for a note about the array possibly being invalid on
579return.
cb50131a
CB
580
581=cut
582*/
583
79072805 584void
5aaab254 585Perl_av_undef(pTHX_ AV *av)
79072805 586{
60edcf09 587 bool real;
84610c52 588 SSize_t orig_ix = PL_tmps_ix; /* silence bogus warning about possible unitialized use */
60edcf09 589
7918f24d 590 PERL_ARGS_ASSERT_AV_UNDEF;
2fed2a1b 591 assert(SvTYPE(av) == SVt_PVAV);
93965878
NIS
592
593 /* Give any tie a chance to cleanup first */
ad64d0ec 594 if (SvTIED_mg((const SV *)av, PERL_MAGIC_tied))
1604cfb0 595 av_fill(av, -1);
93965878 596
84610c52
YO
597 real = cBOOL(AvREAL(av));
598 if (real) {
1604cfb0 599 SSize_t key = AvFILLp(av) + 1;
be988557
DM
600
601 /* avoid av being freed when calling destructors below */
602 EXTEND_MORTAL(1);
603 PL_tmps_stack[++PL_tmps_ix] = SvREFCNT_inc_simple_NN(av);
604 orig_ix = PL_tmps_ix;
605
1604cfb0
MS
606 while (key)
607 SvREFCNT_dec(AvARRAY(av)[--key]);
a0d0e21e 608 }
22717f83 609
463ee0b2 610 Safefree(AvALLOC(av));
35da51f7 611 AvALLOC(av) = NULL;
9c6bc640 612 AvARRAY(av) = NULL;
93965878 613 AvMAX(av) = AvFILLp(av) = -1;
22717f83 614
ad64d0ec 615 if(SvRMAGICAL(av)) mg_clear(MUTABLE_SV(av));
be988557
DM
616 if (real) {
617 /* disarm av's premature free guard */
618 if (LIKELY(PL_tmps_ix == orig_ix))
619 PL_tmps_ix--;
620 else
621 PL_tmps_stack[orig_ix] = &PL_sv_undef;
622 SvREFCNT_dec_NN(av);
623 }
79072805
LW
624}
625
cb50131a 626/*
29a861e7
NC
627
628=for apidoc av_create_and_push
629
630Push an SV onto the end of the array, creating the array if necessary.
631A small internal helper function to remove a commonly duplicated idiom.
632
633=cut
634*/
635
636void
637Perl_av_create_and_push(pTHX_ AV **const avp, SV *const val)
638{
7918f24d 639 PERL_ARGS_ASSERT_AV_CREATE_AND_PUSH;
2fed2a1b 640
832a378e
KW
641 if (!*avp)
642 *avp = newAV();
643 av_push(*avp, val);
29a861e7
NC
644}
645
646/*
cb50131a
CB
647=for apidoc av_push
648
b895c103
KW
649Pushes an SV (transferring control of one reference count) onto the end of the
650array. The array will grow automatically to accommodate the addition.
cb50131a 651
17b0bd77 652Perl equivalent: C<push @myarray, $val;>.
f0b90de1 653
cb50131a
CB
654=cut
655*/
656
a0d0e21e 657void
5aaab254 658Perl_av_push(pTHX_ AV *av, SV *val)
93965878
NIS
659{
660 MAGIC *mg;
7918f24d
NC
661
662 PERL_ARGS_ASSERT_AV_PUSH;
2fed2a1b 663 assert(SvTYPE(av) == SVt_PVAV);
ba5d1d60 664
93965878 665 if (SvREADONLY(av))
1604cfb0 666 Perl_croak_no_modify();
93965878 667
ad64d0ec 668 if ((mg = SvTIED_mg((const SV *)av, PERL_MAGIC_tied))) {
1604cfb0
MS
669 Perl_magic_methcall(aTHX_ MUTABLE_SV(av), mg, SV_CONST(PUSH), G_DISCARD, 1,
670 val);
671 return;
93965878
NIS
672 }
673 av_store(av,AvFILLp(av)+1,val);
79072805
LW
674}
675
cb50131a
CB
676/*
677=for apidoc av_pop
678
f5d13a25
KW
679Removes one SV from the end of the array, reducing its size by one and
680returning the SV (transferring control of one reference count) to the
681caller. Returns C<&PL_sv_undef> if the array is empty.
cb50131a 682
f0b90de1
SF
683Perl equivalent: C<pop(@myarray);>
684
cb50131a
CB
685=cut
686*/
687
79072805 688SV *
5aaab254 689Perl_av_pop(pTHX_ AV *av)
79072805
LW
690{
691 SV *retval;
93965878 692 MAGIC* mg;
79072805 693
7918f24d 694 PERL_ARGS_ASSERT_AV_POP;
2fed2a1b 695 assert(SvTYPE(av) == SVt_PVAV);
ba5d1d60 696
43fcc5d2 697 if (SvREADONLY(av))
1604cfb0 698 Perl_croak_no_modify();
ad64d0ec 699 if ((mg = SvTIED_mg((const SV *)av, PERL_MAGIC_tied))) {
1604cfb0
MS
700 retval = Perl_magic_methcall(aTHX_ MUTABLE_SV(av), mg, SV_CONST(POP), 0, 0);
701 if (retval)
702 retval = newSVsv(retval);
703 return retval;
93965878 704 }
d19c0e07 705 if (AvFILL(av) < 0)
1604cfb0 706 return &PL_sv_undef;
93965878 707 retval = AvARRAY(av)[AvFILLp(av)];
ce0d59fd 708 AvARRAY(av)[AvFILLp(av)--] = NULL;
8990e307 709 if (SvSMAGICAL(av))
1604cfb0 710 mg_set(MUTABLE_SV(av));
ce0d59fd 711 return retval ? retval : &PL_sv_undef;
79072805
LW
712}
713
cb50131a 714/*
29a861e7
NC
715
716=for apidoc av_create_and_unshift_one
717
718Unshifts an SV onto the beginning of the array, creating the array if
719necessary.
720A small internal helper function to remove a commonly duplicated idiom.
721
722=cut
723*/
724
725SV **
726Perl_av_create_and_unshift_one(pTHX_ AV **const avp, SV *const val)
727{
7918f24d 728 PERL_ARGS_ASSERT_AV_CREATE_AND_UNSHIFT_ONE;
2fed2a1b 729
832a378e
KW
730 if (!*avp)
731 *avp = newAV();
732 av_unshift(*avp, 1);
733 return av_store(*avp, 0, val);
29a861e7
NC
734}
735
736/*
cb50131a
CB
737=for apidoc av_unshift
738
739Unshift the given number of C<undef> values onto the beginning of the
17b0bd77 740array. The array will grow automatically to accommodate the addition.
cb50131a 741
17b0bd77 742Perl equivalent: S<C<unshift @myarray, ((undef) x $num);>>
f703fc96 743
cb50131a
CB
744=cut
745*/
746
79072805 747void
c70927a6 748Perl_av_unshift(pTHX_ AV *av, SSize_t num)
79072805 749{
c70927a6 750 SSize_t i;
93965878 751 MAGIC* mg;
79072805 752
7918f24d 753 PERL_ARGS_ASSERT_AV_UNSHIFT;
2fed2a1b 754 assert(SvTYPE(av) == SVt_PVAV);
ba5d1d60 755
43fcc5d2 756 if (SvREADONLY(av))
1604cfb0 757 Perl_croak_no_modify();
93965878 758
ad64d0ec 759 if ((mg = SvTIED_mg((const SV *)av, PERL_MAGIC_tied))) {
1604cfb0
MS
760 Perl_magic_methcall(aTHX_ MUTABLE_SV(av), mg, SV_CONST(UNSHIFT),
761 G_DISCARD | G_UNDEF_FILL, num);
762 return;
93965878
NIS
763 }
764
d19c0e07
MJD
765 if (num <= 0)
766 return;
49beac48 767 if (!AvREAL(av) && AvREIFY(av))
1604cfb0 768 av_reify(av);
a0d0e21e
LW
769 i = AvARRAY(av) - AvALLOC(av);
770 if (i) {
1604cfb0
MS
771 if (i > num)
772 i = num;
773 num -= i;
a0d0e21e 774
1604cfb0
MS
775 AvMAX(av) += i;
776 AvFILLp(av) += i;
777 AvARRAY(av) = AvARRAY(av) - i;
a0d0e21e 778 }
d2719217 779 if (num) {
1604cfb0
MS
780 SV **ary;
781 const SSize_t i = AvFILLp(av);
782 /* Create extra elements */
783 const SSize_t slide = i > 0 ? i : 0;
784 num += slide;
785 av_extend(av, i + num);
786 AvFILLp(av) += num;
787 ary = AvARRAY(av);
788 Move(ary, ary + num, i + 1, SV*);
789 do {
790 ary[--num] = NULL;
791 } while (num);
792 /* Make extra elements into a buffer */
793 AvMAX(av) -= slide;
794 AvFILLp(av) -= slide;
795 AvARRAY(av) = AvARRAY(av) + slide;
79072805
LW
796 }
797}
798
cb50131a
CB
799/*
800=for apidoc av_shift
801
dbc2ea0c
SM
802Removes one SV from the start of the array, reducing its size by one and
803returning the SV (transferring control of one reference count) to the
804caller. Returns C<&PL_sv_undef> if the array is empty.
cb50131a 805
f0b90de1
SF
806Perl equivalent: C<shift(@myarray);>
807
cb50131a
CB
808=cut
809*/
810
79072805 811SV *
5aaab254 812Perl_av_shift(pTHX_ AV *av)
79072805
LW
813{
814 SV *retval;
93965878 815 MAGIC* mg;
79072805 816
7918f24d 817 PERL_ARGS_ASSERT_AV_SHIFT;
2fed2a1b 818 assert(SvTYPE(av) == SVt_PVAV);
ba5d1d60 819
43fcc5d2 820 if (SvREADONLY(av))
1604cfb0 821 Perl_croak_no_modify();
ad64d0ec 822 if ((mg = SvTIED_mg((const SV *)av, PERL_MAGIC_tied))) {
1604cfb0
MS
823 retval = Perl_magic_methcall(aTHX_ MUTABLE_SV(av), mg, SV_CONST(SHIFT), 0, 0);
824 if (retval)
825 retval = newSVsv(retval);
826 return retval;
93965878 827 }
d19c0e07
MJD
828 if (AvFILL(av) < 0)
829 return &PL_sv_undef;
463ee0b2 830 retval = *AvARRAY(av);
a0d0e21e 831 if (AvREAL(av))
1604cfb0 832 *AvARRAY(av) = NULL;
9c6bc640 833 AvARRAY(av) = AvARRAY(av) + 1;
463ee0b2 834 AvMAX(av)--;
93965878 835 AvFILLp(av)--;
8990e307 836 if (SvSMAGICAL(av))
1604cfb0 837 mg_set(MUTABLE_SV(av));
ce0d59fd 838 return retval ? retval : &PL_sv_undef;
79072805
LW
839}
840
cb50131a 841/*
a56541eb
KW
842=for apidoc av_tindex
843=for apidoc_item av_top_index
cb50131a 844
a56541eb
KW
845These behave identically.
846If the array C<av> is empty, these return -1; otherwise they return the maximum
847value of the indices of all the array elements which are currently defined in
848C<av>.
cb50131a 849
a56541eb 850They process 'get' magic.
a8676f70 851
a56541eb
KW
852The Perl equivalent for these is C<$#av>.
853
854Use C<L</av_count>> to get the number of elements in an array.
12719193 855
36baafc9
KW
856=for apidoc av_len
857
b985ae61 858Same as L</av_top_index>. Note that, unlike what the name implies, it returns
a56541eb 859the maximum index in the array. This is unlike L</sv_len>, which returns what
87306e06
KW
860you would expect.
861
862B<To get the true number of elements in the array, instead use C<L</av_count>>>.
36baafc9 863
cb50131a
CB
864=cut
865*/
866
c70927a6 867SSize_t
bb5dd93d 868Perl_av_len(pTHX_ AV *av)
79072805 869{
7918f24d 870 PERL_ARGS_ASSERT_AV_LEN;
36baafc9 871
be3a7a5d 872 return av_top_index(av);
36baafc9
KW
873}
874
f3b76584
SC
875/*
876=for apidoc av_fill
877
977a499b 878Set the highest index in the array to the given number, equivalent to
61b16eb9 879Perl's S<C<$#array = $fill;>>.
f3b76584 880
61b16eb9 881The number of elements in the array will be S<C<fill + 1>> after
796b6530 882C<av_fill()> returns. If the array was previously shorter, then the
ce0d59fd 883additional elements appended are set to NULL. If the array
61b16eb9 884was longer, then the excess elements are freed. S<C<av_fill(av, -1)>> is
977a499b
GA
885the same as C<av_clear(av)>.
886
f3b76584
SC
887=cut
888*/
79072805 889void
c70927a6 890Perl_av_fill(pTHX_ AV *av, SSize_t fill)
79072805 891{
93965878 892 MAGIC *mg;
ba5d1d60 893
7918f24d 894 PERL_ARGS_ASSERT_AV_FILL;
2fed2a1b 895 assert(SvTYPE(av) == SVt_PVAV);
ba5d1d60 896
79072805 897 if (fill < 0)
1604cfb0 898 fill = -1;
ad64d0ec 899 if ((mg = SvTIED_mg((const SV *)av, PERL_MAGIC_tied))) {
1604cfb0
MS
900 SV *arg1 = sv_newmortal();
901 sv_setiv(arg1, (IV)(fill + 1));
902 Perl_magic_methcall(aTHX_ MUTABLE_SV(av), mg, SV_CONST(STORESIZE), G_DISCARD,
903 1, arg1);
904 return;
93965878 905 }
463ee0b2 906 if (fill <= AvMAX(av)) {
1604cfb0
MS
907 SSize_t key = AvFILLp(av);
908 SV** const ary = AvARRAY(av);
909
910 if (AvREAL(av)) {
911 while (key > fill) {
912 SvREFCNT_dec(ary[key]);
913 ary[key--] = NULL;
914 }
915 }
916 else {
917 while (key < fill)
918 ary[++key] = NULL;
919 }
920
921 AvFILLp(av) = fill;
922 if (SvSMAGICAL(av))
923 mg_set(MUTABLE_SV(av));
463ee0b2 924 }
a0d0e21e 925 else
1604cfb0 926 (void)av_store(av,fill,NULL);
79072805 927}
c750a3ec 928
f3b76584
SC
929/*
930=for apidoc av_delete
931
17b0bd77
DM
932Deletes the element indexed by C<key> from the array, makes the element
933mortal, and returns it. If C<flags> equals C<G_DISCARD>, the element is
934freed and NULL is returned. NULL is also returned if C<key> is out of
935range.
936
937Perl equivalent: S<C<splice(@myarray, $key, 1, undef)>> (with the
938C<splice> in void context if C<G_DISCARD> is present).
f3b76584
SC
939
940=cut
941*/
146174a9 942SV *
c70927a6 943Perl_av_delete(pTHX_ AV *av, SSize_t key, I32 flags)
146174a9
CB
944{
945 SV *sv;
946
7918f24d 947 PERL_ARGS_ASSERT_AV_DELETE;
2fed2a1b 948 assert(SvTYPE(av) == SVt_PVAV);
ba5d1d60 949
146174a9 950 if (SvREADONLY(av))
1604cfb0 951 Perl_croak_no_modify();
6f12eb6d
MJD
952
953 if (SvRMAGICAL(av)) {
ad64d0ec 954 const MAGIC * const tied_magic
1604cfb0 955 = mg_find((const SV *)av, PERL_MAGIC_tied);
ad64d0ec 956 if ((tied_magic || mg_find((const SV *)av, PERL_MAGIC_regdata))) {
35a4481c 957 SV **svp;
6f12eb6d 958 if (key < 0) {
1604cfb0
MS
959 if (!S_adjust_index(aTHX_ av, tied_magic, &key))
960 return NULL;
6f12eb6d
MJD
961 }
962 svp = av_fetch(av, key, TRUE);
963 if (svp) {
964 sv = *svp;
965 mg_clear(sv);
966 if (mg_find(sv, PERL_MAGIC_tiedelem)) {
967 sv_unmagic(sv, PERL_MAGIC_tiedelem); /* No longer an element */
968 return sv;
969 }
1604cfb0 970 return NULL;
6f12eb6d
MJD
971 }
972 }
973 }
974
146174a9 975 if (key < 0) {
1604cfb0
MS
976 key += AvFILL(av) + 1;
977 if (key < 0)
978 return NULL;
146174a9 979 }
6f12eb6d 980
146174a9 981 if (key > AvFILLp(av))
1604cfb0 982 return NULL;
146174a9 983 else {
1604cfb0
MS
984 if (!AvREAL(av) && AvREIFY(av))
985 av_reify(av);
986 sv = AvARRAY(av)[key];
987 AvARRAY(av)[key] = NULL;
988 if (key == AvFILLp(av)) {
989 do {
990 AvFILLp(av)--;
991 } while (--key >= 0 && !AvARRAY(av)[key]);
992 }
993 if (SvSMAGICAL(av))
994 mg_set(MUTABLE_SV(av));
146174a9 995 }
725995b4 996 if(sv != NULL) {
1604cfb0
MS
997 if (flags & G_DISCARD) {
998 SvREFCNT_dec_NN(sv);
999 return NULL;
1000 }
1001 else if (AvREAL(av))
1002 sv_2mortal(sv);
146174a9
CB
1003 }
1004 return sv;
1005}
1006
1007/*
f3b76584
SC
1008=for apidoc av_exists
1009
1010Returns true if the element indexed by C<key> has been initialized.
146174a9 1011
f3b76584 1012This relies on the fact that uninitialized array elements are set to
796b6530 1013C<NULL>.
f3b76584 1014
b7ff7ff2
SF
1015Perl equivalent: C<exists($myarray[$key])>.
1016
f3b76584
SC
1017=cut
1018*/
146174a9 1019bool
c70927a6 1020Perl_av_exists(pTHX_ AV *av, SSize_t key)
146174a9 1021{
7918f24d 1022 PERL_ARGS_ASSERT_AV_EXISTS;
2fed2a1b 1023 assert(SvTYPE(av) == SVt_PVAV);
6f12eb6d
MJD
1024
1025 if (SvRMAGICAL(av)) {
ad64d0ec 1026 const MAGIC * const tied_magic
1604cfb0 1027 = mg_find((const SV *)av, PERL_MAGIC_tied);
54a4274e
PM
1028 const MAGIC * const regdata_magic
1029 = mg_find((const SV *)av, PERL_MAGIC_regdata);
1030 if (tied_magic || regdata_magic) {
6f12eb6d
MJD
1031 MAGIC *mg;
1032 /* Handle negative array indices 20020222 MJD */
1033 if (key < 0) {
1604cfb0 1034 if (!S_adjust_index(aTHX_ av, tied_magic, &key))
6f12eb6d 1035 return FALSE;
6f12eb6d
MJD
1036 }
1037
54a4274e
PM
1038 if(key >= 0 && regdata_magic) {
1039 if (key <= AvFILL(av))
1040 return TRUE;
1041 else
1042 return FALSE;
1043 }
1604cfb0
MS
1044 {
1045 SV * const sv = sv_newmortal();
1046 mg_copy(MUTABLE_SV(av), sv, 0, key);
1047 mg = mg_find(sv, PERL_MAGIC_tiedelem);
1048 if (mg) {
1049 magic_existspack(sv, mg);
1050 {
1051 I32 retbool = SvTRUE_nomg_NN(sv);
1052 return cBOOL(retbool);
1053 }
1054 }
1055 }
6f12eb6d
MJD
1056 }
1057 }
1058
146174a9 1059 if (key < 0) {
1604cfb0
MS
1060 key += AvFILL(av) + 1;
1061 if (key < 0)
1062 return FALSE;
146174a9 1063 }
6f12eb6d 1064
ce0d59fd 1065 if (key <= AvFILLp(av) && AvARRAY(av)[key])
146174a9 1066 {
1604cfb0
MS
1067 if (SvSMAGICAL(AvARRAY(av)[key])
1068 && mg_find(AvARRAY(av)[key], PERL_MAGIC_nonelem))
1069 return FALSE;
1070 return TRUE;
146174a9
CB
1071 }
1072 else
1604cfb0 1073 return FALSE;
146174a9 1074}
66610fdd 1075
c33269f7 1076static MAGIC *
878d132a 1077S_get_aux_mg(pTHX_ AV *av) {
ba5d1d60
GA
1078 MAGIC *mg;
1079
7918f24d 1080 PERL_ARGS_ASSERT_GET_AUX_MG;
2fed2a1b 1081 assert(SvTYPE(av) == SVt_PVAV);
ba5d1d60 1082
ad64d0ec 1083 mg = mg_find((const SV *)av, PERL_MAGIC_arylen_p);
a3874608
NC
1084
1085 if (!mg) {
1604cfb0
MS
1086 mg = sv_magicext(MUTABLE_SV(av), 0, PERL_MAGIC_arylen_p,
1087 &PL_vtbl_arylen_p, 0, 0);
1088 assert(mg);
1089 /* sv_magicext won't set this for us because we pass in a NULL obj */
1090 mg->mg_flags |= MGf_REFCOUNTED;
a3874608 1091 }
878d132a
NC
1092 return mg;
1093}
1094
1095SV **
1096Perl_av_arylen_p(pTHX_ AV *av) {
1097 MAGIC *const mg = get_aux_mg(av);
7918f24d
NC
1098
1099 PERL_ARGS_ASSERT_AV_ARYLEN_P;
2fed2a1b 1100 assert(SvTYPE(av) == SVt_PVAV);
7918f24d 1101
a3874608
NC
1102 return &(mg->mg_obj);
1103}
1104
453d94a9 1105IV *
878d132a
NC
1106Perl_av_iter_p(pTHX_ AV *av) {
1107 MAGIC *const mg = get_aux_mg(av);
7918f24d
NC
1108
1109 PERL_ARGS_ASSERT_AV_ITER_P;
2fed2a1b 1110 assert(SvTYPE(av) == SVt_PVAV);
7918f24d 1111
4803e7f7 1112 if (sizeof(IV) == sizeof(SSize_t)) {
1604cfb0 1113 return (IV *)&(mg->mg_len);
4803e7f7 1114 } else {
1604cfb0
MS
1115 if (!mg->mg_ptr) {
1116 IV *temp;
1117 mg->mg_len = IVSIZE;
1118 Newxz(temp, 1, IV);
1119 mg->mg_ptr = (char *) temp;
1120 }
1121 return (IV *)mg->mg_ptr;
453d94a9 1122 }
878d132a
NC
1123}
1124
1f1dcfb5
FC
1125SV *
1126Perl_av_nonelem(pTHX_ AV *av, SSize_t ix) {
1127 SV * const sv = newSV(0);
1128 PERL_ARGS_ASSERT_AV_NONELEM;
1129 if (!av_store(av,ix,sv))
1604cfb0 1130 return sv_2mortal(sv); /* has tie magic */
1f1dcfb5
FC
1131 sv_magic(sv, NULL, PERL_MAGIC_nonelem, NULL, 0);
1132 return sv;
1133}
1134
66610fdd 1135/*
14d04a33 1136 * ex: set ts=8 sts=4 sw=4 et:
37442d52 1137 */