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