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