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