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