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