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