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