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