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