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