This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Avoid test failure with for a -Dusesitecustomize perl.
[perl5.git] / av.c
CommitLineData
a0d0e21e 1/* av.c
79072805 2 *
4bb101f2 3 * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
54ca4ee7 4 * 2000, 2001, 2002, 2003, 2004, 2005, 2006, 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
ba5d1d60
GA
30 assert(av);
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
ba5d1d60
GA
69 assert(av);
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));
a60c0954 80 PUSHs(sv_2mortal(newSViv(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
7bab3ede 120#ifdef MYMALLOC
8d6dde3e
IZ
121 newmax = malloced_size((void*)AvALLOC(av))/sizeof(SV*) - 1;
122
123 if (key <= newmax)
124 goto resized;
125#endif
a0d0e21e
LW
126 newmax = key + AvMAX(av) / 5;
127 resize:
2b573ace 128 MEM_WRAP_CHECK_1(newmax+1, SV*, oom_array_extend);
8d6dde3e 129#if defined(STRANGE_MALLOC) || defined(MYMALLOC)
a0d0e21e 130 Renew(AvALLOC(av),newmax+1, SV*);
4633a7c4
LW
131#else
132 bytes = (newmax + 1) * sizeof(SV*);
133#define MALLOC_OVERHEAD 16
c1f7b11a 134 itmp = MALLOC_OVERHEAD;
eb160463 135 while ((MEM_SIZE)(itmp - MALLOC_OVERHEAD) < bytes)
c1f7b11a
SB
136 itmp += itmp;
137 itmp -= MALLOC_OVERHEAD;
138 itmp /= sizeof(SV*);
139 assert(itmp > newmax);
140 newmax = itmp - 1;
141 assert(newmax >= AvMAX(av));
a02a5408 142 Newx(ary, newmax+1, SV*);
4633a7c4 143 Copy(AvALLOC(av), ary, AvMAX(av)+1, SV*);
fba3b22e
MB
144 if (AvMAX(av) > 64)
145 offer_nice_chunk(AvALLOC(av), (AvMAX(av)+1) * sizeof(SV*));
4633a7c4
LW
146 else
147 Safefree(AvALLOC(av));
148 AvALLOC(av) = ary;
149#endif
7bab3ede 150#ifdef MYMALLOC
8d6dde3e 151 resized:
9c5ffd7c 152#endif
a0d0e21e
LW
153 ary = AvALLOC(av) + AvMAX(av) + 1;
154 tmp = newmax - AvMAX(av);
3280af22
NIS
155 if (av == PL_curstack) { /* Oops, grew stack (via av_store()?) */
156 PL_stack_sp = AvALLOC(av) + (PL_stack_sp - PL_stack_base);
157 PL_stack_base = AvALLOC(av);
158 PL_stack_max = PL_stack_base + newmax;
a0d0e21e
LW
159 }
160 }
161 else {
8d6dde3e 162 newmax = key < 3 ? 3 : key;
2b573ace 163 MEM_WRAP_CHECK_1(newmax+1, SV*, oom_array_extend);
a02a5408 164 Newx(AvALLOC(av), newmax+1, SV*);
a0d0e21e
LW
165 ary = AvALLOC(av) + 1;
166 tmp = newmax;
3280af22 167 AvALLOC(av)[0] = &PL_sv_undef; /* For the stacks */
a0d0e21e
LW
168 }
169 if (AvREAL(av)) {
170 while (tmp)
3280af22 171 ary[--tmp] = &PL_sv_undef;
a0d0e21e
LW
172 }
173
9c6bc640 174 AvARRAY(av) = AvALLOC(av);
a0d0e21e
LW
175 AvMAX(av) = newmax;
176 }
177 }
178}
179
cb50131a
CB
180/*
181=for apidoc av_fetch
182
183Returns the SV at the specified index in the array. The C<key> is the
184index. If C<lval> is set then the fetch will be part of a store. Check
185that the return value is non-null before dereferencing it to a C<SV*>.
186
187See L<perlguts/"Understanding the Magic of Tied Hashes and Arrays"> for
188more information on how to use this function on tied arrays.
189
190=cut
191*/
192
79072805 193SV**
864dbfa3 194Perl_av_fetch(pTHX_ register AV *av, I32 key, I32 lval)
79072805 195{
97aff369 196 dVAR;
79072805 197
ba5d1d60 198 assert(av);
a0d0e21e 199
6f12eb6d 200 if (SvRMAGICAL(av)) {
35a4481c 201 const MAGIC * const tied_magic = mg_find((SV*)av, PERL_MAGIC_tied);
6f12eb6d 202 if (tied_magic || mg_find((SV*)av, PERL_MAGIC_regdata)) {
e2d306cb
AL
203 SV *sv;
204 if (key < 0) {
205 I32 adjust_index = 1;
206 if (tied_magic) {
207 /* Handle negative array indices 20020222 MJD */
208 SV * const * const negative_indices_glob =
209 hv_fetch(SvSTASH(SvRV(SvTIED_obj((SV *)av, tied_magic))),
210 NEGATIVE_INDICES_VAR, 16, 0);
211
212 if (negative_indices_glob && SvTRUE(GvSV(*negative_indices_glob)))
213 adjust_index = 0;
214 }
6f12eb6d 215
e2d306cb
AL
216 if (adjust_index) {
217 key += AvFILL(av) + 1;
218 if (key < 0)
219 return NULL;
220 }
221 }
6f12eb6d
MJD
222
223 sv = sv_newmortal();
dd28f7bb
DM
224 sv_upgrade(sv, SVt_PVLV);
225 mg_copy((SV*)av, sv, 0, key);
226 LvTYPE(sv) = 't';
227 LvTARG(sv) = sv; /* fake (SV**) */
228 return &(LvTARG(sv));
6f12eb6d
MJD
229 }
230 }
231
93965878
NIS
232 if (key < 0) {
233 key += AvFILL(av) + 1;
234 if (key < 0)
e2d306cb 235 return NULL;
93965878
NIS
236 }
237
93965878 238 if (key > AvFILLp(av)) {
a0d0e21e 239 if (!lval)
e2d306cb
AL
240 return NULL;
241 return av_store(av,key,newSV(0));
79072805 242 }
3280af22 243 if (AvARRAY(av)[key] == &PL_sv_undef) {
4dbf4341 244 emptyness:
e2d306cb
AL
245 if (lval)
246 return av_store(av,key,newSV(0));
247 return NULL;
79072805 248 }
4dbf4341
PP
249 else if (AvREIFY(av)
250 && (!AvARRAY(av)[key] /* eg. @_ could have freed elts */
0565a181 251 || SvIS_FREED(AvARRAY(av)[key]))) {
3280af22 252 AvARRAY(av)[key] = &PL_sv_undef; /* 1/2 reify */
4dbf4341
PP
253 goto emptyness;
254 }
463ee0b2 255 return &AvARRAY(av)[key];
79072805
LW
256}
257
cb50131a
CB
258/*
259=for apidoc av_store
260
261Stores an SV in an array. The array index is specified as C<key>. The
262return value will be NULL if the operation failed or if the value did not
263need to be actually stored within the array (as in the case of tied
264arrays). Otherwise it can be dereferenced to get the original C<SV*>. Note
265that the caller is responsible for suitably incrementing the reference
266count of C<val> before the call, and decrementing it if the function
267returned NULL.
268
269See L<perlguts/"Understanding the Magic of Tied Hashes and Arrays"> for
270more information on how to use this function on tied arrays.
271
272=cut
273*/
274
79072805 275SV**
864dbfa3 276Perl_av_store(pTHX_ register AV *av, I32 key, SV *val)
79072805 277{
97aff369 278 dVAR;
79072805
LW
279 SV** ary;
280
ba5d1d60
GA
281 assert(av);
282
725ac12f
NC
283 /* S_regclass relies on being able to pass in a NULL sv
284 (unicode_alternate may be NULL).
285 */
286
43fcc5d2 287 if (!val)
3280af22 288 val = &PL_sv_undef;
463ee0b2 289
6f12eb6d 290 if (SvRMAGICAL(av)) {
35a4481c 291 const MAGIC * const tied_magic = mg_find((SV*)av, PERL_MAGIC_tied);
6f12eb6d
MJD
292 if (tied_magic) {
293 /* Handle negative array indices 20020222 MJD */
294 if (key < 0) {
e2d306cb 295 bool adjust_index = 1;
823a54a3 296 SV * const * const negative_indices_glob =
6f12eb6d
MJD
297 hv_fetch(SvSTASH(SvRV(SvTIED_obj((SV *)av,
298 tied_magic))),
299 NEGATIVE_INDICES_VAR, 16, 0);
300 if (negative_indices_glob
301 && SvTRUE(GvSV(*negative_indices_glob)))
302 adjust_index = 0;
303 if (adjust_index) {
304 key += AvFILL(av) + 1;
305 if (key < 0)
306 return 0;
307 }
308 }
309 if (val != &PL_sv_undef) {
310 mg_copy((SV*)av, val, 0, key);
311 }
e2d306cb 312 return NULL;
6f12eb6d
MJD
313 }
314 }
315
316
a0d0e21e
LW
317 if (key < 0) {
318 key += AvFILL(av) + 1;
319 if (key < 0)
e2d306cb 320 return NULL;
79072805 321 }
93965878 322
43fcc5d2 323 if (SvREADONLY(av) && key >= AvFILL(av))
cea2e8a9 324 Perl_croak(aTHX_ PL_no_modify);
93965878 325
49beac48 326 if (!AvREAL(av) && AvREIFY(av))
a0d0e21e 327 av_reify(av);
a0d0e21e
LW
328 if (key > AvMAX(av))
329 av_extend(av,key);
463ee0b2 330 ary = AvARRAY(av);
93965878 331 if (AvFILLp(av) < key) {
a0d0e21e 332 if (!AvREAL(av)) {
3280af22
NIS
333 if (av == PL_curstack && key > PL_stack_sp - PL_stack_base)
334 PL_stack_sp = PL_stack_base + key; /* XPUSH in disguise */
e2d306cb 335 do {
3280af22 336 ary[++AvFILLp(av)] = &PL_sv_undef;
e2d306cb 337 } while (AvFILLp(av) < key);
79072805 338 }
93965878 339 AvFILLp(av) = key;
79072805 340 }
a0d0e21e
LW
341 else if (AvREAL(av))
342 SvREFCNT_dec(ary[key]);
79072805 343 ary[key] = val;
8990e307 344 if (SvSMAGICAL(av)) {
3280af22 345 if (val != &PL_sv_undef) {
fabdb6c0 346 const MAGIC* const mg = SvMAGIC(av);
a0d0e21e
LW
347 sv_magic(val, (SV*)av, toLOWER(mg->mg_type), 0, key);
348 }
463ee0b2
LW
349 mg_set((SV*)av);
350 }
79072805
LW
351 return &ary[key];
352}
353
cb50131a
CB
354/*
355=for apidoc newAV
356
357Creates a new AV. The reference count is set to 1.
358
359=cut
360*/
361
79072805 362AV *
864dbfa3 363Perl_newAV(pTHX)
79072805 364{
561b68a9 365 register AV * const av = (AV*)newSV(0);
79072805 366
a0d0e21e 367 sv_upgrade((SV *)av, SVt_PVAV);
a7f5e44d 368 /* sv_upgrade does AvREAL_only() */
463ee0b2 369 AvALLOC(av) = 0;
9c6bc640 370 AvARRAY(av) = NULL;
93965878 371 AvMAX(av) = AvFILLp(av) = -1;
463ee0b2 372 return av;
79072805
LW
373}
374
cb50131a
CB
375/*
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{
561b68a9 388 register AV * const av = (AV*)newSV(0);
79072805 389
a0d0e21e 390 sv_upgrade((SV *) av,SVt_PVAV);
a7f5e44d 391 /* sv_upgrade does AvREAL_only() */
a0288114 392 if (size) { /* "defined" was returning undef for size==0 anyway. */
dd374669
AL
393 register SV** ary;
394 register I32 i;
a02a5408 395 Newx(ary,size,SV*);
573fa4ea 396 AvALLOC(av) = ary;
9c6bc640 397 AvARRAY(av) = ary;
35da51f7 398 AvFILLp(av) = AvMAX(av) = size - 1;
573fa4ea
TB
399 for (i = 0; i < size; i++) {
400 assert (*strp);
561b68a9 401 ary[i] = newSV(0);
573fa4ea
TB
402 sv_setsv(ary[i], *strp);
403 strp++;
404 }
79072805 405 }
463ee0b2 406 return av;
79072805
LW
407}
408
cb50131a
CB
409/*
410=for apidoc av_clear
411
412Clears an array, making it empty. Does not free the memory used by the
413array itself.
414
415=cut
416*/
417
79072805 418void
864dbfa3 419Perl_av_clear(pTHX_ register AV *av)
79072805 420{
97aff369 421 dVAR;
e2d306cb 422 I32 extra;
79072805 423
ba5d1d60 424 assert(av);
7d55f622 425#ifdef DEBUGGING
32da55ab 426 if (SvREFCNT(av) == 0 && ckWARN_d(WARN_DEBUGGING)) {
9014280d 427 Perl_warner(aTHX_ packWARN(WARN_DEBUGGING), "Attempt to clear deleted array");
7d55f622
PP
428 }
429#endif
a0d0e21e 430
39caa665 431 if (SvREADONLY(av))
cea2e8a9 432 Perl_croak(aTHX_ PL_no_modify);
39caa665 433
93965878
NIS
434 /* Give any tie a chance to cleanup first */
435 if (SvRMAGICAL(av))
436 mg_clear((SV*)av);
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{
ba5d1d60 472 assert(av);
93965878
NIS
473
474 /* Give any tie a chance to cleanup first */
14befaf4 475 if (SvTIED_mg((SV*)av, PERL_MAGIC_tied))
93965878
NIS
476 av_fill(av, -1); /* mg_clear() ? */
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 }
463ee0b2 483 Safefree(AvALLOC(av));
35da51f7 484 AvALLOC(av) = NULL;
9c6bc640 485 AvARRAY(av) = NULL;
93965878 486 AvMAX(av) = AvFILLp(av) = -1;
79072805
LW
487}
488
cb50131a
CB
489/*
490=for apidoc av_push
491
492Pushes an SV onto the end of the array. The array will grow automatically
493to accommodate the addition.
494
495=cut
496*/
497
a0d0e21e 498void
864dbfa3 499Perl_av_push(pTHX_ register AV *av, SV *val)
93965878 500{
27da23d5 501 dVAR;
93965878 502 MAGIC *mg;
ba5d1d60
GA
503 assert(av);
504
93965878 505 if (SvREADONLY(av))
cea2e8a9 506 Perl_croak(aTHX_ PL_no_modify);
93965878 507
14befaf4 508 if ((mg = SvTIED_mg((SV*)av, PERL_MAGIC_tied))) {
93965878 509 dSP;
e788e7d3 510 PUSHSTACKi(PERLSI_MAGIC);
924508f0
GS
511 PUSHMARK(SP);
512 EXTEND(SP,2);
33c27489 513 PUSHs(SvTIED_obj((SV*)av, mg));
93965878 514 PUSHs(val);
a60c0954
NIS
515 PUTBACK;
516 ENTER;
864dbfa3 517 call_method("PUSH", G_SCALAR|G_DISCARD);
a60c0954 518 LEAVE;
d3acc0f7 519 POPSTACK;
93965878
NIS
520 return;
521 }
522 av_store(av,AvFILLp(av)+1,val);
79072805
LW
523}
524
cb50131a
CB
525/*
526=for apidoc av_pop
527
528Pops an SV off the end of the array. Returns C<&PL_sv_undef> if the array
529is empty.
530
531=cut
532*/
533
79072805 534SV *
864dbfa3 535Perl_av_pop(pTHX_ register AV *av)
79072805 536{
27da23d5 537 dVAR;
79072805 538 SV *retval;
93965878 539 MAGIC* mg;
79072805 540
ba5d1d60
GA
541 assert(av);
542
43fcc5d2 543 if (SvREADONLY(av))
cea2e8a9 544 Perl_croak(aTHX_ PL_no_modify);
14befaf4 545 if ((mg = SvTIED_mg((SV*)av, PERL_MAGIC_tied))) {
93965878 546 dSP;
e788e7d3 547 PUSHSTACKi(PERLSI_MAGIC);
924508f0 548 PUSHMARK(SP);
33c27489 549 XPUSHs(SvTIED_obj((SV*)av, mg));
a60c0954
NIS
550 PUTBACK;
551 ENTER;
864dbfa3 552 if (call_method("POP", G_SCALAR)) {
3280af22 553 retval = newSVsv(*PL_stack_sp--);
93965878 554 } else {
3280af22 555 retval = &PL_sv_undef;
93965878 556 }
a60c0954 557 LEAVE;
d3acc0f7 558 POPSTACK;
93965878
NIS
559 return retval;
560 }
d19c0e07
MJD
561 if (AvFILL(av) < 0)
562 return &PL_sv_undef;
93965878 563 retval = AvARRAY(av)[AvFILLp(av)];
3280af22 564 AvARRAY(av)[AvFILLp(av)--] = &PL_sv_undef;
8990e307 565 if (SvSMAGICAL(av))
463ee0b2 566 mg_set((SV*)av);
79072805
LW
567 return retval;
568}
569
cb50131a
CB
570/*
571=for apidoc av_unshift
572
573Unshift the given number of C<undef> values onto the beginning of the
574array. The array will grow automatically to accommodate the addition. You
575must then use C<av_store> to assign values to these new elements.
576
577=cut
578*/
579
79072805 580void
864dbfa3 581Perl_av_unshift(pTHX_ register AV *av, register I32 num)
79072805 582{
27da23d5 583 dVAR;
79072805 584 register I32 i;
93965878 585 MAGIC* mg;
79072805 586
ba5d1d60
GA
587 assert(av);
588
43fcc5d2 589 if (SvREADONLY(av))
cea2e8a9 590 Perl_croak(aTHX_ PL_no_modify);
93965878 591
14befaf4 592 if ((mg = SvTIED_mg((SV*)av, PERL_MAGIC_tied))) {
93965878 593 dSP;
e788e7d3 594 PUSHSTACKi(PERLSI_MAGIC);
924508f0
GS
595 PUSHMARK(SP);
596 EXTEND(SP,1+num);
33c27489 597 PUSHs(SvTIED_obj((SV*)av, mg));
93965878 598 while (num-- > 0) {
3280af22 599 PUSHs(&PL_sv_undef);
93965878
NIS
600 }
601 PUTBACK;
a60c0954 602 ENTER;
864dbfa3 603 call_method("UNSHIFT", G_SCALAR|G_DISCARD);
a60c0954 604 LEAVE;
d3acc0f7 605 POPSTACK;
93965878
NIS
606 return;
607 }
608
d19c0e07
MJD
609 if (num <= 0)
610 return;
49beac48
CS
611 if (!AvREAL(av) && AvREIFY(av))
612 av_reify(av);
a0d0e21e
LW
613 i = AvARRAY(av) - AvALLOC(av);
614 if (i) {
615 if (i > num)
616 i = num;
617 num -= i;
618
619 AvMAX(av) += i;
93965878 620 AvFILLp(av) += i;
9c6bc640 621 AvARRAY(av) = AvARRAY(av) - i;
a0d0e21e 622 }
d2719217 623 if (num) {
a3b680e6
AL
624 register SV **ary;
625 I32 slide;
67a38de0 626 i = AvFILLp(av);
e2b534e7
BT
627 /* Create extra elements */
628 slide = i > 0 ? i : 0;
629 num += slide;
67a38de0 630 av_extend(av, i + num);
93965878 631 AvFILLp(av) += num;
67a38de0
NIS
632 ary = AvARRAY(av);
633 Move(ary, ary + num, i + 1, SV*);
634 do {
3280af22 635 ary[--num] = &PL_sv_undef;
67a38de0 636 } while (num);
e2b534e7
BT
637 /* Make extra elements into a buffer */
638 AvMAX(av) -= slide;
639 AvFILLp(av) -= slide;
9c6bc640 640 AvARRAY(av) = AvARRAY(av) + slide;
79072805
LW
641 }
642}
643
cb50131a
CB
644/*
645=for apidoc av_shift
646
647Shifts an SV off the beginning of the array.
648
649=cut
650*/
651
79072805 652SV *
864dbfa3 653Perl_av_shift(pTHX_ register AV *av)
79072805 654{
27da23d5 655 dVAR;
79072805 656 SV *retval;
93965878 657 MAGIC* mg;
79072805 658
ba5d1d60
GA
659 assert(av);
660
43fcc5d2 661 if (SvREADONLY(av))
cea2e8a9 662 Perl_croak(aTHX_ PL_no_modify);
14befaf4 663 if ((mg = SvTIED_mg((SV*)av, PERL_MAGIC_tied))) {
93965878 664 dSP;
e788e7d3 665 PUSHSTACKi(PERLSI_MAGIC);
924508f0 666 PUSHMARK(SP);
33c27489 667 XPUSHs(SvTIED_obj((SV*)av, mg));
a60c0954
NIS
668 PUTBACK;
669 ENTER;
864dbfa3 670 if (call_method("SHIFT", G_SCALAR)) {
3280af22 671 retval = newSVsv(*PL_stack_sp--);
93965878 672 } else {
3280af22 673 retval = &PL_sv_undef;
a60c0954
NIS
674 }
675 LEAVE;
d3acc0f7 676 POPSTACK;
93965878
NIS
677 return retval;
678 }
d19c0e07
MJD
679 if (AvFILL(av) < 0)
680 return &PL_sv_undef;
463ee0b2 681 retval = *AvARRAY(av);
a0d0e21e 682 if (AvREAL(av))
3280af22 683 *AvARRAY(av) = &PL_sv_undef;
9c6bc640 684 AvARRAY(av) = AvARRAY(av) + 1;
463ee0b2 685 AvMAX(av)--;
93965878 686 AvFILLp(av)--;
8990e307 687 if (SvSMAGICAL(av))
463ee0b2 688 mg_set((SV*)av);
79072805
LW
689 return retval;
690}
691
cb50131a
CB
692/*
693=for apidoc av_len
694
977a499b
GA
695Returns the highest index in the array. The number of elements in the
696array is C<av_len(av) + 1>. Returns -1 if the array is empty.
cb50131a
CB
697
698=cut
699*/
700
79072805 701I32
0d46e09a 702Perl_av_len(pTHX_ register const AV *av)
79072805 703{
ba5d1d60 704 assert(av);
463ee0b2 705 return AvFILL(av);
79072805
LW
706}
707
f3b76584
SC
708/*
709=for apidoc av_fill
710
977a499b 711Set the highest index in the array to the given number, equivalent to
f3b76584
SC
712Perl's C<$#array = $fill;>.
713
977a499b
GA
714The number of elements in the an array will be C<fill + 1> after
715av_fill() returns. If the array was previously shorter then the
716additional elements appended are set to C<PL_sv_undef>. If the array
717was longer, then the excess elements are freed. C<av_fill(av, -1)> is
718the same as C<av_clear(av)>.
719
f3b76584
SC
720=cut
721*/
79072805 722void
864dbfa3 723Perl_av_fill(pTHX_ register AV *av, I32 fill)
79072805 724{
27da23d5 725 dVAR;
93965878 726 MAGIC *mg;
ba5d1d60
GA
727
728 assert(av);
729
79072805
LW
730 if (fill < 0)
731 fill = -1;
14befaf4 732 if ((mg = SvTIED_mg((SV*)av, PERL_MAGIC_tied))) {
93965878
NIS
733 dSP;
734 ENTER;
735 SAVETMPS;
e788e7d3 736 PUSHSTACKi(PERLSI_MAGIC);
924508f0
GS
737 PUSHMARK(SP);
738 EXTEND(SP,2);
33c27489 739 PUSHs(SvTIED_obj((SV*)av, mg));
a60c0954 740 PUSHs(sv_2mortal(newSViv(fill+1)));
93965878 741 PUTBACK;
864dbfa3 742 call_method("STORESIZE", G_SCALAR|G_DISCARD);
d3acc0f7 743 POPSTACK;
93965878
NIS
744 FREETMPS;
745 LEAVE;
746 return;
747 }
463ee0b2 748 if (fill <= AvMAX(av)) {
93965878 749 I32 key = AvFILLp(av);
fabdb6c0 750 SV** const ary = AvARRAY(av);
a0d0e21e
LW
751
752 if (AvREAL(av)) {
753 while (key > fill) {
754 SvREFCNT_dec(ary[key]);
3280af22 755 ary[key--] = &PL_sv_undef;
a0d0e21e
LW
756 }
757 }
758 else {
759 while (key < fill)
3280af22 760 ary[++key] = &PL_sv_undef;
a0d0e21e
LW
761 }
762
93965878 763 AvFILLp(av) = fill;
8990e307 764 if (SvSMAGICAL(av))
463ee0b2
LW
765 mg_set((SV*)av);
766 }
a0d0e21e 767 else
3280af22 768 (void)av_store(av,fill,&PL_sv_undef);
79072805 769}
c750a3ec 770
f3b76584
SC
771/*
772=for apidoc av_delete
773
774Deletes the element indexed by C<key> from the array. Returns the
a6214072
DM
775deleted element. If C<flags> equals C<G_DISCARD>, the element is freed
776and null is returned.
f3b76584
SC
777
778=cut
779*/
146174a9
CB
780SV *
781Perl_av_delete(pTHX_ AV *av, I32 key, I32 flags)
782{
97aff369 783 dVAR;
146174a9
CB
784 SV *sv;
785
ba5d1d60
GA
786 assert(av);
787
146174a9
CB
788 if (SvREADONLY(av))
789 Perl_croak(aTHX_ PL_no_modify);
6f12eb6d
MJD
790
791 if (SvRMAGICAL(av)) {
35a4481c 792 const MAGIC * const tied_magic = mg_find((SV*)av, PERL_MAGIC_tied);
6f12eb6d
MJD
793 if ((tied_magic || mg_find((SV*)av, PERL_MAGIC_regdata))) {
794 /* Handle negative array indices 20020222 MJD */
35a4481c 795 SV **svp;
6f12eb6d
MJD
796 if (key < 0) {
797 unsigned adjust_index = 1;
798 if (tied_magic) {
823a54a3 799 SV * const * const negative_indices_glob =
6f12eb6d
MJD
800 hv_fetch(SvSTASH(SvRV(SvTIED_obj((SV *)av,
801 tied_magic))),
802 NEGATIVE_INDICES_VAR, 16, 0);
803 if (negative_indices_glob
804 && SvTRUE(GvSV(*negative_indices_glob)))
805 adjust_index = 0;
806 }
807 if (adjust_index) {
808 key += AvFILL(av) + 1;
809 if (key < 0)
fabdb6c0 810 return NULL;
6f12eb6d
MJD
811 }
812 }
813 svp = av_fetch(av, key, TRUE);
814 if (svp) {
815 sv = *svp;
816 mg_clear(sv);
817 if (mg_find(sv, PERL_MAGIC_tiedelem)) {
818 sv_unmagic(sv, PERL_MAGIC_tiedelem); /* No longer an element */
819 return sv;
820 }
fabdb6c0 821 return NULL;
6f12eb6d
MJD
822 }
823 }
824 }
825
146174a9
CB
826 if (key < 0) {
827 key += AvFILL(av) + 1;
828 if (key < 0)
fabdb6c0 829 return NULL;
146174a9 830 }
6f12eb6d 831
146174a9 832 if (key > AvFILLp(av))
fabdb6c0 833 return NULL;
146174a9 834 else {
a6214072
DM
835 if (!AvREAL(av) && AvREIFY(av))
836 av_reify(av);
146174a9
CB
837 sv = AvARRAY(av)[key];
838 if (key == AvFILLp(av)) {
d9c63288 839 AvARRAY(av)[key] = &PL_sv_undef;
146174a9
CB
840 do {
841 AvFILLp(av)--;
842 } while (--key >= 0 && AvARRAY(av)[key] == &PL_sv_undef);
843 }
844 else
845 AvARRAY(av)[key] = &PL_sv_undef;
846 if (SvSMAGICAL(av))
847 mg_set((SV*)av);
848 }
849 if (flags & G_DISCARD) {
850 SvREFCNT_dec(sv);
fabdb6c0 851 sv = NULL;
146174a9 852 }
fdb3bdd0 853 else if (AvREAL(av))
2c8ddff3 854 sv = sv_2mortal(sv);
146174a9
CB
855 return sv;
856}
857
858/*
f3b76584
SC
859=for apidoc av_exists
860
861Returns true if the element indexed by C<key> has been initialized.
146174a9 862
f3b76584
SC
863This relies on the fact that uninitialized array elements are set to
864C<&PL_sv_undef>.
865
866=cut
867*/
146174a9
CB
868bool
869Perl_av_exists(pTHX_ AV *av, I32 key)
870{
97aff369 871 dVAR;
ba5d1d60 872 assert(av);
6f12eb6d
MJD
873
874 if (SvRMAGICAL(av)) {
35a4481c 875 const MAGIC * const tied_magic = mg_find((SV*)av, PERL_MAGIC_tied);
6f12eb6d 876 if (tied_magic || mg_find((SV*)av, PERL_MAGIC_regdata)) {
fabdb6c0 877 SV * const sv = sv_newmortal();
6f12eb6d
MJD
878 MAGIC *mg;
879 /* Handle negative array indices 20020222 MJD */
880 if (key < 0) {
881 unsigned adjust_index = 1;
882 if (tied_magic) {
823a54a3 883 SV * const * const negative_indices_glob =
6f12eb6d
MJD
884 hv_fetch(SvSTASH(SvRV(SvTIED_obj((SV *)av,
885 tied_magic))),
886 NEGATIVE_INDICES_VAR, 16, 0);
887 if (negative_indices_glob
888 && SvTRUE(GvSV(*negative_indices_glob)))
889 adjust_index = 0;
890 }
891 if (adjust_index) {
892 key += AvFILL(av) + 1;
893 if (key < 0)
894 return FALSE;
895 }
896 }
897
898 mg_copy((SV*)av, sv, 0, key);
899 mg = mg_find(sv, PERL_MAGIC_tiedelem);
900 if (mg) {
901 magic_existspack(sv, mg);
902 return (bool)SvTRUE(sv);
903 }
904
905 }
906 }
907
146174a9
CB
908 if (key < 0) {
909 key += AvFILL(av) + 1;
910 if (key < 0)
911 return FALSE;
912 }
6f12eb6d 913
146174a9
CB
914 if (key <= AvFILLp(av) && AvARRAY(av)[key] != &PL_sv_undef
915 && AvARRAY(av)[key])
916 {
917 return TRUE;
918 }
919 else
920 return FALSE;
921}
66610fdd 922
a3874608
NC
923SV **
924Perl_av_arylen_p(pTHX_ AV *av) {
925 dVAR;
ba5d1d60
GA
926 MAGIC *mg;
927
928 assert(av);
929
930 mg = mg_find((SV*)av, PERL_MAGIC_arylen_p);
a3874608
NC
931
932 if (!mg) {
1b20cd17
NC
933 mg = sv_magicext((SV*)av, 0, PERL_MAGIC_arylen_p, &PL_vtbl_arylen_p,
934 0, 0);
c82c7adc 935 assert(mg);
a3874608
NC
936 /* sv_magicext won't set this for us because we pass in a NULL obj */
937 mg->mg_flags |= MGf_REFCOUNTED;
938 }
939 return &(mg->mg_obj);
940}
941
66610fdd
RGS
942/*
943 * Local variables:
944 * c-indentation-style: bsd
945 * c-basic-offset: 4
946 * indent-tabs-mode: t
947 * End:
948 *
37442d52
RGS
949 * ex: set ts=8 sts=4 sw=4 noet:
950 */