This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
av_make: remove unnecessary AvFILLp assignment
[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 = newAV();
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         /* avoid av being leaked if croak when calling magic below */
428         EXTEND_MORTAL(1);
429         PL_tmps_stack[++PL_tmps_ix] = (SV*)av;
430         orig_ix = PL_tmps_ix;
431
432         for (i = 0; i < size; i++) {
433             assert (*strp);
434
435             /* Don't let sv_setsv swipe, since our source array might
436                have multiple references to the same temp scalar (e.g.
437                from a list slice) */
438
439             SvGETMAGIC(*strp); /* before newSV, in case it dies */
440             AvFILLp(av)++;
441             ary[i] = newSV(0);
442             sv_setsv_flags(ary[i], *strp,
443                            SV_DO_COW_SVSETSV|SV_NOSTEAL);
444             strp++;
445         }
446         /* disarm av's leak guard */
447         if (LIKELY(PL_tmps_ix == orig_ix))
448             PL_tmps_ix--;
449         else
450             PL_tmps_stack[orig_ix] = &PL_sv_undef;
451     }
452     return av;
453 }
454
455 /*
456 =for apidoc av_clear
457
458 Frees the all the elements of an array, leaving it empty.
459 The XS equivalent of C<@array = ()>.  See also L</av_undef>.
460
461 Note that it is possible that the actions of a destructor called directly
462 or indirectly by freeing an element of the array could cause the reference
463 count of the array itself to be reduced (e.g. by deleting an entry in the
464 symbol table). So it is a possibility that the AV could have been freed
465 (or even reallocated) on return from the call unless you hold a reference
466 to it.
467
468 =cut
469 */
470
471 void
472 Perl_av_clear(pTHX_ AV *av)
473 {
474     SSize_t extra;
475     bool real;
476     SSize_t orig_ix = 0;
477
478     PERL_ARGS_ASSERT_AV_CLEAR;
479     assert(SvTYPE(av) == SVt_PVAV);
480
481 #ifdef DEBUGGING
482     if (SvREFCNT(av) == 0) {
483         Perl_ck_warner_d(aTHX_ packWARN(WARN_DEBUGGING), "Attempt to clear deleted array");
484     }
485 #endif
486
487     if (SvREADONLY(av))
488         Perl_croak_no_modify();
489
490     /* Give any tie a chance to cleanup first */
491     if (SvRMAGICAL(av)) {
492         const MAGIC* const mg = SvMAGIC(av);
493         if (PL_delaymagic && mg && mg->mg_type == PERL_MAGIC_isa)
494             PL_delaymagic |= DM_ARRAY_ISA;
495         else
496             mg_clear(MUTABLE_SV(av)); 
497     }
498
499     if (AvMAX(av) < 0)
500         return;
501
502     if ((real = cBOOL(AvREAL(av)))) {
503         SV** const ary = AvARRAY(av);
504         SSize_t index = AvFILLp(av) + 1;
505
506         /* avoid av being freed when calling destructors below */
507         EXTEND_MORTAL(1);
508         PL_tmps_stack[++PL_tmps_ix] = SvREFCNT_inc_simple_NN(av);
509         orig_ix = PL_tmps_ix;
510
511         while (index) {
512             SV * const sv = ary[--index];
513             /* undef the slot before freeing the value, because a
514              * destructor might try to modify this array */
515             ary[index] = NULL;
516             SvREFCNT_dec(sv);
517         }
518     }
519     extra = AvARRAY(av) - AvALLOC(av);
520     if (extra) {
521         AvMAX(av) += extra;
522         AvARRAY(av) = AvALLOC(av);
523     }
524     AvFILLp(av) = -1;
525     if (real) {
526         /* disarm av's premature free guard */
527         if (LIKELY(PL_tmps_ix == orig_ix))
528             PL_tmps_ix--;
529         else
530             PL_tmps_stack[orig_ix] = &PL_sv_undef;
531         SvREFCNT_dec_NN(av);
532     }
533 }
534
535 /*
536 =for apidoc av_undef
537
538 Undefines the array. The XS equivalent of C<undef(@array)>.
539
540 As well as freeing all the elements of the array (like C<av_clear()>), this
541 also frees the memory used by the av to store its list of scalars.
542
543 See L</av_clear> for a note about the array possibly being invalid on
544 return.
545
546 =cut
547 */
548
549 void
550 Perl_av_undef(pTHX_ AV *av)
551 {
552     bool real;
553     SSize_t orig_ix = PL_tmps_ix; /* silence bogus warning about possible unitialized use */
554
555     PERL_ARGS_ASSERT_AV_UNDEF;
556     assert(SvTYPE(av) == SVt_PVAV);
557
558     /* Give any tie a chance to cleanup first */
559     if (SvTIED_mg((const SV *)av, PERL_MAGIC_tied)) 
560         av_fill(av, -1);
561
562     real = cBOOL(AvREAL(av));
563     if (real) {
564         SSize_t key = AvFILLp(av) + 1;
565
566         /* avoid av being freed when calling destructors below */
567         EXTEND_MORTAL(1);
568         PL_tmps_stack[++PL_tmps_ix] = SvREFCNT_inc_simple_NN(av);
569         orig_ix = PL_tmps_ix;
570
571         while (key)
572             SvREFCNT_dec(AvARRAY(av)[--key]);
573     }
574
575     Safefree(AvALLOC(av));
576     AvALLOC(av) = NULL;
577     AvARRAY(av) = NULL;
578     AvMAX(av) = AvFILLp(av) = -1;
579
580     if(SvRMAGICAL(av)) mg_clear(MUTABLE_SV(av));
581     if (real) {
582         /* disarm av's premature free guard */
583         if (LIKELY(PL_tmps_ix == orig_ix))
584             PL_tmps_ix--;
585         else
586             PL_tmps_stack[orig_ix] = &PL_sv_undef;
587         SvREFCNT_dec_NN(av);
588     }
589 }
590
591 /*
592
593 =for apidoc av_create_and_push
594
595 Push an SV onto the end of the array, creating the array if necessary.
596 A small internal helper function to remove a commonly duplicated idiom.
597
598 =cut
599 */
600
601 void
602 Perl_av_create_and_push(pTHX_ AV **const avp, SV *const val)
603 {
604     PERL_ARGS_ASSERT_AV_CREATE_AND_PUSH;
605
606     if (!*avp)
607         *avp = newAV();
608     av_push(*avp, val);
609 }
610
611 /*
612 =for apidoc av_push
613
614 Pushes an SV (transferring control of one reference count) onto the end of the
615 array.  The array will grow automatically to accommodate the addition.
616
617 Perl equivalent: C<push @myarray, $val;>.
618
619 =cut
620 */
621
622 void
623 Perl_av_push(pTHX_ AV *av, SV *val)
624 {             
625     MAGIC *mg;
626
627     PERL_ARGS_ASSERT_AV_PUSH;
628     assert(SvTYPE(av) == SVt_PVAV);
629
630     if (SvREADONLY(av))
631         Perl_croak_no_modify();
632
633     if ((mg = SvTIED_mg((const SV *)av, PERL_MAGIC_tied))) {
634         Perl_magic_methcall(aTHX_ MUTABLE_SV(av), mg, SV_CONST(PUSH), G_DISCARD, 1,
635                             val);
636         return;
637     }
638     av_store(av,AvFILLp(av)+1,val);
639 }
640
641 /*
642 =for apidoc av_pop
643
644 Removes one SV from the end of the array, reducing its size by one and
645 returning the SV (transferring control of one reference count) to the
646 caller.  Returns C<&PL_sv_undef> if the array is empty.
647
648 Perl equivalent: C<pop(@myarray);>
649
650 =cut
651 */
652
653 SV *
654 Perl_av_pop(pTHX_ AV *av)
655 {
656     SV *retval;
657     MAGIC* mg;
658
659     PERL_ARGS_ASSERT_AV_POP;
660     assert(SvTYPE(av) == SVt_PVAV);
661
662     if (SvREADONLY(av))
663         Perl_croak_no_modify();
664     if ((mg = SvTIED_mg((const SV *)av, PERL_MAGIC_tied))) {
665         retval = Perl_magic_methcall(aTHX_ MUTABLE_SV(av), mg, SV_CONST(POP), 0, 0);
666         if (retval)
667             retval = newSVsv(retval);
668         return retval;
669     }
670     if (AvFILL(av) < 0)
671         return &PL_sv_undef;
672     retval = AvARRAY(av)[AvFILLp(av)];
673     AvARRAY(av)[AvFILLp(av)--] = NULL;
674     if (SvSMAGICAL(av))
675         mg_set(MUTABLE_SV(av));
676     return retval ? retval : &PL_sv_undef;
677 }
678
679 /*
680
681 =for apidoc av_create_and_unshift_one
682
683 Unshifts an SV onto the beginning of the array, creating the array if
684 necessary.
685 A small internal helper function to remove a commonly duplicated idiom.
686
687 =cut
688 */
689
690 SV **
691 Perl_av_create_and_unshift_one(pTHX_ AV **const avp, SV *const val)
692 {
693     PERL_ARGS_ASSERT_AV_CREATE_AND_UNSHIFT_ONE;
694
695     if (!*avp)
696         *avp = newAV();
697     av_unshift(*avp, 1);
698     return av_store(*avp, 0, val);
699 }
700
701 /*
702 =for apidoc av_unshift
703
704 Unshift the given number of C<undef> values onto the beginning of the
705 array.  The array will grow automatically to accommodate the addition.
706
707 Perl equivalent: S<C<unshift @myarray, ((undef) x $num);>>
708
709 =cut
710 */
711
712 void
713 Perl_av_unshift(pTHX_ AV *av, SSize_t num)
714 {
715     SSize_t i;
716     MAGIC* mg;
717
718     PERL_ARGS_ASSERT_AV_UNSHIFT;
719     assert(SvTYPE(av) == SVt_PVAV);
720
721     if (SvREADONLY(av))
722         Perl_croak_no_modify();
723
724     if ((mg = SvTIED_mg((const SV *)av, PERL_MAGIC_tied))) {
725         Perl_magic_methcall(aTHX_ MUTABLE_SV(av), mg, SV_CONST(UNSHIFT),
726                             G_DISCARD | G_UNDEF_FILL, num);
727         return;
728     }
729
730     if (num <= 0)
731       return;
732     if (!AvREAL(av) && AvREIFY(av))
733         av_reify(av);
734     i = AvARRAY(av) - AvALLOC(av);
735     if (i) {
736         if (i > num)
737             i = num;
738         num -= i;
739     
740         AvMAX(av) += i;
741         AvFILLp(av) += i;
742         AvARRAY(av) = AvARRAY(av) - i;
743     }
744     if (num) {
745         SV **ary;
746         const SSize_t i = AvFILLp(av);
747         /* Create extra elements */
748         const SSize_t slide = i > 0 ? i : 0;
749         num += slide;
750         av_extend(av, i + num);
751         AvFILLp(av) += num;
752         ary = AvARRAY(av);
753         Move(ary, ary + num, i + 1, SV*);
754         do {
755             ary[--num] = NULL;
756         } while (num);
757         /* Make extra elements into a buffer */
758         AvMAX(av) -= slide;
759         AvFILLp(av) -= slide;
760         AvARRAY(av) = AvARRAY(av) + slide;
761     }
762 }
763
764 /*
765 =for apidoc av_shift
766
767 Removes one SV from the start of the array, reducing its size by one and
768 returning the SV (transferring control of one reference count) to the
769 caller.  Returns C<&PL_sv_undef> if the array is empty.
770
771 Perl equivalent: C<shift(@myarray);>
772
773 =cut
774 */
775
776 SV *
777 Perl_av_shift(pTHX_ AV *av)
778 {
779     SV *retval;
780     MAGIC* mg;
781
782     PERL_ARGS_ASSERT_AV_SHIFT;
783     assert(SvTYPE(av) == SVt_PVAV);
784
785     if (SvREADONLY(av))
786         Perl_croak_no_modify();
787     if ((mg = SvTIED_mg((const SV *)av, PERL_MAGIC_tied))) {
788         retval = Perl_magic_methcall(aTHX_ MUTABLE_SV(av), mg, SV_CONST(SHIFT), 0, 0);
789         if (retval)
790             retval = newSVsv(retval);
791         return retval;
792     }
793     if (AvFILL(av) < 0)
794       return &PL_sv_undef;
795     retval = *AvARRAY(av);
796     if (AvREAL(av))
797         *AvARRAY(av) = NULL;
798     AvARRAY(av) = AvARRAY(av) + 1;
799     AvMAX(av)--;
800     AvFILLp(av)--;
801     if (SvSMAGICAL(av))
802         mg_set(MUTABLE_SV(av));
803     return retval ? retval : &PL_sv_undef;
804 }
805
806 /*
807 =for apidoc av_tindex
808 =for apidoc_item av_top_index
809
810 These behave identically.
811 If the array C<av> is empty, these return -1; otherwise they return the maximum
812 value of the indices of all the array elements which are currently defined in
813 C<av>.
814
815 They process 'get' magic.
816
817 The Perl equivalent for these is C<$#av>.
818
819 Use C<L</av_count>> to get the number of elements in an array.
820
821 =for apidoc av_len
822
823 Same as L</av_top_index>.  Note that, unlike what the name implies, it returns
824 the maximum index in the array.  This is unlike L</sv_len>, which returns what
825 you would expect.
826
827 B<To get the true number of elements in the array, instead use C<L</av_count>>>.
828
829 =cut
830 */
831
832 SSize_t
833 Perl_av_len(pTHX_ AV *av)
834 {
835     PERL_ARGS_ASSERT_AV_LEN;
836
837     return av_top_index(av);
838 }
839
840 /*
841 =for apidoc av_fill
842
843 Set the highest index in the array to the given number, equivalent to
844 Perl's S<C<$#array = $fill;>>.
845
846 The number of elements in the array will be S<C<fill + 1>> after
847 C<av_fill()> returns.  If the array was previously shorter, then the
848 additional elements appended are set to NULL.  If the array
849 was longer, then the excess elements are freed.  S<C<av_fill(av, -1)>> is
850 the same as C<av_clear(av)>.
851
852 =cut
853 */
854 void
855 Perl_av_fill(pTHX_ AV *av, SSize_t fill)
856 {
857     MAGIC *mg;
858
859     PERL_ARGS_ASSERT_AV_FILL;
860     assert(SvTYPE(av) == SVt_PVAV);
861
862     if (fill < 0)
863         fill = -1;
864     if ((mg = SvTIED_mg((const SV *)av, PERL_MAGIC_tied))) {
865         SV *arg1 = sv_newmortal();
866         sv_setiv(arg1, (IV)(fill + 1));
867         Perl_magic_methcall(aTHX_ MUTABLE_SV(av), mg, SV_CONST(STORESIZE), G_DISCARD,
868                             1, arg1);
869         return;
870     }
871     if (fill <= AvMAX(av)) {
872         SSize_t key = AvFILLp(av);
873         SV** const ary = AvARRAY(av);
874
875         if (AvREAL(av)) {
876             while (key > fill) {
877                 SvREFCNT_dec(ary[key]);
878                 ary[key--] = NULL;
879             }
880         }
881         else {
882             while (key < fill)
883                 ary[++key] = NULL;
884         }
885             
886         AvFILLp(av) = fill;
887         if (SvSMAGICAL(av))
888             mg_set(MUTABLE_SV(av));
889     }
890     else
891         (void)av_store(av,fill,NULL);
892 }
893
894 /*
895 =for apidoc av_delete
896
897 Deletes the element indexed by C<key> from the array, makes the element
898 mortal, and returns it.  If C<flags> equals C<G_DISCARD>, the element is
899 freed and NULL is returned. NULL is also returned if C<key> is out of
900 range.
901
902 Perl equivalent: S<C<splice(@myarray, $key, 1, undef)>> (with the
903 C<splice> in void context if C<G_DISCARD> is present).
904
905 =cut
906 */
907 SV *
908 Perl_av_delete(pTHX_ AV *av, SSize_t key, I32 flags)
909 {
910     SV *sv;
911
912     PERL_ARGS_ASSERT_AV_DELETE;
913     assert(SvTYPE(av) == SVt_PVAV);
914
915     if (SvREADONLY(av))
916         Perl_croak_no_modify();
917
918     if (SvRMAGICAL(av)) {
919         const MAGIC * const tied_magic
920             = mg_find((const SV *)av, PERL_MAGIC_tied);
921         if ((tied_magic || mg_find((const SV *)av, PERL_MAGIC_regdata))) {
922             SV **svp;
923             if (key < 0) {
924                 if (!S_adjust_index(aTHX_ av, tied_magic, &key))
925                         return NULL;
926             }
927             svp = av_fetch(av, key, TRUE);
928             if (svp) {
929                 sv = *svp;
930                 mg_clear(sv);
931                 if (mg_find(sv, PERL_MAGIC_tiedelem)) {
932                     sv_unmagic(sv, PERL_MAGIC_tiedelem); /* No longer an element */
933                     return sv;
934                 }
935                 return NULL;
936             }
937         }
938     }
939
940     if (key < 0) {
941         key += AvFILL(av) + 1;
942         if (key < 0)
943             return NULL;
944     }
945
946     if (key > AvFILLp(av))
947         return NULL;
948     else {
949         if (!AvREAL(av) && AvREIFY(av))
950             av_reify(av);
951         sv = AvARRAY(av)[key];
952         AvARRAY(av)[key] = NULL;
953         if (key == AvFILLp(av)) {
954             do {
955                 AvFILLp(av)--;
956             } while (--key >= 0 && !AvARRAY(av)[key]);
957         }
958         if (SvSMAGICAL(av))
959             mg_set(MUTABLE_SV(av));
960     }
961     if(sv != NULL) {
962         if (flags & G_DISCARD) {
963             SvREFCNT_dec_NN(sv);
964             return NULL;
965         }
966         else if (AvREAL(av))
967             sv_2mortal(sv);
968     }
969     return sv;
970 }
971
972 /*
973 =for apidoc av_exists
974
975 Returns true if the element indexed by C<key> has been initialized.
976
977 This relies on the fact that uninitialized array elements are set to
978 C<NULL>.
979
980 Perl equivalent: C<exists($myarray[$key])>.
981
982 =cut
983 */
984 bool
985 Perl_av_exists(pTHX_ AV *av, SSize_t key)
986 {
987     PERL_ARGS_ASSERT_AV_EXISTS;
988     assert(SvTYPE(av) == SVt_PVAV);
989
990     if (SvRMAGICAL(av)) {
991         const MAGIC * const tied_magic
992             = mg_find((const SV *)av, PERL_MAGIC_tied);
993         const MAGIC * const regdata_magic
994             = mg_find((const SV *)av, PERL_MAGIC_regdata);
995         if (tied_magic || regdata_magic) {
996             MAGIC *mg;
997             /* Handle negative array indices 20020222 MJD */
998             if (key < 0) {
999                 if (!S_adjust_index(aTHX_ av, tied_magic, &key))
1000                         return FALSE;
1001             }
1002
1003             if(key >= 0 && regdata_magic) {
1004                 if (key <= AvFILL(av))
1005                     return TRUE;
1006                 else
1007                     return FALSE;
1008             }
1009             {
1010                 SV * const sv = sv_newmortal();
1011                 mg_copy(MUTABLE_SV(av), sv, 0, key);
1012                 mg = mg_find(sv, PERL_MAGIC_tiedelem);
1013                 if (mg) {
1014                     magic_existspack(sv, mg);
1015                     {
1016                         I32 retbool = SvTRUE_nomg_NN(sv);
1017                         return cBOOL(retbool);
1018                     }
1019                 }
1020             }
1021         }
1022     }
1023
1024     if (key < 0) {
1025         key += AvFILL(av) + 1;
1026         if (key < 0)
1027             return FALSE;
1028     }
1029
1030     if (key <= AvFILLp(av) && AvARRAY(av)[key])
1031     {
1032         if (SvSMAGICAL(AvARRAY(av)[key])
1033          && mg_find(AvARRAY(av)[key], PERL_MAGIC_nonelem))
1034             return FALSE;
1035         return TRUE;
1036     }
1037     else
1038         return FALSE;
1039 }
1040
1041 static MAGIC *
1042 S_get_aux_mg(pTHX_ AV *av) {
1043     MAGIC *mg;
1044
1045     PERL_ARGS_ASSERT_GET_AUX_MG;
1046     assert(SvTYPE(av) == SVt_PVAV);
1047
1048     mg = mg_find((const SV *)av, PERL_MAGIC_arylen_p);
1049
1050     if (!mg) {
1051         mg = sv_magicext(MUTABLE_SV(av), 0, PERL_MAGIC_arylen_p,
1052                          &PL_vtbl_arylen_p, 0, 0);
1053         assert(mg);
1054         /* sv_magicext won't set this for us because we pass in a NULL obj  */
1055         mg->mg_flags |= MGf_REFCOUNTED;
1056     }
1057     return mg;
1058 }
1059
1060 SV **
1061 Perl_av_arylen_p(pTHX_ AV *av) {
1062     MAGIC *const mg = get_aux_mg(av);
1063
1064     PERL_ARGS_ASSERT_AV_ARYLEN_P;
1065     assert(SvTYPE(av) == SVt_PVAV);
1066
1067     return &(mg->mg_obj);
1068 }
1069
1070 IV *
1071 Perl_av_iter_p(pTHX_ AV *av) {
1072     MAGIC *const mg = get_aux_mg(av);
1073
1074     PERL_ARGS_ASSERT_AV_ITER_P;
1075     assert(SvTYPE(av) == SVt_PVAV);
1076
1077     if (sizeof(IV) == sizeof(SSize_t)) {
1078         return (IV *)&(mg->mg_len);
1079     } else {
1080         if (!mg->mg_ptr) {
1081             IV *temp;
1082             mg->mg_len = IVSIZE;
1083             Newxz(temp, 1, IV);
1084             mg->mg_ptr = (char *) temp;
1085         }
1086         return (IV *)mg->mg_ptr;
1087     }
1088 }
1089
1090 SV *
1091 Perl_av_nonelem(pTHX_ AV *av, SSize_t ix) {
1092     SV * const sv = newSV(0);
1093     PERL_ARGS_ASSERT_AV_NONELEM;
1094     if (!av_store(av,ix,sv))
1095         return sv_2mortal(sv); /* has tie magic */
1096     sv_magic(sv, NULL, PERL_MAGIC_nonelem, NULL, 0);
1097     return sv;
1098 }
1099
1100 /*
1101  * ex: set ts=8 sts=4 sw=4 et:
1102  */