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