perl5133delta.pod: editorial changes and cleanup
[perl.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))
39         Perl_ck_warner_d(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         SV *arg1 = sv_newmortal();
78         sv_setiv(arg1, (IV)(key + 1));
79         Perl_magic_methcall(aTHX_ MUTABLE_SV(av), mg, "EXTEND", G_DISCARD, 1,
80                             arg1);
81         return;
82     }
83     if (key > AvMAX(av)) {
84         SV** ary;
85         I32 tmp;
86         I32 newmax;
87
88         if (AvALLOC(av) != AvARRAY(av)) {
89             ary = AvALLOC(av) + AvFILLp(av) + 1;
90             tmp = AvARRAY(av) - AvALLOC(av);
91             Move(AvARRAY(av), AvALLOC(av), AvFILLp(av)+1, SV*);
92             AvMAX(av) += tmp;
93             AvARRAY(av) = AvALLOC(av);
94             if (AvREAL(av)) {
95                 while (tmp)
96                     ary[--tmp] = &PL_sv_undef;
97             }
98             if (key > AvMAX(av) - 10) {
99                 newmax = key + AvMAX(av);
100                 goto resize;
101             }
102         }
103         else {
104 #ifdef PERL_MALLOC_WRAP
105             static const char oom_array_extend[] =
106               "Out of memory during array extend"; /* Duplicated in pp_hot.c */
107 #endif
108
109             if (AvALLOC(av)) {
110 #if !defined(STRANGE_MALLOC) && !defined(MYMALLOC)
111                 MEM_SIZE bytes;
112                 IV itmp;
113 #endif
114
115 #ifdef Perl_safesysmalloc_size
116                 /* Whilst it would be quite possible to move this logic around
117                    (as I did in the SV code), so as to set AvMAX(av) early,
118                    based on calling Perl_safesysmalloc_size() immediately after
119                    allocation, I'm not convinced that it is a great idea here.
120                    In an array we have to loop round setting everything to
121                    &PL_sv_undef, which means writing to memory, potentially lots
122                    of it, whereas for the SV buffer case we don't touch the
123                    "bonus" memory. So there there is no cost in telling the
124                    world about it, whereas here we have to do work before we can
125                    tell the world about it, and that work involves writing to
126                    memory that might never be read. So, I feel, better to keep
127                    the current lazy system of only writing to it if our caller
128                    has a need for more space. NWC  */
129                 newmax = Perl_safesysmalloc_size((void*)AvALLOC(av)) /
130                     sizeof(const SV *) - 1;
131
132                 if (key <= newmax) 
133                     goto resized;
134 #endif 
135                 newmax = key + AvMAX(av) / 5;
136               resize:
137                 MEM_WRAP_CHECK_1(newmax+1, SV*, oom_array_extend);
138 #if defined(STRANGE_MALLOC) || defined(MYMALLOC)
139                 Renew(AvALLOC(av),newmax+1, SV*);
140 #else
141                 bytes = (newmax + 1) * sizeof(const SV *);
142 #define MALLOC_OVERHEAD 16
143                 itmp = MALLOC_OVERHEAD;
144                 while ((MEM_SIZE)(itmp - MALLOC_OVERHEAD) < bytes)
145                     itmp += itmp;
146                 itmp -= MALLOC_OVERHEAD;
147                 itmp /= sizeof(const SV *);
148                 assert(itmp > newmax);
149                 newmax = itmp - 1;
150                 assert(newmax >= AvMAX(av));
151                 Newx(ary, newmax+1, SV*);
152                 Copy(AvALLOC(av), ary, AvMAX(av)+1, SV*);
153                 if (AvMAX(av) > 64)
154                     offer_nice_chunk(AvALLOC(av),
155                                      (AvMAX(av)+1) * sizeof(const SV *));
156                 else
157                     Safefree(AvALLOC(av));
158                 AvALLOC(av) = ary;
159 #endif
160 #ifdef Perl_safesysmalloc_size
161               resized:
162 #endif
163                 ary = AvALLOC(av) + AvMAX(av) + 1;
164                 tmp = newmax - AvMAX(av);
165                 if (av == PL_curstack) {        /* Oops, grew stack (via av_store()?) */
166                     PL_stack_sp = AvALLOC(av) + (PL_stack_sp - PL_stack_base);
167                     PL_stack_base = AvALLOC(av);
168                     PL_stack_max = PL_stack_base + newmax;
169                 }
170             }
171             else {
172                 newmax = key < 3 ? 3 : key;
173                 MEM_WRAP_CHECK_1(newmax+1, SV*, oom_array_extend);
174                 Newx(AvALLOC(av), newmax+1, SV*);
175                 ary = AvALLOC(av) + 1;
176                 tmp = newmax;
177                 AvALLOC(av)[0] = &PL_sv_undef;  /* For the stacks */
178             }
179             if (AvREAL(av)) {
180                 while (tmp)
181                     ary[--tmp] = &PL_sv_undef;
182             }
183             
184             AvARRAY(av) = AvALLOC(av);
185             AvMAX(av) = newmax;
186         }
187     }
188 }
189
190 /*
191 =for apidoc av_fetch
192
193 Returns the SV at the specified index in the array.  The C<key> is the
194 index.  If lval is true, you are guaranteed to get a real SV back (in case
195 it wasn't real before), which you can then modify.  Check that the return
196 value is non-null before dereferencing it to a C<SV*>.
197
198 See L<perlguts/"Understanding the Magic of Tied Hashes and Arrays"> for
199 more information on how to use this function on tied arrays. 
200
201 The rough perl equivalent is C<$myarray[$idx]>.
202 =cut
203 */
204
205 SV**
206 Perl_av_fetch(pTHX_ register AV *av, I32 key, I32 lval)
207 {
208     dVAR;
209
210     PERL_ARGS_ASSERT_AV_FETCH;
211     assert(SvTYPE(av) == SVt_PVAV);
212
213     if (SvRMAGICAL(av)) {
214         const MAGIC * const tied_magic
215             = mg_find((const SV *)av, PERL_MAGIC_tied);
216         if (tied_magic || mg_find((const 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(MUTABLE_SV(av),
224                                                          tied_magic))),
225                                 NEGATIVE_INDICES_VAR, 16, 0);
226
227                     if (negative_indices_glob && SvTRUE(GvSV(*negative_indices_glob)))
228                         adjust_index = 0;
229                 }
230
231                 if (adjust_index) {
232                     key += AvFILL(av) + 1;
233                     if (key < 0)
234                         return NULL;
235                 }
236             }
237
238             sv = sv_newmortal();
239             sv_upgrade(sv, SVt_PVLV);
240             mg_copy(MUTABLE_SV(av), sv, 0, key);
241             if (!tied_magic) /* for regdata, force leavesub to make copies */
242                 SvTEMP_off(sv);
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((const 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(MUTABLE_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(MUTABLE_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_no_modify(aTHX);
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, MUTABLE_SV(av), toLOWER(mg->mg_type), 0, key);
366         }
367         if (PL_delaymagic && mg->mg_type == PERL_MAGIC_isa)
368             PL_delaymagic |= DM_ARRAY_ISA;
369         else
370            mg_set(MUTABLE_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 Perl equivalent: C<my @new_array = ($scalar1, $scalar2, $scalar3...);>
383
384 =cut
385 */
386
387 AV *
388 Perl_av_make(pTHX_ register I32 size, register SV **strp)
389 {
390     register AV * const av = MUTABLE_AV(newSV_type(SVt_PVAV));
391     /* sv_upgrade does AvREAL_only()  */
392     PERL_ARGS_ASSERT_AV_MAKE;
393     assert(SvTYPE(av) == SVt_PVAV);
394
395     if (size) {         /* "defined" was returning undef for size==0 anyway. */
396         register SV** ary;
397         register I32 i;
398         Newx(ary,size,SV*);
399         AvALLOC(av) = ary;
400         AvARRAY(av) = ary;
401         AvFILLp(av) = AvMAX(av) = size - 1;
402         for (i = 0; i < size; i++) {
403             assert (*strp);
404
405             /* Don't let sv_setsv swipe, since our source array might
406                have multiple references to the same temp scalar (e.g.
407                from a list slice) */
408
409             ary[i] = newSV(0);
410             sv_setsv_flags(ary[i], *strp,
411                            SV_GMAGIC|SV_DO_COW_SVSETSV|SV_NOSTEAL);
412             strp++;
413         }
414     }
415     return av;
416 }
417
418 /*
419 =for apidoc av_clear
420
421 Clears an array, making it empty.  Does not free the memory used by the
422 array itself. Perl equivalent: C<@myarray = ();>.
423
424 =cut
425 */
426
427 void
428 Perl_av_clear(pTHX_ register AV *av)
429 {
430     dVAR;
431     I32 extra;
432
433     PERL_ARGS_ASSERT_AV_CLEAR;
434     assert(SvTYPE(av) == SVt_PVAV);
435
436 #ifdef DEBUGGING
437     if (SvREFCNT(av) == 0) {
438         Perl_ck_warner_d(aTHX_ packWARN(WARN_DEBUGGING), "Attempt to clear deleted array");
439     }
440 #endif
441
442     if (SvREADONLY(av))
443         Perl_croak_no_modify(aTHX);
444
445     /* Give any tie a chance to cleanup first */
446     if (SvRMAGICAL(av)) {
447         const MAGIC* const mg = SvMAGIC(av);
448         if (PL_delaymagic && mg && mg->mg_type == PERL_MAGIC_isa)
449             PL_delaymagic |= DM_ARRAY_ISA;
450         else
451             mg_clear(MUTABLE_SV(av)); 
452     }
453
454     if (AvMAX(av) < 0)
455         return;
456
457     if (AvREAL(av)) {
458         SV** const ary = AvARRAY(av);
459         I32 index = AvFILLp(av) + 1;
460         while (index) {
461             SV * const sv = ary[--index];
462             /* undef the slot before freeing the value, because a
463              * destructor might try to modify this array */
464             ary[index] = &PL_sv_undef;
465             SvREFCNT_dec(sv);
466         }
467     }
468     extra = AvARRAY(av) - AvALLOC(av);
469     if (extra) {
470         AvMAX(av) += extra;
471         AvARRAY(av) = AvALLOC(av);
472     }
473     AvFILLp(av) = -1;
474
475 }
476
477 /*
478 =for apidoc av_undef
479
480 Undefines the array.  Frees the memory used by the array itself.
481
482 =cut
483 */
484
485 void
486 Perl_av_undef(pTHX_ register AV *av)
487 {
488     PERL_ARGS_ASSERT_AV_UNDEF;
489     assert(SvTYPE(av) == SVt_PVAV);
490
491     /* Give any tie a chance to cleanup first */
492     if (SvTIED_mg((const SV *)av, PERL_MAGIC_tied)) 
493         av_fill(av, -1);
494
495     if (AvREAL(av)) {
496         register I32 key = AvFILLp(av) + 1;
497         while (key)
498             SvREFCNT_dec(AvARRAY(av)[--key]);
499     }
500
501     Safefree(AvALLOC(av));
502     AvALLOC(av) = NULL;
503     AvARRAY(av) = NULL;
504     AvMAX(av) = AvFILLp(av) = -1;
505
506     if(SvRMAGICAL(av)) mg_clear(MUTABLE_SV(av));
507 }
508
509 /*
510
511 =for apidoc av_create_and_push
512
513 Push an SV onto the end of the array, creating the array if necessary.
514 A small internal helper function to remove a commonly duplicated idiom.
515
516 =cut
517 */
518
519 void
520 Perl_av_create_and_push(pTHX_ AV **const avp, SV *const val)
521 {
522     PERL_ARGS_ASSERT_AV_CREATE_AND_PUSH;
523
524     if (!*avp)
525         *avp = newAV();
526     av_push(*avp, val);
527 }
528
529 /*
530 =for apidoc av_push
531
532 Pushes an SV onto the end of the array.  The array will grow automatically
533 to accommodate the addition. Like C<av_store>, this takes ownership of one
534 reference count.
535
536 =cut
537 */
538
539 void
540 Perl_av_push(pTHX_ register AV *av, SV *val)
541 {             
542     dVAR;
543     MAGIC *mg;
544
545     PERL_ARGS_ASSERT_AV_PUSH;
546     assert(SvTYPE(av) == SVt_PVAV);
547
548     if (SvREADONLY(av))
549         Perl_croak_no_modify(aTHX);
550
551     if ((mg = SvTIED_mg((const SV *)av, PERL_MAGIC_tied))) {
552         Perl_magic_methcall(aTHX_ MUTABLE_SV(av), mg, "PUSH", G_DISCARD, 1,
553                             val);
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_no_modify(aTHX);
580     if ((mg = SvTIED_mg((const SV *)av, PERL_MAGIC_tied))) {
581         retval = Perl_magic_methcall(aTHX_ MUTABLE_SV(av), mg, "POP", 0, 0);
582         if (retval)
583             retval = newSVsv(retval);
584         return retval;
585     }
586     if (AvFILL(av) < 0)
587         return &PL_sv_undef;
588     retval = AvARRAY(av)[AvFILLp(av)];
589     AvARRAY(av)[AvFILLp(av)--] = &PL_sv_undef;
590     if (SvSMAGICAL(av))
591         mg_set(MUTABLE_SV(av));
592     return retval;
593 }
594
595 /*
596
597 =for apidoc av_create_and_unshift_one
598
599 Unshifts an SV onto the beginning of the array, creating the array if
600 necessary.
601 A small internal helper function to remove a commonly duplicated idiom.
602
603 =cut
604 */
605
606 SV **
607 Perl_av_create_and_unshift_one(pTHX_ AV **const avp, SV *const val)
608 {
609     PERL_ARGS_ASSERT_AV_CREATE_AND_UNSHIFT_ONE;
610
611     if (!*avp)
612         *avp = newAV();
613     av_unshift(*avp, 1);
614     return av_store(*avp, 0, val);
615 }
616
617 /*
618 =for apidoc av_unshift
619
620 Unshift the given number of C<undef> values onto the beginning of the
621 array.  The array will grow automatically to accommodate the addition.  You
622 must then use C<av_store> to assign values to these new elements.
623
624 =cut
625 */
626
627 void
628 Perl_av_unshift(pTHX_ register AV *av, register I32 num)
629 {
630     dVAR;
631     register I32 i;
632     MAGIC* mg;
633
634     PERL_ARGS_ASSERT_AV_UNSHIFT;
635     assert(SvTYPE(av) == SVt_PVAV);
636
637     if (SvREADONLY(av))
638         Perl_croak_no_modify(aTHX);
639
640     if ((mg = SvTIED_mg((const SV *)av, PERL_MAGIC_tied))) {
641         Perl_magic_methcall(aTHX_ MUTABLE_SV(av), mg, "UNSHIFT",
642                             G_DISCARD | G_UNDEF_FILL, num);
643         return;
644     }
645
646     if (num <= 0)
647       return;
648     if (!AvREAL(av) && AvREIFY(av))
649         av_reify(av);
650     i = AvARRAY(av) - AvALLOC(av);
651     if (i) {
652         if (i > num)
653             i = num;
654         num -= i;
655     
656         AvMAX(av) += i;
657         AvFILLp(av) += i;
658         AvARRAY(av) = AvARRAY(av) - i;
659     }
660     if (num) {
661         register SV **ary;
662         const I32 i = AvFILLp(av);
663         /* Create extra elements */
664         const I32 slide = i > 0 ? i : 0;
665         num += slide;
666         av_extend(av, i + num);
667         AvFILLp(av) += num;
668         ary = AvARRAY(av);
669         Move(ary, ary + num, i + 1, SV*);
670         do {
671             ary[--num] = &PL_sv_undef;
672         } while (num);
673         /* Make extra elements into a buffer */
674         AvMAX(av) -= slide;
675         AvFILLp(av) -= slide;
676         AvARRAY(av) = AvARRAY(av) + slide;
677     }
678 }
679
680 /*
681 =for apidoc av_shift
682
683 Shifts an SV off the beginning of the array. Returns C<&PL_sv_undef> if the 
684 array is empty.
685
686 =cut
687 */
688
689 SV *
690 Perl_av_shift(pTHX_ register AV *av)
691 {
692     dVAR;
693     SV *retval;
694     MAGIC* mg;
695
696     PERL_ARGS_ASSERT_AV_SHIFT;
697     assert(SvTYPE(av) == SVt_PVAV);
698
699     if (SvREADONLY(av))
700         Perl_croak_no_modify(aTHX);
701     if ((mg = SvTIED_mg((const SV *)av, PERL_MAGIC_tied))) {
702         retval = Perl_magic_methcall(aTHX_ MUTABLE_SV(av), mg, "SHIFT", 0, 0);
703         if (retval)
704             retval = newSVsv(retval);
705         return retval;
706     }
707     if (AvFILL(av) < 0)
708       return &PL_sv_undef;
709     retval = *AvARRAY(av);
710     if (AvREAL(av))
711         *AvARRAY(av) = &PL_sv_undef;
712     AvARRAY(av) = AvARRAY(av) + 1;
713     AvMAX(av)--;
714     AvFILLp(av)--;
715     if (SvSMAGICAL(av))
716         mg_set(MUTABLE_SV(av));
717     return retval;
718 }
719
720 /*
721 =for apidoc av_len
722
723 Returns the highest index in the array.  The number of elements in the
724 array is C<av_len(av) + 1>.  Returns -1 if the array is empty.
725
726 The Perl equivalent for this is C<$#myarray>.
727
728 =cut
729 */
730
731 I32
732 Perl_av_len(pTHX_ AV *av)
733 {
734     PERL_ARGS_ASSERT_AV_LEN;
735     assert(SvTYPE(av) == SVt_PVAV);
736
737     return AvFILL(av);
738 }
739
740 /*
741 =for apidoc av_fill
742
743 Set the highest index in the array to the given number, equivalent to
744 Perl's C<$#array = $fill;>.
745
746 The number of elements in the an array will be C<fill + 1> after
747 av_fill() returns.  If the array was previously shorter, then the
748 additional elements appended are set to C<PL_sv_undef>.  If the array
749 was longer, then the excess elements are freed.  C<av_fill(av, -1)> is
750 the same as C<av_clear(av)>.
751
752 =cut
753 */
754 void
755 Perl_av_fill(pTHX_ register AV *av, I32 fill)
756 {
757     dVAR;
758     MAGIC *mg;
759
760     PERL_ARGS_ASSERT_AV_FILL;
761     assert(SvTYPE(av) == SVt_PVAV);
762
763     if (fill < 0)
764         fill = -1;
765     if ((mg = SvTIED_mg((const SV *)av, PERL_MAGIC_tied))) {
766         SV *arg1 = sv_newmortal();
767         sv_setiv(arg1, (IV)(fill + 1));
768         Perl_magic_methcall(aTHX_ MUTABLE_SV(av), mg, "STORESIZE", G_DISCARD,
769                             1, arg1);
770         return;
771     }
772     if (fill <= AvMAX(av)) {
773         I32 key = AvFILLp(av);
774         SV** const ary = AvARRAY(av);
775
776         if (AvREAL(av)) {
777             while (key > fill) {
778                 SvREFCNT_dec(ary[key]);
779                 ary[key--] = &PL_sv_undef;
780             }
781         }
782         else {
783             while (key < fill)
784                 ary[++key] = &PL_sv_undef;
785         }
786             
787         AvFILLp(av) = fill;
788         if (SvSMAGICAL(av))
789             mg_set(MUTABLE_SV(av));
790     }
791     else
792         (void)av_store(av,fill,&PL_sv_undef);
793 }
794
795 /*
796 =for apidoc av_delete
797
798 Deletes the element indexed by C<key> from the array.  Returns the
799 deleted element. If C<flags> equals C<G_DISCARD>, the element is freed
800 and null is returned. Perl equivalent: C<my $elem = delete($myarray[$idx]);>
801 for the non-C<G_DISCARD> version and a void-context C<delete($myarray[$idx]);>
802 for the C<G_DISCARD> version.
803
804 =cut
805 */
806 SV *
807 Perl_av_delete(pTHX_ AV *av, I32 key, I32 flags)
808 {
809     dVAR;
810     SV *sv;
811
812     PERL_ARGS_ASSERT_AV_DELETE;
813     assert(SvTYPE(av) == SVt_PVAV);
814
815     if (SvREADONLY(av))
816         Perl_croak_no_modify(aTHX);
817
818     if (SvRMAGICAL(av)) {
819         const MAGIC * const tied_magic
820             = mg_find((const SV *)av, PERL_MAGIC_tied);
821         if ((tied_magic || mg_find((const SV *)av, PERL_MAGIC_regdata))) {
822             /* Handle negative array indices 20020222 MJD */
823             SV **svp;
824             if (key < 0) {
825                 unsigned adjust_index = 1;
826                 if (tied_magic) {
827                     SV * const * const negative_indices_glob =
828                         hv_fetch(SvSTASH(SvRV(SvTIED_obj(MUTABLE_SV(av), 
829                                                          tied_magic))), 
830                                  NEGATIVE_INDICES_VAR, 16, 0);
831                     if (negative_indices_glob
832                         && SvTRUE(GvSV(*negative_indices_glob)))
833                         adjust_index = 0;
834                 }
835                 if (adjust_index) {
836                     key += AvFILL(av) + 1;
837                     if (key < 0)
838                         return NULL;
839                 }
840             }
841             svp = av_fetch(av, key, TRUE);
842             if (svp) {
843                 sv = *svp;
844                 mg_clear(sv);
845                 if (mg_find(sv, PERL_MAGIC_tiedelem)) {
846                     sv_unmagic(sv, PERL_MAGIC_tiedelem); /* No longer an element */
847                     return sv;
848                 }
849                 return NULL;
850             }
851         }
852     }
853
854     if (key < 0) {
855         key += AvFILL(av) + 1;
856         if (key < 0)
857             return NULL;
858     }
859
860     if (key > AvFILLp(av))
861         return NULL;
862     else {
863         if (!AvREAL(av) && AvREIFY(av))
864             av_reify(av);
865         sv = AvARRAY(av)[key];
866         if (key == AvFILLp(av)) {
867             AvARRAY(av)[key] = &PL_sv_undef;
868             do {
869                 AvFILLp(av)--;
870             } while (--key >= 0 && AvARRAY(av)[key] == &PL_sv_undef);
871         }
872         else
873             AvARRAY(av)[key] = &PL_sv_undef;
874         if (SvSMAGICAL(av))
875             mg_set(MUTABLE_SV(av));
876     }
877     if (flags & G_DISCARD) {
878         SvREFCNT_dec(sv);
879         sv = NULL;
880     }
881     else if (AvREAL(av))
882         sv = sv_2mortal(sv);
883     return sv;
884 }
885
886 /*
887 =for apidoc av_exists
888
889 Returns true if the element indexed by C<key> has been initialized.
890
891 This relies on the fact that uninitialized array elements are set to
892 C<&PL_sv_undef>.
893
894 Perl equivalent: C<exists($myarray[$key])>.
895
896 =cut
897 */
898 bool
899 Perl_av_exists(pTHX_ AV *av, I32 key)
900 {
901     dVAR;
902     PERL_ARGS_ASSERT_AV_EXISTS;
903     assert(SvTYPE(av) == SVt_PVAV);
904
905     if (SvRMAGICAL(av)) {
906         const MAGIC * const tied_magic
907             = mg_find((const SV *)av, PERL_MAGIC_tied);
908         if (tied_magic || mg_find((const SV *)av, PERL_MAGIC_regdata)) {
909             SV * const sv = sv_newmortal();
910             MAGIC *mg;
911             /* Handle negative array indices 20020222 MJD */
912             if (key < 0) {
913                 unsigned adjust_index = 1;
914                 if (tied_magic) {
915                     SV * const * const negative_indices_glob =
916                         hv_fetch(SvSTASH(SvRV(SvTIED_obj(MUTABLE_SV(av), 
917                                                          tied_magic))), 
918                                  NEGATIVE_INDICES_VAR, 16, 0);
919                     if (negative_indices_glob
920                         && SvTRUE(GvSV(*negative_indices_glob)))
921                         adjust_index = 0;
922                 }
923                 if (adjust_index) {
924                     key += AvFILL(av) + 1;
925                     if (key < 0)
926                         return FALSE;
927                 }
928             }
929
930             mg_copy(MUTABLE_SV(av), sv, 0, key);
931             mg = mg_find(sv, PERL_MAGIC_tiedelem);
932             if (mg) {
933                 magic_existspack(sv, mg);
934                 return cBOOL(SvTRUE(sv));
935             }
936
937         }
938     }
939
940     if (key < 0) {
941         key += AvFILL(av) + 1;
942         if (key < 0)
943             return FALSE;
944     }
945
946     if (key <= AvFILLp(av) && AvARRAY(av)[key] != &PL_sv_undef
947         && AvARRAY(av)[key])
948     {
949         return TRUE;
950     }
951     else
952         return FALSE;
953 }
954
955 static MAGIC *
956 S_get_aux_mg(pTHX_ AV *av) {
957     dVAR;
958     MAGIC *mg;
959
960     PERL_ARGS_ASSERT_GET_AUX_MG;
961     assert(SvTYPE(av) == SVt_PVAV);
962
963     mg = mg_find((const SV *)av, PERL_MAGIC_arylen_p);
964
965     if (!mg) {
966         mg = sv_magicext(MUTABLE_SV(av), 0, PERL_MAGIC_arylen_p,
967                          &PL_vtbl_arylen_p, 0, 0);
968         assert(mg);
969         /* sv_magicext won't set this for us because we pass in a NULL obj  */
970         mg->mg_flags |= MGf_REFCOUNTED;
971     }
972     return mg;
973 }
974
975 SV **
976 Perl_av_arylen_p(pTHX_ AV *av) {
977     MAGIC *const mg = get_aux_mg(av);
978
979     PERL_ARGS_ASSERT_AV_ARYLEN_P;
980     assert(SvTYPE(av) == SVt_PVAV);
981
982     return &(mg->mg_obj);
983 }
984
985 IV *
986 Perl_av_iter_p(pTHX_ AV *av) {
987     MAGIC *const mg = get_aux_mg(av);
988
989     PERL_ARGS_ASSERT_AV_ITER_P;
990     assert(SvTYPE(av) == SVt_PVAV);
991
992 #if IVSIZE == I32SIZE
993     return (IV *)&(mg->mg_len);
994 #else
995     if (!mg->mg_ptr) {
996         IV *temp;
997         mg->mg_len = IVSIZE;
998         Newxz(temp, 1, IV);
999         mg->mg_ptr = (char *) temp;
1000     }
1001     return (IV *)mg->mg_ptr;
1002 #endif
1003 }
1004
1005 /*
1006  * Local variables:
1007  * c-indentation-style: bsd
1008  * c-basic-offset: 4
1009  * indent-tabs-mode: t
1010  * End:
1011  *
1012  * ex: set ts=8 sts=4 sw=4 noet:
1013  */