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