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