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