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