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