Minor hints/linux.sh patch to allow setting -Doptimize
[perl.git] / av.c
1 /*    av.c
2  *
3  *    Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
4  *    2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, by Larry Wall and others
5  *
6  *    You may distribute under the terms of either the GNU General Public
7  *    License or the Artistic License, as specified in the README file.
8  *
9  */
10
11 /*
12  * "...for the Entwives desired order, and plenty, and peace (by which they
13  * meant that things should remain where they had set them)." --Treebeard
14  */
15
16 /*
17 =head1 Array Manipulation Functions
18 */
19
20 #include "EXTERN.h"
21 #define PERL_IN_AV_C
22 #include "perl.h"
23
24 void
25 Perl_av_reify(pTHX_ AV *av)
26 {
27     dVAR;
28     I32 key;
29
30     PERL_ARGS_ASSERT_AV_REIFY;
31     assert(SvTYPE(av) == SVt_PVAV);
32
33     if (AvREAL(av))
34         return;
35 #ifdef DEBUGGING
36     if (SvTIED_mg((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((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((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 = mg_find((SV*)av, PERL_MAGIC_tied);
219         if (tied_magic || mg_find((SV*)av, PERL_MAGIC_regdata)) {
220             SV *sv;
221             if (key < 0) {
222                 I32 adjust_index = 1;
223                 if (tied_magic) {
224                     /* Handle negative array indices 20020222 MJD */
225                     SV * const * const negative_indices_glob =
226                         hv_fetch(SvSTASH(SvRV(SvTIED_obj((SV *)av, tied_magic))),
227                                 NEGATIVE_INDICES_VAR, 16, 0);
228
229                     if (negative_indices_glob && SvTRUE(GvSV(*negative_indices_glob)))
230                         adjust_index = 0;
231                 }
232
233                 if (adjust_index) {
234                     key += AvFILL(av) + 1;
235                     if (key < 0)
236                         return NULL;
237                 }
238             }
239
240             sv = sv_newmortal();
241             sv_upgrade(sv, SVt_PVLV);
242             mg_copy((SV*)av, sv, 0, key);
243             LvTYPE(sv) = 't';
244             LvTARG(sv) = sv; /* fake (SV**) */
245             return &(LvTARG(sv));
246         }
247     }
248
249     if (key < 0) {
250         key += AvFILL(av) + 1;
251         if (key < 0)
252             return NULL;
253     }
254
255     if (key > AvFILLp(av)) {
256         if (!lval)
257             return NULL;
258         return av_store(av,key,newSV(0));
259     }
260     if (AvARRAY(av)[key] == &PL_sv_undef) {
261     emptyness:
262         if (lval)
263             return av_store(av,key,newSV(0));
264         return NULL;
265     }
266     else if (AvREIFY(av)
267              && (!AvARRAY(av)[key]      /* eg. @_ could have freed elts */
268                  || SvIS_FREED(AvARRAY(av)[key]))) {
269         AvARRAY(av)[key] = &PL_sv_undef;        /* 1/2 reify */
270         goto emptyness;
271     }
272     return &AvARRAY(av)[key];
273 }
274
275 /*
276 =for apidoc av_store
277
278 Stores an SV in an array.  The array index is specified as C<key>.  The
279 return value will be NULL if the operation failed or if the value did not
280 need to be actually stored within the array (as in the case of tied
281 arrays). Otherwise it can be dereferenced to get the original C<SV*>.  Note
282 that the caller is responsible for suitably incrementing the reference
283 count of C<val> before the call, and decrementing it if the function
284 returned NULL.
285
286 See L<perlguts/"Understanding the Magic of Tied Hashes and Arrays"> for
287 more information on how to use this function on tied arrays.
288
289 =cut
290 */
291
292 SV**
293 Perl_av_store(pTHX_ register AV *av, I32 key, SV *val)
294 {
295     dVAR;
296     SV** ary;
297
298     PERL_ARGS_ASSERT_AV_STORE;
299     assert(SvTYPE(av) == SVt_PVAV);
300
301     /* S_regclass relies on being able to pass in a NULL sv
302        (unicode_alternate may be NULL).
303     */
304
305     if (!val)
306         val = &PL_sv_undef;
307
308     if (SvRMAGICAL(av)) {
309         const MAGIC * const tied_magic = mg_find((SV*)av, PERL_MAGIC_tied);
310         if (tied_magic) {
311             /* Handle negative array indices 20020222 MJD */
312             if (key < 0) {
313                 bool adjust_index = 1;
314                 SV * const * const negative_indices_glob =
315                     hv_fetch(SvSTASH(SvRV(SvTIED_obj((SV *)av, 
316                                                      tied_magic))), 
317                              NEGATIVE_INDICES_VAR, 16, 0);
318                 if (negative_indices_glob
319                     && SvTRUE(GvSV(*negative_indices_glob)))
320                     adjust_index = 0;
321                 if (adjust_index) {
322                     key += AvFILL(av) + 1;
323                     if (key < 0)
324                         return 0;
325                 }
326             }
327             if (val != &PL_sv_undef) {
328                 mg_copy((SV*)av, val, 0, key);
329             }
330             return NULL;
331         }
332     }
333
334
335     if (key < 0) {
336         key += AvFILL(av) + 1;
337         if (key < 0)
338             return NULL;
339     }
340
341     if (SvREADONLY(av) && key >= AvFILL(av))
342         Perl_croak(aTHX_ PL_no_modify);
343
344     if (!AvREAL(av) && AvREIFY(av))
345         av_reify(av);
346     if (key > AvMAX(av))
347         av_extend(av,key);
348     ary = AvARRAY(av);
349     if (AvFILLp(av) < key) {
350         if (!AvREAL(av)) {
351             if (av == PL_curstack && key > PL_stack_sp - PL_stack_base)
352                 PL_stack_sp = PL_stack_base + key;      /* XPUSH in disguise */
353             do {
354                 ary[++AvFILLp(av)] = &PL_sv_undef;
355             } while (AvFILLp(av) < key);
356         }
357         AvFILLp(av) = key;
358     }
359     else if (AvREAL(av))
360         SvREFCNT_dec(ary[key]);
361     ary[key] = val;
362     if (SvSMAGICAL(av)) {
363         const MAGIC* const mg = SvMAGIC(av);
364         if (val != &PL_sv_undef) {
365             sv_magic(val, (SV*)av, toLOWER(mg->mg_type), 0, key);
366         }
367         if (PL_delaymagic && mg->mg_type == PERL_MAGIC_isa)
368             PL_delaymagic |= DM_ARRAY;
369         else
370            mg_set((SV*)av);
371     }
372     return &ary[key];
373 }
374
375 /*
376 =for apidoc av_make
377
378 Creates a new AV and populates it with a list of SVs.  The SVs are copied
379 into the array, so they may be freed after the call to av_make.  The new AV
380 will have a reference count of 1.
381
382 =cut
383 */
384
385 AV *
386 Perl_av_make(pTHX_ register I32 size, register SV **strp)
387 {
388     register AV * const av = (AV*)newSV_type(SVt_PVAV);
389     /* sv_upgrade does AvREAL_only()  */
390     PERL_ARGS_ASSERT_AV_MAKE;
391     assert(SvTYPE(av) == SVt_PVAV);
392
393     if (size) {         /* "defined" was returning undef for size==0 anyway. */
394         register SV** ary;
395         register I32 i;
396         Newx(ary,size,SV*);
397         AvALLOC(av) = ary;
398         AvARRAY(av) = ary;
399         AvFILLp(av) = AvMAX(av) = size - 1;
400         for (i = 0; i < size; i++) {
401             assert (*strp);
402             ary[i] = newSV(0);
403             sv_setsv(ary[i], *strp);
404             strp++;
405         }
406     }
407     return av;
408 }
409
410 /*
411 =for apidoc av_clear
412
413 Clears an array, making it empty.  Does not free the memory used by the
414 array itself.
415
416 =cut
417 */
418
419 void
420 Perl_av_clear(pTHX_ register AV *av)
421 {
422     dVAR;
423     I32 extra;
424
425     PERL_ARGS_ASSERT_AV_CLEAR;
426     assert(SvTYPE(av) == SVt_PVAV);
427
428 #ifdef DEBUGGING
429     if (SvREFCNT(av) == 0 && ckWARN_d(WARN_DEBUGGING)) {
430         Perl_warner(aTHX_ packWARN(WARN_DEBUGGING), "Attempt to clear deleted array");
431     }
432 #endif
433
434     if (SvREADONLY(av))
435         Perl_croak(aTHX_ PL_no_modify);
436
437     /* Give any tie a chance to cleanup first */
438     if (SvRMAGICAL(av)) {
439         const MAGIC* const mg = SvMAGIC(av);
440         if (PL_delaymagic && mg && mg->mg_type == PERL_MAGIC_isa)
441             PL_delaymagic |= DM_ARRAY;
442         else
443             mg_clear((SV*)av); 
444     }
445
446     if (AvMAX(av) < 0)
447         return;
448
449     if (AvREAL(av)) {
450         SV** const ary = AvARRAY(av);
451         I32 index = AvFILLp(av) + 1;
452         while (index) {
453             SV * const sv = ary[--index];
454             /* undef the slot before freeing the value, because a
455              * destructor might try to modify this array */
456             ary[index] = &PL_sv_undef;
457             SvREFCNT_dec(sv);
458         }
459     }
460     extra = AvARRAY(av) - AvALLOC(av);
461     if (extra) {
462         AvMAX(av) += extra;
463         AvARRAY(av) = AvALLOC(av);
464     }
465     AvFILLp(av) = -1;
466
467 }
468
469 /*
470 =for apidoc av_undef
471
472 Undefines the array.  Frees the memory used by the array itself.
473
474 =cut
475 */
476
477 void
478 Perl_av_undef(pTHX_ register AV *av)
479 {
480     PERL_ARGS_ASSERT_AV_UNDEF;
481     assert(SvTYPE(av) == SVt_PVAV);
482
483     /* Give any tie a chance to cleanup first */
484     if (SvTIED_mg((SV*)av, PERL_MAGIC_tied)) 
485         av_fill(av, -1);
486
487     if (AvREAL(av)) {
488         register I32 key = AvFILLp(av) + 1;
489         while (key)
490             SvREFCNT_dec(AvARRAY(av)[--key]);
491     }
492
493     Safefree(AvALLOC(av));
494     AvALLOC(av) = NULL;
495     AvARRAY(av) = NULL;
496     AvMAX(av) = AvFILLp(av) = -1;
497
498     if(SvRMAGICAL(av)) mg_clear((SV*)av);
499 }
500
501 /*
502
503 =for apidoc av_create_and_push
504
505 Push an SV onto the end of the array, creating the array if necessary.
506 A small internal helper function to remove a commonly duplicated idiom.
507
508 =cut
509 */
510
511 void
512 Perl_av_create_and_push(pTHX_ AV **const avp, SV *const val)
513 {
514     PERL_ARGS_ASSERT_AV_CREATE_AND_PUSH;
515
516     if (!*avp)
517         *avp = newAV();
518     av_push(*avp, val);
519 }
520
521 /*
522 =for apidoc av_push
523
524 Pushes an SV onto the end of the array.  The array will grow automatically
525 to accommodate the addition.
526
527 =cut
528 */
529
530 void
531 Perl_av_push(pTHX_ register AV *av, SV *val)
532 {             
533     dVAR;
534     MAGIC *mg;
535
536     PERL_ARGS_ASSERT_AV_PUSH;
537     assert(SvTYPE(av) == SVt_PVAV);
538
539     if (SvREADONLY(av))
540         Perl_croak(aTHX_ PL_no_modify);
541
542     if ((mg = SvTIED_mg((SV*)av, PERL_MAGIC_tied))) {
543         dSP;
544         PUSHSTACKi(PERLSI_MAGIC);
545         PUSHMARK(SP);
546         EXTEND(SP,2);
547         PUSHs(SvTIED_obj((SV*)av, mg));
548         PUSHs(val);
549         PUTBACK;
550         ENTER;
551         call_method("PUSH", G_SCALAR|G_DISCARD);
552         LEAVE;
553         POPSTACK;
554         return;
555     }
556     av_store(av,AvFILLp(av)+1,val);
557 }
558
559 /*
560 =for apidoc av_pop
561
562 Pops an SV off the end of the array.  Returns C<&PL_sv_undef> if the array
563 is empty.
564
565 =cut
566 */
567
568 SV *
569 Perl_av_pop(pTHX_ register AV *av)
570 {
571     dVAR;
572     SV *retval;
573     MAGIC* mg;
574
575     PERL_ARGS_ASSERT_AV_POP;
576     assert(SvTYPE(av) == SVt_PVAV);
577
578     if (SvREADONLY(av))
579         Perl_croak(aTHX_ PL_no_modify);
580     if ((mg = SvTIED_mg((SV*)av, PERL_MAGIC_tied))) {
581         dSP;    
582         PUSHSTACKi(PERLSI_MAGIC);
583         PUSHMARK(SP);
584         XPUSHs(SvTIED_obj((SV*)av, mg));
585         PUTBACK;
586         ENTER;
587         if (call_method("POP", G_SCALAR)) {
588             retval = newSVsv(*PL_stack_sp--);    
589         } else {    
590             retval = &PL_sv_undef;
591         }
592         LEAVE;
593         POPSTACK;
594         return retval;
595     }
596     if (AvFILL(av) < 0)
597         return &PL_sv_undef;
598     retval = AvARRAY(av)[AvFILLp(av)];
599     AvARRAY(av)[AvFILLp(av)--] = &PL_sv_undef;
600     if (SvSMAGICAL(av))
601         mg_set((SV*)av);
602     return retval;
603 }
604
605 /*
606
607 =for apidoc av_create_and_unshift_one
608
609 Unshifts an SV onto the beginning of the array, creating the array if
610 necessary.
611 A small internal helper function to remove a commonly duplicated idiom.
612
613 =cut
614 */
615
616 SV **
617 Perl_av_create_and_unshift_one(pTHX_ AV **const avp, SV *const val)
618 {
619     PERL_ARGS_ASSERT_AV_CREATE_AND_UNSHIFT_ONE;
620
621     if (!*avp)
622         *avp = newAV();
623     av_unshift(*avp, 1);
624     return av_store(*avp, 0, val);
625 }
626
627 /*
628 =for apidoc av_unshift
629
630 Unshift the given number of C<undef> values onto the beginning of the
631 array.  The array will grow automatically to accommodate the addition.  You
632 must then use C<av_store> to assign values to these new elements.
633
634 =cut
635 */
636
637 void
638 Perl_av_unshift(pTHX_ register AV *av, register I32 num)
639 {
640     dVAR;
641     register I32 i;
642     MAGIC* mg;
643
644     PERL_ARGS_ASSERT_AV_UNSHIFT;
645     assert(SvTYPE(av) == SVt_PVAV);
646
647     if (SvREADONLY(av))
648         Perl_croak(aTHX_ PL_no_modify);
649
650     if ((mg = SvTIED_mg((SV*)av, PERL_MAGIC_tied))) {
651         dSP;
652         PUSHSTACKi(PERLSI_MAGIC);
653         PUSHMARK(SP);
654         EXTEND(SP,1+num);
655         PUSHs(SvTIED_obj((SV*)av, mg));
656         while (num-- > 0) {
657             PUSHs(&PL_sv_undef);
658         }
659         PUTBACK;
660         ENTER;
661         call_method("UNSHIFT", G_SCALAR|G_DISCARD);
662         LEAVE;
663         POPSTACK;
664         return;
665     }
666
667     if (num <= 0)
668       return;
669     if (!AvREAL(av) && AvREIFY(av))
670         av_reify(av);
671     i = AvARRAY(av) - AvALLOC(av);
672     if (i) {
673         if (i > num)
674             i = num;
675         num -= i;
676     
677         AvMAX(av) += i;
678         AvFILLp(av) += i;
679         AvARRAY(av) = AvARRAY(av) - i;
680     }
681     if (num) {
682         register SV **ary;
683         const I32 i = AvFILLp(av);
684         /* Create extra elements */
685         const I32 slide = i > 0 ? i : 0;
686         num += slide;
687         av_extend(av, i + num);
688         AvFILLp(av) += num;
689         ary = AvARRAY(av);
690         Move(ary, ary + num, i + 1, SV*);
691         do {
692             ary[--num] = &PL_sv_undef;
693         } while (num);
694         /* Make extra elements into a buffer */
695         AvMAX(av) -= slide;
696         AvFILLp(av) -= slide;
697         AvARRAY(av) = AvARRAY(av) + slide;
698     }
699 }
700
701 /*
702 =for apidoc av_shift
703
704 Shifts an SV off the beginning of the array.
705
706 =cut
707 */
708
709 SV *
710 Perl_av_shift(pTHX_ register AV *av)
711 {
712     dVAR;
713     SV *retval;
714     MAGIC* mg;
715
716     PERL_ARGS_ASSERT_AV_SHIFT;
717     assert(SvTYPE(av) == SVt_PVAV);
718
719     if (SvREADONLY(av))
720         Perl_croak(aTHX_ PL_no_modify);
721     if ((mg = SvTIED_mg((SV*)av, PERL_MAGIC_tied))) {
722         dSP;
723         PUSHSTACKi(PERLSI_MAGIC);
724         PUSHMARK(SP);
725         XPUSHs(SvTIED_obj((SV*)av, mg));
726         PUTBACK;
727         ENTER;
728         if (call_method("SHIFT", G_SCALAR)) {
729             retval = newSVsv(*PL_stack_sp--);            
730         } else {    
731             retval = &PL_sv_undef;
732         }     
733         LEAVE;
734         POPSTACK;
735         return retval;
736     }
737     if (AvFILL(av) < 0)
738       return &PL_sv_undef;
739     retval = *AvARRAY(av);
740     if (AvREAL(av))
741         *AvARRAY(av) = &PL_sv_undef;
742     AvARRAY(av) = AvARRAY(av) + 1;
743     AvMAX(av)--;
744     AvFILLp(av)--;
745     if (SvSMAGICAL(av))
746         mg_set((SV*)av);
747     return retval;
748 }
749
750 /*
751 =for apidoc av_len
752
753 Returns the highest index in the array.  The number of elements in the
754 array is C<av_len(av) + 1>.  Returns -1 if the array is empty.
755
756 =cut
757 */
758
759 I32
760 Perl_av_len(pTHX_ register const AV *av)
761 {
762     PERL_ARGS_ASSERT_AV_LEN;
763     assert(SvTYPE(av) == SVt_PVAV);
764
765     return AvFILL(av);
766 }
767
768 /*
769 =for apidoc av_fill
770
771 Set the highest index in the array to the given number, equivalent to
772 Perl's C<$#array = $fill;>.
773
774 The number of elements in the an array will be C<fill + 1> after
775 av_fill() returns.  If the array was previously shorter then the
776 additional elements appended are set to C<PL_sv_undef>.  If the array
777 was longer, then the excess elements are freed.  C<av_fill(av, -1)> is
778 the same as C<av_clear(av)>.
779
780 =cut
781 */
782 void
783 Perl_av_fill(pTHX_ register AV *av, I32 fill)
784 {
785     dVAR;
786     MAGIC *mg;
787
788     PERL_ARGS_ASSERT_AV_FILL;
789     assert(SvTYPE(av) == SVt_PVAV);
790
791     if (fill < 0)
792         fill = -1;
793     if ((mg = SvTIED_mg((SV*)av, PERL_MAGIC_tied))) {
794         dSP;            
795         ENTER;
796         SAVETMPS;
797         PUSHSTACKi(PERLSI_MAGIC);
798         PUSHMARK(SP);
799         EXTEND(SP,2);
800         PUSHs(SvTIED_obj((SV*)av, mg));
801         mPUSHi(fill + 1);
802         PUTBACK;
803         call_method("STORESIZE", G_SCALAR|G_DISCARD);
804         POPSTACK;
805         FREETMPS;
806         LEAVE;
807         return;
808     }
809     if (fill <= AvMAX(av)) {
810         I32 key = AvFILLp(av);
811         SV** const ary = AvARRAY(av);
812
813         if (AvREAL(av)) {
814             while (key > fill) {
815                 SvREFCNT_dec(ary[key]);
816                 ary[key--] = &PL_sv_undef;
817             }
818         }
819         else {
820             while (key < fill)
821                 ary[++key] = &PL_sv_undef;
822         }
823             
824         AvFILLp(av) = fill;
825         if (SvSMAGICAL(av))
826             mg_set((SV*)av);
827     }
828     else
829         (void)av_store(av,fill,&PL_sv_undef);
830 }
831
832 /*
833 =for apidoc av_delete
834
835 Deletes the element indexed by C<key> from the array.  Returns the
836 deleted element. If C<flags> equals C<G_DISCARD>, the element is freed
837 and null is returned.
838
839 =cut
840 */
841 SV *
842 Perl_av_delete(pTHX_ AV *av, I32 key, I32 flags)
843 {
844     dVAR;
845     SV *sv;
846
847     PERL_ARGS_ASSERT_AV_DELETE;
848     assert(SvTYPE(av) == SVt_PVAV);
849
850     if (SvREADONLY(av))
851         Perl_croak(aTHX_ PL_no_modify);
852
853     if (SvRMAGICAL(av)) {
854         const MAGIC * const tied_magic = mg_find((SV*)av, PERL_MAGIC_tied);
855         if ((tied_magic || mg_find((SV*)av, PERL_MAGIC_regdata))) {
856             /* Handle negative array indices 20020222 MJD */
857             SV **svp;
858             if (key < 0) {
859                 unsigned adjust_index = 1;
860                 if (tied_magic) {
861                     SV * const * const negative_indices_glob =
862                         hv_fetch(SvSTASH(SvRV(SvTIED_obj((SV *)av, 
863                                                          tied_magic))), 
864                                  NEGATIVE_INDICES_VAR, 16, 0);
865                     if (negative_indices_glob
866                         && SvTRUE(GvSV(*negative_indices_glob)))
867                         adjust_index = 0;
868                 }
869                 if (adjust_index) {
870                     key += AvFILL(av) + 1;
871                     if (key < 0)
872                         return NULL;
873                 }
874             }
875             svp = av_fetch(av, key, TRUE);
876             if (svp) {
877                 sv = *svp;
878                 mg_clear(sv);
879                 if (mg_find(sv, PERL_MAGIC_tiedelem)) {
880                     sv_unmagic(sv, PERL_MAGIC_tiedelem); /* No longer an element */
881                     return sv;
882                 }
883                 return NULL;
884             }
885         }
886     }
887
888     if (key < 0) {
889         key += AvFILL(av) + 1;
890         if (key < 0)
891             return NULL;
892     }
893
894     if (key > AvFILLp(av))
895         return NULL;
896     else {
897         if (!AvREAL(av) && AvREIFY(av))
898             av_reify(av);
899         sv = AvARRAY(av)[key];
900         if (key == AvFILLp(av)) {
901             AvARRAY(av)[key] = &PL_sv_undef;
902             do {
903                 AvFILLp(av)--;
904             } while (--key >= 0 && AvARRAY(av)[key] == &PL_sv_undef);
905         }
906         else
907             AvARRAY(av)[key] = &PL_sv_undef;
908         if (SvSMAGICAL(av))
909             mg_set((SV*)av);
910     }
911     if (flags & G_DISCARD) {
912         SvREFCNT_dec(sv);
913         sv = NULL;
914     }
915     else if (AvREAL(av))
916         sv = sv_2mortal(sv);
917     return sv;
918 }
919
920 /*
921 =for apidoc av_exists
922
923 Returns true if the element indexed by C<key> has been initialized.
924
925 This relies on the fact that uninitialized array elements are set to
926 C<&PL_sv_undef>.
927
928 =cut
929 */
930 bool
931 Perl_av_exists(pTHX_ AV *av, I32 key)
932 {
933     dVAR;
934     PERL_ARGS_ASSERT_AV_EXISTS;
935     assert(SvTYPE(av) == SVt_PVAV);
936
937     if (SvRMAGICAL(av)) {
938         const MAGIC * const tied_magic = mg_find((SV*)av, PERL_MAGIC_tied);
939         if (tied_magic || mg_find((SV*)av, PERL_MAGIC_regdata)) {
940             SV * const sv = sv_newmortal();
941             MAGIC *mg;
942             /* Handle negative array indices 20020222 MJD */
943             if (key < 0) {
944                 unsigned adjust_index = 1;
945                 if (tied_magic) {
946                     SV * const * const negative_indices_glob =
947                         hv_fetch(SvSTASH(SvRV(SvTIED_obj((SV *)av, 
948                                                          tied_magic))), 
949                                  NEGATIVE_INDICES_VAR, 16, 0);
950                     if (negative_indices_glob
951                         && SvTRUE(GvSV(*negative_indices_glob)))
952                         adjust_index = 0;
953                 }
954                 if (adjust_index) {
955                     key += AvFILL(av) + 1;
956                     if (key < 0)
957                         return FALSE;
958                 }
959             }
960
961             mg_copy((SV*)av, sv, 0, key);
962             mg = mg_find(sv, PERL_MAGIC_tiedelem);
963             if (mg) {
964                 magic_existspack(sv, mg);
965                 return (bool)SvTRUE(sv);
966             }
967
968         }
969     }
970
971     if (key < 0) {
972         key += AvFILL(av) + 1;
973         if (key < 0)
974             return FALSE;
975     }
976
977     if (key <= AvFILLp(av) && AvARRAY(av)[key] != &PL_sv_undef
978         && AvARRAY(av)[key])
979     {
980         return TRUE;
981     }
982     else
983         return FALSE;
984 }
985
986 MAGIC *
987 S_get_aux_mg(pTHX_ AV *av) {
988     dVAR;
989     MAGIC *mg;
990
991     PERL_ARGS_ASSERT_GET_AUX_MG;
992     assert(SvTYPE(av) == SVt_PVAV);
993
994     mg = mg_find((SV*)av, PERL_MAGIC_arylen_p);
995
996     if (!mg) {
997         mg = sv_magicext((SV*)av, 0, PERL_MAGIC_arylen_p, &PL_vtbl_arylen_p,
998                          0, 0);
999         assert(mg);
1000         /* sv_magicext won't set this for us because we pass in a NULL obj  */
1001         mg->mg_flags |= MGf_REFCOUNTED;
1002     }
1003     return mg;
1004 }
1005
1006 SV **
1007 Perl_av_arylen_p(pTHX_ AV *av) {
1008     MAGIC *const mg = get_aux_mg(av);
1009
1010     PERL_ARGS_ASSERT_AV_ARYLEN_P;
1011     assert(SvTYPE(av) == SVt_PVAV);
1012
1013     return &(mg->mg_obj);
1014 }
1015
1016 IV *
1017 Perl_av_iter_p(pTHX_ AV *av) {
1018     MAGIC *const mg = get_aux_mg(av);
1019
1020     PERL_ARGS_ASSERT_AV_ITER_P;
1021     assert(SvTYPE(av) == SVt_PVAV);
1022
1023 #if IVSIZE == I32SIZE
1024     return (IV *)&(mg->mg_len);
1025 #else
1026     if (!mg->mg_ptr) {
1027         IV *temp;
1028         mg->mg_len = IVSIZE;
1029         Newxz(temp, 1, IV);
1030         mg->mg_ptr = (char *) temp;
1031     }
1032     return (IV *)mg->mg_ptr;
1033 #endif
1034 }
1035
1036 /*
1037  * Local variables:
1038  * c-indentation-style: bsd
1039  * c-basic-offset: 4
1040  * indent-tabs-mode: t
1041  * End:
1042  *
1043  * ex: set ts=8 sts=4 sw=4 noet:
1044  */