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
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
15 * [p.476 of _The Lord of the Rings_, III/iv: "Treebeard"]
19 =head1 Array Manipulation Functions
27 Perl_av_reify(pTHX_ AV *av)
32 PERL_ARGS_ASSERT_AV_REIFY;
33 assert(SvTYPE(av) == SVt_PVAV);
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");
42 while (key > AvFILLp(av) + 1)
43 AvARRAY(av)[--key] = &PL_sv_undef;
45 SV * const sv = AvARRAY(av)[--key];
47 if (sv != &PL_sv_undef)
48 SvREFCNT_inc_simple_void_NN(sv);
50 key = AvARRAY(av) - AvALLOC(av);
52 AvALLOC(av)[--key] = &PL_sv_undef;
60 Pre-extend an array. The C<key> is the index to which the array should be
67 Perl_av_extend(pTHX_ AV *av, I32 key)
72 PERL_ARGS_ASSERT_AV_EXTEND;
73 assert(SvTYPE(av) == SVt_PVAV);
75 mg = SvTIED_mg((const SV *)av, PERL_MAGIC_tied);
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,
83 if (key > AvMAX(av)) {
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*);
93 AvARRAY(av) = AvALLOC(av);
96 ary[--tmp] = &PL_sv_undef;
98 if (key > AvMAX(av) - 10) {
99 newmax = key + AvMAX(av);
104 #ifdef PERL_MALLOC_WRAP
105 static const char oom_array_extend[] =
106 "Out of memory during array extend"; /* Duplicated in pp_hot.c */
110 #if !defined(STRANGE_MALLOC) && !defined(MYMALLOC)
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;
135 newmax = key + AvMAX(av) / 5;
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*);
141 bytes = (newmax + 1) * sizeof(const SV *);
142 #define MALLOC_OVERHEAD 16
143 itmp = MALLOC_OVERHEAD;
144 while ((MEM_SIZE)(itmp - MALLOC_OVERHEAD) < bytes)
146 itmp -= MALLOC_OVERHEAD;
147 itmp /= sizeof(const SV *);
148 assert(itmp > newmax);
150 assert(newmax >= AvMAX(av));
151 Newx(ary, newmax+1, SV*);
152 Copy(AvALLOC(av), ary, AvMAX(av)+1, SV*);
154 offer_nice_chunk(AvALLOC(av),
155 (AvMAX(av)+1) * sizeof(const SV *));
157 Safefree(AvALLOC(av));
160 #ifdef Perl_safesysmalloc_size
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;
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;
177 AvALLOC(av)[0] = &PL_sv_undef; /* For the stacks */
181 ary[--tmp] = &PL_sv_undef;
184 AvARRAY(av) = AvALLOC(av);
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*>.
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.
201 The rough perl equivalent is C<$myarray[$idx]>.
206 Perl_av_fetch(pTHX_ register AV *av, I32 key, I32 lval)
210 PERL_ARGS_ASSERT_AV_FETCH;
211 assert(SvTYPE(av) == SVt_PVAV);
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)) {
219 I32 adjust_index = 1;
221 /* Handle negative array indices 20020222 MJD */
222 SV * const * const negative_indices_glob =
223 hv_fetch(SvSTASH(SvRV(SvTIED_obj(MUTABLE_SV(av),
225 NEGATIVE_INDICES_VAR, 16, 0);
227 if (negative_indices_glob && SvTRUE(GvSV(*negative_indices_glob)))
232 key += AvFILL(av) + 1;
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 */
244 LvTARG(sv) = sv; /* fake (SV**) */
245 return &(LvTARG(sv));
250 key += AvFILL(av) + 1;
255 if (key > AvFILLp(av)) {
258 return av_store(av,key,newSV(0));
260 if (AvARRAY(av)[key] == &PL_sv_undef) {
263 return av_store(av,key,newSV(0));
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 */
272 return &AvARRAY(av)[key];
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
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.
293 Perl_av_store(pTHX_ register AV *av, I32 key, SV *val)
298 PERL_ARGS_ASSERT_AV_STORE;
299 assert(SvTYPE(av) == SVt_PVAV);
301 /* S_regclass relies on being able to pass in a NULL sv
302 (unicode_alternate may be NULL).
308 if (SvRMAGICAL(av)) {
309 const MAGIC * const tied_magic = mg_find((const SV *)av, PERL_MAGIC_tied);
311 /* Handle negative array indices 20020222 MJD */
313 bool adjust_index = 1;
314 SV * const * const negative_indices_glob =
315 hv_fetch(SvSTASH(SvRV(SvTIED_obj(MUTABLE_SV(av),
317 NEGATIVE_INDICES_VAR, 16, 0);
318 if (negative_indices_glob
319 && SvTRUE(GvSV(*negative_indices_glob)))
322 key += AvFILL(av) + 1;
327 if (val != &PL_sv_undef) {
328 mg_copy(MUTABLE_SV(av), val, 0, key);
336 key += AvFILL(av) + 1;
341 if (SvREADONLY(av) && key >= AvFILL(av))
342 Perl_croak(aTHX_ "%s", PL_no_modify);
344 if (!AvREAL(av) && AvREIFY(av))
349 if (AvFILLp(av) < key) {
351 if (av == PL_curstack && key > PL_stack_sp - PL_stack_base)
352 PL_stack_sp = PL_stack_base + key; /* XPUSH in disguise */
354 ary[++AvFILLp(av)] = &PL_sv_undef;
355 } while (AvFILLp(av) < key);
360 SvREFCNT_dec(ary[key]);
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);
367 if (PL_delaymagic && mg->mg_type == PERL_MAGIC_isa)
368 PL_delaymagic |= DM_ARRAY;
370 mg_set(MUTABLE_SV(av));
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.
386 Perl_av_make(pTHX_ register I32 size, register SV **strp)
388 register AV * const av = MUTABLE_AV(newSV_type(SVt_PVAV));
389 /* sv_upgrade does AvREAL_only() */
390 PERL_ARGS_ASSERT_AV_MAKE;
391 assert(SvTYPE(av) == SVt_PVAV);
393 if (size) { /* "defined" was returning undef for size==0 anyway. */
399 AvFILLp(av) = AvMAX(av) = size - 1;
400 for (i = 0; i < size; i++) {
403 /* Don't let sv_setsv swipe, since our source array might
404 have multiple references to the same temp scalar (e.g.
405 from a list slice) */
408 sv_setsv_flags(ary[i], *strp,
409 SV_GMAGIC|SV_DO_COW_SVSETSV|SV_NOSTEAL);
419 Clears an array, making it empty. Does not free the memory used by the
420 array itself. Perl equivalent: C<@myarray = ();>.
426 Perl_av_clear(pTHX_ register AV *av)
431 PERL_ARGS_ASSERT_AV_CLEAR;
432 assert(SvTYPE(av) == SVt_PVAV);
435 if (SvREFCNT(av) == 0) {
436 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEBUGGING), "Attempt to clear deleted array");
441 Perl_croak(aTHX_ "%s", PL_no_modify);
443 /* Give any tie a chance to cleanup first */
444 if (SvRMAGICAL(av)) {
445 const MAGIC* const mg = SvMAGIC(av);
446 if (PL_delaymagic && mg && mg->mg_type == PERL_MAGIC_isa)
447 PL_delaymagic |= DM_ARRAY;
449 mg_clear(MUTABLE_SV(av));
456 SV** const ary = AvARRAY(av);
457 I32 index = AvFILLp(av) + 1;
459 SV * const sv = ary[--index];
460 /* undef the slot before freeing the value, because a
461 * destructor might try to modify this array */
462 ary[index] = &PL_sv_undef;
466 extra = AvARRAY(av) - AvALLOC(av);
469 AvARRAY(av) = AvALLOC(av);
478 Undefines the array. Frees the memory used by the array itself.
484 Perl_av_undef(pTHX_ register AV *av)
486 PERL_ARGS_ASSERT_AV_UNDEF;
487 assert(SvTYPE(av) == SVt_PVAV);
489 /* Give any tie a chance to cleanup first */
490 if (SvTIED_mg((const SV *)av, PERL_MAGIC_tied))
494 register I32 key = AvFILLp(av) + 1;
496 SvREFCNT_dec(AvARRAY(av)[--key]);
499 Safefree(AvALLOC(av));
502 AvMAX(av) = AvFILLp(av) = -1;
504 if(SvRMAGICAL(av)) mg_clear(MUTABLE_SV(av));
509 =for apidoc av_create_and_push
511 Push an SV onto the end of the array, creating the array if necessary.
512 A small internal helper function to remove a commonly duplicated idiom.
518 Perl_av_create_and_push(pTHX_ AV **const avp, SV *const val)
520 PERL_ARGS_ASSERT_AV_CREATE_AND_PUSH;
530 Pushes an SV onto the end of the array. The array will grow automatically
531 to accommodate the addition. Like C<av_store>, this takes ownership of one
538 Perl_av_push(pTHX_ register AV *av, SV *val)
543 PERL_ARGS_ASSERT_AV_PUSH;
544 assert(SvTYPE(av) == SVt_PVAV);
547 Perl_croak(aTHX_ "%s", PL_no_modify);
549 if ((mg = SvTIED_mg((const SV *)av, PERL_MAGIC_tied))) {
550 Perl_magic_methcall(aTHX_ MUTABLE_SV(av), mg, "PUSH", G_DISCARD, 1,
554 av_store(av,AvFILLp(av)+1,val);
560 Pops an SV off the end of the array. Returns C<&PL_sv_undef> if the array
567 Perl_av_pop(pTHX_ register AV *av)
573 PERL_ARGS_ASSERT_AV_POP;
574 assert(SvTYPE(av) == SVt_PVAV);
577 Perl_croak(aTHX_ "%s", PL_no_modify);
578 if ((mg = SvTIED_mg((const SV *)av, PERL_MAGIC_tied))) {
579 retval = Perl_magic_methcall(aTHX_ MUTABLE_SV(av), mg, "POP", 0, 0);
581 retval = newSVsv(retval);
586 retval = AvARRAY(av)[AvFILLp(av)];
587 AvARRAY(av)[AvFILLp(av)--] = &PL_sv_undef;
589 mg_set(MUTABLE_SV(av));
595 =for apidoc av_create_and_unshift_one
597 Unshifts an SV onto the beginning of the array, creating the array if
599 A small internal helper function to remove a commonly duplicated idiom.
605 Perl_av_create_and_unshift_one(pTHX_ AV **const avp, SV *const val)
607 PERL_ARGS_ASSERT_AV_CREATE_AND_UNSHIFT_ONE;
612 return av_store(*avp, 0, val);
616 =for apidoc av_unshift
618 Unshift the given number of C<undef> values onto the beginning of the
619 array. The array will grow automatically to accommodate the addition. You
620 must then use C<av_store> to assign values to these new elements.
626 Perl_av_unshift(pTHX_ register AV *av, register I32 num)
632 PERL_ARGS_ASSERT_AV_UNSHIFT;
633 assert(SvTYPE(av) == SVt_PVAV);
636 Perl_croak(aTHX_ "%s", PL_no_modify);
638 if ((mg = SvTIED_mg((const SV *)av, PERL_MAGIC_tied))) {
639 Perl_magic_methcall(aTHX_ MUTABLE_SV(av), mg, "UNSHIFT",
640 G_DISCARD | G_UNDEF_FILL, num);
646 if (!AvREAL(av) && AvREIFY(av))
648 i = AvARRAY(av) - AvALLOC(av);
656 AvARRAY(av) = AvARRAY(av) - i;
660 const I32 i = AvFILLp(av);
661 /* Create extra elements */
662 const I32 slide = i > 0 ? i : 0;
664 av_extend(av, i + num);
667 Move(ary, ary + num, i + 1, SV*);
669 ary[--num] = &PL_sv_undef;
671 /* Make extra elements into a buffer */
673 AvFILLp(av) -= slide;
674 AvARRAY(av) = AvARRAY(av) + slide;
681 Shifts an SV off the beginning of the array. Returns C<&PL_sv_undef> if the
688 Perl_av_shift(pTHX_ register AV *av)
694 PERL_ARGS_ASSERT_AV_SHIFT;
695 assert(SvTYPE(av) == SVt_PVAV);
698 Perl_croak(aTHX_ "%s", PL_no_modify);
699 if ((mg = SvTIED_mg((const SV *)av, PERL_MAGIC_tied))) {
700 retval = Perl_magic_methcall(aTHX_ MUTABLE_SV(av), mg, "SHIFT", 0, 0);
702 retval = newSVsv(retval);
707 retval = *AvARRAY(av);
709 *AvARRAY(av) = &PL_sv_undef;
710 AvARRAY(av) = AvARRAY(av) + 1;
714 mg_set(MUTABLE_SV(av));
721 Returns the highest index in the array. The number of elements in the
722 array is C<av_len(av) + 1>. Returns -1 if the array is empty.
728 Perl_av_len(pTHX_ AV *av)
730 PERL_ARGS_ASSERT_AV_LEN;
731 assert(SvTYPE(av) == SVt_PVAV);
739 Set the highest index in the array to the given number, equivalent to
740 Perl's C<$#array = $fill;>.
742 The number of elements in the an array will be C<fill + 1> after
743 av_fill() returns. If the array was previously shorter then the
744 additional elements appended are set to C<PL_sv_undef>. If the array
745 was longer, then the excess elements are freed. C<av_fill(av, -1)> is
746 the same as C<av_clear(av)>.
751 Perl_av_fill(pTHX_ register AV *av, I32 fill)
756 PERL_ARGS_ASSERT_AV_FILL;
757 assert(SvTYPE(av) == SVt_PVAV);
761 if ((mg = SvTIED_mg((const SV *)av, PERL_MAGIC_tied))) {
762 SV *arg1 = sv_newmortal();
763 sv_setiv(arg1, (IV)(fill + 1));
764 Perl_magic_methcall(aTHX_ MUTABLE_SV(av), mg, "STORESIZE", G_DISCARD,
768 if (fill <= AvMAX(av)) {
769 I32 key = AvFILLp(av);
770 SV** const ary = AvARRAY(av);
774 SvREFCNT_dec(ary[key]);
775 ary[key--] = &PL_sv_undef;
780 ary[++key] = &PL_sv_undef;
785 mg_set(MUTABLE_SV(av));
788 (void)av_store(av,fill,&PL_sv_undef);
792 =for apidoc av_delete
794 Deletes the element indexed by C<key> from the array. Returns the
795 deleted element. If C<flags> equals C<G_DISCARD>, the element is freed
796 and null is returned. Perl equivalent: C<my $elem = delete($myarray[$idx]);>
797 for the non-C<G_DISCARD> version and a void-context C<delete($myarray[$idx]);>
798 for the C<G_DISCARD> version.
803 Perl_av_delete(pTHX_ AV *av, I32 key, I32 flags)
808 PERL_ARGS_ASSERT_AV_DELETE;
809 assert(SvTYPE(av) == SVt_PVAV);
812 Perl_croak(aTHX_ "%s", PL_no_modify);
814 if (SvRMAGICAL(av)) {
815 const MAGIC * const tied_magic
816 = mg_find((const SV *)av, PERL_MAGIC_tied);
817 if ((tied_magic || mg_find((const SV *)av, PERL_MAGIC_regdata))) {
818 /* Handle negative array indices 20020222 MJD */
821 unsigned adjust_index = 1;
823 SV * const * const negative_indices_glob =
824 hv_fetch(SvSTASH(SvRV(SvTIED_obj(MUTABLE_SV(av),
826 NEGATIVE_INDICES_VAR, 16, 0);
827 if (negative_indices_glob
828 && SvTRUE(GvSV(*negative_indices_glob)))
832 key += AvFILL(av) + 1;
837 svp = av_fetch(av, key, TRUE);
841 if (mg_find(sv, PERL_MAGIC_tiedelem)) {
842 sv_unmagic(sv, PERL_MAGIC_tiedelem); /* No longer an element */
851 key += AvFILL(av) + 1;
856 if (key > AvFILLp(av))
859 if (!AvREAL(av) && AvREIFY(av))
861 sv = AvARRAY(av)[key];
862 if (key == AvFILLp(av)) {
863 AvARRAY(av)[key] = &PL_sv_undef;
866 } while (--key >= 0 && AvARRAY(av)[key] == &PL_sv_undef);
869 AvARRAY(av)[key] = &PL_sv_undef;
871 mg_set(MUTABLE_SV(av));
873 if (flags & G_DISCARD) {
883 =for apidoc av_exists
885 Returns true if the element indexed by C<key> has been initialized.
887 This relies on the fact that uninitialized array elements are set to
890 Perl equivalent: C<exists($myarray[$key])>.
895 Perl_av_exists(pTHX_ AV *av, I32 key)
898 PERL_ARGS_ASSERT_AV_EXISTS;
899 assert(SvTYPE(av) == SVt_PVAV);
901 if (SvRMAGICAL(av)) {
902 const MAGIC * const tied_magic
903 = mg_find((const SV *)av, PERL_MAGIC_tied);
904 if (tied_magic || mg_find((const SV *)av, PERL_MAGIC_regdata)) {
905 SV * const sv = sv_newmortal();
907 /* Handle negative array indices 20020222 MJD */
909 unsigned adjust_index = 1;
911 SV * const * const negative_indices_glob =
912 hv_fetch(SvSTASH(SvRV(SvTIED_obj(MUTABLE_SV(av),
914 NEGATIVE_INDICES_VAR, 16, 0);
915 if (negative_indices_glob
916 && SvTRUE(GvSV(*negative_indices_glob)))
920 key += AvFILL(av) + 1;
926 mg_copy(MUTABLE_SV(av), sv, 0, key);
927 mg = mg_find(sv, PERL_MAGIC_tiedelem);
929 magic_existspack(sv, mg);
930 return cBOOL(SvTRUE(sv));
937 key += AvFILL(av) + 1;
942 if (key <= AvFILLp(av) && AvARRAY(av)[key] != &PL_sv_undef
952 S_get_aux_mg(pTHX_ AV *av) {
956 PERL_ARGS_ASSERT_GET_AUX_MG;
957 assert(SvTYPE(av) == SVt_PVAV);
959 mg = mg_find((const SV *)av, PERL_MAGIC_arylen_p);
962 mg = sv_magicext(MUTABLE_SV(av), 0, PERL_MAGIC_arylen_p,
963 &PL_vtbl_arylen_p, 0, 0);
965 /* sv_magicext won't set this for us because we pass in a NULL obj */
966 mg->mg_flags |= MGf_REFCOUNTED;
972 Perl_av_arylen_p(pTHX_ AV *av) {
973 MAGIC *const mg = get_aux_mg(av);
975 PERL_ARGS_ASSERT_AV_ARYLEN_P;
976 assert(SvTYPE(av) == SVt_PVAV);
978 return &(mg->mg_obj);
982 Perl_av_iter_p(pTHX_ AV *av) {
983 MAGIC *const mg = get_aux_mg(av);
985 PERL_ARGS_ASSERT_AV_ITER_P;
986 assert(SvTYPE(av) == SVt_PVAV);
988 #if IVSIZE == I32SIZE
989 return (IV *)&(mg->mg_len);
995 mg->mg_ptr = (char *) temp;
997 return (IV *)mg->mg_ptr;
1003 * c-indentation-style: bsd
1005 * indent-tabs-mode: t
1008 * ex: set ts=8 sts=4 sw=4 noet: