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