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