3 * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
4 * 2000, 2001, 2002, 2003, 2004, 2005, 2006, 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)
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");
39 while (key > AvFILLp(av) + 1)
40 AvARRAY(av)[--key] = &PL_sv_undef;
42 SV * const sv = AvARRAY(av)[--key];
44 if (sv != &PL_sv_undef)
45 SvREFCNT_inc_void_NN(sv);
47 key = AvARRAY(av) - AvALLOC(av);
49 AvALLOC(av)[--key] = &PL_sv_undef;
57 Pre-extend an array. The C<key> is the index to which the array should be
64 Perl_av_extend(pTHX_ AV *av, I32 key)
71 mg = SvTIED_mg((SV*)av, PERL_MAGIC_tied);
76 PUSHSTACKi(PERLSI_MAGIC);
79 PUSHs(SvTIED_obj((SV*)av, mg));
80 PUSHs(sv_2mortal(newSViv(key+1)));
82 call_method("EXTEND", G_SCALAR|G_DISCARD);
88 if (key > AvMAX(av)) {
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*);
98 SvPV_set(av, (char*)AvALLOC(av));
101 ary[--tmp] = &PL_sv_undef;
103 if (key > AvMAX(av) - 10) {
104 newmax = key + AvMAX(av);
109 #ifdef PERL_MALLOC_WRAP
110 static const char oom_array_extend[] =
111 "Out of memory during array extend"; /* Duplicated in pp_hot.c */
115 #if !defined(STRANGE_MALLOC) && !defined(MYMALLOC)
121 newmax = malloced_size((void*)AvALLOC(av))/sizeof(SV*) - 1;
126 newmax = key + AvMAX(av) / 5;
128 MEM_WRAP_CHECK_1(newmax+1, SV*, oom_array_extend);
129 #if defined(STRANGE_MALLOC) || defined(MYMALLOC)
130 Renew(AvALLOC(av),newmax+1, SV*);
132 bytes = (newmax + 1) * sizeof(SV*);
133 #define MALLOC_OVERHEAD 16
134 itmp = MALLOC_OVERHEAD;
135 while ((MEM_SIZE)(itmp - MALLOC_OVERHEAD) < bytes)
137 itmp -= MALLOC_OVERHEAD;
139 assert(itmp > newmax);
141 assert(newmax >= AvMAX(av));
142 Newx(ary, newmax+1, SV*);
143 Copy(AvALLOC(av), ary, AvMAX(av)+1, SV*);
145 offer_nice_chunk(AvALLOC(av), (AvMAX(av)+1) * sizeof(SV*));
147 Safefree(AvALLOC(av));
153 ary = AvALLOC(av) + AvMAX(av) + 1;
154 tmp = newmax - AvMAX(av);
155 if (av == PL_curstack) { /* Oops, grew stack (via av_store()?) */
156 PL_stack_sp = AvALLOC(av) + (PL_stack_sp - PL_stack_base);
157 PL_stack_base = AvALLOC(av);
158 PL_stack_max = PL_stack_base + newmax;
162 newmax = key < 3 ? 3 : key;
163 MEM_WRAP_CHECK_1(newmax+1, SV*, oom_array_extend);
164 Newx(AvALLOC(av), newmax+1, SV*);
165 ary = AvALLOC(av) + 1;
167 AvALLOC(av)[0] = &PL_sv_undef; /* For the stacks */
171 ary[--tmp] = &PL_sv_undef;
174 SvPV_set(av, (char*)AvALLOC(av));
183 Returns the SV at the specified index in the array. The C<key> is the
184 index. If C<lval> is set then the fetch will be part of a store. Check
185 that the return value is non-null before dereferencing it to a C<SV*>.
187 See L<perlguts/"Understanding the Magic of Tied Hashes and Arrays"> for
188 more information on how to use this function on tied arrays.
194 Perl_av_fetch(pTHX_ register AV *av, I32 key, I32 lval)
201 if (SvRMAGICAL(av)) {
202 const MAGIC * const tied_magic = mg_find((SV*)av, PERL_MAGIC_tied);
203 if (tied_magic || mg_find((SV*)av, PERL_MAGIC_regdata)) {
204 U32 adjust_index = 1;
206 if (tied_magic && key < 0) {
207 /* Handle negative array indices 20020222 MJD */
208 SV * const * const negative_indices_glob =
209 hv_fetch(SvSTASH(SvRV(SvTIED_obj((SV *)av,
211 NEGATIVE_INDICES_VAR, 16, 0);
213 if (negative_indices_glob
214 && SvTRUE(GvSV(*negative_indices_glob)))
218 if (key < 0 && adjust_index) {
219 key += AvFILL(av) + 1;
225 sv_upgrade(sv, SVt_PVLV);
226 mg_copy((SV*)av, sv, 0, key);
228 LvTARG(sv) = sv; /* fake (SV**) */
229 return &(LvTARG(sv));
234 key += AvFILL(av) + 1;
239 if (key > AvFILLp(av)) {
243 return av_store(av,key,sv);
245 if (AvARRAY(av)[key] == &PL_sv_undef) {
249 return av_store(av,key,sv);
254 && (!AvARRAY(av)[key] /* eg. @_ could have freed elts */
255 || SvIS_FREED(AvARRAY(av)[key]))) {
256 AvARRAY(av)[key] = &PL_sv_undef; /* 1/2 reify */
259 return &AvARRAY(av)[key];
265 Stores an SV in an array. The array index is specified as C<key>. The
266 return value will be NULL if the operation failed or if the value did not
267 need to be actually stored within the array (as in the case of tied
268 arrays). Otherwise it can be dereferenced to get the original C<SV*>. Note
269 that the caller is responsible for suitably incrementing the reference
270 count of C<val> before the call, and decrementing it if the function
273 See L<perlguts/"Understanding the Magic of Tied Hashes and Arrays"> for
274 more information on how to use this function on tied arrays.
280 Perl_av_store(pTHX_ register AV *av, I32 key, SV *val)
287 /* S_regclass relies on being able to pass in a NULL sv
288 (unicode_alternate may be NULL).
294 if (SvRMAGICAL(av)) {
295 const MAGIC * const tied_magic = mg_find((SV*)av, PERL_MAGIC_tied);
297 /* Handle negative array indices 20020222 MJD */
299 unsigned adjust_index = 1;
300 SV * const * const negative_indices_glob =
301 hv_fetch(SvSTASH(SvRV(SvTIED_obj((SV *)av,
303 NEGATIVE_INDICES_VAR, 16, 0);
304 if (negative_indices_glob
305 && SvTRUE(GvSV(*negative_indices_glob)))
308 key += AvFILL(av) + 1;
313 if (val != &PL_sv_undef) {
314 mg_copy((SV*)av, val, 0, key);
322 key += AvFILL(av) + 1;
327 if (SvREADONLY(av) && key >= AvFILL(av))
328 Perl_croak(aTHX_ PL_no_modify);
330 if (!AvREAL(av) && AvREIFY(av))
335 if (AvFILLp(av) < key) {
337 if (av == PL_curstack && key > PL_stack_sp - PL_stack_base)
338 PL_stack_sp = PL_stack_base + key; /* XPUSH in disguise */
340 ary[++AvFILLp(av)] = &PL_sv_undef;
341 while (AvFILLp(av) < key);
346 SvREFCNT_dec(ary[key]);
348 if (SvSMAGICAL(av)) {
349 if (val != &PL_sv_undef) {
350 const MAGIC* const mg = SvMAGIC(av);
351 sv_magic(val, (SV*)av, toLOWER(mg->mg_type), 0, key);
361 Creates a new AV. The reference count is set to 1.
369 register AV * const av = (AV*)newSV(0);
371 sv_upgrade((SV *)av, SVt_PVAV);
372 /* sv_upgrade does AvREAL_only() */
375 AvMAX(av) = AvFILLp(av) = -1;
382 Creates a new AV and populates it with a list of SVs. The SVs are copied
383 into the array, so they may be freed after the call to av_make. The new AV
384 will have a reference count of 1.
390 Perl_av_make(pTHX_ register I32 size, register SV **strp)
392 register AV * const av = (AV*)newSV(0);
394 sv_upgrade((SV *) av,SVt_PVAV);
395 /* sv_upgrade does AvREAL_only() */
396 if (size) { /* "defined" was returning undef for size==0 anyway. */
401 SvPV_set(av, (char*)ary);
402 AvFILLp(av) = size - 1;
403 AvMAX(av) = size - 1;
404 for (i = 0; i < size; i++) {
407 sv_setsv(ary[i], *strp);
417 Clears an array, making it empty. Does not free the memory used by the
424 Perl_av_clear(pTHX_ register AV *av)
431 if (SvREFCNT(av) == 0 && ckWARN_d(WARN_DEBUGGING)) {
432 Perl_warner(aTHX_ packWARN(WARN_DEBUGGING), "Attempt to clear deleted array");
437 Perl_croak(aTHX_ PL_no_modify);
439 /* Give any tie a chance to cleanup first */
447 SV** const ary = AvARRAY(av);
448 key = AvFILLp(av) + 1;
450 SV * const sv = ary[--key];
451 /* undef the slot before freeing the value, because a
452 * destructor might try to modify this arrray */
453 ary[key] = &PL_sv_undef;
457 if ((key = AvARRAY(av) - AvALLOC(av))) {
459 SvPV_set(av, (char*)AvALLOC(av));
468 Undefines the array. Frees the memory used by the array itself.
474 Perl_av_undef(pTHX_ register AV *av)
478 /* Give any tie a chance to cleanup first */
479 if (SvTIED_mg((SV*)av, PERL_MAGIC_tied))
480 av_fill(av, -1); /* mg_clear() ? */
483 register I32 key = AvFILLp(av) + 1;
485 SvREFCNT_dec(AvARRAY(av)[--key]);
487 Safefree(AvALLOC(av));
490 AvMAX(av) = AvFILLp(av) = -1;
496 Pushes an SV onto the end of the array. The array will grow automatically
497 to accommodate the addition.
503 Perl_av_push(pTHX_ register AV *av, SV *val)
510 Perl_croak(aTHX_ PL_no_modify);
512 if ((mg = SvTIED_mg((SV*)av, PERL_MAGIC_tied))) {
514 PUSHSTACKi(PERLSI_MAGIC);
517 PUSHs(SvTIED_obj((SV*)av, mg));
521 call_method("PUSH", G_SCALAR|G_DISCARD);
526 av_store(av,AvFILLp(av)+1,val);
532 Pops an SV off the end of the array. Returns C<&PL_sv_undef> if the array
539 Perl_av_pop(pTHX_ register AV *av)
548 Perl_croak(aTHX_ PL_no_modify);
549 if ((mg = SvTIED_mg((SV*)av, PERL_MAGIC_tied))) {
551 PUSHSTACKi(PERLSI_MAGIC);
553 XPUSHs(SvTIED_obj((SV*)av, mg));
556 if (call_method("POP", G_SCALAR)) {
557 retval = newSVsv(*PL_stack_sp--);
559 retval = &PL_sv_undef;
567 retval = AvARRAY(av)[AvFILLp(av)];
568 AvARRAY(av)[AvFILLp(av)--] = &PL_sv_undef;
575 =for apidoc av_unshift
577 Unshift the given number of C<undef> values onto the beginning of the
578 array. The array will grow automatically to accommodate the addition. You
579 must then use C<av_store> to assign values to these new elements.
585 Perl_av_unshift(pTHX_ register AV *av, register I32 num)
594 Perl_croak(aTHX_ PL_no_modify);
596 if ((mg = SvTIED_mg((SV*)av, PERL_MAGIC_tied))) {
598 PUSHSTACKi(PERLSI_MAGIC);
601 PUSHs(SvTIED_obj((SV*)av, mg));
607 call_method("UNSHIFT", G_SCALAR|G_DISCARD);
615 if (!AvREAL(av) && AvREIFY(av))
617 i = AvARRAY(av) - AvALLOC(av);
625 SvPV_set(av, (char*)(AvARRAY(av) - i));
631 /* Create extra elements */
632 slide = i > 0 ? i : 0;
634 av_extend(av, i + num);
637 Move(ary, ary + num, i + 1, SV*);
639 ary[--num] = &PL_sv_undef;
641 /* Make extra elements into a buffer */
643 AvFILLp(av) -= slide;
644 SvPV_set(av, (char*)(AvARRAY(av) + slide));
651 Shifts an SV off the beginning of the array.
657 Perl_av_shift(pTHX_ register AV *av)
666 Perl_croak(aTHX_ PL_no_modify);
667 if ((mg = SvTIED_mg((SV*)av, PERL_MAGIC_tied))) {
669 PUSHSTACKi(PERLSI_MAGIC);
671 XPUSHs(SvTIED_obj((SV*)av, mg));
674 if (call_method("SHIFT", G_SCALAR)) {
675 retval = newSVsv(*PL_stack_sp--);
677 retval = &PL_sv_undef;
685 retval = *AvARRAY(av);
687 *AvARRAY(av) = &PL_sv_undef;
688 SvPV_set(av, (char*)(AvARRAY(av) + 1));
699 Returns the highest index in the array. Returns -1 if the array is
706 Perl_av_len(pTHX_ register const AV *av)
715 Ensure than an array has a given number of elements, equivalent to
716 Perl's C<$#array = $fill;>.
721 Perl_av_fill(pTHX_ register AV *av, I32 fill)
730 if ((mg = SvTIED_mg((SV*)av, PERL_MAGIC_tied))) {
734 PUSHSTACKi(PERLSI_MAGIC);
737 PUSHs(SvTIED_obj((SV*)av, mg));
738 PUSHs(sv_2mortal(newSViv(fill+1)));
740 call_method("STORESIZE", G_SCALAR|G_DISCARD);
746 if (fill <= AvMAX(av)) {
747 I32 key = AvFILLp(av);
748 SV** const ary = AvARRAY(av);
752 SvREFCNT_dec(ary[key]);
753 ary[key--] = &PL_sv_undef;
758 ary[++key] = &PL_sv_undef;
766 (void)av_store(av,fill,&PL_sv_undef);
770 =for apidoc av_delete
772 Deletes the element indexed by C<key> from the array. Returns the
773 deleted element. If C<flags> equals C<G_DISCARD>, the element is freed
774 and null is returned.
779 Perl_av_delete(pTHX_ AV *av, I32 key, I32 flags)
787 Perl_croak(aTHX_ PL_no_modify);
789 if (SvRMAGICAL(av)) {
790 const MAGIC * const tied_magic = mg_find((SV*)av, PERL_MAGIC_tied);
791 if ((tied_magic || mg_find((SV*)av, PERL_MAGIC_regdata))) {
792 /* Handle negative array indices 20020222 MJD */
795 unsigned adjust_index = 1;
797 SV * const * const negative_indices_glob =
798 hv_fetch(SvSTASH(SvRV(SvTIED_obj((SV *)av,
800 NEGATIVE_INDICES_VAR, 16, 0);
801 if (negative_indices_glob
802 && SvTRUE(GvSV(*negative_indices_glob)))
806 key += AvFILL(av) + 1;
811 svp = av_fetch(av, key, TRUE);
815 if (mg_find(sv, PERL_MAGIC_tiedelem)) {
816 sv_unmagic(sv, PERL_MAGIC_tiedelem); /* No longer an element */
825 key += AvFILL(av) + 1;
830 if (key > AvFILLp(av))
833 if (!AvREAL(av) && AvREIFY(av))
835 sv = AvARRAY(av)[key];
836 if (key == AvFILLp(av)) {
837 AvARRAY(av)[key] = &PL_sv_undef;
840 } while (--key >= 0 && AvARRAY(av)[key] == &PL_sv_undef);
843 AvARRAY(av)[key] = &PL_sv_undef;
847 if (flags & G_DISCARD) {
857 =for apidoc av_exists
859 Returns true if the element indexed by C<key> has been initialized.
861 This relies on the fact that uninitialized array elements are set to
867 Perl_av_exists(pTHX_ AV *av, I32 key)
872 if (SvRMAGICAL(av)) {
873 const MAGIC * const tied_magic = mg_find((SV*)av, PERL_MAGIC_tied);
874 if (tied_magic || mg_find((SV*)av, PERL_MAGIC_regdata)) {
875 SV * const sv = sv_newmortal();
877 /* Handle negative array indices 20020222 MJD */
879 unsigned adjust_index = 1;
881 SV * const * const negative_indices_glob =
882 hv_fetch(SvSTASH(SvRV(SvTIED_obj((SV *)av,
884 NEGATIVE_INDICES_VAR, 16, 0);
885 if (negative_indices_glob
886 && SvTRUE(GvSV(*negative_indices_glob)))
890 key += AvFILL(av) + 1;
896 mg_copy((SV*)av, sv, 0, key);
897 mg = mg_find(sv, PERL_MAGIC_tiedelem);
899 magic_existspack(sv, mg);
900 return (bool)SvTRUE(sv);
907 key += AvFILL(av) + 1;
912 if (key <= AvFILLp(av) && AvARRAY(av)[key] != &PL_sv_undef
922 Perl_av_arylen_p(pTHX_ AV *av) {
928 mg = mg_find((SV*)av, PERL_MAGIC_arylen_p);
931 mg = sv_magicext((SV*)av, 0, PERL_MAGIC_arylen_p, &PL_vtbl_arylen_p,
934 /* sv_magicext won't set this for us because we pass in a NULL obj */
935 mg->mg_flags |= MGf_REFCOUNTED;
937 return &(mg->mg_obj);
942 * c-indentation-style: bsd
944 * indent-tabs-mode: t
947 * ex: set ts=8 sts=4 sw=4 noet: