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