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