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