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