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