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