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