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