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