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