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