This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Second patch from:
[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{
b9f83d2f 365 register AV * const av = (AV*)newSV_type(SVt_PVAV);
a7f5e44d 366 /* sv_upgrade does AvREAL_only() */
463ee0b2 367 AvALLOC(av) = 0;
9c6bc640 368 AvARRAY(av) = NULL;
93965878 369 AvMAX(av) = AvFILLp(av) = -1;
463ee0b2 370 return av;
79072805
LW
371}
372
cb50131a
CB
373/*
374=for apidoc av_make
375
376Creates a new AV and populates it with a list of SVs. The SVs are copied
377into the array, so they may be freed after the call to av_make. The new AV
378will have a reference count of 1.
379
380=cut
381*/
382
79072805 383AV *
864dbfa3 384Perl_av_make(pTHX_ register I32 size, register SV **strp)
79072805 385{
b9f83d2f 386 register AV * const av = (AV*)newSV_type(SVt_PVAV);
a7f5e44d 387 /* sv_upgrade does AvREAL_only() */
a0288114 388 if (size) { /* "defined" was returning undef for size==0 anyway. */
dd374669
AL
389 register SV** ary;
390 register I32 i;
a02a5408 391 Newx(ary,size,SV*);
573fa4ea 392 AvALLOC(av) = ary;
9c6bc640 393 AvARRAY(av) = ary;
35da51f7 394 AvFILLp(av) = AvMAX(av) = size - 1;
573fa4ea
TB
395 for (i = 0; i < size; i++) {
396 assert (*strp);
561b68a9 397 ary[i] = newSV(0);
573fa4ea
TB
398 sv_setsv(ary[i], *strp);
399 strp++;
400 }
79072805 401 }
463ee0b2 402 return av;
79072805
LW
403}
404
cb50131a
CB
405/*
406=for apidoc av_clear
407
408Clears an array, making it empty. Does not free the memory used by the
409array itself.
410
411=cut
412*/
413
79072805 414void
864dbfa3 415Perl_av_clear(pTHX_ register AV *av)
79072805 416{
97aff369 417 dVAR;
e2d306cb 418 I32 extra;
79072805 419
ba5d1d60 420 assert(av);
7d55f622 421#ifdef DEBUGGING
32da55ab 422 if (SvREFCNT(av) == 0 && ckWARN_d(WARN_DEBUGGING)) {
9014280d 423 Perl_warner(aTHX_ packWARN(WARN_DEBUGGING), "Attempt to clear deleted array");
7d55f622
PP
424 }
425#endif
a0d0e21e 426
39caa665 427 if (SvREADONLY(av))
cea2e8a9 428 Perl_croak(aTHX_ PL_no_modify);
39caa665 429
93965878
NIS
430 /* Give any tie a chance to cleanup first */
431 if (SvRMAGICAL(av))
432 mg_clear((SV*)av);
433
a60c0954
NIS
434 if (AvMAX(av) < 0)
435 return;
436
a0d0e21e 437 if (AvREAL(av)) {
823a54a3 438 SV** const ary = AvARRAY(av);
e2d306cb
AL
439 I32 index = AvFILLp(av) + 1;
440 while (index) {
441 SV * const sv = ary[--index];
6b42d12b 442 /* undef the slot before freeing the value, because a
e2d306cb
AL
443 * destructor might try to modify this array */
444 ary[index] = &PL_sv_undef;
6b42d12b 445 SvREFCNT_dec(sv);
a0d0e21e
LW
446 }
447 }
e2d306cb
AL
448 extra = AvARRAY(av) - AvALLOC(av);
449 if (extra) {
450 AvMAX(av) += extra;
9c6bc640 451 AvARRAY(av) = AvALLOC(av);
79072805 452 }
93965878 453 AvFILLp(av) = -1;
fb73857a 454
79072805
LW
455}
456
cb50131a
CB
457/*
458=for apidoc av_undef
459
460Undefines the array. Frees the memory used by the array itself.
461
462=cut
463*/
464
79072805 465void
864dbfa3 466Perl_av_undef(pTHX_ register AV *av)
79072805 467{
ba5d1d60 468 assert(av);
93965878
NIS
469
470 /* Give any tie a chance to cleanup first */
14befaf4 471 if (SvTIED_mg((SV*)av, PERL_MAGIC_tied))
22717f83 472 av_fill(av, -1);
93965878 473
a0d0e21e 474 if (AvREAL(av)) {
a3b680e6 475 register I32 key = AvFILLp(av) + 1;
a0d0e21e
LW
476 while (key)
477 SvREFCNT_dec(AvARRAY(av)[--key]);
478 }
22717f83 479
463ee0b2 480 Safefree(AvALLOC(av));
35da51f7 481 AvALLOC(av) = NULL;
9c6bc640 482 AvARRAY(av) = NULL;
93965878 483 AvMAX(av) = AvFILLp(av) = -1;
22717f83
BB
484
485 if(SvRMAGICAL(av)) mg_clear((SV*)av);
79072805
LW
486}
487
cb50131a 488/*
29a861e7
NC
489
490=for apidoc av_create_and_push
491
492Push an SV onto the end of the array, creating the array if necessary.
493A small internal helper function to remove a commonly duplicated idiom.
494
495=cut
496*/
497
498void
499Perl_av_create_and_push(pTHX_ AV **const avp, SV *const val)
500{
501 if (!*avp)
502 *avp = newAV();
503 av_push(*avp, val);
504}
505
506/*
cb50131a
CB
507=for apidoc av_push
508
509Pushes an SV onto the end of the array. The array will grow automatically
510to accommodate the addition.
511
512=cut
513*/
514
a0d0e21e 515void
864dbfa3 516Perl_av_push(pTHX_ register AV *av, SV *val)
93965878 517{
27da23d5 518 dVAR;
93965878 519 MAGIC *mg;
ba5d1d60
GA
520 assert(av);
521
93965878 522 if (SvREADONLY(av))
cea2e8a9 523 Perl_croak(aTHX_ PL_no_modify);
93965878 524
14befaf4 525 if ((mg = SvTIED_mg((SV*)av, PERL_MAGIC_tied))) {
93965878 526 dSP;
e788e7d3 527 PUSHSTACKi(PERLSI_MAGIC);
924508f0
GS
528 PUSHMARK(SP);
529 EXTEND(SP,2);
33c27489 530 PUSHs(SvTIED_obj((SV*)av, mg));
93965878 531 PUSHs(val);
a60c0954
NIS
532 PUTBACK;
533 ENTER;
864dbfa3 534 call_method("PUSH", G_SCALAR|G_DISCARD);
a60c0954 535 LEAVE;
d3acc0f7 536 POPSTACK;
93965878
NIS
537 return;
538 }
539 av_store(av,AvFILLp(av)+1,val);
79072805
LW
540}
541
cb50131a
CB
542/*
543=for apidoc av_pop
544
545Pops an SV off the end of the array. Returns C<&PL_sv_undef> if the array
546is empty.
547
548=cut
549*/
550
79072805 551SV *
864dbfa3 552Perl_av_pop(pTHX_ register AV *av)
79072805 553{
27da23d5 554 dVAR;
79072805 555 SV *retval;
93965878 556 MAGIC* mg;
79072805 557
ba5d1d60
GA
558 assert(av);
559
43fcc5d2 560 if (SvREADONLY(av))
cea2e8a9 561 Perl_croak(aTHX_ PL_no_modify);
14befaf4 562 if ((mg = SvTIED_mg((SV*)av, PERL_MAGIC_tied))) {
93965878 563 dSP;
e788e7d3 564 PUSHSTACKi(PERLSI_MAGIC);
924508f0 565 PUSHMARK(SP);
33c27489 566 XPUSHs(SvTIED_obj((SV*)av, mg));
a60c0954
NIS
567 PUTBACK;
568 ENTER;
864dbfa3 569 if (call_method("POP", G_SCALAR)) {
3280af22 570 retval = newSVsv(*PL_stack_sp--);
93965878 571 } else {
3280af22 572 retval = &PL_sv_undef;
93965878 573 }
a60c0954 574 LEAVE;
d3acc0f7 575 POPSTACK;
93965878
NIS
576 return retval;
577 }
d19c0e07
MJD
578 if (AvFILL(av) < 0)
579 return &PL_sv_undef;
93965878 580 retval = AvARRAY(av)[AvFILLp(av)];
3280af22 581 AvARRAY(av)[AvFILLp(av)--] = &PL_sv_undef;
8990e307 582 if (SvSMAGICAL(av))
463ee0b2 583 mg_set((SV*)av);
79072805
LW
584 return retval;
585}
586
cb50131a 587/*
29a861e7
NC
588
589=for apidoc av_create_and_unshift_one
590
591Unshifts an SV onto the beginning of the array, creating the array if
592necessary.
593A small internal helper function to remove a commonly duplicated idiom.
594
595=cut
596*/
597
598SV **
599Perl_av_create_and_unshift_one(pTHX_ AV **const avp, SV *const val)
600{
601 if (!*avp)
602 *avp = newAV();
603 av_unshift(*avp, 1);
604 return av_store(*avp, 0, val);
605}
606
607/*
cb50131a
CB
608=for apidoc av_unshift
609
610Unshift the given number of C<undef> values onto the beginning of the
611array. The array will grow automatically to accommodate the addition. You
612must then use C<av_store> to assign values to these new elements.
613
614=cut
615*/
616
79072805 617void
864dbfa3 618Perl_av_unshift(pTHX_ register AV *av, register I32 num)
79072805 619{
27da23d5 620 dVAR;
79072805 621 register I32 i;
93965878 622 MAGIC* mg;
79072805 623
ba5d1d60
GA
624 assert(av);
625
43fcc5d2 626 if (SvREADONLY(av))
cea2e8a9 627 Perl_croak(aTHX_ PL_no_modify);
93965878 628
14befaf4 629 if ((mg = SvTIED_mg((SV*)av, PERL_MAGIC_tied))) {
93965878 630 dSP;
e788e7d3 631 PUSHSTACKi(PERLSI_MAGIC);
924508f0
GS
632 PUSHMARK(SP);
633 EXTEND(SP,1+num);
33c27489 634 PUSHs(SvTIED_obj((SV*)av, mg));
93965878 635 while (num-- > 0) {
3280af22 636 PUSHs(&PL_sv_undef);
93965878
NIS
637 }
638 PUTBACK;
a60c0954 639 ENTER;
864dbfa3 640 call_method("UNSHIFT", G_SCALAR|G_DISCARD);
a60c0954 641 LEAVE;
d3acc0f7 642 POPSTACK;
93965878
NIS
643 return;
644 }
645
d19c0e07
MJD
646 if (num <= 0)
647 return;
49beac48
CS
648 if (!AvREAL(av) && AvREIFY(av))
649 av_reify(av);
a0d0e21e
LW
650 i = AvARRAY(av) - AvALLOC(av);
651 if (i) {
652 if (i > num)
653 i = num;
654 num -= i;
655
656 AvMAX(av) += i;
93965878 657 AvFILLp(av) += i;
9c6bc640 658 AvARRAY(av) = AvARRAY(av) - i;
a0d0e21e 659 }
d2719217 660 if (num) {
a3b680e6 661 register SV **ary;
c86f7df5 662 const I32 i = AvFILLp(av);
e2b534e7 663 /* Create extra elements */
c86f7df5 664 const I32 slide = i > 0 ? i : 0;
e2b534e7 665 num += slide;
67a38de0 666 av_extend(av, i + num);
93965878 667 AvFILLp(av) += num;
67a38de0
NIS
668 ary = AvARRAY(av);
669 Move(ary, ary + num, i + 1, SV*);
670 do {
3280af22 671 ary[--num] = &PL_sv_undef;
67a38de0 672 } while (num);
e2b534e7
BT
673 /* Make extra elements into a buffer */
674 AvMAX(av) -= slide;
675 AvFILLp(av) -= slide;
9c6bc640 676 AvARRAY(av) = AvARRAY(av) + slide;
79072805
LW
677 }
678}
679
cb50131a
CB
680/*
681=for apidoc av_shift
682
683Shifts an SV off the beginning of the array.
684
685=cut
686*/
687
79072805 688SV *
864dbfa3 689Perl_av_shift(pTHX_ register AV *av)
79072805 690{
27da23d5 691 dVAR;
79072805 692 SV *retval;
93965878 693 MAGIC* mg;
79072805 694
ba5d1d60
GA
695 assert(av);
696
43fcc5d2 697 if (SvREADONLY(av))
cea2e8a9 698 Perl_croak(aTHX_ PL_no_modify);
14befaf4 699 if ((mg = SvTIED_mg((SV*)av, PERL_MAGIC_tied))) {
93965878 700 dSP;
e788e7d3 701 PUSHSTACKi(PERLSI_MAGIC);
924508f0 702 PUSHMARK(SP);
33c27489 703 XPUSHs(SvTIED_obj((SV*)av, mg));
a60c0954
NIS
704 PUTBACK;
705 ENTER;
864dbfa3 706 if (call_method("SHIFT", G_SCALAR)) {
3280af22 707 retval = newSVsv(*PL_stack_sp--);
93965878 708 } else {
3280af22 709 retval = &PL_sv_undef;
a60c0954
NIS
710 }
711 LEAVE;
d3acc0f7 712 POPSTACK;
93965878
NIS
713 return retval;
714 }
d19c0e07
MJD
715 if (AvFILL(av) < 0)
716 return &PL_sv_undef;
463ee0b2 717 retval = *AvARRAY(av);
a0d0e21e 718 if (AvREAL(av))
3280af22 719 *AvARRAY(av) = &PL_sv_undef;
9c6bc640 720 AvARRAY(av) = AvARRAY(av) + 1;
463ee0b2 721 AvMAX(av)--;
93965878 722 AvFILLp(av)--;
8990e307 723 if (SvSMAGICAL(av))
463ee0b2 724 mg_set((SV*)av);
79072805
LW
725 return retval;
726}
727
cb50131a
CB
728/*
729=for apidoc av_len
730
977a499b
GA
731Returns the highest index in the array. The number of elements in the
732array is C<av_len(av) + 1>. Returns -1 if the array is empty.
cb50131a
CB
733
734=cut
735*/
736
79072805 737I32
0d46e09a 738Perl_av_len(pTHX_ register const AV *av)
79072805 739{
ba5d1d60 740 assert(av);
463ee0b2 741 return AvFILL(av);
79072805
LW
742}
743
f3b76584
SC
744/*
745=for apidoc av_fill
746
977a499b 747Set the highest index in the array to the given number, equivalent to
f3b76584
SC
748Perl's C<$#array = $fill;>.
749
977a499b
GA
750The number of elements in the an array will be C<fill + 1> after
751av_fill() returns. If the array was previously shorter then the
752additional elements appended are set to C<PL_sv_undef>. If the array
753was longer, then the excess elements are freed. C<av_fill(av, -1)> is
754the same as C<av_clear(av)>.
755
f3b76584
SC
756=cut
757*/
79072805 758void
864dbfa3 759Perl_av_fill(pTHX_ register AV *av, I32 fill)
79072805 760{
27da23d5 761 dVAR;
93965878 762 MAGIC *mg;
ba5d1d60
GA
763
764 assert(av);
765
79072805
LW
766 if (fill < 0)
767 fill = -1;
14befaf4 768 if ((mg = SvTIED_mg((SV*)av, PERL_MAGIC_tied))) {
93965878
NIS
769 dSP;
770 ENTER;
771 SAVETMPS;
e788e7d3 772 PUSHSTACKi(PERLSI_MAGIC);
924508f0
GS
773 PUSHMARK(SP);
774 EXTEND(SP,2);
33c27489 775 PUSHs(SvTIED_obj((SV*)av, mg));
a60c0954 776 PUSHs(sv_2mortal(newSViv(fill+1)));
93965878 777 PUTBACK;
864dbfa3 778 call_method("STORESIZE", G_SCALAR|G_DISCARD);
d3acc0f7 779 POPSTACK;
93965878
NIS
780 FREETMPS;
781 LEAVE;
782 return;
783 }
463ee0b2 784 if (fill <= AvMAX(av)) {
93965878 785 I32 key = AvFILLp(av);
fabdb6c0 786 SV** const ary = AvARRAY(av);
a0d0e21e
LW
787
788 if (AvREAL(av)) {
789 while (key > fill) {
790 SvREFCNT_dec(ary[key]);
3280af22 791 ary[key--] = &PL_sv_undef;
a0d0e21e
LW
792 }
793 }
794 else {
795 while (key < fill)
3280af22 796 ary[++key] = &PL_sv_undef;
a0d0e21e
LW
797 }
798
93965878 799 AvFILLp(av) = fill;
8990e307 800 if (SvSMAGICAL(av))
463ee0b2
LW
801 mg_set((SV*)av);
802 }
a0d0e21e 803 else
3280af22 804 (void)av_store(av,fill,&PL_sv_undef);
79072805 805}
c750a3ec 806
f3b76584
SC
807/*
808=for apidoc av_delete
809
810Deletes the element indexed by C<key> from the array. Returns the
a6214072
DM
811deleted element. If C<flags> equals C<G_DISCARD>, the element is freed
812and null is returned.
f3b76584
SC
813
814=cut
815*/
146174a9
CB
816SV *
817Perl_av_delete(pTHX_ AV *av, I32 key, I32 flags)
818{
97aff369 819 dVAR;
146174a9
CB
820 SV *sv;
821
ba5d1d60
GA
822 assert(av);
823
146174a9
CB
824 if (SvREADONLY(av))
825 Perl_croak(aTHX_ PL_no_modify);
6f12eb6d
MJD
826
827 if (SvRMAGICAL(av)) {
35a4481c 828 const MAGIC * const tied_magic = mg_find((SV*)av, PERL_MAGIC_tied);
6f12eb6d
MJD
829 if ((tied_magic || mg_find((SV*)av, PERL_MAGIC_regdata))) {
830 /* Handle negative array indices 20020222 MJD */
35a4481c 831 SV **svp;
6f12eb6d
MJD
832 if (key < 0) {
833 unsigned adjust_index = 1;
834 if (tied_magic) {
823a54a3 835 SV * const * const negative_indices_glob =
6f12eb6d
MJD
836 hv_fetch(SvSTASH(SvRV(SvTIED_obj((SV *)av,
837 tied_magic))),
838 NEGATIVE_INDICES_VAR, 16, 0);
839 if (negative_indices_glob
840 && SvTRUE(GvSV(*negative_indices_glob)))
841 adjust_index = 0;
842 }
843 if (adjust_index) {
844 key += AvFILL(av) + 1;
845 if (key < 0)
fabdb6c0 846 return NULL;
6f12eb6d
MJD
847 }
848 }
849 svp = av_fetch(av, key, TRUE);
850 if (svp) {
851 sv = *svp;
852 mg_clear(sv);
853 if (mg_find(sv, PERL_MAGIC_tiedelem)) {
854 sv_unmagic(sv, PERL_MAGIC_tiedelem); /* No longer an element */
855 return sv;
856 }
fabdb6c0 857 return NULL;
6f12eb6d
MJD
858 }
859 }
860 }
861
146174a9
CB
862 if (key < 0) {
863 key += AvFILL(av) + 1;
864 if (key < 0)
fabdb6c0 865 return NULL;
146174a9 866 }
6f12eb6d 867
146174a9 868 if (key > AvFILLp(av))
fabdb6c0 869 return NULL;
146174a9 870 else {
a6214072
DM
871 if (!AvREAL(av) && AvREIFY(av))
872 av_reify(av);
146174a9
CB
873 sv = AvARRAY(av)[key];
874 if (key == AvFILLp(av)) {
d9c63288 875 AvARRAY(av)[key] = &PL_sv_undef;
146174a9
CB
876 do {
877 AvFILLp(av)--;
878 } while (--key >= 0 && AvARRAY(av)[key] == &PL_sv_undef);
879 }
880 else
881 AvARRAY(av)[key] = &PL_sv_undef;
882 if (SvSMAGICAL(av))
883 mg_set((SV*)av);
884 }
885 if (flags & G_DISCARD) {
886 SvREFCNT_dec(sv);
fabdb6c0 887 sv = NULL;
146174a9 888 }
fdb3bdd0 889 else if (AvREAL(av))
2c8ddff3 890 sv = sv_2mortal(sv);
146174a9
CB
891 return sv;
892}
893
894/*
f3b76584
SC
895=for apidoc av_exists
896
897Returns true if the element indexed by C<key> has been initialized.
146174a9 898
f3b76584
SC
899This relies on the fact that uninitialized array elements are set to
900C<&PL_sv_undef>.
901
902=cut
903*/
146174a9
CB
904bool
905Perl_av_exists(pTHX_ AV *av, I32 key)
906{
97aff369 907 dVAR;
ba5d1d60 908 assert(av);
6f12eb6d
MJD
909
910 if (SvRMAGICAL(av)) {
35a4481c 911 const MAGIC * const tied_magic = mg_find((SV*)av, PERL_MAGIC_tied);
6f12eb6d 912 if (tied_magic || mg_find((SV*)av, PERL_MAGIC_regdata)) {
fabdb6c0 913 SV * const sv = sv_newmortal();
6f12eb6d
MJD
914 MAGIC *mg;
915 /* Handle negative array indices 20020222 MJD */
916 if (key < 0) {
917 unsigned adjust_index = 1;
918 if (tied_magic) {
823a54a3 919 SV * const * const negative_indices_glob =
6f12eb6d
MJD
920 hv_fetch(SvSTASH(SvRV(SvTIED_obj((SV *)av,
921 tied_magic))),
922 NEGATIVE_INDICES_VAR, 16, 0);
923 if (negative_indices_glob
924 && SvTRUE(GvSV(*negative_indices_glob)))
925 adjust_index = 0;
926 }
927 if (adjust_index) {
928 key += AvFILL(av) + 1;
929 if (key < 0)
930 return FALSE;
931 }
932 }
933
934 mg_copy((SV*)av, sv, 0, key);
935 mg = mg_find(sv, PERL_MAGIC_tiedelem);
936 if (mg) {
937 magic_existspack(sv, mg);
938 return (bool)SvTRUE(sv);
939 }
940
941 }
942 }
943
146174a9
CB
944 if (key < 0) {
945 key += AvFILL(av) + 1;
946 if (key < 0)
947 return FALSE;
948 }
6f12eb6d 949
146174a9
CB
950 if (key <= AvFILLp(av) && AvARRAY(av)[key] != &PL_sv_undef
951 && AvARRAY(av)[key])
952 {
953 return TRUE;
954 }
955 else
956 return FALSE;
957}
66610fdd 958
a3874608
NC
959SV **
960Perl_av_arylen_p(pTHX_ AV *av) {
961 dVAR;
ba5d1d60
GA
962 MAGIC *mg;
963
964 assert(av);
965
966 mg = mg_find((SV*)av, PERL_MAGIC_arylen_p);
a3874608
NC
967
968 if (!mg) {
1b20cd17
NC
969 mg = sv_magicext((SV*)av, 0, PERL_MAGIC_arylen_p, &PL_vtbl_arylen_p,
970 0, 0);
c82c7adc 971 assert(mg);
a3874608
NC
972 /* sv_magicext won't set this for us because we pass in a NULL obj */
973 mg->mg_flags |= MGf_REFCOUNTED;
974 }
975 return &(mg->mg_obj);
976}
977
66610fdd
RGS
978/*
979 * Local variables:
980 * c-indentation-style: bsd
981 * c-basic-offset: 4
982 * indent-tabs-mode: t
983 * End:
984 *
37442d52
RGS
985 * ex: set ts=8 sts=4 sw=4 noet:
986 */