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