3 * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
4 * 2000, 2001, 2002, 2003, 2004, 2005 by Larry Wall and others
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.
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
17 =head1 Array Manipulation Functions
25 Perl_av_reify(pTHX_ AV *av)
33 if (SvTIED_mg((SV*)av, PERL_MAGIC_tied) && ckWARN_d(WARN_DEBUGGING))
34 Perl_warner(aTHX_ packWARN(WARN_DEBUGGING), "av_reify called on tied array");
37 while (key > AvFILLp(av) + 1)
38 AvARRAY(av)[--key] = &PL_sv_undef;
40 sv = AvARRAY(av)[--key];
42 if (sv != &PL_sv_undef)
43 (void)SvREFCNT_inc(sv);
45 key = AvARRAY(av) - AvALLOC(av);
47 AvALLOC(av)[--key] = &PL_sv_undef;
55 Pre-extend an array. The C<key> is the index to which the array should be
62 Perl_av_extend(pTHX_ AV *av, I32 key)
65 if ((mg = SvTIED_mg((SV*)av, PERL_MAGIC_tied))) {
69 PUSHSTACKi(PERLSI_MAGIC);
72 PUSHs(SvTIED_obj((SV*)av, mg));
73 PUSHs(sv_2mortal(newSViv(key+1)));
75 call_method("EXTEND", G_SCALAR|G_DISCARD);
81 if (key > AvMAX(av)) {
86 if (AvALLOC(av) != AvARRAY(av)) {
87 ary = AvALLOC(av) + AvFILLp(av) + 1;
88 tmp = AvARRAY(av) - AvALLOC(av);
89 Move(AvARRAY(av), AvALLOC(av), AvFILLp(av)+1, SV*);
91 SvPVX(av) = (char*)AvALLOC(av);
94 ary[--tmp] = &PL_sv_undef;
97 if (key > AvMAX(av) - 10) {
98 newmax = key + AvMAX(av);
103 #ifdef PERL_MALLOC_WRAP
104 static const char oom_array_extend[] =
105 "Out of memory during array extend"; /* Duplicated in pp_hot.c */
109 #if !defined(STRANGE_MALLOC) && !defined(MYMALLOC)
115 newmax = malloced_size((void*)AvALLOC(av))/sizeof(SV*) - 1;
120 newmax = key + AvMAX(av) / 5;
122 MEM_WRAP_CHECK_1(newmax+1, SV*, oom_array_extend);
123 #if defined(STRANGE_MALLOC) || defined(MYMALLOC)
124 Renew(AvALLOC(av),newmax+1, SV*);
126 bytes = (newmax + 1) * sizeof(SV*);
127 #define MALLOC_OVERHEAD 16
128 itmp = MALLOC_OVERHEAD;
129 while ((MEM_SIZE)(itmp - MALLOC_OVERHEAD) < bytes)
131 itmp -= MALLOC_OVERHEAD;
133 assert(itmp > newmax);
135 assert(newmax >= AvMAX(av));
136 New(2,ary, newmax+1, SV*);
137 Copy(AvALLOC(av), ary, AvMAX(av)+1, SV*);
139 offer_nice_chunk(AvALLOC(av), (AvMAX(av)+1) * sizeof(SV*));
141 Safefree(AvALLOC(av));
147 ary = AvALLOC(av) + AvMAX(av) + 1;
148 tmp = newmax - AvMAX(av);
149 if (av == PL_curstack) { /* Oops, grew stack (via av_store()?) */
150 PL_stack_sp = AvALLOC(av) + (PL_stack_sp - PL_stack_base);
151 PL_stack_base = AvALLOC(av);
152 PL_stack_max = PL_stack_base + newmax;
156 newmax = key < 3 ? 3 : key;
157 MEM_WRAP_CHECK_1(newmax+1, SV*, oom_array_extend);
158 New(2,AvALLOC(av), newmax+1, SV*);
159 ary = AvALLOC(av) + 1;
161 AvALLOC(av)[0] = &PL_sv_undef; /* For the stacks */
165 ary[--tmp] = &PL_sv_undef;
168 SvPVX(av) = (char*)AvALLOC(av);
177 Returns the SV at the specified index in the array. The C<key> is the
178 index. If C<lval> is set then the fetch will be part of a store. Check
179 that the return value is non-null before dereferencing it to a C<SV*>.
181 See L<perlguts/"Understanding the Magic of Tied Hashes and Arrays"> for
182 more information on how to use this function on tied arrays.
188 Perl_av_fetch(pTHX_ register AV *av, I32 key, I32 lval)
195 if (SvRMAGICAL(av)) {
196 const MAGIC * const tied_magic = mg_find((SV*)av, PERL_MAGIC_tied);
197 if (tied_magic || mg_find((SV*)av, PERL_MAGIC_regdata)) {
198 U32 adjust_index = 1;
200 if (tied_magic && key < 0) {
201 /* Handle negative array indices 20020222 MJD */
202 SV **negative_indices_glob =
203 hv_fetch(SvSTASH(SvRV(SvTIED_obj((SV *)av,
205 NEGATIVE_INDICES_VAR, 16, 0);
207 if (negative_indices_glob
208 && SvTRUE(GvSV(*negative_indices_glob)))
212 if (key < 0 && adjust_index) {
213 key += AvFILL(av) + 1;
219 sv_upgrade(sv, SVt_PVLV);
220 mg_copy((SV*)av, sv, 0, key);
222 LvTARG(sv) = sv; /* fake (SV**) */
223 return &(LvTARG(sv));
228 key += AvFILL(av) + 1;
233 if (key > AvFILLp(av)) {
237 return av_store(av,key,sv);
239 if (AvARRAY(av)[key] == &PL_sv_undef) {
243 return av_store(av,key,sv);
248 && (!AvARRAY(av)[key] /* eg. @_ could have freed elts */
249 || SvTYPE(AvARRAY(av)[key]) == SVTYPEMASK)) {
250 AvARRAY(av)[key] = &PL_sv_undef; /* 1/2 reify */
253 return &AvARRAY(av)[key];
259 Stores an SV in an array. The array index is specified as C<key>. The
260 return value will be NULL if the operation failed or if the value did not
261 need to be actually stored within the array (as in the case of tied
262 arrays). Otherwise it can be dereferenced to get the original C<SV*>. Note
263 that the caller is responsible for suitably incrementing the reference
264 count of C<val> before the call, and decrementing it if the function
267 See L<perlguts/"Understanding the Magic of Tied Hashes and Arrays"> for
268 more information on how to use this function on tied arrays.
274 Perl_av_store(pTHX_ register AV *av, I32 key, SV *val)
283 if (SvRMAGICAL(av)) {
284 const MAGIC * const tied_magic = mg_find((SV*)av, PERL_MAGIC_tied);
286 /* Handle negative array indices 20020222 MJD */
288 unsigned adjust_index = 1;
289 SV **negative_indices_glob =
290 hv_fetch(SvSTASH(SvRV(SvTIED_obj((SV *)av,
292 NEGATIVE_INDICES_VAR, 16, 0);
293 if (negative_indices_glob
294 && SvTRUE(GvSV(*negative_indices_glob)))
297 key += AvFILL(av) + 1;
302 if (val != &PL_sv_undef) {
303 mg_copy((SV*)av, val, 0, key);
311 key += AvFILL(av) + 1;
316 if (SvREADONLY(av) && key >= AvFILL(av))
317 Perl_croak(aTHX_ PL_no_modify);
319 if (!AvREAL(av) && AvREIFY(av))
324 if (AvFILLp(av) < key) {
326 if (av == PL_curstack && key > PL_stack_sp - PL_stack_base)
327 PL_stack_sp = PL_stack_base + key; /* XPUSH in disguise */
329 ary[++AvFILLp(av)] = &PL_sv_undef;
330 while (AvFILLp(av) < key);
335 SvREFCNT_dec(ary[key]);
337 if (SvSMAGICAL(av)) {
338 if (val != &PL_sv_undef) {
339 MAGIC* mg = SvMAGIC(av);
340 sv_magic(val, (SV*)av, toLOWER(mg->mg_type), 0, key);
350 Creates a new AV. The reference count is set to 1.
360 av = (AV*)NEWSV(3,0);
361 sv_upgrade((SV *)av, SVt_PVAV);
365 AvMAX(av) = AvFILLp(av) = -1;
372 Creates a new AV and populates it with a list of SVs. The SVs are copied
373 into the array, so they may be freed after the call to av_make. The new AV
374 will have a reference count of 1.
380 Perl_av_make(pTHX_ register I32 size, register SV **strp)
384 av = (AV*)NEWSV(8,0);
385 sv_upgrade((SV *) av,SVt_PVAV);
386 AvFLAGS(av) = AVf_REAL;
387 if (size) { /* `defined' was returning undef for size==0 anyway. */
392 SvPVX(av) = (char*)ary;
393 AvFILLp(av) = size - 1;
394 AvMAX(av) = size - 1;
395 for (i = 0; i < size; i++) {
398 sv_setsv(ary[i], *strp);
406 Perl_av_fake(pTHX_ register I32 size, register SV **strp)
411 av = (AV*)NEWSV(9,0);
412 sv_upgrade((SV *)av, SVt_PVAV);
413 New(4,ary,size+1,SV*);
415 Copy(strp,ary,size,SV*);
416 AvFLAGS(av) = AVf_REIFY;
417 SvPVX(av) = (char*)ary;
418 AvFILLp(av) = size - 1;
419 AvMAX(av) = size - 1;
431 Clears an array, making it empty. Does not free the memory used by the
438 Perl_av_clear(pTHX_ register AV *av)
443 if (SvREFCNT(av) == 0 && ckWARN_d(WARN_DEBUGGING)) {
444 Perl_warner(aTHX_ packWARN(WARN_DEBUGGING), "Attempt to clear deleted array");
452 Perl_croak(aTHX_ PL_no_modify);
454 /* Give any tie a chance to cleanup first */
462 SV** ary = AvARRAY(av);
463 key = AvFILLp(av) + 1;
465 SV * sv = ary[--key];
466 /* undef the slot before freeing the value, because a
467 * destructor might try to modify this arrray */
468 ary[key] = &PL_sv_undef;
472 if ((key = AvARRAY(av) - AvALLOC(av))) {
474 SvPVX(av) = (char*)AvALLOC(av);
483 Undefines the array. Frees the memory used by the array itself.
489 Perl_av_undef(pTHX_ register AV *av)
497 /* Give any tie a chance to cleanup first */
498 if (SvTIED_mg((SV*)av, PERL_MAGIC_tied))
499 av_fill(av, -1); /* mg_clear() ? */
502 key = AvFILLp(av) + 1;
504 SvREFCNT_dec(AvARRAY(av)[--key]);
506 Safefree(AvALLOC(av));
509 AvMAX(av) = AvFILLp(av) = -1;
511 SvREFCNT_dec(AvARYLEN(av));
519 Pushes an SV onto the end of the array. The array will grow automatically
520 to accommodate the addition.
526 Perl_av_push(pTHX_ register AV *av, SV *val)
532 Perl_croak(aTHX_ PL_no_modify);
534 if ((mg = SvTIED_mg((SV*)av, PERL_MAGIC_tied))) {
536 PUSHSTACKi(PERLSI_MAGIC);
539 PUSHs(SvTIED_obj((SV*)av, mg));
543 call_method("PUSH", G_SCALAR|G_DISCARD);
548 av_store(av,AvFILLp(av)+1,val);
554 Pops an SV off the end of the array. Returns C<&PL_sv_undef> if the array
561 Perl_av_pop(pTHX_ register AV *av)
569 Perl_croak(aTHX_ PL_no_modify);
570 if ((mg = SvTIED_mg((SV*)av, PERL_MAGIC_tied))) {
572 PUSHSTACKi(PERLSI_MAGIC);
574 XPUSHs(SvTIED_obj((SV*)av, mg));
577 if (call_method("POP", G_SCALAR)) {
578 retval = newSVsv(*PL_stack_sp--);
580 retval = &PL_sv_undef;
588 retval = AvARRAY(av)[AvFILLp(av)];
589 AvARRAY(av)[AvFILLp(av)--] = &PL_sv_undef;
596 =for apidoc av_unshift
598 Unshift the given number of C<undef> values onto the beginning of the
599 array. The array will grow automatically to accommodate the addition. You
600 must then use C<av_store> to assign values to these new elements.
606 Perl_av_unshift(pTHX_ register AV *av, register I32 num)
616 Perl_croak(aTHX_ PL_no_modify);
618 if ((mg = SvTIED_mg((SV*)av, PERL_MAGIC_tied))) {
620 PUSHSTACKi(PERLSI_MAGIC);
623 PUSHs(SvTIED_obj((SV*)av, mg));
629 call_method("UNSHIFT", G_SCALAR|G_DISCARD);
637 if (!AvREAL(av) && AvREIFY(av))
639 i = AvARRAY(av) - AvALLOC(av);
647 SvPVX(av) = (char*)(AvARRAY(av) - i);
651 /* Create extra elements */
652 slide = i > 0 ? i : 0;
654 av_extend(av, i + num);
657 Move(ary, ary + num, i + 1, SV*);
659 ary[--num] = &PL_sv_undef;
661 /* Make extra elements into a buffer */
663 AvFILLp(av) -= slide;
664 SvPVX(av) = (char*)(AvARRAY(av) + slide);
671 Shifts an SV off the beginning of the array.
677 Perl_av_shift(pTHX_ register AV *av)
685 Perl_croak(aTHX_ PL_no_modify);
686 if ((mg = SvTIED_mg((SV*)av, PERL_MAGIC_tied))) {
688 PUSHSTACKi(PERLSI_MAGIC);
690 XPUSHs(SvTIED_obj((SV*)av, mg));
693 if (call_method("SHIFT", G_SCALAR)) {
694 retval = newSVsv(*PL_stack_sp--);
696 retval = &PL_sv_undef;
704 retval = *AvARRAY(av);
706 *AvARRAY(av) = &PL_sv_undef;
707 SvPVX(av) = (char*)(AvARRAY(av) + 1);
718 Returns the highest index in the array. Returns -1 if the array is
725 Perl_av_len(pTHX_ const register AV *av)
733 Ensure than an array has a given number of elements, equivalent to
734 Perl's C<$#array = $fill;>.
739 Perl_av_fill(pTHX_ register AV *av, I32 fill)
743 Perl_croak(aTHX_ "panic: null array");
746 if ((mg = SvTIED_mg((SV*)av, PERL_MAGIC_tied))) {
750 PUSHSTACKi(PERLSI_MAGIC);
753 PUSHs(SvTIED_obj((SV*)av, mg));
754 PUSHs(sv_2mortal(newSViv(fill+1)));
756 call_method("STORESIZE", G_SCALAR|G_DISCARD);
762 if (fill <= AvMAX(av)) {
763 I32 key = AvFILLp(av);
764 SV** ary = AvARRAY(av);
768 SvREFCNT_dec(ary[key]);
769 ary[key--] = &PL_sv_undef;
774 ary[++key] = &PL_sv_undef;
782 (void)av_store(av,fill,&PL_sv_undef);
786 =for apidoc av_delete
788 Deletes the element indexed by C<key> from the array. Returns the
789 deleted element. If C<flags> equals C<G_DISCARD>, the element is freed
790 and null is returned.
795 Perl_av_delete(pTHX_ AV *av, I32 key, I32 flags)
802 Perl_croak(aTHX_ PL_no_modify);
804 if (SvRMAGICAL(av)) {
805 const MAGIC * const tied_magic = mg_find((SV*)av, PERL_MAGIC_tied);
806 if ((tied_magic || mg_find((SV*)av, PERL_MAGIC_regdata))) {
807 /* Handle negative array indices 20020222 MJD */
810 unsigned adjust_index = 1;
812 SV **negative_indices_glob =
813 hv_fetch(SvSTASH(SvRV(SvTIED_obj((SV *)av,
815 NEGATIVE_INDICES_VAR, 16, 0);
816 if (negative_indices_glob
817 && SvTRUE(GvSV(*negative_indices_glob)))
821 key += AvFILL(av) + 1;
826 svp = av_fetch(av, key, TRUE);
830 if (mg_find(sv, PERL_MAGIC_tiedelem)) {
831 sv_unmagic(sv, PERL_MAGIC_tiedelem); /* No longer an element */
840 key += AvFILL(av) + 1;
845 if (key > AvFILLp(av))
848 if (!AvREAL(av) && AvREIFY(av))
850 sv = AvARRAY(av)[key];
851 if (key == AvFILLp(av)) {
852 AvARRAY(av)[key] = &PL_sv_undef;
855 } while (--key >= 0 && AvARRAY(av)[key] == &PL_sv_undef);
858 AvARRAY(av)[key] = &PL_sv_undef;
862 if (flags & G_DISCARD) {
872 =for apidoc av_exists
874 Returns true if the element indexed by C<key> has been initialized.
876 This relies on the fact that uninitialized array elements are set to
882 Perl_av_exists(pTHX_ AV *av, I32 key)
888 if (SvRMAGICAL(av)) {
889 const MAGIC * const tied_magic = mg_find((SV*)av, PERL_MAGIC_tied);
890 if (tied_magic || mg_find((SV*)av, PERL_MAGIC_regdata)) {
891 SV *sv = sv_newmortal();
893 /* Handle negative array indices 20020222 MJD */
895 unsigned adjust_index = 1;
897 SV **negative_indices_glob =
898 hv_fetch(SvSTASH(SvRV(SvTIED_obj((SV *)av,
900 NEGATIVE_INDICES_VAR, 16, 0);
901 if (negative_indices_glob
902 && SvTRUE(GvSV(*negative_indices_glob)))
906 key += AvFILL(av) + 1;
912 mg_copy((SV*)av, sv, 0, key);
913 mg = mg_find(sv, PERL_MAGIC_tiedelem);
915 magic_existspack(sv, mg);
916 return (bool)SvTRUE(sv);
923 key += AvFILL(av) + 1;
928 if (key <= AvFILLp(av) && AvARRAY(av)[key] != &PL_sv_undef