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