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