This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
av.c: Add blank line before =cut
[perl5.git] / av.c
CommitLineData
a0d0e21e 1/* av.c
79072805 2 *
1129b882
NC
3 * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000,
4 * 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008 by Larry Wall and others
79072805
LW
5 *
6 * You may distribute under the terms of either the GNU General Public
7 * License or the Artistic License, as specified in the README file.
8 *
a0d0e21e
LW
9 */
10
11/*
4ac71550
TC
12 * '...for the Entwives desired order, and plenty, and peace (by which they
13 * meant that things should remain where they had set them).' --Treebeard
14 *
15 * [p.476 of _The Lord of the Rings_, III/iv: "Treebeard"]
79072805
LW
16 */
17
ccfc67b7
JH
18/*
19=head1 Array Manipulation Functions
20*/
21
79072805 22#include "EXTERN.h"
864dbfa3 23#define PERL_IN_AV_C
79072805
LW
24#include "perl.h"
25
fb73857a 26void
864dbfa3 27Perl_av_reify(pTHX_ AV *av)
a0d0e21e 28{
97aff369 29 dVAR;
a0d0e21e 30 I32 key;
fb73857a 31
7918f24d 32 PERL_ARGS_ASSERT_AV_REIFY;
2fed2a1b 33 assert(SvTYPE(av) == SVt_PVAV);
ba5d1d60 34
3c78fafa
GS
35 if (AvREAL(av))
36 return;
93965878 37#ifdef DEBUGGING
9b387841
NC
38 if (SvTIED_mg((const SV *)av, PERL_MAGIC_tied))
39 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEBUGGING), "av_reify called on tied array");
93965878 40#endif
a0d0e21e 41 key = AvMAX(av) + 1;
93965878 42 while (key > AvFILLp(av) + 1)
3280af22 43 AvARRAY(av)[--key] = &PL_sv_undef;
a0d0e21e 44 while (key) {
4373e329 45 SV * const sv = AvARRAY(av)[--key];
a0d0e21e 46 assert(sv);
411caa50 47 if (sv != &PL_sv_undef)
e2d306cb 48 SvREFCNT_inc_simple_void_NN(sv);
a0d0e21e 49 }
29de640a
CS
50 key = AvARRAY(av) - AvALLOC(av);
51 while (key)
3280af22 52 AvALLOC(av)[--key] = &PL_sv_undef;
62b1ebc2 53 AvREIFY_off(av);
a0d0e21e
LW
54 AvREAL_on(av);
55}
56
cb50131a
CB
57/*
58=for apidoc av_extend
59
60Pre-extend an array. The C<key> is the index to which the array should be
61extended.
62
63=cut
64*/
65
a0d0e21e 66void
864dbfa3 67Perl_av_extend(pTHX_ AV *av, I32 key)
a0d0e21e 68{
97aff369 69 dVAR;
7a5b473e
AL
70 MAGIC *mg;
71
7918f24d 72 PERL_ARGS_ASSERT_AV_EXTEND;
2fed2a1b 73 assert(SvTYPE(av) == SVt_PVAV);
ba5d1d60 74
ad64d0ec 75 mg = SvTIED_mg((const SV *)av, PERL_MAGIC_tied);
823a54a3 76 if (mg) {
efaf3674
DM
77 SV *arg1 = sv_newmortal();
78 sv_setiv(arg1, (IV)(key + 1));
046b0c7d
NC
79 Perl_magic_methcall(aTHX_ MUTABLE_SV(av), mg, "EXTEND", G_DISCARD, 1,
80 arg1);
93965878
NIS
81 return;
82 }
a0d0e21e
LW
83 if (key > AvMAX(av)) {
84 SV** ary;
85 I32 tmp;
86 I32 newmax;
87
88 if (AvALLOC(av) != AvARRAY(av)) {
93965878 89 ary = AvALLOC(av) + AvFILLp(av) + 1;
a0d0e21e 90 tmp = AvARRAY(av) - AvALLOC(av);
93965878 91 Move(AvARRAY(av), AvALLOC(av), AvFILLp(av)+1, SV*);
a0d0e21e 92 AvMAX(av) += tmp;
9c6bc640 93 AvARRAY(av) = AvALLOC(av);
a0d0e21e
LW
94 if (AvREAL(av)) {
95 while (tmp)
3280af22 96 ary[--tmp] = &PL_sv_undef;
a0d0e21e 97 }
a0d0e21e
LW
98 if (key > AvMAX(av) - 10) {
99 newmax = key + AvMAX(av);
100 goto resize;
101 }
102 }
103 else {
2b573ace
JH
104#ifdef PERL_MALLOC_WRAP
105 static const char oom_array_extend[] =
106 "Out of memory during array extend"; /* Duplicated in pp_hot.c */
107#endif
108
a0d0e21e 109 if (AvALLOC(av)) {
516a5887 110#if !defined(STRANGE_MALLOC) && !defined(MYMALLOC)
c1f7b11a
SB
111 MEM_SIZE bytes;
112 IV itmp;
c07a80fd 113#endif
4633a7c4 114
ca7c1a29 115#ifdef Perl_safesysmalloc_size
e050cc0e
NC
116 /* Whilst it would be quite possible to move this logic around
117 (as I did in the SV code), so as to set AvMAX(av) early,
118 based on calling Perl_safesysmalloc_size() immediately after
119 allocation, I'm not convinced that it is a great idea here.
120 In an array we have to loop round setting everything to
121 &PL_sv_undef, which means writing to memory, potentially lots
122 of it, whereas for the SV buffer case we don't touch the
123 "bonus" memory. So there there is no cost in telling the
124 world about it, whereas here we have to do work before we can
125 tell the world about it, and that work involves writing to
126 memory that might never be read. So, I feel, better to keep
127 the current lazy system of only writing to it if our caller
128 has a need for more space. NWC */
ca7c1a29 129 newmax = Perl_safesysmalloc_size((void*)AvALLOC(av)) /
260890ed 130 sizeof(const SV *) - 1;
8d6dde3e
IZ
131
132 if (key <= newmax)
133 goto resized;
134#endif
a0d0e21e
LW
135 newmax = key + AvMAX(av) / 5;
136 resize:
2b573ace 137 MEM_WRAP_CHECK_1(newmax+1, SV*, oom_array_extend);
8d6dde3e 138#if defined(STRANGE_MALLOC) || defined(MYMALLOC)
a0d0e21e 139 Renew(AvALLOC(av),newmax+1, SV*);
4633a7c4 140#else
260890ed 141 bytes = (newmax + 1) * sizeof(const SV *);
4633a7c4 142#define MALLOC_OVERHEAD 16
c1f7b11a 143 itmp = MALLOC_OVERHEAD;
eb160463 144 while ((MEM_SIZE)(itmp - MALLOC_OVERHEAD) < bytes)
c1f7b11a
SB
145 itmp += itmp;
146 itmp -= MALLOC_OVERHEAD;
260890ed 147 itmp /= sizeof(const SV *);
c1f7b11a
SB
148 assert(itmp > newmax);
149 newmax = itmp - 1;
150 assert(newmax >= AvMAX(av));
a02a5408 151 Newx(ary, newmax+1, SV*);
4633a7c4 152 Copy(AvALLOC(av), ary, AvMAX(av)+1, SV*);
9a87bd09 153 Safefree(AvALLOC(av));
4633a7c4
LW
154 AvALLOC(av) = ary;
155#endif
ca7c1a29 156#ifdef Perl_safesysmalloc_size
8d6dde3e 157 resized:
9c5ffd7c 158#endif
a0d0e21e
LW
159 ary = AvALLOC(av) + AvMAX(av) + 1;
160 tmp = newmax - AvMAX(av);
3280af22
NIS
161 if (av == PL_curstack) { /* Oops, grew stack (via av_store()?) */
162 PL_stack_sp = AvALLOC(av) + (PL_stack_sp - PL_stack_base);
163 PL_stack_base = AvALLOC(av);
164 PL_stack_max = PL_stack_base + newmax;
a0d0e21e
LW
165 }
166 }
167 else {
8d6dde3e 168 newmax = key < 3 ? 3 : key;
2b573ace 169 MEM_WRAP_CHECK_1(newmax+1, SV*, oom_array_extend);
a02a5408 170 Newx(AvALLOC(av), newmax+1, SV*);
a0d0e21e
LW
171 ary = AvALLOC(av) + 1;
172 tmp = newmax;
3280af22 173 AvALLOC(av)[0] = &PL_sv_undef; /* For the stacks */
a0d0e21e
LW
174 }
175 if (AvREAL(av)) {
176 while (tmp)
3280af22 177 ary[--tmp] = &PL_sv_undef;
a0d0e21e
LW
178 }
179
9c6bc640 180 AvARRAY(av) = AvALLOC(av);
a0d0e21e
LW
181 AvMAX(av) = newmax;
182 }
183 }
184}
185
cb50131a
CB
186/*
187=for apidoc av_fetch
188
189Returns the SV at the specified index in the array. The C<key> is the
1a328862
SF
190index. If lval is true, you are guaranteed to get a real SV back (in case
191it wasn't real before), which you can then modify. Check that the return
192value is non-null before dereferencing it to a C<SV*>.
cb50131a
CB
193
194See L<perlguts/"Understanding the Magic of Tied Hashes and Arrays"> for
195more information on how to use this function on tied arrays.
196
1a328862 197The rough perl equivalent is C<$myarray[$idx]>.
3347919d 198
cb50131a
CB
199=cut
200*/
201
79072805 202SV**
864dbfa3 203Perl_av_fetch(pTHX_ register AV *av, I32 key, I32 lval)
79072805 204{
97aff369 205 dVAR;
79072805 206
7918f24d 207 PERL_ARGS_ASSERT_AV_FETCH;
2fed2a1b 208 assert(SvTYPE(av) == SVt_PVAV);
a0d0e21e 209
6f12eb6d 210 if (SvRMAGICAL(av)) {
ad64d0ec
NC
211 const MAGIC * const tied_magic
212 = mg_find((const SV *)av, PERL_MAGIC_tied);
213 if (tied_magic || mg_find((const SV *)av, PERL_MAGIC_regdata)) {
e2d306cb
AL
214 SV *sv;
215 if (key < 0) {
216 I32 adjust_index = 1;
217 if (tied_magic) {
218 /* Handle negative array indices 20020222 MJD */
219 SV * const * const negative_indices_glob =
ad64d0ec
NC
220 hv_fetch(SvSTASH(SvRV(SvTIED_obj(MUTABLE_SV(av),
221 tied_magic))),
e2d306cb
AL
222 NEGATIVE_INDICES_VAR, 16, 0);
223
224 if (negative_indices_glob && SvTRUE(GvSV(*negative_indices_glob)))
225 adjust_index = 0;
226 }
6f12eb6d 227
e2d306cb
AL
228 if (adjust_index) {
229 key += AvFILL(av) + 1;
230 if (key < 0)
231 return NULL;
232 }
233 }
6f12eb6d
MJD
234
235 sv = sv_newmortal();
dd28f7bb 236 sv_upgrade(sv, SVt_PVLV);
ad64d0ec 237 mg_copy(MUTABLE_SV(av), sv, 0, key);
2d961f6d
DM
238 if (!tied_magic) /* for regdata, force leavesub to make copies */
239 SvTEMP_off(sv);
dd28f7bb
DM
240 LvTYPE(sv) = 't';
241 LvTARG(sv) = sv; /* fake (SV**) */
242 return &(LvTARG(sv));
6f12eb6d
MJD
243 }
244 }
245
93965878
NIS
246 if (key < 0) {
247 key += AvFILL(av) + 1;
248 if (key < 0)
e2d306cb 249 return NULL;
93965878
NIS
250 }
251
93965878 252 if (key > AvFILLp(av)) {
a0d0e21e 253 if (!lval)
e2d306cb
AL
254 return NULL;
255 return av_store(av,key,newSV(0));
79072805 256 }
3280af22 257 if (AvARRAY(av)[key] == &PL_sv_undef) {
4dbf4341 258 emptyness:
e2d306cb
AL
259 if (lval)
260 return av_store(av,key,newSV(0));
261 return NULL;
79072805 262 }
4dbf4341
PP
263 else if (AvREIFY(av)
264 && (!AvARRAY(av)[key] /* eg. @_ could have freed elts */
0565a181 265 || SvIS_FREED(AvARRAY(av)[key]))) {
3280af22 266 AvARRAY(av)[key] = &PL_sv_undef; /* 1/2 reify */
4dbf4341
PP
267 goto emptyness;
268 }
463ee0b2 269 return &AvARRAY(av)[key];
79072805
LW
270}
271
cb50131a
CB
272/*
273=for apidoc av_store
274
275Stores an SV in an array. The array index is specified as C<key>. The
276return value will be NULL if the operation failed or if the value did not
277need to be actually stored within the array (as in the case of tied
278arrays). Otherwise it can be dereferenced to get the original C<SV*>. Note
279that the caller is responsible for suitably incrementing the reference
280count of C<val> before the call, and decrementing it if the function
281returned NULL.
282
283See L<perlguts/"Understanding the Magic of Tied Hashes and Arrays"> for
284more information on how to use this function on tied arrays.
285
286=cut
287*/
288
79072805 289SV**
864dbfa3 290Perl_av_store(pTHX_ register AV *av, I32 key, SV *val)
79072805 291{
97aff369 292 dVAR;
79072805
LW
293 SV** ary;
294
7918f24d 295 PERL_ARGS_ASSERT_AV_STORE;
2fed2a1b 296 assert(SvTYPE(av) == SVt_PVAV);
ba5d1d60 297
725ac12f
NC
298 /* S_regclass relies on being able to pass in a NULL sv
299 (unicode_alternate may be NULL).
300 */
301
43fcc5d2 302 if (!val)
3280af22 303 val = &PL_sv_undef;
463ee0b2 304
6f12eb6d 305 if (SvRMAGICAL(av)) {
ad64d0ec 306 const MAGIC * const tied_magic = mg_find((const SV *)av, PERL_MAGIC_tied);
6f12eb6d
MJD
307 if (tied_magic) {
308 /* Handle negative array indices 20020222 MJD */
309 if (key < 0) {
e2d306cb 310 bool adjust_index = 1;
823a54a3 311 SV * const * const negative_indices_glob =
ad64d0ec 312 hv_fetch(SvSTASH(SvRV(SvTIED_obj(MUTABLE_SV(av),
6f12eb6d
MJD
313 tied_magic))),
314 NEGATIVE_INDICES_VAR, 16, 0);
315 if (negative_indices_glob
316 && SvTRUE(GvSV(*negative_indices_glob)))
317 adjust_index = 0;
318 if (adjust_index) {
319 key += AvFILL(av) + 1;
320 if (key < 0)
321 return 0;
322 }
323 }
324 if (val != &PL_sv_undef) {
ad64d0ec 325 mg_copy(MUTABLE_SV(av), val, 0, key);
6f12eb6d 326 }
e2d306cb 327 return NULL;
6f12eb6d
MJD
328 }
329 }
330
331
a0d0e21e
LW
332 if (key < 0) {
333 key += AvFILL(av) + 1;
334 if (key < 0)
e2d306cb 335 return NULL;
79072805 336 }
93965878 337
43fcc5d2 338 if (SvREADONLY(av) && key >= AvFILL(av))
6ad8f254 339 Perl_croak_no_modify(aTHX);
93965878 340
49beac48 341 if (!AvREAL(av) && AvREIFY(av))
a0d0e21e 342 av_reify(av);
a0d0e21e
LW
343 if (key > AvMAX(av))
344 av_extend(av,key);
463ee0b2 345 ary = AvARRAY(av);
93965878 346 if (AvFILLp(av) < key) {
a0d0e21e 347 if (!AvREAL(av)) {
3280af22
NIS
348 if (av == PL_curstack && key > PL_stack_sp - PL_stack_base)
349 PL_stack_sp = PL_stack_base + key; /* XPUSH in disguise */
e2d306cb 350 do {
3280af22 351 ary[++AvFILLp(av)] = &PL_sv_undef;
e2d306cb 352 } while (AvFILLp(av) < key);
79072805 353 }
93965878 354 AvFILLp(av) = key;
79072805 355 }
a0d0e21e
LW
356 else if (AvREAL(av))
357 SvREFCNT_dec(ary[key]);
79072805 358 ary[key] = val;
8990e307 359 if (SvSMAGICAL(av)) {
89c14e2e 360 const MAGIC* const mg = SvMAGIC(av);
3280af22 361 if (val != &PL_sv_undef) {
ad64d0ec 362 sv_magic(val, MUTABLE_SV(av), toLOWER(mg->mg_type), 0, key);
a0d0e21e 363 }
89c14e2e 364 if (PL_delaymagic && mg->mg_type == PERL_MAGIC_isa)
354b0578 365 PL_delaymagic |= DM_ARRAY_ISA;
89c14e2e 366 else
ad64d0ec 367 mg_set(MUTABLE_SV(av));
463ee0b2 368 }
79072805
LW
369 return &ary[key];
370}
371
cb50131a 372/*
cb50131a
CB
373=for apidoc av_make
374
375Creates a new AV and populates it with a list of SVs. The SVs are copied
376into the array, so they may be freed after the call to av_make. The new AV
377will have a reference count of 1.
378
775f1d61
SF
379Perl equivalent: C<my @new_array = ($scalar1, $scalar2, $scalar3...);>
380
cb50131a
CB
381=cut
382*/
383
79072805 384AV *
864dbfa3 385Perl_av_make(pTHX_ register I32 size, register SV **strp)
79072805 386{
502c6561 387 register AV * const av = MUTABLE_AV(newSV_type(SVt_PVAV));
a7f5e44d 388 /* sv_upgrade does AvREAL_only() */
7918f24d 389 PERL_ARGS_ASSERT_AV_MAKE;
2fed2a1b
NC
390 assert(SvTYPE(av) == SVt_PVAV);
391
a0288114 392 if (size) { /* "defined" was returning undef for size==0 anyway. */
dd374669
AL
393 register SV** ary;
394 register I32 i;
a02a5408 395 Newx(ary,size,SV*);
573fa4ea 396 AvALLOC(av) = ary;
9c6bc640 397 AvARRAY(av) = ary;
35da51f7 398 AvFILLp(av) = AvMAX(av) = size - 1;
573fa4ea
TB
399 for (i = 0; i < size; i++) {
400 assert (*strp);
2b676593
BB
401
402 /* Don't let sv_setsv swipe, since our source array might
403 have multiple references to the same temp scalar (e.g.
404 from a list slice) */
405
561b68a9 406 ary[i] = newSV(0);
2b676593
BB
407 sv_setsv_flags(ary[i], *strp,
408 SV_GMAGIC|SV_DO_COW_SVSETSV|SV_NOSTEAL);
573fa4ea
TB
409 strp++;
410 }
79072805 411 }
463ee0b2 412 return av;
79072805
LW
413}
414
cb50131a
CB
415/*
416=for apidoc av_clear
417
418Clears an array, making it empty. Does not free the memory used by the
31bde0ac 419array itself. Perl equivalent: C<@myarray = ();>.
cb50131a
CB
420
421=cut
422*/
423
79072805 424void
864dbfa3 425Perl_av_clear(pTHX_ register AV *av)
79072805 426{
97aff369 427 dVAR;
e2d306cb 428 I32 extra;
79072805 429
7918f24d 430 PERL_ARGS_ASSERT_AV_CLEAR;
2fed2a1b
NC
431 assert(SvTYPE(av) == SVt_PVAV);
432
7d55f622 433#ifdef DEBUGGING
9b387841
NC
434 if (SvREFCNT(av) == 0) {
435 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEBUGGING), "Attempt to clear deleted array");
7d55f622
PP
436 }
437#endif
a0d0e21e 438
39caa665 439 if (SvREADONLY(av))
6ad8f254 440 Perl_croak_no_modify(aTHX);
39caa665 441
93965878 442 /* Give any tie a chance to cleanup first */
89c14e2e
BB
443 if (SvRMAGICAL(av)) {
444 const MAGIC* const mg = SvMAGIC(av);
b63c7c55 445 if (PL_delaymagic && mg && mg->mg_type == PERL_MAGIC_isa)
354b0578 446 PL_delaymagic |= DM_ARRAY_ISA;
89c14e2e 447 else
ad64d0ec 448 mg_clear(MUTABLE_SV(av));
89c14e2e 449 }
93965878 450
a60c0954
NIS
451 if (AvMAX(av) < 0)
452 return;
453
a0d0e21e 454 if (AvREAL(av)) {
823a54a3 455 SV** const ary = AvARRAY(av);
e2d306cb
AL
456 I32 index = AvFILLp(av) + 1;
457 while (index) {
458 SV * const sv = ary[--index];
6b42d12b 459 /* undef the slot before freeing the value, because a
e2d306cb
AL
460 * destructor might try to modify this array */
461 ary[index] = &PL_sv_undef;
6b42d12b 462 SvREFCNT_dec(sv);
a0d0e21e
LW
463 }
464 }
e2d306cb
AL
465 extra = AvARRAY(av) - AvALLOC(av);
466 if (extra) {
467 AvMAX(av) += extra;
9c6bc640 468 AvARRAY(av) = AvALLOC(av);
79072805 469 }
93965878 470 AvFILLp(av) = -1;
fb73857a 471
79072805
LW
472}
473
cb50131a
CB
474/*
475=for apidoc av_undef
476
477Undefines the array. Frees the memory used by the array itself.
478
479=cut
480*/
481
79072805 482void
864dbfa3 483Perl_av_undef(pTHX_ register AV *av)
79072805 484{
7918f24d 485 PERL_ARGS_ASSERT_AV_UNDEF;
2fed2a1b 486 assert(SvTYPE(av) == SVt_PVAV);
93965878
NIS
487
488 /* Give any tie a chance to cleanup first */
ad64d0ec 489 if (SvTIED_mg((const SV *)av, PERL_MAGIC_tied))
22717f83 490 av_fill(av, -1);
93965878 491
a0d0e21e 492 if (AvREAL(av)) {
a3b680e6 493 register I32 key = AvFILLp(av) + 1;
a0d0e21e
LW
494 while (key)
495 SvREFCNT_dec(AvARRAY(av)[--key]);
496 }
22717f83 497
463ee0b2 498 Safefree(AvALLOC(av));
35da51f7 499 AvALLOC(av) = NULL;
9c6bc640 500 AvARRAY(av) = NULL;
93965878 501 AvMAX(av) = AvFILLp(av) = -1;
22717f83 502
ad64d0ec 503 if(SvRMAGICAL(av)) mg_clear(MUTABLE_SV(av));
79072805
LW
504}
505
cb50131a 506/*
29a861e7
NC
507
508=for apidoc av_create_and_push
509
510Push an SV onto the end of the array, creating the array if necessary.
511A small internal helper function to remove a commonly duplicated idiom.
512
513=cut
514*/
515
516void
517Perl_av_create_and_push(pTHX_ AV **const avp, SV *const val)
518{
7918f24d 519 PERL_ARGS_ASSERT_AV_CREATE_AND_PUSH;
2fed2a1b 520
29a861e7
NC
521 if (!*avp)
522 *avp = newAV();
523 av_push(*avp, val);
524}
525
526/*
cb50131a
CB
527=for apidoc av_push
528
529Pushes an SV onto the end of the array. The array will grow automatically
ee058167 530to accommodate the addition. This takes ownership of one reference count.
cb50131a
CB
531
532=cut
533*/
534
a0d0e21e 535void
864dbfa3 536Perl_av_push(pTHX_ register AV *av, SV *val)
93965878 537{
27da23d5 538 dVAR;
93965878 539 MAGIC *mg;
7918f24d
NC
540
541 PERL_ARGS_ASSERT_AV_PUSH;
2fed2a1b 542 assert(SvTYPE(av) == SVt_PVAV);
ba5d1d60 543
93965878 544 if (SvREADONLY(av))
6ad8f254 545 Perl_croak_no_modify(aTHX);
93965878 546
ad64d0ec 547 if ((mg = SvTIED_mg((const SV *)av, PERL_MAGIC_tied))) {
046b0c7d
NC
548 Perl_magic_methcall(aTHX_ MUTABLE_SV(av), mg, "PUSH", G_DISCARD, 1,
549 val);
93965878
NIS
550 return;
551 }
552 av_store(av,AvFILLp(av)+1,val);
79072805
LW
553}
554
cb50131a
CB
555/*
556=for apidoc av_pop
557
558Pops an SV off the end of the array. Returns C<&PL_sv_undef> if the array
559is empty.
560
561=cut
562*/
563
79072805 564SV *
864dbfa3 565Perl_av_pop(pTHX_ register AV *av)
79072805 566{
27da23d5 567 dVAR;
79072805 568 SV *retval;
93965878 569 MAGIC* mg;
79072805 570
7918f24d 571 PERL_ARGS_ASSERT_AV_POP;
2fed2a1b 572 assert(SvTYPE(av) == SVt_PVAV);
ba5d1d60 573
43fcc5d2 574 if (SvREADONLY(av))
6ad8f254 575 Perl_croak_no_modify(aTHX);
ad64d0ec 576 if ((mg = SvTIED_mg((const SV *)av, PERL_MAGIC_tied))) {
046b0c7d 577 retval = Perl_magic_methcall(aTHX_ MUTABLE_SV(av), mg, "POP", 0, 0);
efaf3674
DM
578 if (retval)
579 retval = newSVsv(retval);
93965878
NIS
580 return retval;
581 }
d19c0e07
MJD
582 if (AvFILL(av) < 0)
583 return &PL_sv_undef;
93965878 584 retval = AvARRAY(av)[AvFILLp(av)];
3280af22 585 AvARRAY(av)[AvFILLp(av)--] = &PL_sv_undef;
8990e307 586 if (SvSMAGICAL(av))
ad64d0ec 587 mg_set(MUTABLE_SV(av));
79072805
LW
588 return retval;
589}
590
cb50131a 591/*
29a861e7
NC
592
593=for apidoc av_create_and_unshift_one
594
595Unshifts an SV onto the beginning of the array, creating the array if
596necessary.
597A small internal helper function to remove a commonly duplicated idiom.
598
599=cut
600*/
601
602SV **
603Perl_av_create_and_unshift_one(pTHX_ AV **const avp, SV *const val)
604{
7918f24d 605 PERL_ARGS_ASSERT_AV_CREATE_AND_UNSHIFT_ONE;
2fed2a1b 606
29a861e7
NC
607 if (!*avp)
608 *avp = newAV();
609 av_unshift(*avp, 1);
610 return av_store(*avp, 0, val);
611}
612
613/*
cb50131a
CB
614=for apidoc av_unshift
615
616Unshift the given number of C<undef> values onto the beginning of the
617array. The array will grow automatically to accommodate the addition. You
618must then use C<av_store> to assign values to these new elements.
619
620=cut
621*/
622
79072805 623void
864dbfa3 624Perl_av_unshift(pTHX_ register AV *av, register I32 num)
79072805 625{
27da23d5 626 dVAR;
79072805 627 register I32 i;
93965878 628 MAGIC* mg;
79072805 629
7918f24d 630 PERL_ARGS_ASSERT_AV_UNSHIFT;
2fed2a1b 631 assert(SvTYPE(av) == SVt_PVAV);
ba5d1d60 632
43fcc5d2 633 if (SvREADONLY(av))
6ad8f254 634 Perl_croak_no_modify(aTHX);
93965878 635
ad64d0ec 636 if ((mg = SvTIED_mg((const SV *)av, PERL_MAGIC_tied))) {
046b0c7d
NC
637 Perl_magic_methcall(aTHX_ MUTABLE_SV(av), mg, "UNSHIFT",
638 G_DISCARD | G_UNDEF_FILL, num);
93965878
NIS
639 return;
640 }
641
d19c0e07
MJD
642 if (num <= 0)
643 return;
49beac48
CS
644 if (!AvREAL(av) && AvREIFY(av))
645 av_reify(av);
a0d0e21e
LW
646 i = AvARRAY(av) - AvALLOC(av);
647 if (i) {
648 if (i > num)
649 i = num;
650 num -= i;
651
652 AvMAX(av) += i;
93965878 653 AvFILLp(av) += i;
9c6bc640 654 AvARRAY(av) = AvARRAY(av) - i;
a0d0e21e 655 }
d2719217 656 if (num) {
a3b680e6 657 register SV **ary;
c86f7df5 658 const I32 i = AvFILLp(av);
e2b534e7 659 /* Create extra elements */
c86f7df5 660 const I32 slide = i > 0 ? i : 0;
e2b534e7 661 num += slide;
67a38de0 662 av_extend(av, i + num);
93965878 663 AvFILLp(av) += num;
67a38de0
NIS
664 ary = AvARRAY(av);
665 Move(ary, ary + num, i + 1, SV*);
666 do {
3280af22 667 ary[--num] = &PL_sv_undef;
67a38de0 668 } while (num);
e2b534e7
BT
669 /* Make extra elements into a buffer */
670 AvMAX(av) -= slide;
671 AvFILLp(av) -= slide;
9c6bc640 672 AvARRAY(av) = AvARRAY(av) + slide;
79072805
LW
673 }
674}
675
cb50131a
CB
676/*
677=for apidoc av_shift
678
6ae70e43
CJ
679Shifts an SV off the beginning of the array. Returns C<&PL_sv_undef> if the
680array is empty.
cb50131a
CB
681
682=cut
683*/
684
79072805 685SV *
864dbfa3 686Perl_av_shift(pTHX_ register AV *av)
79072805 687{
27da23d5 688 dVAR;
79072805 689 SV *retval;
93965878 690 MAGIC* mg;
79072805 691
7918f24d 692 PERL_ARGS_ASSERT_AV_SHIFT;
2fed2a1b 693 assert(SvTYPE(av) == SVt_PVAV);
ba5d1d60 694
43fcc5d2 695 if (SvREADONLY(av))
6ad8f254 696 Perl_croak_no_modify(aTHX);
ad64d0ec 697 if ((mg = SvTIED_mg((const SV *)av, PERL_MAGIC_tied))) {
046b0c7d 698 retval = Perl_magic_methcall(aTHX_ MUTABLE_SV(av), mg, "SHIFT", 0, 0);
efaf3674
DM
699 if (retval)
700 retval = newSVsv(retval);
93965878
NIS
701 return retval;
702 }
d19c0e07
MJD
703 if (AvFILL(av) < 0)
704 return &PL_sv_undef;
463ee0b2 705 retval = *AvARRAY(av);
a0d0e21e 706 if (AvREAL(av))
3280af22 707 *AvARRAY(av) = &PL_sv_undef;
9c6bc640 708 AvARRAY(av) = AvARRAY(av) + 1;
463ee0b2 709 AvMAX(av)--;
93965878 710 AvFILLp(av)--;
8990e307 711 if (SvSMAGICAL(av))
ad64d0ec 712 mg_set(MUTABLE_SV(av));
79072805
LW
713 return retval;
714}
715
cb50131a
CB
716/*
717=for apidoc av_len
718
977a499b
GA
719Returns the highest index in the array. The number of elements in the
720array is C<av_len(av) + 1>. Returns -1 if the array is empty.
cb50131a 721
a8676f70
SF
722The Perl equivalent for this is C<$#myarray>.
723
cb50131a
CB
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 742The number of elements in the an array will be C<fill + 1> after
1a3362a5 743av_fill() returns. If the array was previously shorter, then the
977a499b
GA
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
3025a2e4
CS
794Deletes the element indexed by C<key> from the array, makes the element mortal,
795and returns it. If C<flags> equals C<G_DISCARD>, the element is freed and null
796is returned. Perl equivalent: C<my $elem = delete($myarray[$idx]);> for the
797non-C<G_DISCARD> version and a void-context C<delete($myarray[$idx]);> for the
798C<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))
6ad8f254 812 Perl_croak_no_modify(aTHX);
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);
54a4274e
PM
904 const MAGIC * const regdata_magic
905 = mg_find((const SV *)av, PERL_MAGIC_regdata);
906 if (tied_magic || regdata_magic) {
fabdb6c0 907 SV * const sv = sv_newmortal();
6f12eb6d
MJD
908 MAGIC *mg;
909 /* Handle negative array indices 20020222 MJD */
910 if (key < 0) {
911 unsigned adjust_index = 1;
912 if (tied_magic) {
823a54a3 913 SV * const * const negative_indices_glob =
ad64d0ec 914 hv_fetch(SvSTASH(SvRV(SvTIED_obj(MUTABLE_SV(av),
6f12eb6d
MJD
915 tied_magic))),
916 NEGATIVE_INDICES_VAR, 16, 0);
917 if (negative_indices_glob
918 && SvTRUE(GvSV(*negative_indices_glob)))
919 adjust_index = 0;
920 }
921 if (adjust_index) {
922 key += AvFILL(av) + 1;
923 if (key < 0)
924 return FALSE;
54a4274e
PM
925 else
926 return TRUE;
6f12eb6d
MJD
927 }
928 }
929
54a4274e
PM
930 if(key >= 0 && regdata_magic) {
931 if (key <= AvFILL(av))
932 return TRUE;
933 else
934 return FALSE;
935 }
936
ad64d0ec 937 mg_copy(MUTABLE_SV(av), sv, 0, key);
6f12eb6d
MJD
938 mg = mg_find(sv, PERL_MAGIC_tiedelem);
939 if (mg) {
940 magic_existspack(sv, mg);
f2338a2e 941 return cBOOL(SvTRUE(sv));
6f12eb6d
MJD
942 }
943
944 }
945 }
946
146174a9
CB
947 if (key < 0) {
948 key += AvFILL(av) + 1;
949 if (key < 0)
950 return FALSE;
951 }
6f12eb6d 952
146174a9
CB
953 if (key <= AvFILLp(av) && AvARRAY(av)[key] != &PL_sv_undef
954 && AvARRAY(av)[key])
955 {
956 return TRUE;
957 }
958 else
959 return FALSE;
960}
66610fdd 961
c33269f7 962static MAGIC *
878d132a 963S_get_aux_mg(pTHX_ AV *av) {
a3874608 964 dVAR;
ba5d1d60
GA
965 MAGIC *mg;
966
7918f24d 967 PERL_ARGS_ASSERT_GET_AUX_MG;
2fed2a1b 968 assert(SvTYPE(av) == SVt_PVAV);
ba5d1d60 969
ad64d0ec 970 mg = mg_find((const SV *)av, PERL_MAGIC_arylen_p);
a3874608
NC
971
972 if (!mg) {
ad64d0ec
NC
973 mg = sv_magicext(MUTABLE_SV(av), 0, PERL_MAGIC_arylen_p,
974 &PL_vtbl_arylen_p, 0, 0);
c82c7adc 975 assert(mg);
a3874608
NC
976 /* sv_magicext won't set this for us because we pass in a NULL obj */
977 mg->mg_flags |= MGf_REFCOUNTED;
978 }
878d132a
NC
979 return mg;
980}
981
982SV **
983Perl_av_arylen_p(pTHX_ AV *av) {
984 MAGIC *const mg = get_aux_mg(av);
7918f24d
NC
985
986 PERL_ARGS_ASSERT_AV_ARYLEN_P;
2fed2a1b 987 assert(SvTYPE(av) == SVt_PVAV);
7918f24d 988
a3874608
NC
989 return &(mg->mg_obj);
990}
991
453d94a9 992IV *
878d132a
NC
993Perl_av_iter_p(pTHX_ AV *av) {
994 MAGIC *const mg = get_aux_mg(av);
7918f24d
NC
995
996 PERL_ARGS_ASSERT_AV_ITER_P;
2fed2a1b 997 assert(SvTYPE(av) == SVt_PVAV);
7918f24d 998
453d94a9 999#if IVSIZE == I32SIZE
20bff64c 1000 return (IV *)&(mg->mg_len);
453d94a9
NC
1001#else
1002 if (!mg->mg_ptr) {
156d2b43 1003 IV *temp;
453d94a9 1004 mg->mg_len = IVSIZE;
156d2b43
NC
1005 Newxz(temp, 1, IV);
1006 mg->mg_ptr = (char *) temp;
453d94a9
NC
1007 }
1008 return (IV *)mg->mg_ptr;
1009#endif
878d132a
NC
1010}
1011
66610fdd
RGS
1012/*
1013 * Local variables:
1014 * c-indentation-style: bsd
1015 * c-basic-offset: 4
1016 * indent-tabs-mode: t
1017 * End:
1018 *
37442d52
RGS
1019 * ex: set ts=8 sts=4 sw=4 noet:
1020 */