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