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.
382 Perl equivalent: C<my @new_array = ($scalar1, $scalar2, $scalar3...);>
388 Perl_av_make(pTHX_ register I32 size, register SV **strp)
390 register AV * const av = MUTABLE_AV(newSV_type(SVt_PVAV));
391 /* sv_upgrade does AvREAL_only() */
392 PERL_ARGS_ASSERT_AV_MAKE;
393 assert(SvTYPE(av) == SVt_PVAV);
395 if (size) { /* "defined" was returning undef for size==0 anyway. */
401 AvFILLp(av) = AvMAX(av) = size - 1;
402 for (i = 0; i < size; i++) {
405 /* Don't let sv_setsv swipe, since our source array might
406 have multiple references to the same temp scalar (e.g.
407 from a list slice) */
410 sv_setsv_flags(ary[i], *strp,
411 SV_GMAGIC|SV_DO_COW_SVSETSV|SV_NOSTEAL);
421 Clears an array, making it empty. Does not free the memory used by the
422 array itself. Perl equivalent: C<@myarray = ();>.
428 Perl_av_clear(pTHX_ register AV *av)
433 PERL_ARGS_ASSERT_AV_CLEAR;
434 assert(SvTYPE(av) == SVt_PVAV);
437 if (SvREFCNT(av) == 0) {
438 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEBUGGING), "Attempt to clear deleted array");
443 Perl_croak(aTHX_ "%s", PL_no_modify);
445 /* Give any tie a chance to cleanup first */
446 if (SvRMAGICAL(av)) {
447 const MAGIC* const mg = SvMAGIC(av);
448 if (PL_delaymagic && mg && mg->mg_type == PERL_MAGIC_isa)
449 PL_delaymagic |= DM_ARRAY;
451 mg_clear(MUTABLE_SV(av));
458 SV** const ary = AvARRAY(av);
459 I32 index = AvFILLp(av) + 1;
461 SV * const sv = ary[--index];
462 /* undef the slot before freeing the value, because a
463 * destructor might try to modify this array */
464 ary[index] = &PL_sv_undef;
468 extra = AvARRAY(av) - AvALLOC(av);
471 AvARRAY(av) = AvALLOC(av);
480 Undefines the array. Frees the memory used by the array itself.
486 Perl_av_undef(pTHX_ register AV *av)
488 PERL_ARGS_ASSERT_AV_UNDEF;
489 assert(SvTYPE(av) == SVt_PVAV);
491 /* Give any tie a chance to cleanup first */
492 if (SvTIED_mg((const SV *)av, PERL_MAGIC_tied))
496 register I32 key = AvFILLp(av) + 1;
498 SvREFCNT_dec(AvARRAY(av)[--key]);
501 Safefree(AvALLOC(av));
504 AvMAX(av) = AvFILLp(av) = -1;
506 if(SvRMAGICAL(av)) mg_clear(MUTABLE_SV(av));
511 =for apidoc av_create_and_push
513 Push an SV onto the end of the array, creating the array if necessary.
514 A small internal helper function to remove a commonly duplicated idiom.
520 Perl_av_create_and_push(pTHX_ AV **const avp, SV *const val)
522 PERL_ARGS_ASSERT_AV_CREATE_AND_PUSH;
532 Pushes an SV onto the end of the array. The array will grow automatically
533 to accommodate the addition. Like C<av_store>, this takes ownership of one
540 Perl_av_push(pTHX_ register AV *av, SV *val)
545 PERL_ARGS_ASSERT_AV_PUSH;
546 assert(SvTYPE(av) == SVt_PVAV);
549 Perl_croak(aTHX_ "%s", PL_no_modify);
551 if ((mg = SvTIED_mg((const SV *)av, PERL_MAGIC_tied))) {
552 Perl_magic_methcall(aTHX_ MUTABLE_SV(av), mg, "PUSH", G_DISCARD, 1,
556 av_store(av,AvFILLp(av)+1,val);
562 Pops an SV off the end of the array. Returns C<&PL_sv_undef> if the array
569 Perl_av_pop(pTHX_ register AV *av)
575 PERL_ARGS_ASSERT_AV_POP;
576 assert(SvTYPE(av) == SVt_PVAV);
579 Perl_croak(aTHX_ "%s", PL_no_modify);
580 if ((mg = SvTIED_mg((const SV *)av, PERL_MAGIC_tied))) {
581 retval = Perl_magic_methcall(aTHX_ MUTABLE_SV(av), mg, "POP", 0, 0);
583 retval = newSVsv(retval);
588 retval = AvARRAY(av)[AvFILLp(av)];
589 AvARRAY(av)[AvFILLp(av)--] = &PL_sv_undef;
591 mg_set(MUTABLE_SV(av));
597 =for apidoc av_create_and_unshift_one
599 Unshifts an SV onto the beginning of the array, creating the array if
601 A small internal helper function to remove a commonly duplicated idiom.
607 Perl_av_create_and_unshift_one(pTHX_ AV **const avp, SV *const val)
609 PERL_ARGS_ASSERT_AV_CREATE_AND_UNSHIFT_ONE;
614 return av_store(*avp, 0, val);
618 =for apidoc av_unshift
620 Unshift the given number of C<undef> values onto the beginning of the
621 array. The array will grow automatically to accommodate the addition. You
622 must then use C<av_store> to assign values to these new elements.
628 Perl_av_unshift(pTHX_ register AV *av, register I32 num)
634 PERL_ARGS_ASSERT_AV_UNSHIFT;
635 assert(SvTYPE(av) == SVt_PVAV);
638 Perl_croak(aTHX_ "%s", PL_no_modify);
640 if ((mg = SvTIED_mg((const SV *)av, PERL_MAGIC_tied))) {
641 Perl_magic_methcall(aTHX_ MUTABLE_SV(av), mg, "UNSHIFT",
642 G_DISCARD | G_UNDEF_FILL, num);
648 if (!AvREAL(av) && AvREIFY(av))
650 i = AvARRAY(av) - AvALLOC(av);
658 AvARRAY(av) = AvARRAY(av) - i;
662 const I32 i = AvFILLp(av);
663 /* Create extra elements */
664 const I32 slide = i > 0 ? i : 0;
666 av_extend(av, i + num);
669 Move(ary, ary + num, i + 1, SV*);
671 ary[--num] = &PL_sv_undef;
673 /* Make extra elements into a buffer */
675 AvFILLp(av) -= slide;
676 AvARRAY(av) = AvARRAY(av) + slide;
683 Shifts an SV off the beginning of the array. Returns C<&PL_sv_undef> if the
690 Perl_av_shift(pTHX_ register AV *av)
696 PERL_ARGS_ASSERT_AV_SHIFT;
697 assert(SvTYPE(av) == SVt_PVAV);
700 Perl_croak(aTHX_ "%s", PL_no_modify);
701 if ((mg = SvTIED_mg((const SV *)av, PERL_MAGIC_tied))) {
702 retval = Perl_magic_methcall(aTHX_ MUTABLE_SV(av), mg, "SHIFT", 0, 0);
704 retval = newSVsv(retval);
709 retval = *AvARRAY(av);
711 *AvARRAY(av) = &PL_sv_undef;
712 AvARRAY(av) = AvARRAY(av) + 1;
716 mg_set(MUTABLE_SV(av));
723 Returns the highest index in the array. The number of elements in the
724 array is C<av_len(av) + 1>. Returns -1 if the array is empty.
726 The Perl equivalent for this is C<$#myarray>.
732 Perl_av_len(pTHX_ AV *av)
734 PERL_ARGS_ASSERT_AV_LEN;
735 assert(SvTYPE(av) == SVt_PVAV);
743 Set the highest index in the array to the given number, equivalent to
744 Perl's C<$#array = $fill;>.
746 The number of elements in the an array will be C<fill + 1> after
747 av_fill() returns. If the array was previously shorter, then the
748 additional elements appended are set to C<PL_sv_undef>. If the array
749 was longer, then the excess elements are freed. C<av_fill(av, -1)> is
750 the same as C<av_clear(av)>.
755 Perl_av_fill(pTHX_ register AV *av, I32 fill)
760 PERL_ARGS_ASSERT_AV_FILL;
761 assert(SvTYPE(av) == SVt_PVAV);
765 if ((mg = SvTIED_mg((const SV *)av, PERL_MAGIC_tied))) {
766 SV *arg1 = sv_newmortal();
767 sv_setiv(arg1, (IV)(fill + 1));
768 Perl_magic_methcall(aTHX_ MUTABLE_SV(av), mg, "STORESIZE", G_DISCARD,
772 if (fill <= AvMAX(av)) {
773 I32 key = AvFILLp(av);
774 SV** const ary = AvARRAY(av);
778 SvREFCNT_dec(ary[key]);
779 ary[key--] = &PL_sv_undef;
784 ary[++key] = &PL_sv_undef;
789 mg_set(MUTABLE_SV(av));
792 (void)av_store(av,fill,&PL_sv_undef);
796 =for apidoc av_delete
798 Deletes the element indexed by C<key> from the array. Returns the
799 deleted element. If C<flags> equals C<G_DISCARD>, the element is freed
800 and null is returned. Perl equivalent: C<my $elem = delete($myarray[$idx]);>
801 for the non-C<G_DISCARD> version and a void-context C<delete($myarray[$idx]);>
802 for the C<G_DISCARD> version.
807 Perl_av_delete(pTHX_ AV *av, I32 key, I32 flags)
812 PERL_ARGS_ASSERT_AV_DELETE;
813 assert(SvTYPE(av) == SVt_PVAV);
816 Perl_croak(aTHX_ "%s", PL_no_modify);
818 if (SvRMAGICAL(av)) {
819 const MAGIC * const tied_magic
820 = mg_find((const SV *)av, PERL_MAGIC_tied);
821 if ((tied_magic || mg_find((const SV *)av, PERL_MAGIC_regdata))) {
822 /* Handle negative array indices 20020222 MJD */
825 unsigned adjust_index = 1;
827 SV * const * const negative_indices_glob =
828 hv_fetch(SvSTASH(SvRV(SvTIED_obj(MUTABLE_SV(av),
830 NEGATIVE_INDICES_VAR, 16, 0);
831 if (negative_indices_glob
832 && SvTRUE(GvSV(*negative_indices_glob)))
836 key += AvFILL(av) + 1;
841 svp = av_fetch(av, key, TRUE);
845 if (mg_find(sv, PERL_MAGIC_tiedelem)) {
846 sv_unmagic(sv, PERL_MAGIC_tiedelem); /* No longer an element */
855 key += AvFILL(av) + 1;
860 if (key > AvFILLp(av))
863 if (!AvREAL(av) && AvREIFY(av))
865 sv = AvARRAY(av)[key];
866 if (key == AvFILLp(av)) {
867 AvARRAY(av)[key] = &PL_sv_undef;
870 } while (--key >= 0 && AvARRAY(av)[key] == &PL_sv_undef);
873 AvARRAY(av)[key] = &PL_sv_undef;
875 mg_set(MUTABLE_SV(av));
877 if (flags & G_DISCARD) {
887 =for apidoc av_exists
889 Returns true if the element indexed by C<key> has been initialized.
891 This relies on the fact that uninitialized array elements are set to
894 Perl equivalent: C<exists($myarray[$key])>.
899 Perl_av_exists(pTHX_ AV *av, I32 key)
902 PERL_ARGS_ASSERT_AV_EXISTS;
903 assert(SvTYPE(av) == SVt_PVAV);
905 if (SvRMAGICAL(av)) {
906 const MAGIC * const tied_magic
907 = mg_find((const SV *)av, PERL_MAGIC_tied);
908 if (tied_magic || mg_find((const SV *)av, PERL_MAGIC_regdata)) {
909 SV * const sv = sv_newmortal();
911 /* Handle negative array indices 20020222 MJD */
913 unsigned adjust_index = 1;
915 SV * const * const negative_indices_glob =
916 hv_fetch(SvSTASH(SvRV(SvTIED_obj(MUTABLE_SV(av),
918 NEGATIVE_INDICES_VAR, 16, 0);
919 if (negative_indices_glob
920 && SvTRUE(GvSV(*negative_indices_glob)))
924 key += AvFILL(av) + 1;
930 mg_copy(MUTABLE_SV(av), sv, 0, key);
931 mg = mg_find(sv, PERL_MAGIC_tiedelem);
933 magic_existspack(sv, mg);
934 return cBOOL(SvTRUE(sv));
941 key += AvFILL(av) + 1;
946 if (key <= AvFILLp(av) && AvARRAY(av)[key] != &PL_sv_undef
956 S_get_aux_mg(pTHX_ AV *av) {
960 PERL_ARGS_ASSERT_GET_AUX_MG;
961 assert(SvTYPE(av) == SVt_PVAV);
963 mg = mg_find((const SV *)av, PERL_MAGIC_arylen_p);
966 mg = sv_magicext(MUTABLE_SV(av), 0, PERL_MAGIC_arylen_p,
967 &PL_vtbl_arylen_p, 0, 0);
969 /* sv_magicext won't set this for us because we pass in a NULL obj */
970 mg->mg_flags |= MGf_REFCOUNTED;
976 Perl_av_arylen_p(pTHX_ AV *av) {
977 MAGIC *const mg = get_aux_mg(av);
979 PERL_ARGS_ASSERT_AV_ARYLEN_P;
980 assert(SvTYPE(av) == SVt_PVAV);
982 return &(mg->mg_obj);
986 Perl_av_iter_p(pTHX_ AV *av) {
987 MAGIC *const mg = get_aux_mg(av);
989 PERL_ARGS_ASSERT_AV_ITER_P;
990 assert(SvTYPE(av) == SVt_PVAV);
992 #if IVSIZE == I32SIZE
993 return (IV *)&(mg->mg_len);
999 mg->mg_ptr = (char *) temp;
1001 return (IV *)mg->mg_ptr;
1007 * c-indentation-style: bsd
1009 * indent-tabs-mode: t
1012 * ex: set ts=8 sts=4 sw=4 noet: