Fix prototype detection for C++
[p5sagit/p5-mst-13.2.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((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. Returns C<&PL_sv_undef> if the 
705 array is empty.
706
707 =cut
708 */
709
710 SV *
711 Perl_av_shift(pTHX_ register AV *av)
712 {
713     dVAR;
714     SV *retval;
715     MAGIC* mg;
716
717     PERL_ARGS_ASSERT_AV_SHIFT;
718     assert(SvTYPE(av) == SVt_PVAV);
719
720     if (SvREADONLY(av))
721         Perl_croak(aTHX_ PL_no_modify);
722     if ((mg = SvTIED_mg((SV*)av, PERL_MAGIC_tied))) {
723         dSP;
724         PUSHSTACKi(PERLSI_MAGIC);
725         PUSHMARK(SP);
726         XPUSHs(SvTIED_obj((SV*)av, mg));
727         PUTBACK;
728         ENTER;
729         if (call_method("SHIFT", G_SCALAR)) {
730             retval = newSVsv(*PL_stack_sp--);            
731         } else {    
732             retval = &PL_sv_undef;
733         }     
734         LEAVE;
735         POPSTACK;
736         return retval;
737     }
738     if (AvFILL(av) < 0)
739       return &PL_sv_undef;
740     retval = *AvARRAY(av);
741     if (AvREAL(av))
742         *AvARRAY(av) = &PL_sv_undef;
743     AvARRAY(av) = AvARRAY(av) + 1;
744     AvMAX(av)--;
745     AvFILLp(av)--;
746     if (SvSMAGICAL(av))
747         mg_set((SV*)av);
748     return retval;
749 }
750
751 /*
752 =for apidoc av_len
753
754 Returns the highest index in the array.  The number of elements in the
755 array is C<av_len(av) + 1>.  Returns -1 if the array is empty.
756
757 =cut
758 */
759
760 I32
761 Perl_av_len(pTHX_ register const AV *av)
762 {
763     PERL_ARGS_ASSERT_AV_LEN;
764     assert(SvTYPE(av) == SVt_PVAV);
765
766     return AvFILL(av);
767 }
768
769 /*
770 =for apidoc av_fill
771
772 Set the highest index in the array to the given number, equivalent to
773 Perl's C<$#array = $fill;>.
774
775 The number of elements in the an array will be C<fill + 1> after
776 av_fill() returns.  If the array was previously shorter then the
777 additional elements appended are set to C<PL_sv_undef>.  If the array
778 was longer, then the excess elements are freed.  C<av_fill(av, -1)> is
779 the same as C<av_clear(av)>.
780
781 =cut
782 */
783 void
784 Perl_av_fill(pTHX_ register AV *av, I32 fill)
785 {
786     dVAR;
787     MAGIC *mg;
788
789     PERL_ARGS_ASSERT_AV_FILL;
790     assert(SvTYPE(av) == SVt_PVAV);
791
792     if (fill < 0)
793         fill = -1;
794     if ((mg = SvTIED_mg((SV*)av, PERL_MAGIC_tied))) {
795         dSP;            
796         ENTER;
797         SAVETMPS;
798         PUSHSTACKi(PERLSI_MAGIC);
799         PUSHMARK(SP);
800         EXTEND(SP,2);
801         PUSHs(SvTIED_obj((SV*)av, mg));
802         mPUSHi(fill + 1);
803         PUTBACK;
804         call_method("STORESIZE", G_SCALAR|G_DISCARD);
805         POPSTACK;
806         FREETMPS;
807         LEAVE;
808         return;
809     }
810     if (fill <= AvMAX(av)) {
811         I32 key = AvFILLp(av);
812         SV** const ary = AvARRAY(av);
813
814         if (AvREAL(av)) {
815             while (key > fill) {
816                 SvREFCNT_dec(ary[key]);
817                 ary[key--] = &PL_sv_undef;
818             }
819         }
820         else {
821             while (key < fill)
822                 ary[++key] = &PL_sv_undef;
823         }
824             
825         AvFILLp(av) = fill;
826         if (SvSMAGICAL(av))
827             mg_set((SV*)av);
828     }
829     else
830         (void)av_store(av,fill,&PL_sv_undef);
831 }
832
833 /*
834 =for apidoc av_delete
835
836 Deletes the element indexed by C<key> from the array.  Returns the
837 deleted element. If C<flags> equals C<G_DISCARD>, the element is freed
838 and null is returned.
839
840 =cut
841 */
842 SV *
843 Perl_av_delete(pTHX_ AV *av, I32 key, I32 flags)
844 {
845     dVAR;
846     SV *sv;
847
848     PERL_ARGS_ASSERT_AV_DELETE;
849     assert(SvTYPE(av) == SVt_PVAV);
850
851     if (SvREADONLY(av))
852         Perl_croak(aTHX_ PL_no_modify);
853
854     if (SvRMAGICAL(av)) {
855         const MAGIC * const tied_magic = mg_find((SV*)av, PERL_MAGIC_tied);
856         if ((tied_magic || mg_find((SV*)av, PERL_MAGIC_regdata))) {
857             /* Handle negative array indices 20020222 MJD */
858             SV **svp;
859             if (key < 0) {
860                 unsigned adjust_index = 1;
861                 if (tied_magic) {
862                     SV * const * const negative_indices_glob =
863                         hv_fetch(SvSTASH(SvRV(SvTIED_obj((SV *)av, 
864                                                          tied_magic))), 
865                                  NEGATIVE_INDICES_VAR, 16, 0);
866                     if (negative_indices_glob
867                         && SvTRUE(GvSV(*negative_indices_glob)))
868                         adjust_index = 0;
869                 }
870                 if (adjust_index) {
871                     key += AvFILL(av) + 1;
872                     if (key < 0)
873                         return NULL;
874                 }
875             }
876             svp = av_fetch(av, key, TRUE);
877             if (svp) {
878                 sv = *svp;
879                 mg_clear(sv);
880                 if (mg_find(sv, PERL_MAGIC_tiedelem)) {
881                     sv_unmagic(sv, PERL_MAGIC_tiedelem); /* No longer an element */
882                     return sv;
883                 }
884                 return NULL;
885             }
886         }
887     }
888
889     if (key < 0) {
890         key += AvFILL(av) + 1;
891         if (key < 0)
892             return NULL;
893     }
894
895     if (key > AvFILLp(av))
896         return NULL;
897     else {
898         if (!AvREAL(av) && AvREIFY(av))
899             av_reify(av);
900         sv = AvARRAY(av)[key];
901         if (key == AvFILLp(av)) {
902             AvARRAY(av)[key] = &PL_sv_undef;
903             do {
904                 AvFILLp(av)--;
905             } while (--key >= 0 && AvARRAY(av)[key] == &PL_sv_undef);
906         }
907         else
908             AvARRAY(av)[key] = &PL_sv_undef;
909         if (SvSMAGICAL(av))
910             mg_set((SV*)av);
911     }
912     if (flags & G_DISCARD) {
913         SvREFCNT_dec(sv);
914         sv = NULL;
915     }
916     else if (AvREAL(av))
917         sv = sv_2mortal(sv);
918     return sv;
919 }
920
921 /*
922 =for apidoc av_exists
923
924 Returns true if the element indexed by C<key> has been initialized.
925
926 This relies on the fact that uninitialized array elements are set to
927 C<&PL_sv_undef>.
928
929 =cut
930 */
931 bool
932 Perl_av_exists(pTHX_ AV *av, I32 key)
933 {
934     dVAR;
935     PERL_ARGS_ASSERT_AV_EXISTS;
936     assert(SvTYPE(av) == SVt_PVAV);
937
938     if (SvRMAGICAL(av)) {
939         const MAGIC * const tied_magic = mg_find((SV*)av, PERL_MAGIC_tied);
940         if (tied_magic || mg_find((SV*)av, PERL_MAGIC_regdata)) {
941             SV * const sv = sv_newmortal();
942             MAGIC *mg;
943             /* Handle negative array indices 20020222 MJD */
944             if (key < 0) {
945                 unsigned adjust_index = 1;
946                 if (tied_magic) {
947                     SV * const * const negative_indices_glob =
948                         hv_fetch(SvSTASH(SvRV(SvTIED_obj((SV *)av, 
949                                                          tied_magic))), 
950                                  NEGATIVE_INDICES_VAR, 16, 0);
951                     if (negative_indices_glob
952                         && SvTRUE(GvSV(*negative_indices_glob)))
953                         adjust_index = 0;
954                 }
955                 if (adjust_index) {
956                     key += AvFILL(av) + 1;
957                     if (key < 0)
958                         return FALSE;
959                 }
960             }
961
962             mg_copy((SV*)av, sv, 0, key);
963             mg = mg_find(sv, PERL_MAGIC_tiedelem);
964             if (mg) {
965                 magic_existspack(sv, mg);
966                 return (bool)SvTRUE(sv);
967             }
968
969         }
970     }
971
972     if (key < 0) {
973         key += AvFILL(av) + 1;
974         if (key < 0)
975             return FALSE;
976     }
977
978     if (key <= AvFILLp(av) && AvARRAY(av)[key] != &PL_sv_undef
979         && AvARRAY(av)[key])
980     {
981         return TRUE;
982     }
983     else
984         return FALSE;
985 }
986
987 static MAGIC *
988 S_get_aux_mg(pTHX_ AV *av) {
989     dVAR;
990     MAGIC *mg;
991
992     PERL_ARGS_ASSERT_GET_AUX_MG;
993     assert(SvTYPE(av) == SVt_PVAV);
994
995     mg = mg_find((SV*)av, PERL_MAGIC_arylen_p);
996
997     if (!mg) {
998         mg = sv_magicext((SV*)av, 0, PERL_MAGIC_arylen_p, &PL_vtbl_arylen_p,
999                          0, 0);
1000         assert(mg);
1001         /* sv_magicext won't set this for us because we pass in a NULL obj  */
1002         mg->mg_flags |= MGf_REFCOUNTED;
1003     }
1004     return mg;
1005 }
1006
1007 SV **
1008 Perl_av_arylen_p(pTHX_ AV *av) {
1009     MAGIC *const mg = get_aux_mg(av);
1010
1011     PERL_ARGS_ASSERT_AV_ARYLEN_P;
1012     assert(SvTYPE(av) == SVt_PVAV);
1013
1014     return &(mg->mg_obj);
1015 }
1016
1017 IV *
1018 Perl_av_iter_p(pTHX_ AV *av) {
1019     MAGIC *const mg = get_aux_mg(av);
1020
1021     PERL_ARGS_ASSERT_AV_ITER_P;
1022     assert(SvTYPE(av) == SVt_PVAV);
1023
1024 #if IVSIZE == I32SIZE
1025     return (IV *)&(mg->mg_len);
1026 #else
1027     if (!mg->mg_ptr) {
1028         IV *temp;
1029         mg->mg_len = IVSIZE;
1030         Newxz(temp, 1, IV);
1031         mg->mg_ptr = (char *) temp;
1032     }
1033     return (IV *)mg->mg_ptr;
1034 #endif
1035 }
1036
1037 /*
1038  * Local variables:
1039  * c-indentation-style: bsd
1040  * c-basic-offset: 4
1041  * indent-tabs-mode: t
1042  * End:
1043  *
1044  * ex: set ts=8 sts=4 sw=4 noet:
1045  */