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