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