This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
store AV iterator as mg_len in more cases
[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_
147e3846 92 "panic: av_extend_guts() negative count (%" IVdf ")", (IV)key);
6768377c 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;
84610c52 545 SSize_t orig_ix = PL_tmps_ix; /* silence bogus warning about possible unitialized use */
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
84610c52
YO
554 real = cBOOL(AvREAL(av));
555 if (real) {
c70927a6 556 SSize_t key = AvFILLp(av) + 1;
be988557
DM
557
558 /* avoid av being freed when calling destructors below */
559 EXTEND_MORTAL(1);
560 PL_tmps_stack[++PL_tmps_ix] = SvREFCNT_inc_simple_NN(av);
561 orig_ix = PL_tmps_ix;
562
a0d0e21e
LW
563 while (key)
564 SvREFCNT_dec(AvARRAY(av)[--key]);
565 }
22717f83 566
463ee0b2 567 Safefree(AvALLOC(av));
35da51f7 568 AvALLOC(av) = NULL;
9c6bc640 569 AvARRAY(av) = NULL;
93965878 570 AvMAX(av) = AvFILLp(av) = -1;
22717f83 571
ad64d0ec 572 if(SvRMAGICAL(av)) mg_clear(MUTABLE_SV(av));
be988557
DM
573 if (real) {
574 /* disarm av's premature free guard */
575 if (LIKELY(PL_tmps_ix == orig_ix))
576 PL_tmps_ix--;
577 else
578 PL_tmps_stack[orig_ix] = &PL_sv_undef;
579 SvREFCNT_dec_NN(av);
580 }
79072805
LW
581}
582
cb50131a 583/*
29a861e7
NC
584
585=for apidoc av_create_and_push
586
587Push an SV onto the end of the array, creating the array if necessary.
588A small internal helper function to remove a commonly duplicated idiom.
589
590=cut
591*/
592
593void
594Perl_av_create_and_push(pTHX_ AV **const avp, SV *const val)
595{
7918f24d 596 PERL_ARGS_ASSERT_AV_CREATE_AND_PUSH;
2fed2a1b 597
29a861e7
NC
598 if (!*avp)
599 *avp = newAV();
600 av_push(*avp, val);
601}
602
603/*
cb50131a
CB
604=for apidoc av_push
605
b895c103
KW
606Pushes an SV (transferring control of one reference count) onto the end of the
607array. The array will grow automatically to accommodate the addition.
cb50131a 608
17b0bd77 609Perl equivalent: C<push @myarray, $val;>.
f0b90de1 610
cb50131a
CB
611=cut
612*/
613
a0d0e21e 614void
5aaab254 615Perl_av_push(pTHX_ AV *av, SV *val)
93965878
NIS
616{
617 MAGIC *mg;
7918f24d
NC
618
619 PERL_ARGS_ASSERT_AV_PUSH;
2fed2a1b 620 assert(SvTYPE(av) == SVt_PVAV);
ba5d1d60 621
93965878 622 if (SvREADONLY(av))
cb077ed2 623 Perl_croak_no_modify();
93965878 624
ad64d0ec 625 if ((mg = SvTIED_mg((const SV *)av, PERL_MAGIC_tied))) {
36925d9e 626 Perl_magic_methcall(aTHX_ MUTABLE_SV(av), mg, SV_CONST(PUSH), G_DISCARD, 1,
046b0c7d 627 val);
93965878
NIS
628 return;
629 }
630 av_store(av,AvFILLp(av)+1,val);
79072805
LW
631}
632
cb50131a
CB
633/*
634=for apidoc av_pop
635
f5d13a25
KW
636Removes one SV from the end of the array, reducing its size by one and
637returning the SV (transferring control of one reference count) to the
638caller. Returns C<&PL_sv_undef> if the array is empty.
cb50131a 639
f0b90de1
SF
640Perl equivalent: C<pop(@myarray);>
641
cb50131a
CB
642=cut
643*/
644
79072805 645SV *
5aaab254 646Perl_av_pop(pTHX_ AV *av)
79072805
LW
647{
648 SV *retval;
93965878 649 MAGIC* mg;
79072805 650
7918f24d 651 PERL_ARGS_ASSERT_AV_POP;
2fed2a1b 652 assert(SvTYPE(av) == SVt_PVAV);
ba5d1d60 653
43fcc5d2 654 if (SvREADONLY(av))
cb077ed2 655 Perl_croak_no_modify();
ad64d0ec 656 if ((mg = SvTIED_mg((const SV *)av, PERL_MAGIC_tied))) {
36925d9e 657 retval = Perl_magic_methcall(aTHX_ MUTABLE_SV(av), mg, SV_CONST(POP), 0, 0);
efaf3674
DM
658 if (retval)
659 retval = newSVsv(retval);
93965878
NIS
660 return retval;
661 }
d19c0e07
MJD
662 if (AvFILL(av) < 0)
663 return &PL_sv_undef;
93965878 664 retval = AvARRAY(av)[AvFILLp(av)];
ce0d59fd 665 AvARRAY(av)[AvFILLp(av)--] = NULL;
8990e307 666 if (SvSMAGICAL(av))
ad64d0ec 667 mg_set(MUTABLE_SV(av));
ce0d59fd 668 return retval ? retval : &PL_sv_undef;
79072805
LW
669}
670
cb50131a 671/*
29a861e7
NC
672
673=for apidoc av_create_and_unshift_one
674
675Unshifts an SV onto the beginning of the array, creating the array if
676necessary.
677A small internal helper function to remove a commonly duplicated idiom.
678
679=cut
680*/
681
682SV **
683Perl_av_create_and_unshift_one(pTHX_ AV **const avp, SV *const val)
684{
7918f24d 685 PERL_ARGS_ASSERT_AV_CREATE_AND_UNSHIFT_ONE;
2fed2a1b 686
29a861e7
NC
687 if (!*avp)
688 *avp = newAV();
689 av_unshift(*avp, 1);
690 return av_store(*avp, 0, val);
691}
692
693/*
cb50131a
CB
694=for apidoc av_unshift
695
696Unshift the given number of C<undef> values onto the beginning of the
17b0bd77 697array. The array will grow automatically to accommodate the addition.
cb50131a 698
17b0bd77 699Perl equivalent: S<C<unshift @myarray, ((undef) x $num);>>
f703fc96 700
cb50131a
CB
701=cut
702*/
703
79072805 704void
c70927a6 705Perl_av_unshift(pTHX_ AV *av, SSize_t num)
79072805 706{
c70927a6 707 SSize_t i;
93965878 708 MAGIC* mg;
79072805 709
7918f24d 710 PERL_ARGS_ASSERT_AV_UNSHIFT;
2fed2a1b 711 assert(SvTYPE(av) == SVt_PVAV);
ba5d1d60 712
43fcc5d2 713 if (SvREADONLY(av))
cb077ed2 714 Perl_croak_no_modify();
93965878 715
ad64d0ec 716 if ((mg = SvTIED_mg((const SV *)av, PERL_MAGIC_tied))) {
36925d9e 717 Perl_magic_methcall(aTHX_ MUTABLE_SV(av), mg, SV_CONST(UNSHIFT),
046b0c7d 718 G_DISCARD | G_UNDEF_FILL, num);
93965878
NIS
719 return;
720 }
721
d19c0e07
MJD
722 if (num <= 0)
723 return;
49beac48
CS
724 if (!AvREAL(av) && AvREIFY(av))
725 av_reify(av);
a0d0e21e
LW
726 i = AvARRAY(av) - AvALLOC(av);
727 if (i) {
728 if (i > num)
729 i = num;
730 num -= i;
731
732 AvMAX(av) += i;
93965878 733 AvFILLp(av) += i;
9c6bc640 734 AvARRAY(av) = AvARRAY(av) - i;
a0d0e21e 735 }
d2719217 736 if (num) {
eb578fdb 737 SV **ary;
c70927a6 738 const SSize_t i = AvFILLp(av);
e2b534e7 739 /* Create extra elements */
c70927a6 740 const SSize_t slide = i > 0 ? i : 0;
e2b534e7 741 num += slide;
67a38de0 742 av_extend(av, i + num);
93965878 743 AvFILLp(av) += num;
67a38de0
NIS
744 ary = AvARRAY(av);
745 Move(ary, ary + num, i + 1, SV*);
746 do {
ce0d59fd 747 ary[--num] = NULL;
67a38de0 748 } while (num);
e2b534e7
BT
749 /* Make extra elements into a buffer */
750 AvMAX(av) -= slide;
751 AvFILLp(av) -= slide;
9c6bc640 752 AvARRAY(av) = AvARRAY(av) + slide;
79072805
LW
753 }
754}
755
cb50131a
CB
756/*
757=for apidoc av_shift
758
dbc2ea0c
SM
759Removes one SV from the start of the array, reducing its size by one and
760returning the SV (transferring control of one reference count) to the
761caller. Returns C<&PL_sv_undef> if the array is empty.
cb50131a 762
f0b90de1
SF
763Perl equivalent: C<shift(@myarray);>
764
cb50131a
CB
765=cut
766*/
767
79072805 768SV *
5aaab254 769Perl_av_shift(pTHX_ AV *av)
79072805
LW
770{
771 SV *retval;
93965878 772 MAGIC* mg;
79072805 773
7918f24d 774 PERL_ARGS_ASSERT_AV_SHIFT;
2fed2a1b 775 assert(SvTYPE(av) == SVt_PVAV);
ba5d1d60 776
43fcc5d2 777 if (SvREADONLY(av))
cb077ed2 778 Perl_croak_no_modify();
ad64d0ec 779 if ((mg = SvTIED_mg((const SV *)av, PERL_MAGIC_tied))) {
36925d9e 780 retval = Perl_magic_methcall(aTHX_ MUTABLE_SV(av), mg, SV_CONST(SHIFT), 0, 0);
efaf3674
DM
781 if (retval)
782 retval = newSVsv(retval);
93965878
NIS
783 return retval;
784 }
d19c0e07
MJD
785 if (AvFILL(av) < 0)
786 return &PL_sv_undef;
463ee0b2 787 retval = *AvARRAY(av);
a0d0e21e 788 if (AvREAL(av))
ce0d59fd 789 *AvARRAY(av) = NULL;
9c6bc640 790 AvARRAY(av) = AvARRAY(av) + 1;
463ee0b2 791 AvMAX(av)--;
93965878 792 AvFILLp(av)--;
8990e307 793 if (SvSMAGICAL(av))
ad64d0ec 794 mg_set(MUTABLE_SV(av));
ce0d59fd 795 return retval ? retval : &PL_sv_undef;
79072805
LW
796}
797
cb50131a 798/*
dab460cd 799=for apidoc av_top_index
cb50131a 800
977a499b 801Returns the highest index in the array. The number of elements in the
61b16eb9 802array is S<C<av_top_index(av) + 1>>. Returns -1 if the array is empty.
cb50131a 803
a8676f70
SF
804The Perl equivalent for this is C<$#myarray>.
805
12719193
KW
806(A slightly shorter form is C<av_tindex>.)
807
36baafc9
KW
808=for apidoc av_len
809
b985ae61
KW
810Same as L</av_top_index>. Note that, unlike what the name implies, it returns
811the highest index in the array, so to get the size of the array you need to use
812S<C<av_len(av) + 1>>. This is unlike L</sv_len>, which returns what you would
813expect.
36baafc9 814
cb50131a
CB
815=cut
816*/
817
c70927a6 818SSize_t
bb5dd93d 819Perl_av_len(pTHX_ AV *av)
79072805 820{
7918f24d 821 PERL_ARGS_ASSERT_AV_LEN;
36baafc9 822
be3a7a5d 823 return av_top_index(av);
36baafc9
KW
824}
825
f3b76584
SC
826/*
827=for apidoc av_fill
828
977a499b 829Set the highest index in the array to the given number, equivalent to
61b16eb9 830Perl's S<C<$#array = $fill;>>.
f3b76584 831
61b16eb9 832The number of elements in the array will be S<C<fill + 1>> after
796b6530 833C<av_fill()> returns. If the array was previously shorter, then the
ce0d59fd 834additional elements appended are set to NULL. If the array
61b16eb9 835was longer, then the excess elements are freed. S<C<av_fill(av, -1)>> is
977a499b
GA
836the same as C<av_clear(av)>.
837
f3b76584
SC
838=cut
839*/
79072805 840void
c70927a6 841Perl_av_fill(pTHX_ AV *av, SSize_t fill)
79072805 842{
93965878 843 MAGIC *mg;
ba5d1d60 844
7918f24d 845 PERL_ARGS_ASSERT_AV_FILL;
2fed2a1b 846 assert(SvTYPE(av) == SVt_PVAV);
ba5d1d60 847
79072805
LW
848 if (fill < 0)
849 fill = -1;
ad64d0ec 850 if ((mg = SvTIED_mg((const SV *)av, PERL_MAGIC_tied))) {
efaf3674
DM
851 SV *arg1 = sv_newmortal();
852 sv_setiv(arg1, (IV)(fill + 1));
36925d9e 853 Perl_magic_methcall(aTHX_ MUTABLE_SV(av), mg, SV_CONST(STORESIZE), G_DISCARD,
046b0c7d 854 1, arg1);
93965878
NIS
855 return;
856 }
463ee0b2 857 if (fill <= AvMAX(av)) {
c70927a6 858 SSize_t key = AvFILLp(av);
fabdb6c0 859 SV** const ary = AvARRAY(av);
a0d0e21e
LW
860
861 if (AvREAL(av)) {
862 while (key > fill) {
863 SvREFCNT_dec(ary[key]);
ce0d59fd 864 ary[key--] = NULL;
a0d0e21e
LW
865 }
866 }
867 else {
868 while (key < fill)
ce0d59fd 869 ary[++key] = NULL;
a0d0e21e
LW
870 }
871
93965878 872 AvFILLp(av) = fill;
8990e307 873 if (SvSMAGICAL(av))
ad64d0ec 874 mg_set(MUTABLE_SV(av));
463ee0b2 875 }
a0d0e21e 876 else
ce0d59fd 877 (void)av_store(av,fill,NULL);
79072805 878}
c750a3ec 879
f3b76584
SC
880/*
881=for apidoc av_delete
882
17b0bd77
DM
883Deletes the element indexed by C<key> from the array, makes the element
884mortal, and returns it. If C<flags> equals C<G_DISCARD>, the element is
885freed and NULL is returned. NULL is also returned if C<key> is out of
886range.
887
888Perl equivalent: S<C<splice(@myarray, $key, 1, undef)>> (with the
889C<splice> in void context if C<G_DISCARD> is present).
f3b76584
SC
890
891=cut
892*/
146174a9 893SV *
c70927a6 894Perl_av_delete(pTHX_ AV *av, SSize_t key, I32 flags)
146174a9
CB
895{
896 SV *sv;
897
7918f24d 898 PERL_ARGS_ASSERT_AV_DELETE;
2fed2a1b 899 assert(SvTYPE(av) == SVt_PVAV);
ba5d1d60 900
146174a9 901 if (SvREADONLY(av))
cb077ed2 902 Perl_croak_no_modify();
6f12eb6d
MJD
903
904 if (SvRMAGICAL(av)) {
ad64d0ec
NC
905 const MAGIC * const tied_magic
906 = mg_find((const SV *)av, PERL_MAGIC_tied);
907 if ((tied_magic || mg_find((const SV *)av, PERL_MAGIC_regdata))) {
35a4481c 908 SV **svp;
6f12eb6d 909 if (key < 0) {
ac9f75b5 910 if (!S_adjust_index(aTHX_ av, tied_magic, &key))
fabdb6c0 911 return NULL;
6f12eb6d
MJD
912 }
913 svp = av_fetch(av, key, TRUE);
914 if (svp) {
915 sv = *svp;
916 mg_clear(sv);
917 if (mg_find(sv, PERL_MAGIC_tiedelem)) {
918 sv_unmagic(sv, PERL_MAGIC_tiedelem); /* No longer an element */
919 return sv;
920 }
fabdb6c0 921 return NULL;
6f12eb6d
MJD
922 }
923 }
924 }
925
146174a9
CB
926 if (key < 0) {
927 key += AvFILL(av) + 1;
928 if (key < 0)
fabdb6c0 929 return NULL;
146174a9 930 }
6f12eb6d 931
146174a9 932 if (key > AvFILLp(av))
fabdb6c0 933 return NULL;
146174a9 934 else {
a6214072
DM
935 if (!AvREAL(av) && AvREIFY(av))
936 av_reify(av);
146174a9 937 sv = AvARRAY(av)[key];
725995b4 938 AvARRAY(av)[key] = NULL;
146174a9
CB
939 if (key == AvFILLp(av)) {
940 do {
941 AvFILLp(av)--;
ce0d59fd 942 } while (--key >= 0 && !AvARRAY(av)[key]);
146174a9 943 }
146174a9 944 if (SvSMAGICAL(av))
ad64d0ec 945 mg_set(MUTABLE_SV(av));
146174a9 946 }
725995b4
DD
947 if(sv != NULL) {
948 if (flags & G_DISCARD) {
949 SvREFCNT_dec_NN(sv);
950 return NULL;
951 }
952 else if (AvREAL(av))
953 sv_2mortal(sv);
146174a9
CB
954 }
955 return sv;
956}
957
958/*
f3b76584
SC
959=for apidoc av_exists
960
961Returns true if the element indexed by C<key> has been initialized.
146174a9 962
f3b76584 963This relies on the fact that uninitialized array elements are set to
796b6530 964C<NULL>.
f3b76584 965
b7ff7ff2
SF
966Perl equivalent: C<exists($myarray[$key])>.
967
f3b76584
SC
968=cut
969*/
146174a9 970bool
c70927a6 971Perl_av_exists(pTHX_ AV *av, SSize_t key)
146174a9 972{
7918f24d 973 PERL_ARGS_ASSERT_AV_EXISTS;
2fed2a1b 974 assert(SvTYPE(av) == SVt_PVAV);
6f12eb6d
MJD
975
976 if (SvRMAGICAL(av)) {
ad64d0ec
NC
977 const MAGIC * const tied_magic
978 = mg_find((const SV *)av, PERL_MAGIC_tied);
54a4274e
PM
979 const MAGIC * const regdata_magic
980 = mg_find((const SV *)av, PERL_MAGIC_regdata);
981 if (tied_magic || regdata_magic) {
6f12eb6d
MJD
982 MAGIC *mg;
983 /* Handle negative array indices 20020222 MJD */
984 if (key < 0) {
ac9f75b5 985 if (!S_adjust_index(aTHX_ av, tied_magic, &key))
6f12eb6d 986 return FALSE;
6f12eb6d
MJD
987 }
988
54a4274e
PM
989 if(key >= 0 && regdata_magic) {
990 if (key <= AvFILL(av))
991 return TRUE;
992 else
993 return FALSE;
994 }
716ae3b0
R
995 {
996 SV * const sv = sv_newmortal();
997 mg_copy(MUTABLE_SV(av), sv, 0, key);
998 mg = mg_find(sv, PERL_MAGIC_tiedelem);
999 if (mg) {
1000 magic_existspack(sv, mg);
1001 {
1002 I32 retbool = SvTRUE_nomg_NN(sv);
1003 return cBOOL(retbool);
1004 }
1005 }
1006 }
6f12eb6d
MJD
1007 }
1008 }
1009
146174a9
CB
1010 if (key < 0) {
1011 key += AvFILL(av) + 1;
1012 if (key < 0)
1013 return FALSE;
1014 }
6f12eb6d 1015
ce0d59fd 1016 if (key <= AvFILLp(av) && AvARRAY(av)[key])
146174a9
CB
1017 {
1018 return TRUE;
1019 }
1020 else
1021 return FALSE;
1022}
66610fdd 1023
c33269f7 1024static MAGIC *
878d132a 1025S_get_aux_mg(pTHX_ AV *av) {
ba5d1d60
GA
1026 MAGIC *mg;
1027
7918f24d 1028 PERL_ARGS_ASSERT_GET_AUX_MG;
2fed2a1b 1029 assert(SvTYPE(av) == SVt_PVAV);
ba5d1d60 1030
ad64d0ec 1031 mg = mg_find((const SV *)av, PERL_MAGIC_arylen_p);
a3874608
NC
1032
1033 if (!mg) {
ad64d0ec
NC
1034 mg = sv_magicext(MUTABLE_SV(av), 0, PERL_MAGIC_arylen_p,
1035 &PL_vtbl_arylen_p, 0, 0);
c82c7adc 1036 assert(mg);
a3874608
NC
1037 /* sv_magicext won't set this for us because we pass in a NULL obj */
1038 mg->mg_flags |= MGf_REFCOUNTED;
1039 }
878d132a
NC
1040 return mg;
1041}
1042
1043SV **
1044Perl_av_arylen_p(pTHX_ AV *av) {
1045 MAGIC *const mg = get_aux_mg(av);
7918f24d
NC
1046
1047 PERL_ARGS_ASSERT_AV_ARYLEN_P;
2fed2a1b 1048 assert(SvTYPE(av) == SVt_PVAV);
7918f24d 1049
a3874608
NC
1050 return &(mg->mg_obj);
1051}
1052
453d94a9 1053IV *
878d132a
NC
1054Perl_av_iter_p(pTHX_ AV *av) {
1055 MAGIC *const mg = get_aux_mg(av);
7918f24d
NC
1056
1057 PERL_ARGS_ASSERT_AV_ITER_P;
2fed2a1b 1058 assert(SvTYPE(av) == SVt_PVAV);
7918f24d 1059
4803e7f7
Z
1060 if (sizeof(IV) == sizeof(SSize_t)) {
1061 return (IV *)&(mg->mg_len);
1062 } else {
1063 if (!mg->mg_ptr) {
1064 IV *temp;
1065 mg->mg_len = IVSIZE;
1066 Newxz(temp, 1, IV);
1067 mg->mg_ptr = (char *) temp;
1068 }
1069 return (IV *)mg->mg_ptr;
453d94a9 1070 }
878d132a
NC
1071}
1072
66610fdd 1073/*
14d04a33 1074 * ex: set ts=8 sts=4 sw=4 et:
37442d52 1075 */