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