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 C<lval> is set then the fetch will be part of a store. Check
195 that the return value is non-null before dereferencing it to a C<SV*>.
197 See L<perlguts/"Understanding the Magic of Tied Hashes and Arrays"> for
198 more information on how to use this function on tied arrays.
204 Perl_av_fetch(pTHX_ register AV *av, I32 key, I32 lval)
208 PERL_ARGS_ASSERT_AV_FETCH;
209 assert(SvTYPE(av) == SVt_PVAV);
211 if (SvRMAGICAL(av)) {
212 const MAGIC * const tied_magic
213 = mg_find((const SV *)av, PERL_MAGIC_tied);
214 if (tied_magic || mg_find((const SV *)av, PERL_MAGIC_regdata)) {
217 I32 adjust_index = 1;
219 /* Handle negative array indices 20020222 MJD */
220 SV * const * const negative_indices_glob =
221 hv_fetch(SvSTASH(SvRV(SvTIED_obj(MUTABLE_SV(av),
223 NEGATIVE_INDICES_VAR, 16, 0);
225 if (negative_indices_glob && SvTRUE(GvSV(*negative_indices_glob)))
230 key += AvFILL(av) + 1;
237 sv_upgrade(sv, SVt_PVLV);
238 mg_copy(MUTABLE_SV(av), sv, 0, key);
239 if (!tied_magic) /* for regdata, force leavesub to make copies */
242 LvTARG(sv) = sv; /* fake (SV**) */
243 return &(LvTARG(sv));
248 key += AvFILL(av) + 1;
253 if (key > AvFILLp(av)) {
256 return av_store(av,key,newSV(0));
258 if (AvARRAY(av)[key] == &PL_sv_undef) {
261 return av_store(av,key,newSV(0));
265 && (!AvARRAY(av)[key] /* eg. @_ could have freed elts */
266 || SvIS_FREED(AvARRAY(av)[key]))) {
267 AvARRAY(av)[key] = &PL_sv_undef; /* 1/2 reify */
270 return &AvARRAY(av)[key];
276 Stores an SV in an array. The array index is specified as C<key>. The
277 return value will be NULL if the operation failed or if the value did not
278 need to be actually stored within the array (as in the case of tied
279 arrays). Otherwise it can be dereferenced to get the original C<SV*>. Note
280 that the caller is responsible for suitably incrementing the reference
281 count of C<val> before the call, and decrementing it if the function
284 See L<perlguts/"Understanding the Magic of Tied Hashes and Arrays"> for
285 more information on how to use this function on tied arrays.
291 Perl_av_store(pTHX_ register AV *av, I32 key, SV *val)
296 PERL_ARGS_ASSERT_AV_STORE;
297 assert(SvTYPE(av) == SVt_PVAV);
299 /* S_regclass relies on being able to pass in a NULL sv
300 (unicode_alternate may be NULL).
306 if (SvRMAGICAL(av)) {
307 const MAGIC * const tied_magic = mg_find((const SV *)av, PERL_MAGIC_tied);
309 /* Handle negative array indices 20020222 MJD */
311 bool adjust_index = 1;
312 SV * const * const negative_indices_glob =
313 hv_fetch(SvSTASH(SvRV(SvTIED_obj(MUTABLE_SV(av),
315 NEGATIVE_INDICES_VAR, 16, 0);
316 if (negative_indices_glob
317 && SvTRUE(GvSV(*negative_indices_glob)))
320 key += AvFILL(av) + 1;
325 if (val != &PL_sv_undef) {
326 mg_copy(MUTABLE_SV(av), val, 0, key);
334 key += AvFILL(av) + 1;
339 if (SvREADONLY(av) && key >= AvFILL(av))
340 Perl_croak(aTHX_ "%s", PL_no_modify);
342 if (!AvREAL(av) && AvREIFY(av))
347 if (AvFILLp(av) < key) {
349 if (av == PL_curstack && key > PL_stack_sp - PL_stack_base)
350 PL_stack_sp = PL_stack_base + key; /* XPUSH in disguise */
352 ary[++AvFILLp(av)] = &PL_sv_undef;
353 } while (AvFILLp(av) < key);
358 SvREFCNT_dec(ary[key]);
360 if (SvSMAGICAL(av)) {
361 const MAGIC* const mg = SvMAGIC(av);
362 if (val != &PL_sv_undef) {
363 sv_magic(val, MUTABLE_SV(av), toLOWER(mg->mg_type), 0, key);
365 if (PL_delaymagic && mg->mg_type == PERL_MAGIC_isa)
366 PL_delaymagic |= DM_ARRAY;
368 mg_set(MUTABLE_SV(av));
376 Creates a new AV and populates it with a list of SVs. The SVs are copied
377 into the array, so they may be freed after the call to av_make. The new AV
378 will have a reference count of 1.
384 Perl_av_make(pTHX_ register I32 size, register SV **strp)
386 register AV * const av = MUTABLE_AV(newSV_type(SVt_PVAV));
387 /* sv_upgrade does AvREAL_only() */
388 PERL_ARGS_ASSERT_AV_MAKE;
389 assert(SvTYPE(av) == SVt_PVAV);
391 if (size) { /* "defined" was returning undef for size==0 anyway. */
397 AvFILLp(av) = AvMAX(av) = size - 1;
398 for (i = 0; i < size; i++) {
401 /* Don't let sv_setsv swipe, since our source array might
402 have multiple references to the same temp scalar (e.g.
403 from a list slice) */
406 sv_setsv_flags(ary[i], *strp,
407 SV_GMAGIC|SV_DO_COW_SVSETSV|SV_NOSTEAL);
417 Clears an array, making it empty. Does not free the memory used by the
424 Perl_av_clear(pTHX_ register AV *av)
429 PERL_ARGS_ASSERT_AV_CLEAR;
430 assert(SvTYPE(av) == SVt_PVAV);
433 if (SvREFCNT(av) == 0) {
434 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEBUGGING), "Attempt to clear deleted array");
439 Perl_croak(aTHX_ "%s", PL_no_modify);
441 /* Give any tie a chance to cleanup first */
442 if (SvRMAGICAL(av)) {
443 const MAGIC* const mg = SvMAGIC(av);
444 if (PL_delaymagic && mg && mg->mg_type == PERL_MAGIC_isa)
445 PL_delaymagic |= DM_ARRAY;
447 mg_clear(MUTABLE_SV(av));
454 SV** const ary = AvARRAY(av);
455 I32 index = AvFILLp(av) + 1;
457 SV * const sv = ary[--index];
458 /* undef the slot before freeing the value, because a
459 * destructor might try to modify this array */
460 ary[index] = &PL_sv_undef;
464 extra = AvARRAY(av) - AvALLOC(av);
467 AvARRAY(av) = AvALLOC(av);
476 Undefines the array. Frees the memory used by the array itself.
482 Perl_av_undef(pTHX_ register AV *av)
484 PERL_ARGS_ASSERT_AV_UNDEF;
485 assert(SvTYPE(av) == SVt_PVAV);
487 /* Give any tie a chance to cleanup first */
488 if (SvTIED_mg((const SV *)av, PERL_MAGIC_tied))
492 register I32 key = AvFILLp(av) + 1;
494 SvREFCNT_dec(AvARRAY(av)[--key]);
497 Safefree(AvALLOC(av));
500 AvMAX(av) = AvFILLp(av) = -1;
502 if(SvRMAGICAL(av)) mg_clear(MUTABLE_SV(av));
507 =for apidoc av_create_and_push
509 Push an SV onto the end of the array, creating the array if necessary.
510 A small internal helper function to remove a commonly duplicated idiom.
516 Perl_av_create_and_push(pTHX_ AV **const avp, SV *const val)
518 PERL_ARGS_ASSERT_AV_CREATE_AND_PUSH;
528 Pushes an SV onto the end of the array. The array will grow automatically
529 to accommodate the addition. Like C<av_store>, this takes ownership of one
536 Perl_av_push(pTHX_ register AV *av, SV *val)
541 PERL_ARGS_ASSERT_AV_PUSH;
542 assert(SvTYPE(av) == SVt_PVAV);
545 Perl_croak(aTHX_ "%s", PL_no_modify);
547 if ((mg = SvTIED_mg((const SV *)av, PERL_MAGIC_tied))) {
548 Perl_magic_methcall(aTHX_ MUTABLE_SV(av), mg, "PUSH", G_DISCARD, 1,
552 av_store(av,AvFILLp(av)+1,val);
558 Pops an SV off the end of the array. Returns C<&PL_sv_undef> if the array
565 Perl_av_pop(pTHX_ register AV *av)
571 PERL_ARGS_ASSERT_AV_POP;
572 assert(SvTYPE(av) == SVt_PVAV);
575 Perl_croak(aTHX_ "%s", PL_no_modify);
576 if ((mg = SvTIED_mg((const SV *)av, PERL_MAGIC_tied))) {
577 retval = Perl_magic_methcall(aTHX_ MUTABLE_SV(av), mg, "POP", 0, 0);
579 retval = newSVsv(retval);
584 retval = AvARRAY(av)[AvFILLp(av)];
585 AvARRAY(av)[AvFILLp(av)--] = &PL_sv_undef;
587 mg_set(MUTABLE_SV(av));
593 =for apidoc av_create_and_unshift_one
595 Unshifts an SV onto the beginning of the array, creating the array if
597 A small internal helper function to remove a commonly duplicated idiom.
603 Perl_av_create_and_unshift_one(pTHX_ AV **const avp, SV *const val)
605 PERL_ARGS_ASSERT_AV_CREATE_AND_UNSHIFT_ONE;
610 return av_store(*avp, 0, val);
614 =for apidoc av_unshift
616 Unshift the given number of C<undef> values onto the beginning of the
617 array. The array will grow automatically to accommodate the addition. You
618 must then use C<av_store> to assign values to these new elements.
624 Perl_av_unshift(pTHX_ register AV *av, register I32 num)
630 PERL_ARGS_ASSERT_AV_UNSHIFT;
631 assert(SvTYPE(av) == SVt_PVAV);
634 Perl_croak(aTHX_ "%s", PL_no_modify);
636 if ((mg = SvTIED_mg((const SV *)av, PERL_MAGIC_tied))) {
637 Perl_magic_methcall(aTHX_ MUTABLE_SV(av), mg, "UNSHIFT",
638 G_DISCARD | G_UNDEF_FILL, num);
644 if (!AvREAL(av) && AvREIFY(av))
646 i = AvARRAY(av) - AvALLOC(av);
654 AvARRAY(av) = AvARRAY(av) - i;
658 const I32 i = AvFILLp(av);
659 /* Create extra elements */
660 const I32 slide = i > 0 ? i : 0;
662 av_extend(av, i + num);
665 Move(ary, ary + num, i + 1, SV*);
667 ary[--num] = &PL_sv_undef;
669 /* Make extra elements into a buffer */
671 AvFILLp(av) -= slide;
672 AvARRAY(av) = AvARRAY(av) + slide;
679 Shifts an SV off the beginning of the array. Returns C<&PL_sv_undef> if the
686 Perl_av_shift(pTHX_ register AV *av)
692 PERL_ARGS_ASSERT_AV_SHIFT;
693 assert(SvTYPE(av) == SVt_PVAV);
696 Perl_croak(aTHX_ "%s", PL_no_modify);
697 if ((mg = SvTIED_mg((const SV *)av, PERL_MAGIC_tied))) {
698 retval = Perl_magic_methcall(aTHX_ MUTABLE_SV(av), mg, "SHIFT", 0, 0);
700 retval = newSVsv(retval);
705 retval = *AvARRAY(av);
707 *AvARRAY(av) = &PL_sv_undef;
708 AvARRAY(av) = AvARRAY(av) + 1;
712 mg_set(MUTABLE_SV(av));
719 Returns the highest index in the array. The number of elements in the
720 array is C<av_len(av) + 1>. Returns -1 if the array is empty.
726 Perl_av_len(pTHX_ AV *av)
728 PERL_ARGS_ASSERT_AV_LEN;
729 assert(SvTYPE(av) == SVt_PVAV);
737 Set the highest index in the array to the given number, equivalent to
738 Perl's C<$#array = $fill;>.
740 The number of elements in the an array will be C<fill + 1> after
741 av_fill() returns. If the array was previously shorter then the
742 additional elements appended are set to C<PL_sv_undef>. If the array
743 was longer, then the excess elements are freed. C<av_fill(av, -1)> is
744 the same as C<av_clear(av)>.
749 Perl_av_fill(pTHX_ register AV *av, I32 fill)
754 PERL_ARGS_ASSERT_AV_FILL;
755 assert(SvTYPE(av) == SVt_PVAV);
759 if ((mg = SvTIED_mg((const SV *)av, PERL_MAGIC_tied))) {
760 SV *arg1 = sv_newmortal();
761 sv_setiv(arg1, (IV)(fill + 1));
762 Perl_magic_methcall(aTHX_ MUTABLE_SV(av), mg, "STORESIZE", G_DISCARD,
766 if (fill <= AvMAX(av)) {
767 I32 key = AvFILLp(av);
768 SV** const ary = AvARRAY(av);
772 SvREFCNT_dec(ary[key]);
773 ary[key--] = &PL_sv_undef;
778 ary[++key] = &PL_sv_undef;
783 mg_set(MUTABLE_SV(av));
786 (void)av_store(av,fill,&PL_sv_undef);
790 =for apidoc av_delete
792 Deletes the element indexed by C<key> from the array. Returns the
793 deleted element. If C<flags> equals C<G_DISCARD>, the element is freed
794 and null is returned.
799 Perl_av_delete(pTHX_ AV *av, I32 key, I32 flags)
804 PERL_ARGS_ASSERT_AV_DELETE;
805 assert(SvTYPE(av) == SVt_PVAV);
808 Perl_croak(aTHX_ "%s", PL_no_modify);
810 if (SvRMAGICAL(av)) {
811 const MAGIC * const tied_magic
812 = mg_find((const SV *)av, PERL_MAGIC_tied);
813 if ((tied_magic || mg_find((const SV *)av, PERL_MAGIC_regdata))) {
814 /* Handle negative array indices 20020222 MJD */
817 unsigned adjust_index = 1;
819 SV * const * const negative_indices_glob =
820 hv_fetch(SvSTASH(SvRV(SvTIED_obj(MUTABLE_SV(av),
822 NEGATIVE_INDICES_VAR, 16, 0);
823 if (negative_indices_glob
824 && SvTRUE(GvSV(*negative_indices_glob)))
828 key += AvFILL(av) + 1;
833 svp = av_fetch(av, key, TRUE);
837 if (mg_find(sv, PERL_MAGIC_tiedelem)) {
838 sv_unmagic(sv, PERL_MAGIC_tiedelem); /* No longer an element */
847 key += AvFILL(av) + 1;
852 if (key > AvFILLp(av))
855 if (!AvREAL(av) && AvREIFY(av))
857 sv = AvARRAY(av)[key];
858 if (key == AvFILLp(av)) {
859 AvARRAY(av)[key] = &PL_sv_undef;
862 } while (--key >= 0 && AvARRAY(av)[key] == &PL_sv_undef);
865 AvARRAY(av)[key] = &PL_sv_undef;
867 mg_set(MUTABLE_SV(av));
869 if (flags & G_DISCARD) {
879 =for apidoc av_exists
881 Returns true if the element indexed by C<key> has been initialized.
883 This relies on the fact that uninitialized array elements are set to
889 Perl_av_exists(pTHX_ AV *av, I32 key)
892 PERL_ARGS_ASSERT_AV_EXISTS;
893 assert(SvTYPE(av) == SVt_PVAV);
895 if (SvRMAGICAL(av)) {
896 const MAGIC * const tied_magic
897 = mg_find((const SV *)av, PERL_MAGIC_tied);
898 if (tied_magic || mg_find((const SV *)av, PERL_MAGIC_regdata)) {
899 SV * const sv = sv_newmortal();
901 /* Handle negative array indices 20020222 MJD */
903 unsigned adjust_index = 1;
905 SV * const * const negative_indices_glob =
906 hv_fetch(SvSTASH(SvRV(SvTIED_obj(MUTABLE_SV(av),
908 NEGATIVE_INDICES_VAR, 16, 0);
909 if (negative_indices_glob
910 && SvTRUE(GvSV(*negative_indices_glob)))
914 key += AvFILL(av) + 1;
920 mg_copy(MUTABLE_SV(av), sv, 0, key);
921 mg = mg_find(sv, PERL_MAGIC_tiedelem);
923 magic_existspack(sv, mg);
924 return cBOOL(SvTRUE(sv));
931 key += AvFILL(av) + 1;
936 if (key <= AvFILLp(av) && AvARRAY(av)[key] != &PL_sv_undef
946 S_get_aux_mg(pTHX_ AV *av) {
950 PERL_ARGS_ASSERT_GET_AUX_MG;
951 assert(SvTYPE(av) == SVt_PVAV);
953 mg = mg_find((const SV *)av, PERL_MAGIC_arylen_p);
956 mg = sv_magicext(MUTABLE_SV(av), 0, PERL_MAGIC_arylen_p,
957 &PL_vtbl_arylen_p, 0, 0);
959 /* sv_magicext won't set this for us because we pass in a NULL obj */
960 mg->mg_flags |= MGf_REFCOUNTED;
966 Perl_av_arylen_p(pTHX_ AV *av) {
967 MAGIC *const mg = get_aux_mg(av);
969 PERL_ARGS_ASSERT_AV_ARYLEN_P;
970 assert(SvTYPE(av) == SVt_PVAV);
972 return &(mg->mg_obj);
976 Perl_av_iter_p(pTHX_ AV *av) {
977 MAGIC *const mg = get_aux_mg(av);
979 PERL_ARGS_ASSERT_AV_ITER_P;
980 assert(SvTYPE(av) == SVt_PVAV);
982 #if IVSIZE == I32SIZE
983 return (IV *)&(mg->mg_len);
989 mg->mg_ptr = (char *) temp;
991 return (IV *)mg->mg_ptr;
997 * c-indentation-style: bsd
999 * indent-tabs-mode: t
1002 * ex: set ts=8 sts=4 sw=4 noet: