This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
av_fetch(): remove redundant condition
[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     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[$idx]>.
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     PERL_ARGS_ASSERT_AV_FETCH;
248     assert(SvTYPE(av) == SVt_PVAV);
249
250     if (SvRMAGICAL(av)) {
251         const MAGIC * const tied_magic
252             = mg_find((const SV *)av, PERL_MAGIC_tied);
253         if (tied_magic || mg_find((const SV *)av, PERL_MAGIC_regdata)) {
254             SV *sv;
255             if (key < 0) {
256                 if (!S_adjust_index(aTHX_ av, tied_magic, &key))
257                         return NULL;
258             }
259
260             sv = sv_newmortal();
261             sv_upgrade(sv, SVt_PVLV);
262             mg_copy(MUTABLE_SV(av), sv, 0, key);
263             if (!tied_magic) /* for regdata, force leavesub to make copies */
264                 SvTEMP_off(sv);
265             LvTYPE(sv) = 't';
266             LvTARG(sv) = sv; /* fake (SV**) */
267             return &(LvTARG(sv));
268         }
269     }
270
271     if (key < 0) {
272         key += AvFILL(av) + 1;
273         if (key < 0)
274             return NULL;
275     }
276
277     if (key > AvFILLp(av) || !AvARRAY(av)[key]) {
278       emptyness:
279         return lval ? av_store(av,key,newSV(0)) : NULL;
280     }
281
282     if (AvREIFY(av) && SvIS_FREED(AvARRAY(av)[key])) {
283         /* eg. @_ could have freed elts */
284         AvARRAY(av)[key] = NULL;        /* 1/2 reify */
285         goto emptyness;
286     }
287     return &AvARRAY(av)[key];
288 }
289
290 /*
291 =for apidoc av_store
292
293 Stores an SV in an array.  The array index is specified as C<key>.  The
294 return value will be C<NULL> if the operation failed or if the value did not
295 need to be actually stored within the array (as in the case of tied
296 arrays).  Otherwise, it can be dereferenced
297 to get the C<SV*> that was stored
298 there (= C<val>)).
299
300 Note that the caller is responsible for suitably incrementing the reference
301 count of C<val> before the call, and decrementing it if the function
302 returned C<NULL>.
303
304 Approximate Perl equivalent: C<$myarray[$key] = $val;>.
305
306 See L<perlguts/"Understanding the Magic of Tied Hashes and Arrays"> for
307 more information on how to use this function on tied arrays.
308
309 =cut
310 */
311
312 SV**
313 Perl_av_store(pTHX_ AV *av, SSize_t key, SV *val)
314 {
315     SV** ary;
316
317     PERL_ARGS_ASSERT_AV_STORE;
318     assert(SvTYPE(av) == SVt_PVAV);
319
320     /* S_regclass relies on being able to pass in a NULL sv
321        (unicode_alternate may be NULL).
322     */
323
324     if (SvRMAGICAL(av)) {
325         const MAGIC * const tied_magic = mg_find((const SV *)av, PERL_MAGIC_tied);
326         if (tied_magic) {
327             if (key < 0) {
328                 if (!S_adjust_index(aTHX_ av, tied_magic, &key))
329                         return 0;
330             }
331             if (val) {
332                 mg_copy(MUTABLE_SV(av), val, 0, key);
333             }
334             return NULL;
335         }
336     }
337
338
339     if (key < 0) {
340         key += AvFILL(av) + 1;
341         if (key < 0)
342             return NULL;
343     }
344
345     if (SvREADONLY(av) && key >= AvFILL(av))
346         Perl_croak_no_modify();
347
348     if (!AvREAL(av) && AvREIFY(av))
349         av_reify(av);
350     if (key > AvMAX(av))
351         av_extend(av,key);
352     ary = AvARRAY(av);
353     if (AvFILLp(av) < key) {
354         if (!AvREAL(av)) {
355             if (av == PL_curstack && key > PL_stack_sp - PL_stack_base)
356                 PL_stack_sp = PL_stack_base + key;      /* XPUSH in disguise */
357             do {
358                 ary[++AvFILLp(av)] = NULL;
359             } while (AvFILLp(av) < key);
360         }
361         AvFILLp(av) = key;
362     }
363     else if (AvREAL(av))
364         SvREFCNT_dec(ary[key]);
365     ary[key] = val;
366     if (SvSMAGICAL(av)) {
367         const MAGIC *mg = SvMAGIC(av);
368         bool set = TRUE;
369         for (; mg; mg = mg->mg_moremagic) {
370           if (!isUPPER(mg->mg_type)) continue;
371           if (val) {
372             sv_magic(val, MUTABLE_SV(av), toLOWER(mg->mg_type), 0, key);
373           }
374           if (PL_delaymagic && mg->mg_type == PERL_MAGIC_isa) {
375             PL_delaymagic |= DM_ARRAY_ISA;
376             set = FALSE;
377           }
378         }
379         if (set)
380            mg_set(MUTABLE_SV(av));
381     }
382     return &ary[key];
383 }
384
385 /*
386 =for apidoc av_make
387
388 Creates a new AV and populates it with a list of SVs.  The SVs are copied
389 into the array, so they may be freed after the call to C<av_make>.  The new AV
390 will have a reference count of 1.
391
392 Perl equivalent: C<my @new_array = ($scalar1, $scalar2, $scalar3...);>
393
394 =cut
395 */
396
397 AV *
398 Perl_av_make(pTHX_ SSize_t size, SV **strp)
399 {
400     AV * const av = MUTABLE_AV(newSV_type(SVt_PVAV));
401     /* sv_upgrade does AvREAL_only()  */
402     PERL_ARGS_ASSERT_AV_MAKE;
403     assert(SvTYPE(av) == SVt_PVAV);
404
405     if (size) {         /* "defined" was returning undef for size==0 anyway. */
406         SV** ary;
407         SSize_t i;
408         Newx(ary,size,SV*);
409         AvALLOC(av) = ary;
410         AvARRAY(av) = ary;
411         AvMAX(av) = size - 1;
412         AvFILLp(av) = -1;
413         ENTER;
414         SAVEFREESV(av);
415         for (i = 0; i < size; i++) {
416             assert (*strp);
417
418             /* Don't let sv_setsv swipe, since our source array might
419                have multiple references to the same temp scalar (e.g.
420                from a list slice) */
421
422             SvGETMAGIC(*strp); /* before newSV, in case it dies */
423             AvFILLp(av)++;
424             ary[i] = newSV(0);
425             sv_setsv_flags(ary[i], *strp,
426                            SV_DO_COW_SVSETSV|SV_NOSTEAL);
427             strp++;
428         }
429         SvREFCNT_inc_simple_void_NN(av);
430         LEAVE;
431     }
432     return av;
433 }
434
435 /*
436 =for apidoc av_clear
437
438 Frees the all the elements of an array, leaving it empty.
439 The XS equivalent of C<@array = ()>.  See also L</av_undef>.
440
441 Note that it is possible that the actions of a destructor called directly
442 or indirectly by freeing an element of the array could cause the reference
443 count of the array itself to be reduced (e.g. by deleting an entry in the
444 symbol table). So it is a possibility that the AV could have been freed
445 (or even reallocated) on return from the call unless you hold a reference
446 to it.
447
448 =cut
449 */
450
451 void
452 Perl_av_clear(pTHX_ AV *av)
453 {
454     SSize_t extra;
455     bool real;
456
457     PERL_ARGS_ASSERT_AV_CLEAR;
458     assert(SvTYPE(av) == SVt_PVAV);
459
460 #ifdef DEBUGGING
461     if (SvREFCNT(av) == 0) {
462         Perl_ck_warner_d(aTHX_ packWARN(WARN_DEBUGGING), "Attempt to clear deleted array");
463     }
464 #endif
465
466     if (SvREADONLY(av))
467         Perl_croak_no_modify();
468
469     /* Give any tie a chance to cleanup first */
470     if (SvRMAGICAL(av)) {
471         const MAGIC* const mg = SvMAGIC(av);
472         if (PL_delaymagic && mg && mg->mg_type == PERL_MAGIC_isa)
473             PL_delaymagic |= DM_ARRAY_ISA;
474         else
475             mg_clear(MUTABLE_SV(av)); 
476     }
477
478     if (AvMAX(av) < 0)
479         return;
480
481     if ((real = !!AvREAL(av))) {
482         SV** const ary = AvARRAY(av);
483         SSize_t index = AvFILLp(av) + 1;
484         ENTER;
485         SAVEFREESV(SvREFCNT_inc_simple_NN(av));
486         while (index) {
487             SV * const sv = ary[--index];
488             /* undef the slot before freeing the value, because a
489              * destructor might try to modify this array */
490             ary[index] = NULL;
491             SvREFCNT_dec(sv);
492         }
493     }
494     extra = AvARRAY(av) - AvALLOC(av);
495     if (extra) {
496         AvMAX(av) += extra;
497         AvARRAY(av) = AvALLOC(av);
498     }
499     AvFILLp(av) = -1;
500     if (real) LEAVE;
501 }
502
503 /*
504 =for apidoc av_undef
505
506 Undefines the array. The XS equivalent of C<undef(@array)>.
507
508 As well as freeing all the elements of the array (like C<av_clear()>), this
509 also frees the memory used by the av to store its list of scalars.
510
511 See L</av_clear> for a note about the array possibly being invalid on
512 return.
513
514 =cut
515 */
516
517 void
518 Perl_av_undef(pTHX_ AV *av)
519 {
520     bool real;
521
522     PERL_ARGS_ASSERT_AV_UNDEF;
523     assert(SvTYPE(av) == SVt_PVAV);
524
525     /* Give any tie a chance to cleanup first */
526     if (SvTIED_mg((const SV *)av, PERL_MAGIC_tied)) 
527         av_fill(av, -1);
528
529     if ((real = !!AvREAL(av))) {
530         SSize_t key = AvFILLp(av) + 1;
531         ENTER;
532         SAVEFREESV(SvREFCNT_inc_simple_NN(av));
533         while (key)
534             SvREFCNT_dec(AvARRAY(av)[--key]);
535     }
536
537     Safefree(AvALLOC(av));
538     AvALLOC(av) = NULL;
539     AvARRAY(av) = NULL;
540     AvMAX(av) = AvFILLp(av) = -1;
541
542     if(SvRMAGICAL(av)) mg_clear(MUTABLE_SV(av));
543     if(real) LEAVE;
544 }
545
546 /*
547
548 =for apidoc av_create_and_push
549
550 Push an SV onto the end of the array, creating the array if necessary.
551 A small internal helper function to remove a commonly duplicated idiom.
552
553 =cut
554 */
555
556 void
557 Perl_av_create_and_push(pTHX_ AV **const avp, SV *const val)
558 {
559     PERL_ARGS_ASSERT_AV_CREATE_AND_PUSH;
560
561     if (!*avp)
562         *avp = newAV();
563     av_push(*avp, val);
564 }
565
566 /*
567 =for apidoc av_push
568
569 Pushes an SV (transferring control of one reference count) onto the end of the
570 array.  The array will grow automatically to accommodate the addition.
571
572 Perl equivalent: C<push @myarray, $elem;>.
573
574 =cut
575 */
576
577 void
578 Perl_av_push(pTHX_ AV *av, SV *val)
579 {             
580     MAGIC *mg;
581
582     PERL_ARGS_ASSERT_AV_PUSH;
583     assert(SvTYPE(av) == SVt_PVAV);
584
585     if (SvREADONLY(av))
586         Perl_croak_no_modify();
587
588     if ((mg = SvTIED_mg((const SV *)av, PERL_MAGIC_tied))) {
589         Perl_magic_methcall(aTHX_ MUTABLE_SV(av), mg, SV_CONST(PUSH), G_DISCARD, 1,
590                             val);
591         return;
592     }
593     av_store(av,AvFILLp(av)+1,val);
594 }
595
596 /*
597 =for apidoc av_pop
598
599 Removes one SV from the end of the array, reducing its size by one and
600 returning the SV (transferring control of one reference count) to the
601 caller.  Returns C<&PL_sv_undef> if the array is empty.
602
603 Perl equivalent: C<pop(@myarray);>
604
605 =cut
606 */
607
608 SV *
609 Perl_av_pop(pTHX_ AV *av)
610 {
611     SV *retval;
612     MAGIC* mg;
613
614     PERL_ARGS_ASSERT_AV_POP;
615     assert(SvTYPE(av) == SVt_PVAV);
616
617     if (SvREADONLY(av))
618         Perl_croak_no_modify();
619     if ((mg = SvTIED_mg((const SV *)av, PERL_MAGIC_tied))) {
620         retval = Perl_magic_methcall(aTHX_ MUTABLE_SV(av), mg, SV_CONST(POP), 0, 0);
621         if (retval)
622             retval = newSVsv(retval);
623         return retval;
624     }
625     if (AvFILL(av) < 0)
626         return &PL_sv_undef;
627     retval = AvARRAY(av)[AvFILLp(av)];
628     AvARRAY(av)[AvFILLp(av)--] = NULL;
629     if (SvSMAGICAL(av))
630         mg_set(MUTABLE_SV(av));
631     return retval ? retval : &PL_sv_undef;
632 }
633
634 /*
635
636 =for apidoc av_create_and_unshift_one
637
638 Unshifts an SV onto the beginning of the array, creating the array if
639 necessary.
640 A small internal helper function to remove a commonly duplicated idiom.
641
642 =cut
643 */
644
645 SV **
646 Perl_av_create_and_unshift_one(pTHX_ AV **const avp, SV *const val)
647 {
648     PERL_ARGS_ASSERT_AV_CREATE_AND_UNSHIFT_ONE;
649
650     if (!*avp)
651         *avp = newAV();
652     av_unshift(*avp, 1);
653     return av_store(*avp, 0, val);
654 }
655
656 /*
657 =for apidoc av_unshift
658
659 Unshift the given number of C<undef> values onto the beginning of the
660 array.  The array will grow automatically to accommodate the addition.  You
661 must then use C<av_store> to assign values to these new elements.
662
663 Perl equivalent: S<C<unshift @myarray, ( (undef) x $n );>>
664
665 =cut
666 */
667
668 void
669 Perl_av_unshift(pTHX_ AV *av, SSize_t num)
670 {
671     SSize_t i;
672     MAGIC* mg;
673
674     PERL_ARGS_ASSERT_AV_UNSHIFT;
675     assert(SvTYPE(av) == SVt_PVAV);
676
677     if (SvREADONLY(av))
678         Perl_croak_no_modify();
679
680     if ((mg = SvTIED_mg((const SV *)av, PERL_MAGIC_tied))) {
681         Perl_magic_methcall(aTHX_ MUTABLE_SV(av), mg, SV_CONST(UNSHIFT),
682                             G_DISCARD | G_UNDEF_FILL, num);
683         return;
684     }
685
686     if (num <= 0)
687       return;
688     if (!AvREAL(av) && AvREIFY(av))
689         av_reify(av);
690     i = AvARRAY(av) - AvALLOC(av);
691     if (i) {
692         if (i > num)
693             i = num;
694         num -= i;
695     
696         AvMAX(av) += i;
697         AvFILLp(av) += i;
698         AvARRAY(av) = AvARRAY(av) - i;
699     }
700     if (num) {
701         SV **ary;
702         const SSize_t i = AvFILLp(av);
703         /* Create extra elements */
704         const SSize_t slide = i > 0 ? i : 0;
705         num += slide;
706         av_extend(av, i + num);
707         AvFILLp(av) += num;
708         ary = AvARRAY(av);
709         Move(ary, ary + num, i + 1, SV*);
710         do {
711             ary[--num] = NULL;
712         } while (num);
713         /* Make extra elements into a buffer */
714         AvMAX(av) -= slide;
715         AvFILLp(av) -= slide;
716         AvARRAY(av) = AvARRAY(av) + slide;
717     }
718 }
719
720 /*
721 =for apidoc av_shift
722
723 Removes one SV from the start of the array, reducing its size by one and
724 returning the SV (transferring control of one reference count) to the
725 caller.  Returns C<&PL_sv_undef> if the array is empty.
726
727 Perl equivalent: C<shift(@myarray);>
728
729 =cut
730 */
731
732 SV *
733 Perl_av_shift(pTHX_ AV *av)
734 {
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();
743     if ((mg = SvTIED_mg((const SV *)av, PERL_MAGIC_tied))) {
744         retval = Perl_magic_methcall(aTHX_ MUTABLE_SV(av), mg, SV_CONST(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) = NULL;
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 ? retval : &PL_sv_undef;
760 }
761
762 /*
763 =for apidoc av_top_index
764
765 Returns the highest index in the array.  The number of elements in the
766 array is S<C<av_top_index(av) + 1>>.  Returns -1 if the array is empty.
767
768 The Perl equivalent for this is C<$#myarray>.
769
770 (A slightly shorter form is C<av_tindex>.)
771
772 =for apidoc av_len
773
774 Same as L</av_top_index>.  Note that, unlike what the name implies, it returns
775 the highest index in the array, so to get the size of the array you need to use
776 S<C<av_len(av) + 1>>.  This is unlike L</sv_len>, which returns what you would
777 expect.
778
779 =cut
780 */
781
782 SSize_t
783 Perl_av_len(pTHX_ AV *av)
784 {
785     PERL_ARGS_ASSERT_AV_LEN;
786
787     return av_top_index(av);
788 }
789
790 /*
791 =for apidoc av_fill
792
793 Set the highest index in the array to the given number, equivalent to
794 Perl's S<C<$#array = $fill;>>.
795
796 The number of elements in the array will be S<C<fill + 1>> after
797 C<av_fill()> returns.  If the array was previously shorter, then the
798 additional elements appended are set to NULL.  If the array
799 was longer, then the excess elements are freed.  S<C<av_fill(av, -1)>> is
800 the same as C<av_clear(av)>.
801
802 =cut
803 */
804 void
805 Perl_av_fill(pTHX_ AV *av, SSize_t fill)
806 {
807     MAGIC *mg;
808
809     PERL_ARGS_ASSERT_AV_FILL;
810     assert(SvTYPE(av) == SVt_PVAV);
811
812     if (fill < 0)
813         fill = -1;
814     if ((mg = SvTIED_mg((const SV *)av, PERL_MAGIC_tied))) {
815         SV *arg1 = sv_newmortal();
816         sv_setiv(arg1, (IV)(fill + 1));
817         Perl_magic_methcall(aTHX_ MUTABLE_SV(av), mg, SV_CONST(STORESIZE), G_DISCARD,
818                             1, arg1);
819         return;
820     }
821     if (fill <= AvMAX(av)) {
822         SSize_t key = AvFILLp(av);
823         SV** const ary = AvARRAY(av);
824
825         if (AvREAL(av)) {
826             while (key > fill) {
827                 SvREFCNT_dec(ary[key]);
828                 ary[key--] = NULL;
829             }
830         }
831         else {
832             while (key < fill)
833                 ary[++key] = NULL;
834         }
835             
836         AvFILLp(av) = fill;
837         if (SvSMAGICAL(av))
838             mg_set(MUTABLE_SV(av));
839     }
840     else
841         (void)av_store(av,fill,NULL);
842 }
843
844 /*
845 =for apidoc av_delete
846
847 Deletes the element indexed by C<key> from the array, makes the element mortal,
848 and returns it.  If C<flags> equals C<G_DISCARD>, the element is freed and null
849 is returned.  Perl equivalent: S<C<my $elem = delete($myarray[$idx]);>> for the
850 non-C<G_DISCARD> version and a void-context S<C<delete($myarray[$idx]);>> for the
851 C<G_DISCARD> version.
852
853 =cut
854 */
855 SV *
856 Perl_av_delete(pTHX_ AV *av, SSize_t key, I32 flags)
857 {
858     SV *sv;
859
860     PERL_ARGS_ASSERT_AV_DELETE;
861     assert(SvTYPE(av) == SVt_PVAV);
862
863     if (SvREADONLY(av))
864         Perl_croak_no_modify();
865
866     if (SvRMAGICAL(av)) {
867         const MAGIC * const tied_magic
868             = mg_find((const SV *)av, PERL_MAGIC_tied);
869         if ((tied_magic || mg_find((const SV *)av, PERL_MAGIC_regdata))) {
870             SV **svp;
871             if (key < 0) {
872                 if (!S_adjust_index(aTHX_ av, tied_magic, &key))
873                         return NULL;
874             }
875             svp = av_fetch(av, key, TRUE);
876             if (svp) {
877                 sv = *svp;
878                 mg_clear(sv);
879                 if (mg_find(sv, PERL_MAGIC_tiedelem)) {
880                     sv_unmagic(sv, PERL_MAGIC_tiedelem); /* No longer an element */
881                     return sv;
882                 }
883                 return NULL;
884             }
885         }
886     }
887
888     if (key < 0) {
889         key += AvFILL(av) + 1;
890         if (key < 0)
891             return NULL;
892     }
893
894     if (key > AvFILLp(av))
895         return NULL;
896     else {
897         if (!AvREAL(av) && AvREIFY(av))
898             av_reify(av);
899         sv = AvARRAY(av)[key];
900         AvARRAY(av)[key] = NULL;
901         if (key == AvFILLp(av)) {
902             do {
903                 AvFILLp(av)--;
904             } while (--key >= 0 && !AvARRAY(av)[key]);
905         }
906         if (SvSMAGICAL(av))
907             mg_set(MUTABLE_SV(av));
908     }
909     if(sv != NULL) {
910         if (flags & G_DISCARD) {
911             SvREFCNT_dec_NN(sv);
912             return NULL;
913         }
914         else if (AvREAL(av))
915             sv_2mortal(sv);
916     }
917     return sv;
918 }
919
920 /*
921 =for apidoc av_exists
922
923 Returns true if the element indexed by C<key> has been initialized.
924
925 This relies on the fact that uninitialized array elements are set to
926 C<NULL>.
927
928 Perl equivalent: C<exists($myarray[$key])>.
929
930 =cut
931 */
932 bool
933 Perl_av_exists(pTHX_ AV *av, SSize_t key)
934 {
935     PERL_ARGS_ASSERT_AV_EXISTS;
936     assert(SvTYPE(av) == SVt_PVAV);
937
938     if (SvRMAGICAL(av)) {
939         const MAGIC * const tied_magic
940             = mg_find((const SV *)av, PERL_MAGIC_tied);
941         const MAGIC * const regdata_magic
942             = mg_find((const SV *)av, PERL_MAGIC_regdata);
943         if (tied_magic || regdata_magic) {
944             MAGIC *mg;
945             /* Handle negative array indices 20020222 MJD */
946             if (key < 0) {
947                 if (!S_adjust_index(aTHX_ av, tied_magic, &key))
948                         return FALSE;
949             }
950
951             if(key >= 0 && regdata_magic) {
952                 if (key <= AvFILL(av))
953                     return TRUE;
954                 else
955                     return FALSE;
956             }
957             {
958                 SV * const sv = sv_newmortal();
959                 mg_copy(MUTABLE_SV(av), sv, 0, key);
960                 mg = mg_find(sv, PERL_MAGIC_tiedelem);
961                 if (mg) {
962                     magic_existspack(sv, mg);
963                     {
964                         I32 retbool = SvTRUE_nomg_NN(sv);
965                         return cBOOL(retbool);
966                     }
967                 }
968             }
969         }
970     }
971
972     if (key < 0) {
973         key += AvFILL(av) + 1;
974         if (key < 0)
975             return FALSE;
976     }
977
978     if (key <= AvFILLp(av) && AvARRAY(av)[key])
979     {
980         return TRUE;
981     }
982     else
983         return FALSE;
984 }
985
986 static MAGIC *
987 S_get_aux_mg(pTHX_ AV *av) {
988     MAGIC *mg;
989
990     PERL_ARGS_ASSERT_GET_AUX_MG;
991     assert(SvTYPE(av) == SVt_PVAV);
992
993     mg = mg_find((const SV *)av, PERL_MAGIC_arylen_p);
994
995     if (!mg) {
996         mg = sv_magicext(MUTABLE_SV(av), 0, PERL_MAGIC_arylen_p,
997                          &PL_vtbl_arylen_p, 0, 0);
998         assert(mg);
999         /* sv_magicext won't set this for us because we pass in a NULL obj  */
1000         mg->mg_flags |= MGf_REFCOUNTED;
1001     }
1002     return mg;
1003 }
1004
1005 SV **
1006 Perl_av_arylen_p(pTHX_ AV *av) {
1007     MAGIC *const mg = get_aux_mg(av);
1008
1009     PERL_ARGS_ASSERT_AV_ARYLEN_P;
1010     assert(SvTYPE(av) == SVt_PVAV);
1011
1012     return &(mg->mg_obj);
1013 }
1014
1015 IV *
1016 Perl_av_iter_p(pTHX_ AV *av) {
1017     MAGIC *const mg = get_aux_mg(av);
1018
1019     PERL_ARGS_ASSERT_AV_ITER_P;
1020     assert(SvTYPE(av) == SVt_PVAV);
1021
1022 #if IVSIZE == I32SIZE
1023     return (IV *)&(mg->mg_len);
1024 #else
1025     if (!mg->mg_ptr) {
1026         IV *temp;
1027         mg->mg_len = IVSIZE;
1028         Newxz(temp, 1, IV);
1029         mg->mg_ptr = (char *) temp;
1030     }
1031     return (IV *)mg->mg_ptr;
1032 #endif
1033 }
1034
1035 /*
1036  * ex: set ts=8 sts=4 sw=4 et:
1037  */