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