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