This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
4bdd72df168a19bceb883c91f4827c96ac8f6064
[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 =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     dVAR;
30     I32 key;
31
32     PERL_ARGS_ASSERT_AV_REIFY;
33     assert(SvTYPE(av) == SVt_PVAV);
34
35     if (AvREAL(av))
36         return;
37 #ifdef DEBUGGING
38     if (SvTIED_mg((const SV *)av, PERL_MAGIC_tied))
39         Perl_ck_warner_d(aTHX_ packWARN(WARN_DEBUGGING), "av_reify called on tied array");
40 #endif
41     key = AvMAX(av) + 1;
42     while (key > AvFILLp(av) + 1)
43         AvARRAY(av)[--key] = &PL_sv_undef;
44     while (key) {
45         SV * const sv = AvARRAY(av)[--key];
46         assert(sv);
47         if (sv != &PL_sv_undef)
48             SvREFCNT_inc_simple_void_NN(sv);
49     }
50     key = AvARRAY(av) - AvALLOC(av);
51     while (key)
52         AvALLOC(av)[--key] = &PL_sv_undef;
53     AvREIFY_off(av);
54     AvREAL_on(av);
55 }
56
57 /*
58 =for apidoc av_extend
59
60 Pre-extend an array.  The C<key> is the index to which the array should be
61 extended.
62
63 =cut
64 */
65
66 void
67 Perl_av_extend(pTHX_ AV *av, I32 key)
68 {
69     dVAR;
70     MAGIC *mg;
71
72     PERL_ARGS_ASSERT_AV_EXTEND;
73     assert(SvTYPE(av) == SVt_PVAV);
74
75     mg = SvTIED_mg((const SV *)av, PERL_MAGIC_tied);
76     if (mg) {
77         SV *arg1 = sv_newmortal();
78         sv_setiv(arg1, (IV)(key + 1));
79         Perl_magic_methcall(aTHX_ MUTABLE_SV(av), mg, "EXTEND", G_DISCARD, 1,
80                             arg1);
81         return;
82     }
83     av_extend_guts(av,key,&AvMAX(av),&AvALLOC(av),&AvARRAY(av));
84 }    
85
86 /* The guts of av_extend.  *Not* for general use! */
87 void
88 Perl_av_extend_guts(pTHX_ AV *av, I32 key, SSize_t *maxp, SV ***allocp,
89                           SV ***arrayp)
90 {
91     dVAR;
92
93     PERL_ARGS_ASSERT_AV_EXTEND_GUTS;
94
95     if (key > *maxp) {
96         SV** ary;
97         I32 tmp;
98         I32 newmax;
99
100         if (av && *allocp != *arrayp) {
101             ary = *allocp + AvFILLp(av) + 1;
102             tmp = *arrayp - *allocp;
103             Move(*arrayp, *allocp, AvFILLp(av)+1, SV*);
104             *maxp += tmp;
105             *arrayp = *allocp;
106             if (AvREAL(av)) {
107                 while (tmp)
108                     ary[--tmp] = &PL_sv_undef;
109             }
110             if (key > *maxp - 10) {
111                 newmax = key + *maxp;
112                 goto resize;
113             }
114         }
115         else {
116 #ifdef PERL_MALLOC_WRAP
117             static const char oom_array_extend[] =
118               "Out of memory during array extend"; /* Duplicated in pp_hot.c */
119 #endif
120
121             if (*allocp) {
122 #if !defined(STRANGE_MALLOC) && !defined(MYMALLOC)
123                 MEM_SIZE bytes;
124                 IV itmp;
125 #endif
126
127 #ifdef Perl_safesysmalloc_size
128                 /* Whilst it would be quite possible to move this logic around
129                    (as I did in the SV code), so as to set AvMAX(av) early,
130                    based on calling Perl_safesysmalloc_size() immediately after
131                    allocation, I'm not convinced that it is a great idea here.
132                    In an array we have to loop round setting everything to
133                    &PL_sv_undef, which means writing to memory, potentially lots
134                    of it, whereas for the SV buffer case we don't touch the
135                    "bonus" memory. So there there is no cost in telling the
136                    world about it, whereas here we have to do work before we can
137                    tell the world about it, and that work involves writing to
138                    memory that might never be read. So, I feel, better to keep
139                    the current lazy system of only writing to it if our caller
140                    has a need for more space. NWC  */
141                 newmax = Perl_safesysmalloc_size((void*)*allocp) /
142                     sizeof(const SV *) - 1;
143
144                 if (key <= newmax) 
145                     goto resized;
146 #endif 
147                 newmax = key + *maxp / 5;
148               resize:
149                 MEM_WRAP_CHECK_1(newmax+1, SV*, oom_array_extend);
150 #if defined(STRANGE_MALLOC) || defined(MYMALLOC)
151                 Renew(*allocp,newmax+1, SV*);
152 #else
153                 bytes = (newmax + 1) * sizeof(const SV *);
154 #define MALLOC_OVERHEAD 16
155                 itmp = MALLOC_OVERHEAD;
156                 while ((MEM_SIZE)(itmp - MALLOC_OVERHEAD) < bytes)
157                     itmp += itmp;
158                 itmp -= MALLOC_OVERHEAD;
159                 itmp /= sizeof(const SV *);
160                 assert(itmp > newmax);
161                 newmax = itmp - 1;
162                 assert(newmax >= *maxp);
163                 Newx(ary, newmax+1, SV*);
164                 Copy(*allocp, ary, *maxp+1, SV*);
165                 Safefree(*allocp);
166                 *allocp = ary;
167 #endif
168 #ifdef Perl_safesysmalloc_size
169               resized:
170 #endif
171                 ary = *allocp + *maxp + 1;
172                 tmp = newmax - *maxp;
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             }
179             else {
180                 newmax = key < 3 ? 3 : key;
181                 MEM_WRAP_CHECK_1(newmax+1, SV*, oom_array_extend);
182                 Newx(*allocp, newmax+1, SV*);
183                 ary = *allocp + 1;
184                 tmp = newmax;
185                 *allocp[0] = &PL_sv_undef;      /* For the stacks */
186             }
187             if (av && AvREAL(av)) {
188                 while (tmp)
189                     ary[--tmp] = &PL_sv_undef;
190             }
191             
192             *arrayp = *allocp;
193             *maxp = newmax;
194         }
195     }
196 }
197
198 /*
199 =for apidoc av_fetch
200
201 Returns the SV at the specified index in the array.  The C<key> is the
202 index.  If lval is true, you are guaranteed to get a real SV back (in case
203 it wasn't real before), which you can then modify.  Check that the return
204 value is non-null before dereferencing it to a C<SV*>.
205
206 See L<perlguts/"Understanding the Magic of Tied Hashes and Arrays"> for
207 more information on how to use this function on tied arrays. 
208
209 The rough perl equivalent is C<$myarray[$idx]>.
210
211 =cut
212 */
213
214 SV**
215 Perl_av_fetch(pTHX_ register AV *av, I32 key, I32 lval)
216 {
217     dVAR;
218
219     PERL_ARGS_ASSERT_AV_FETCH;
220     assert(SvTYPE(av) == SVt_PVAV);
221
222     if (SvRMAGICAL(av)) {
223         const MAGIC * const tied_magic
224             = mg_find((const SV *)av, PERL_MAGIC_tied);
225         if (tied_magic || mg_find((const SV *)av, PERL_MAGIC_regdata)) {
226             SV *sv;
227             if (key < 0) {
228                 I32 adjust_index = 1;
229                 if (tied_magic) {
230                     /* Handle negative array indices 20020222 MJD */
231                     SV * const * const negative_indices_glob =
232                         hv_fetch(SvSTASH(SvRV(SvTIED_obj(MUTABLE_SV(av),
233                                                          tied_magic))),
234                                 NEGATIVE_INDICES_VAR, 16, 0);
235
236                     if (negative_indices_glob && SvTRUE(GvSV(*negative_indices_glob)))
237                         adjust_index = 0;
238                 }
239
240                 if (adjust_index) {
241                     key += AvFILL(av) + 1;
242                     if (key < 0)
243                         return NULL;
244                 }
245             }
246
247             sv = sv_newmortal();
248             sv_upgrade(sv, SVt_PVLV);
249             mg_copy(MUTABLE_SV(av), sv, 0, key);
250             if (!tied_magic) /* for regdata, force leavesub to make copies */
251                 SvTEMP_off(sv);
252             LvTYPE(sv) = 't';
253             LvTARG(sv) = sv; /* fake (SV**) */
254             return &(LvTARG(sv));
255         }
256     }
257
258     if (key < 0) {
259         key += AvFILL(av) + 1;
260         if (key < 0)
261             return NULL;
262     }
263
264     if (key > AvFILLp(av) || AvARRAY(av)[key] == &PL_sv_undef) {
265       emptyness:
266         return lval ? av_store(av,key,newSV(0)) : NULL;
267     }
268
269     if (AvREIFY(av)
270              && (!AvARRAY(av)[key]      /* eg. @_ could have freed elts */
271                  || SvIS_FREED(AvARRAY(av)[key]))) {
272         AvARRAY(av)[key] = &PL_sv_undef;        /* 1/2 reify */
273         goto emptyness;
274     }
275     return &AvARRAY(av)[key];
276 }
277
278 /*
279 =for apidoc av_store
280
281 Stores an SV in an array.  The array index is specified as C<key>.  The
282 return value will be NULL if the operation failed or if the value did not
283 need to be actually stored within the array (as in the case of tied
284 arrays). Otherwise, it can be dereferenced
285 to get the C<SV*> that was stored
286 there (= C<val>)).
287
288 Note that the caller is responsible for suitably incrementing the reference
289 count of C<val> before the call, and decrementing it if the function
290 returned NULL.
291
292 Approximate Perl equivalent: C<$myarray[$key] = $val;>.
293
294 See L<perlguts/"Understanding the Magic of Tied Hashes and Arrays"> for
295 more information on how to use this function on tied arrays.
296
297 =cut
298 */
299
300 SV**
301 Perl_av_store(pTHX_ register AV *av, I32 key, SV *val)
302 {
303     dVAR;
304     SV** ary;
305
306     PERL_ARGS_ASSERT_AV_STORE;
307     assert(SvTYPE(av) == SVt_PVAV);
308
309     /* S_regclass relies on being able to pass in a NULL sv
310        (unicode_alternate may be NULL).
311     */
312
313     if (!val)
314         val = &PL_sv_undef;
315
316     if (SvRMAGICAL(av)) {
317         const MAGIC * const tied_magic = mg_find((const SV *)av, PERL_MAGIC_tied);
318         if (tied_magic) {
319             /* Handle negative array indices 20020222 MJD */
320             if (key < 0) {
321                 bool adjust_index = 1;
322                 SV * const * const negative_indices_glob =
323                     hv_fetch(SvSTASH(SvRV(SvTIED_obj(MUTABLE_SV(av), 
324                                                      tied_magic))), 
325                              NEGATIVE_INDICES_VAR, 16, 0);
326                 if (negative_indices_glob
327                     && SvTRUE(GvSV(*negative_indices_glob)))
328                     adjust_index = 0;
329                 if (adjust_index) {
330                     key += AvFILL(av) + 1;
331                     if (key < 0)
332                         return 0;
333                 }
334             }
335             if (val != &PL_sv_undef) {
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(aTHX);
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)] = &PL_sv_undef;
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 != &PL_sv_undef) {
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 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_ register I32 size, register 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         I32 i;
412         Newx(ary,size,SV*);
413         AvALLOC(av) = ary;
414         AvARRAY(av) = ary;
415         AvMAX(av) = size - 1;
416         AvFILLp(av) = -1;
417         ENTER;
418         SAVEFREESV(av);
419         for (i = 0; i < size; i++) {
420             assert (*strp);
421
422             /* Don't let sv_setsv swipe, since our source array might
423                have multiple references to the same temp scalar (e.g.
424                from a list slice) */
425
426             SvGETMAGIC(*strp); /* before newSV, in case it dies */
427             AvFILLp(av)++;
428             ary[i] = newSV(0);
429             sv_setsv_flags(ary[i], *strp,
430                            SV_DO_COW_SVSETSV|SV_NOSTEAL);
431             strp++;
432         }
433         SvREFCNT_inc_simple_void_NN(av);
434         LEAVE;
435     }
436     return av;
437 }
438
439 /*
440 =for apidoc av_clear
441
442 Clears an array, making it empty.  Does not free the memory the av uses to
443 store its list of scalars.  If any destructors are triggered as a result,
444 the av itself may be freed when this function returns.
445
446 Perl equivalent: C<@myarray = ();>.
447
448 =cut
449 */
450
451 void
452 Perl_av_clear(pTHX_ register AV *av)
453 {
454     dVAR;
455     I32 extra;
456     bool real;
457
458     PERL_ARGS_ASSERT_AV_CLEAR;
459     assert(SvTYPE(av) == SVt_PVAV);
460
461 #ifdef DEBUGGING
462     if (SvREFCNT(av) == 0) {
463         Perl_ck_warner_d(aTHX_ packWARN(WARN_DEBUGGING), "Attempt to clear deleted array");
464     }
465 #endif
466
467     if (SvREADONLY(av))
468         Perl_croak_no_modify(aTHX);
469
470     /* Give any tie a chance to cleanup first */
471     if (SvRMAGICAL(av)) {
472         const MAGIC* const mg = SvMAGIC(av);
473         if (PL_delaymagic && mg && mg->mg_type == PERL_MAGIC_isa)
474             PL_delaymagic |= DM_ARRAY_ISA;
475         else
476             mg_clear(MUTABLE_SV(av)); 
477     }
478
479     if (AvMAX(av) < 0)
480         return;
481
482     if ((real = !!AvREAL(av))) {
483         SV** const ary = AvARRAY(av);
484         I32 index = AvFILLp(av) + 1;
485         ENTER;
486         SAVEFREESV(SvREFCNT_inc_simple_NN(av));
487         while (index) {
488             SV * const sv = ary[--index];
489             /* undef the slot before freeing the value, because a
490              * destructor might try to modify this array */
491             ary[index] = &PL_sv_undef;
492             SvREFCNT_dec(sv);
493         }
494     }
495     extra = AvARRAY(av) - AvALLOC(av);
496     if (extra) {
497         AvMAX(av) += extra;
498         AvARRAY(av) = AvALLOC(av);
499     }
500     AvFILLp(av) = -1;
501     if (real) LEAVE;
502 }
503
504 /*
505 =for apidoc av_undef
506
507 Undefines the array.  Frees the memory used by the av to store its list of
508 scalars.  If any destructors are triggered as a result, the av itself may
509 be freed.
510
511 =cut
512 */
513
514 void
515 Perl_av_undef(pTHX_ register AV *av)
516 {
517     bool real;
518
519     PERL_ARGS_ASSERT_AV_UNDEF;
520     assert(SvTYPE(av) == SVt_PVAV);
521
522     /* Give any tie a chance to cleanup first */
523     if (SvTIED_mg((const SV *)av, PERL_MAGIC_tied)) 
524         av_fill(av, -1);
525
526     if ((real = !!AvREAL(av))) {
527         I32 key = AvFILLp(av) + 1;
528         ENTER;
529         SAVEFREESV(SvREFCNT_inc_simple_NN(av));
530         while (key)
531             SvREFCNT_dec(AvARRAY(av)[--key]);
532     }
533
534     Safefree(AvALLOC(av));
535     AvALLOC(av) = NULL;
536     AvARRAY(av) = NULL;
537     AvMAX(av) = AvFILLp(av) = -1;
538
539     if(SvRMAGICAL(av)) mg_clear(MUTABLE_SV(av));
540     if(real) LEAVE;
541 }
542
543 /*
544
545 =for apidoc av_create_and_push
546
547 Push an SV onto the end of the array, creating the array if necessary.
548 A small internal helper function to remove a commonly duplicated idiom.
549
550 =cut
551 */
552
553 void
554 Perl_av_create_and_push(pTHX_ AV **const avp, SV *const val)
555 {
556     PERL_ARGS_ASSERT_AV_CREATE_AND_PUSH;
557
558     if (!*avp)
559         *avp = newAV();
560     av_push(*avp, val);
561 }
562
563 /*
564 =for apidoc av_push
565
566 Pushes an SV onto the end of the array.  The array will grow automatically
567 to accommodate the addition.  This takes ownership of one reference count.
568
569 Perl equivalent: C<push @myarray, $elem;>.
570
571 =cut
572 */
573
574 void
575 Perl_av_push(pTHX_ register AV *av, SV *val)
576 {             
577     dVAR;
578     MAGIC *mg;
579
580     PERL_ARGS_ASSERT_AV_PUSH;
581     assert(SvTYPE(av) == SVt_PVAV);
582
583     if (SvREADONLY(av))
584         Perl_croak_no_modify(aTHX);
585
586     if ((mg = SvTIED_mg((const SV *)av, PERL_MAGIC_tied))) {
587         Perl_magic_methcall(aTHX_ MUTABLE_SV(av), mg, "PUSH", G_DISCARD, 1,
588                             val);
589         return;
590     }
591     av_store(av,AvFILLp(av)+1,val);
592 }
593
594 /*
595 =for apidoc av_pop
596
597 Pops an SV off the end of the array.  Returns C<&PL_sv_undef> if the array
598 is empty.
599
600 Perl equivalent: C<pop(@myarray);>
601
602 =cut
603 */
604
605 SV *
606 Perl_av_pop(pTHX_ register AV *av)
607 {
608     dVAR;
609     SV *retval;
610     MAGIC* mg;
611
612     PERL_ARGS_ASSERT_AV_POP;
613     assert(SvTYPE(av) == SVt_PVAV);
614
615     if (SvREADONLY(av))
616         Perl_croak_no_modify(aTHX);
617     if ((mg = SvTIED_mg((const SV *)av, PERL_MAGIC_tied))) {
618         retval = Perl_magic_methcall(aTHX_ MUTABLE_SV(av), mg, "POP", 0, 0);
619         if (retval)
620             retval = newSVsv(retval);
621         return retval;
622     }
623     if (AvFILL(av) < 0)
624         return &PL_sv_undef;
625     retval = AvARRAY(av)[AvFILLp(av)];
626     AvARRAY(av)[AvFILLp(av)--] = &PL_sv_undef;
627     if (SvSMAGICAL(av))
628         mg_set(MUTABLE_SV(av));
629     return retval;
630 }
631
632 /*
633
634 =for apidoc av_create_and_unshift_one
635
636 Unshifts an SV onto the beginning of the array, creating the array if
637 necessary.
638 A small internal helper function to remove a commonly duplicated idiom.
639
640 =cut
641 */
642
643 SV **
644 Perl_av_create_and_unshift_one(pTHX_ AV **const avp, SV *const val)
645 {
646     PERL_ARGS_ASSERT_AV_CREATE_AND_UNSHIFT_ONE;
647
648     if (!*avp)
649         *avp = newAV();
650     av_unshift(*avp, 1);
651     return av_store(*avp, 0, val);
652 }
653
654 /*
655 =for apidoc av_unshift
656
657 Unshift the given number of C<undef> values onto the beginning of the
658 array.  The array will grow automatically to accommodate the addition.  You
659 must then use C<av_store> to assign values to these new elements.
660
661 Perl equivalent: C<unshift @myarray, ( (undef) x $n );>
662     
663 =cut
664 */
665
666 void
667 Perl_av_unshift(pTHX_ register AV *av, register I32 num)
668 {
669     dVAR;
670     I32 i;
671     MAGIC* mg;
672
673     PERL_ARGS_ASSERT_AV_UNSHIFT;
674     assert(SvTYPE(av) == SVt_PVAV);
675
676     if (SvREADONLY(av))
677         Perl_croak_no_modify(aTHX);
678
679     if ((mg = SvTIED_mg((const SV *)av, PERL_MAGIC_tied))) {
680         Perl_magic_methcall(aTHX_ MUTABLE_SV(av), mg, "UNSHIFT",
681                             G_DISCARD | G_UNDEF_FILL, num);
682         return;
683     }
684
685     if (num <= 0)
686       return;
687     if (!AvREAL(av) && AvREIFY(av))
688         av_reify(av);
689     i = AvARRAY(av) - AvALLOC(av);
690     if (i) {
691         if (i > num)
692             i = num;
693         num -= i;
694     
695         AvMAX(av) += i;
696         AvFILLp(av) += i;
697         AvARRAY(av) = AvARRAY(av) - i;
698     }
699     if (num) {
700         SV **ary;
701         const I32 i = AvFILLp(av);
702         /* Create extra elements */
703         const I32 slide = i > 0 ? i : 0;
704         num += slide;
705         av_extend(av, i + num);
706         AvFILLp(av) += num;
707         ary = AvARRAY(av);
708         Move(ary, ary + num, i + 1, SV*);
709         do {
710             ary[--num] = &PL_sv_undef;
711         } while (num);
712         /* Make extra elements into a buffer */
713         AvMAX(av) -= slide;
714         AvFILLp(av) -= slide;
715         AvARRAY(av) = AvARRAY(av) + slide;
716     }
717 }
718
719 /*
720 =for apidoc av_shift
721
722 Shifts an SV off the beginning of the
723 array.  Returns C<&PL_sv_undef> if the 
724 array is empty.
725
726 Perl equivalent: C<shift(@myarray);>
727
728 =cut
729 */
730
731 SV *
732 Perl_av_shift(pTHX_ register AV *av)
733 {
734     dVAR;
735     SV *retval;
736     MAGIC* mg;
737
738     PERL_ARGS_ASSERT_AV_SHIFT;
739     assert(SvTYPE(av) == SVt_PVAV);
740
741     if (SvREADONLY(av))
742         Perl_croak_no_modify(aTHX);
743     if ((mg = SvTIED_mg((const SV *)av, PERL_MAGIC_tied))) {
744         retval = Perl_magic_methcall(aTHX_ MUTABLE_SV(av), mg, "SHIFT", 0, 0);
745         if (retval)
746             retval = newSVsv(retval);
747         return retval;
748     }
749     if (AvFILL(av) < 0)
750       return &PL_sv_undef;
751     retval = *AvARRAY(av);
752     if (AvREAL(av))
753         *AvARRAY(av) = &PL_sv_undef;
754     AvARRAY(av) = AvARRAY(av) + 1;
755     AvMAX(av)--;
756     AvFILLp(av)--;
757     if (SvSMAGICAL(av))
758         mg_set(MUTABLE_SV(av));
759     return retval;
760 }
761
762 /*
763 =for apidoc av_len
764
765 Returns the highest index in the array.  The number of elements in the
766 array is C<av_len(av) + 1>.  Returns -1 if the array is empty.
767
768 The Perl equivalent for this is C<$#myarray>.
769
770 =cut
771 */
772
773 I32
774 Perl_av_len(pTHX_ AV *av)
775 {
776     PERL_ARGS_ASSERT_AV_LEN;
777     assert(SvTYPE(av) == SVt_PVAV);
778
779     return AvFILL(av);
780 }
781
782 /*
783 =for apidoc av_fill
784
785 Set the highest index in the array to the given number, equivalent to
786 Perl's C<$#array = $fill;>.
787
788 The number of elements in the an array will be C<fill + 1> after
789 av_fill() returns.  If the array was previously shorter, then the
790 additional elements appended are set to C<PL_sv_undef>.  If the array
791 was longer, then the excess elements are freed.  C<av_fill(av, -1)> is
792 the same as C<av_clear(av)>.
793
794 =cut
795 */
796 void
797 Perl_av_fill(pTHX_ register AV *av, I32 fill)
798 {
799     dVAR;
800     MAGIC *mg;
801
802     PERL_ARGS_ASSERT_AV_FILL;
803     assert(SvTYPE(av) == SVt_PVAV);
804
805     if (fill < 0)
806         fill = -1;
807     if ((mg = SvTIED_mg((const SV *)av, PERL_MAGIC_tied))) {
808         SV *arg1 = sv_newmortal();
809         sv_setiv(arg1, (IV)(fill + 1));
810         Perl_magic_methcall(aTHX_ MUTABLE_SV(av), mg, "STORESIZE", G_DISCARD,
811                             1, arg1);
812         return;
813     }
814     if (fill <= AvMAX(av)) {
815         I32 key = AvFILLp(av);
816         SV** const ary = AvARRAY(av);
817
818         if (AvREAL(av)) {
819             while (key > fill) {
820                 SvREFCNT_dec(ary[key]);
821                 ary[key--] = &PL_sv_undef;
822             }
823         }
824         else {
825             while (key < fill)
826                 ary[++key] = &PL_sv_undef;
827         }
828             
829         AvFILLp(av) = fill;
830         if (SvSMAGICAL(av))
831             mg_set(MUTABLE_SV(av));
832     }
833     else
834         (void)av_store(av,fill,&PL_sv_undef);
835 }
836
837 /*
838 =for apidoc av_delete
839
840 Deletes the element indexed by C<key> from the array, makes the element mortal,
841 and returns it.  If C<flags> equals C<G_DISCARD>, the element is freed and null
842 is returned.  Perl equivalent: C<my $elem = delete($myarray[$idx]);> for the
843 non-C<G_DISCARD> version and a void-context C<delete($myarray[$idx]);> for the
844 C<G_DISCARD> version.
845
846 =cut
847 */
848 SV *
849 Perl_av_delete(pTHX_ AV *av, I32 key, I32 flags)
850 {
851     dVAR;
852     SV *sv;
853
854     PERL_ARGS_ASSERT_AV_DELETE;
855     assert(SvTYPE(av) == SVt_PVAV);
856
857     if (SvREADONLY(av))
858         Perl_croak_no_modify(aTHX);
859
860     if (SvRMAGICAL(av)) {
861         const MAGIC * const tied_magic
862             = mg_find((const SV *)av, PERL_MAGIC_tied);
863         if ((tied_magic || mg_find((const SV *)av, PERL_MAGIC_regdata))) {
864             /* Handle negative array indices 20020222 MJD */
865             SV **svp;
866             if (key < 0) {
867                 unsigned adjust_index = 1;
868                 if (tied_magic) {
869                     SV * const * const negative_indices_glob =
870                         hv_fetch(SvSTASH(SvRV(SvTIED_obj(MUTABLE_SV(av), 
871                                                          tied_magic))), 
872                                  NEGATIVE_INDICES_VAR, 16, 0);
873                     if (negative_indices_glob
874                         && SvTRUE(GvSV(*negative_indices_glob)))
875                         adjust_index = 0;
876                 }
877                 if (adjust_index) {
878                     key += AvFILL(av) + 1;
879                     if (key < 0)
880                         return NULL;
881                 }
882             }
883             svp = av_fetch(av, key, TRUE);
884             if (svp) {
885                 sv = *svp;
886                 mg_clear(sv);
887                 if (mg_find(sv, PERL_MAGIC_tiedelem)) {
888                     sv_unmagic(sv, PERL_MAGIC_tiedelem); /* No longer an element */
889                     return sv;
890                 }
891                 return NULL;
892             }
893         }
894     }
895
896     if (key < 0) {
897         key += AvFILL(av) + 1;
898         if (key < 0)
899             return NULL;
900     }
901
902     if (key > AvFILLp(av))
903         return NULL;
904     else {
905         if (!AvREAL(av) && AvREIFY(av))
906             av_reify(av);
907         sv = AvARRAY(av)[key];
908         if (key == AvFILLp(av)) {
909             AvARRAY(av)[key] = &PL_sv_undef;
910             do {
911                 AvFILLp(av)--;
912             } while (--key >= 0 && AvARRAY(av)[key] == &PL_sv_undef);
913         }
914         else
915             AvARRAY(av)[key] = &PL_sv_undef;
916         if (SvSMAGICAL(av))
917             mg_set(MUTABLE_SV(av));
918     }
919     if (flags & G_DISCARD) {
920         SvREFCNT_dec(sv);
921         sv = NULL;
922     }
923     else if (AvREAL(av))
924         sv = sv_2mortal(sv);
925     return sv;
926 }
927
928 /*
929 =for apidoc av_exists
930
931 Returns true if the element indexed by C<key> has been initialized.
932
933 This relies on the fact that uninitialized array elements are set to
934 C<&PL_sv_undef>.
935
936 Perl equivalent: C<exists($myarray[$key])>.
937
938 =cut
939 */
940 bool
941 Perl_av_exists(pTHX_ AV *av, I32 key)
942 {
943     dVAR;
944     PERL_ARGS_ASSERT_AV_EXISTS;
945     assert(SvTYPE(av) == SVt_PVAV);
946
947     if (SvRMAGICAL(av)) {
948         const MAGIC * const tied_magic
949             = mg_find((const SV *)av, PERL_MAGIC_tied);
950         const MAGIC * const regdata_magic
951             = mg_find((const SV *)av, PERL_MAGIC_regdata);
952         if (tied_magic || regdata_magic) {
953             SV * const sv = sv_newmortal();
954             MAGIC *mg;
955             /* Handle negative array indices 20020222 MJD */
956             if (key < 0) {
957                 unsigned adjust_index = 1;
958                 if (tied_magic) {
959                     SV * const * const negative_indices_glob =
960                         hv_fetch(SvSTASH(SvRV(SvTIED_obj(MUTABLE_SV(av), 
961                                                          tied_magic))), 
962                                  NEGATIVE_INDICES_VAR, 16, 0);
963                     if (negative_indices_glob
964                         && SvTRUE(GvSV(*negative_indices_glob)))
965                         adjust_index = 0;
966                 }
967                 if (adjust_index) {
968                     key += AvFILL(av) + 1;
969                     if (key < 0)
970                         return FALSE;
971                 }
972             }
973
974             if(key >= 0 && regdata_magic) {
975                 if (key <= AvFILL(av))
976                     return TRUE;
977                 else
978                     return FALSE;
979             }
980
981             mg_copy(MUTABLE_SV(av), sv, 0, key);
982             mg = mg_find(sv, PERL_MAGIC_tiedelem);
983             if (mg) {
984                 magic_existspack(sv, mg);
985                 return cBOOL(SvTRUE_nomg(sv));
986             }
987
988         }
989     }
990
991     if (key < 0) {
992         key += AvFILL(av) + 1;
993         if (key < 0)
994             return FALSE;
995     }
996
997     if (key <= AvFILLp(av) && AvARRAY(av)[key] != &PL_sv_undef
998         && AvARRAY(av)[key])
999     {
1000         return TRUE;
1001     }
1002     else
1003         return FALSE;
1004 }
1005
1006 static MAGIC *
1007 S_get_aux_mg(pTHX_ AV *av) {
1008     dVAR;
1009     MAGIC *mg;
1010
1011     PERL_ARGS_ASSERT_GET_AUX_MG;
1012     assert(SvTYPE(av) == SVt_PVAV);
1013
1014     mg = mg_find((const SV *)av, PERL_MAGIC_arylen_p);
1015
1016     if (!mg) {
1017         mg = sv_magicext(MUTABLE_SV(av), 0, PERL_MAGIC_arylen_p,
1018                          &PL_vtbl_arylen_p, 0, 0);
1019         assert(mg);
1020         /* sv_magicext won't set this for us because we pass in a NULL obj  */
1021         mg->mg_flags |= MGf_REFCOUNTED;
1022     }
1023     return mg;
1024 }
1025
1026 SV **
1027 Perl_av_arylen_p(pTHX_ AV *av) {
1028     MAGIC *const mg = get_aux_mg(av);
1029
1030     PERL_ARGS_ASSERT_AV_ARYLEN_P;
1031     assert(SvTYPE(av) == SVt_PVAV);
1032
1033     return &(mg->mg_obj);
1034 }
1035
1036 IV *
1037 Perl_av_iter_p(pTHX_ AV *av) {
1038     MAGIC *const mg = get_aux_mg(av);
1039
1040     PERL_ARGS_ASSERT_AV_ITER_P;
1041     assert(SvTYPE(av) == SVt_PVAV);
1042
1043 #if IVSIZE == I32SIZE
1044     return (IV *)&(mg->mg_len);
1045 #else
1046     if (!mg->mg_ptr) {
1047         IV *temp;
1048         mg->mg_len = IVSIZE;
1049         Newxz(temp, 1, IV);
1050         mg->mg_ptr = (char *) temp;
1051     }
1052     return (IV *)mg->mg_ptr;
1053 #endif
1054 }
1055
1056 /*
1057  * Local variables:
1058  * c-indentation-style: bsd
1059  * c-basic-offset: 4
1060  * indent-tabs-mode: nil
1061  * End:
1062  *
1063  * ex: set ts=8 sts=4 sw=4 et:
1064  */