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