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*);
153 Safefree(AvALLOC(av));
156 #ifdef Perl_safesysmalloc_size
159 ary = AvALLOC(av) + AvMAX(av) + 1;
160 tmp = newmax - AvMAX(av);
161 if (av == PL_curstack) { /* Oops, grew stack (via av_store()?) */
162 PL_stack_sp = AvALLOC(av) + (PL_stack_sp - PL_stack_base);
163 PL_stack_base = AvALLOC(av);
164 PL_stack_max = PL_stack_base + newmax;
168 newmax = key < 3 ? 3 : key;
169 MEM_WRAP_CHECK_1(newmax+1, SV*, oom_array_extend);
170 Newx(AvALLOC(av), newmax+1, SV*);
171 ary = AvALLOC(av) + 1;
173 AvALLOC(av)[0] = &PL_sv_undef; /* For the stacks */
177 ary[--tmp] = &PL_sv_undef;
180 AvARRAY(av) = AvALLOC(av);
189 Returns the SV at the specified index in the array. The C<key> is the
190 index. If lval is true, you are guaranteed to get a real SV back (in case
191 it wasn't real before), which you can then modify. Check that the return
192 value is non-null before dereferencing it to a C<SV*>.
194 See L<perlguts/"Understanding the Magic of Tied Hashes and Arrays"> for
195 more information on how to use this function on tied arrays.
197 The rough perl equivalent is C<$myarray[$idx]>.
203 Perl_av_fetch(pTHX_ register AV *av, I32 key, I32 lval)
207 PERL_ARGS_ASSERT_AV_FETCH;
208 assert(SvTYPE(av) == SVt_PVAV);
210 if (SvRMAGICAL(av)) {
211 const MAGIC * const tied_magic
212 = mg_find((const SV *)av, PERL_MAGIC_tied);
213 if (tied_magic || mg_find((const SV *)av, PERL_MAGIC_regdata)) {
216 I32 adjust_index = 1;
218 /* Handle negative array indices 20020222 MJD */
219 SV * const * const negative_indices_glob =
220 hv_fetch(SvSTASH(SvRV(SvTIED_obj(MUTABLE_SV(av),
222 NEGATIVE_INDICES_VAR, 16, 0);
224 if (negative_indices_glob && SvTRUE(GvSV(*negative_indices_glob)))
229 key += AvFILL(av) + 1;
236 sv_upgrade(sv, SVt_PVLV);
237 mg_copy(MUTABLE_SV(av), sv, 0, key);
238 if (!tied_magic) /* for regdata, force leavesub to make copies */
241 LvTARG(sv) = sv; /* fake (SV**) */
242 return &(LvTARG(sv));
247 key += AvFILL(av) + 1;
252 if (key > AvFILLp(av)) {
255 return av_store(av,key,newSV(0));
257 if (AvARRAY(av)[key] == &PL_sv_undef) {
260 return av_store(av,key,newSV(0));
264 && (!AvARRAY(av)[key] /* eg. @_ could have freed elts */
265 || SvIS_FREED(AvARRAY(av)[key]))) {
266 AvARRAY(av)[key] = &PL_sv_undef; /* 1/2 reify */
269 return &AvARRAY(av)[key];
275 Stores an SV in an array. The array index is specified as C<key>. The
276 return value will be NULL if the operation failed or if the value did not
277 need to be actually stored within the array (as in the case of tied
278 arrays). Otherwise, it can be dereferenced to get the C<SV*> that was stored
281 Note that the caller is responsible for suitably incrementing the reference
282 count of C<val> before the call, and decrementing it if the function
285 Approximate Perl equivalent: C<$myarray[$key] = $val;>.
287 See L<perlguts/"Understanding the Magic of Tied Hashes and Arrays"> for
288 more information on how to use this function on tied arrays.
294 Perl_av_store(pTHX_ register AV *av, I32 key, SV *val)
299 PERL_ARGS_ASSERT_AV_STORE;
300 assert(SvTYPE(av) == SVt_PVAV);
302 /* S_regclass relies on being able to pass in a NULL sv
303 (unicode_alternate may be NULL).
309 if (SvRMAGICAL(av)) {
310 const MAGIC * const tied_magic = mg_find((const SV *)av, PERL_MAGIC_tied);
312 /* Handle negative array indices 20020222 MJD */
314 bool adjust_index = 1;
315 SV * const * const negative_indices_glob =
316 hv_fetch(SvSTASH(SvRV(SvTIED_obj(MUTABLE_SV(av),
318 NEGATIVE_INDICES_VAR, 16, 0);
319 if (negative_indices_glob
320 && SvTRUE(GvSV(*negative_indices_glob)))
323 key += AvFILL(av) + 1;
328 if (val != &PL_sv_undef) {
329 mg_copy(MUTABLE_SV(av), val, 0, key);
337 key += AvFILL(av) + 1;
342 if (SvREADONLY(av) && key >= AvFILL(av))
343 Perl_croak_no_modify(aTHX);
345 if (!AvREAL(av) && AvREIFY(av))
350 if (AvFILLp(av) < key) {
352 if (av == PL_curstack && key > PL_stack_sp - PL_stack_base)
353 PL_stack_sp = PL_stack_base + key; /* XPUSH in disguise */
355 ary[++AvFILLp(av)] = &PL_sv_undef;
356 } while (AvFILLp(av) < key);
361 SvREFCNT_dec(ary[key]);
363 if (SvSMAGICAL(av)) {
364 const MAGIC* const mg = SvMAGIC(av);
365 if (val != &PL_sv_undef) {
366 sv_magic(val, MUTABLE_SV(av), toLOWER(mg->mg_type), 0, key);
368 if (PL_delaymagic && mg->mg_type == PERL_MAGIC_isa)
369 PL_delaymagic |= DM_ARRAY_ISA;
371 mg_set(MUTABLE_SV(av));
379 Creates a new AV and populates it with a list of SVs. The SVs are copied
380 into the array, so they may be freed after the call to av_make. The new AV
381 will have a reference count of 1.
383 Perl equivalent: C<my @new_array = ($scalar1, $scalar2, $scalar3...);>
389 Perl_av_make(pTHX_ register I32 size, register SV **strp)
391 register AV * const av = MUTABLE_AV(newSV_type(SVt_PVAV));
392 /* sv_upgrade does AvREAL_only() */
393 PERL_ARGS_ASSERT_AV_MAKE;
394 assert(SvTYPE(av) == SVt_PVAV);
396 if (size) { /* "defined" was returning undef for size==0 anyway. */
402 AvFILLp(av) = AvMAX(av) = size - 1;
403 for (i = 0; i < size; i++) {
406 /* Don't let sv_setsv swipe, since our source array might
407 have multiple references to the same temp scalar (e.g.
408 from a list slice) */
411 sv_setsv_flags(ary[i], *strp,
412 SV_GMAGIC|SV_DO_COW_SVSETSV|SV_NOSTEAL);
422 Clears an array, making it empty. Does not free the memory used by the
423 array itself. Perl equivalent: C<@myarray = ();>.
429 Perl_av_clear(pTHX_ register AV *av)
434 PERL_ARGS_ASSERT_AV_CLEAR;
435 assert(SvTYPE(av) == SVt_PVAV);
438 if (SvREFCNT(av) == 0) {
439 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEBUGGING), "Attempt to clear deleted array");
444 Perl_croak_no_modify(aTHX);
446 /* Give any tie a chance to cleanup first */
447 if (SvRMAGICAL(av)) {
448 const MAGIC* const mg = SvMAGIC(av);
449 if (PL_delaymagic && mg && mg->mg_type == PERL_MAGIC_isa)
450 PL_delaymagic |= DM_ARRAY_ISA;
452 mg_clear(MUTABLE_SV(av));
459 SV** const ary = AvARRAY(av);
460 I32 index = AvFILLp(av) + 1;
462 SV * const sv = ary[--index];
463 /* undef the slot before freeing the value, because a
464 * destructor might try to modify this array */
465 ary[index] = &PL_sv_undef;
469 extra = AvARRAY(av) - AvALLOC(av);
472 AvARRAY(av) = AvALLOC(av);
481 Undefines the array. Frees the memory used by the array itself.
487 Perl_av_undef(pTHX_ register AV *av)
489 PERL_ARGS_ASSERT_AV_UNDEF;
490 assert(SvTYPE(av) == SVt_PVAV);
492 /* Give any tie a chance to cleanup first */
493 if (SvTIED_mg((const SV *)av, PERL_MAGIC_tied))
497 register I32 key = AvFILLp(av) + 1;
499 SvREFCNT_dec(AvARRAY(av)[--key]);
502 Safefree(AvALLOC(av));
505 AvMAX(av) = AvFILLp(av) = -1;
507 if(SvRMAGICAL(av)) mg_clear(MUTABLE_SV(av));
512 =for apidoc av_create_and_push
514 Push an SV onto the end of the array, creating the array if necessary.
515 A small internal helper function to remove a commonly duplicated idiom.
521 Perl_av_create_and_push(pTHX_ AV **const avp, SV *const val)
523 PERL_ARGS_ASSERT_AV_CREATE_AND_PUSH;
533 Pushes an SV onto the end of the array. The array will grow automatically
534 to accommodate the addition. This takes ownership of one reference count.
536 Perl equivalent: C<push @myarray, $elem;>.
542 Perl_av_push(pTHX_ register AV *av, SV *val)
547 PERL_ARGS_ASSERT_AV_PUSH;
548 assert(SvTYPE(av) == SVt_PVAV);
551 Perl_croak_no_modify(aTHX);
553 if ((mg = SvTIED_mg((const SV *)av, PERL_MAGIC_tied))) {
554 Perl_magic_methcall(aTHX_ MUTABLE_SV(av), mg, "PUSH", G_DISCARD, 1,
558 av_store(av,AvFILLp(av)+1,val);
564 Pops an SV off the end of the array. Returns C<&PL_sv_undef> if the array
567 Perl equivalent: C<pop(@myarray);>
573 Perl_av_pop(pTHX_ register AV *av)
579 PERL_ARGS_ASSERT_AV_POP;
580 assert(SvTYPE(av) == SVt_PVAV);
583 Perl_croak_no_modify(aTHX);
584 if ((mg = SvTIED_mg((const SV *)av, PERL_MAGIC_tied))) {
585 retval = Perl_magic_methcall(aTHX_ MUTABLE_SV(av), mg, "POP", 0, 0);
587 retval = newSVsv(retval);
592 retval = AvARRAY(av)[AvFILLp(av)];
593 AvARRAY(av)[AvFILLp(av)--] = &PL_sv_undef;
595 mg_set(MUTABLE_SV(av));
601 =for apidoc av_create_and_unshift_one
603 Unshifts an SV onto the beginning of the array, creating the array if
605 A small internal helper function to remove a commonly duplicated idiom.
611 Perl_av_create_and_unshift_one(pTHX_ AV **const avp, SV *const val)
613 PERL_ARGS_ASSERT_AV_CREATE_AND_UNSHIFT_ONE;
618 return av_store(*avp, 0, val);
622 =for apidoc av_unshift
624 Unshift the given number of C<undef> values onto the beginning of the
625 array. The array will grow automatically to accommodate the addition. You
626 must then use C<av_store> to assign values to these new elements.
628 Perl equivalent: C<unshift @myarray, ( (undef) x $n );>
634 Perl_av_unshift(pTHX_ register AV *av, register I32 num)
640 PERL_ARGS_ASSERT_AV_UNSHIFT;
641 assert(SvTYPE(av) == SVt_PVAV);
644 Perl_croak_no_modify(aTHX);
646 if ((mg = SvTIED_mg((const SV *)av, PERL_MAGIC_tied))) {
647 Perl_magic_methcall(aTHX_ MUTABLE_SV(av), mg, "UNSHIFT",
648 G_DISCARD | G_UNDEF_FILL, num);
654 if (!AvREAL(av) && AvREIFY(av))
656 i = AvARRAY(av) - AvALLOC(av);
664 AvARRAY(av) = AvARRAY(av) - i;
668 const I32 i = AvFILLp(av);
669 /* Create extra elements */
670 const I32 slide = i > 0 ? i : 0;
672 av_extend(av, i + num);
675 Move(ary, ary + num, i + 1, SV*);
677 ary[--num] = &PL_sv_undef;
679 /* Make extra elements into a buffer */
681 AvFILLp(av) -= slide;
682 AvARRAY(av) = AvARRAY(av) + slide;
689 Shifts an SV off the beginning of the array. Returns C<&PL_sv_undef> if the
692 Perl equivalent: C<shift(@myarray);>
698 Perl_av_shift(pTHX_ register AV *av)
704 PERL_ARGS_ASSERT_AV_SHIFT;
705 assert(SvTYPE(av) == SVt_PVAV);
708 Perl_croak_no_modify(aTHX);
709 if ((mg = SvTIED_mg((const SV *)av, PERL_MAGIC_tied))) {
710 retval = Perl_magic_methcall(aTHX_ MUTABLE_SV(av), mg, "SHIFT", 0, 0);
712 retval = newSVsv(retval);
717 retval = *AvARRAY(av);
719 *AvARRAY(av) = &PL_sv_undef;
720 AvARRAY(av) = AvARRAY(av) + 1;
724 mg_set(MUTABLE_SV(av));
731 Returns the highest index in the array. The number of elements in the
732 array is C<av_len(av) + 1>. Returns -1 if the array is empty.
734 The Perl equivalent for this is C<$#myarray>.
740 Perl_av_len(pTHX_ AV *av)
742 PERL_ARGS_ASSERT_AV_LEN;
743 assert(SvTYPE(av) == SVt_PVAV);
751 Set the highest index in the array to the given number, equivalent to
752 Perl's C<$#array = $fill;>.
754 The number of elements in the an array will be C<fill + 1> after
755 av_fill() returns. If the array was previously shorter, then the
756 additional elements appended are set to C<PL_sv_undef>. If the array
757 was longer, then the excess elements are freed. C<av_fill(av, -1)> is
758 the same as C<av_clear(av)>.
763 Perl_av_fill(pTHX_ register AV *av, I32 fill)
768 PERL_ARGS_ASSERT_AV_FILL;
769 assert(SvTYPE(av) == SVt_PVAV);
773 if ((mg = SvTIED_mg((const SV *)av, PERL_MAGIC_tied))) {
774 SV *arg1 = sv_newmortal();
775 sv_setiv(arg1, (IV)(fill + 1));
776 Perl_magic_methcall(aTHX_ MUTABLE_SV(av), mg, "STORESIZE", G_DISCARD,
780 if (fill <= AvMAX(av)) {
781 I32 key = AvFILLp(av);
782 SV** const ary = AvARRAY(av);
786 SvREFCNT_dec(ary[key]);
787 ary[key--] = &PL_sv_undef;
792 ary[++key] = &PL_sv_undef;
797 mg_set(MUTABLE_SV(av));
800 (void)av_store(av,fill,&PL_sv_undef);
804 =for apidoc av_delete
806 Deletes the element indexed by C<key> from the array, makes the element mortal,
807 and returns it. If C<flags> equals C<G_DISCARD>, the element is freed and null
808 is returned. Perl equivalent: C<my $elem = delete($myarray[$idx]);> for the
809 non-C<G_DISCARD> version and a void-context C<delete($myarray[$idx]);> for the
810 C<G_DISCARD> version.
815 Perl_av_delete(pTHX_ AV *av, I32 key, I32 flags)
820 PERL_ARGS_ASSERT_AV_DELETE;
821 assert(SvTYPE(av) == SVt_PVAV);
824 Perl_croak_no_modify(aTHX);
826 if (SvRMAGICAL(av)) {
827 const MAGIC * const tied_magic
828 = mg_find((const SV *)av, PERL_MAGIC_tied);
829 if ((tied_magic || mg_find((const SV *)av, PERL_MAGIC_regdata))) {
830 /* Handle negative array indices 20020222 MJD */
833 unsigned adjust_index = 1;
835 SV * const * const negative_indices_glob =
836 hv_fetch(SvSTASH(SvRV(SvTIED_obj(MUTABLE_SV(av),
838 NEGATIVE_INDICES_VAR, 16, 0);
839 if (negative_indices_glob
840 && SvTRUE(GvSV(*negative_indices_glob)))
844 key += AvFILL(av) + 1;
849 svp = av_fetch(av, key, TRUE);
853 if (mg_find(sv, PERL_MAGIC_tiedelem)) {
854 sv_unmagic(sv, PERL_MAGIC_tiedelem); /* No longer an element */
863 key += AvFILL(av) + 1;
868 if (key > AvFILLp(av))
871 if (!AvREAL(av) && AvREIFY(av))
873 sv = AvARRAY(av)[key];
874 if (key == AvFILLp(av)) {
875 AvARRAY(av)[key] = &PL_sv_undef;
878 } while (--key >= 0 && AvARRAY(av)[key] == &PL_sv_undef);
881 AvARRAY(av)[key] = &PL_sv_undef;
883 mg_set(MUTABLE_SV(av));
885 if (flags & G_DISCARD) {
895 =for apidoc av_exists
897 Returns true if the element indexed by C<key> has been initialized.
899 This relies on the fact that uninitialized array elements are set to
902 Perl equivalent: C<exists($myarray[$key])>.
907 Perl_av_exists(pTHX_ AV *av, I32 key)
910 PERL_ARGS_ASSERT_AV_EXISTS;
911 assert(SvTYPE(av) == SVt_PVAV);
913 if (SvRMAGICAL(av)) {
914 const MAGIC * const tied_magic
915 = mg_find((const SV *)av, PERL_MAGIC_tied);
916 const MAGIC * const regdata_magic
917 = mg_find((const SV *)av, PERL_MAGIC_regdata);
918 if (tied_magic || regdata_magic) {
919 SV * const sv = sv_newmortal();
921 /* Handle negative array indices 20020222 MJD */
923 unsigned adjust_index = 1;
925 SV * const * const negative_indices_glob =
926 hv_fetch(SvSTASH(SvRV(SvTIED_obj(MUTABLE_SV(av),
928 NEGATIVE_INDICES_VAR, 16, 0);
929 if (negative_indices_glob
930 && SvTRUE(GvSV(*negative_indices_glob)))
934 key += AvFILL(av) + 1;
942 if(key >= 0 && regdata_magic) {
943 if (key <= AvFILL(av))
949 mg_copy(MUTABLE_SV(av), sv, 0, key);
950 mg = mg_find(sv, PERL_MAGIC_tiedelem);
952 magic_existspack(sv, mg);
953 return cBOOL(SvTRUE(sv));
960 key += AvFILL(av) + 1;
965 if (key <= AvFILLp(av) && AvARRAY(av)[key] != &PL_sv_undef
975 S_get_aux_mg(pTHX_ AV *av) {
979 PERL_ARGS_ASSERT_GET_AUX_MG;
980 assert(SvTYPE(av) == SVt_PVAV);
982 mg = mg_find((const SV *)av, PERL_MAGIC_arylen_p);
985 mg = sv_magicext(MUTABLE_SV(av), 0, PERL_MAGIC_arylen_p,
986 &PL_vtbl_arylen_p, 0, 0);
988 /* sv_magicext won't set this for us because we pass in a NULL obj */
989 mg->mg_flags |= MGf_REFCOUNTED;
995 Perl_av_arylen_p(pTHX_ AV *av) {
996 MAGIC *const mg = get_aux_mg(av);
998 PERL_ARGS_ASSERT_AV_ARYLEN_P;
999 assert(SvTYPE(av) == SVt_PVAV);
1001 return &(mg->mg_obj);
1005 Perl_av_iter_p(pTHX_ AV *av) {
1006 MAGIC *const mg = get_aux_mg(av);
1008 PERL_ARGS_ASSERT_AV_ITER_P;
1009 assert(SvTYPE(av) == SVt_PVAV);
1011 #if IVSIZE == I32SIZE
1012 return (IV *)&(mg->mg_len);
1016 mg->mg_len = IVSIZE;
1018 mg->mg_ptr = (char *) temp;
1020 return (IV *)mg->mg_ptr;
1026 * c-indentation-style: bsd
1028 * indent-tabs-mode: t
1031 * ex: set ts=8 sts=4 sw=4 noet: