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