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