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