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