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);
80 PUSHSTACKi(PERLSI_MAGIC);
83 PUSHs(SvTIED_obj(MUTABLE_SV(av), mg));
86 call_method("EXTEND", G_SCALAR|G_DISCARD);
92 if (key > AvMAX(av)) {
97 if (AvALLOC(av) != AvARRAY(av)) {
98 ary = AvALLOC(av) + AvFILLp(av) + 1;
99 tmp = AvARRAY(av) - AvALLOC(av);
100 Move(AvARRAY(av), AvALLOC(av), AvFILLp(av)+1, SV*);
102 AvARRAY(av) = AvALLOC(av);
105 ary[--tmp] = &PL_sv_undef;
107 if (key > AvMAX(av) - 10) {
108 newmax = key + AvMAX(av);
113 #ifdef PERL_MALLOC_WRAP
114 static const char oom_array_extend[] =
115 "Out of memory during array extend"; /* Duplicated in pp_hot.c */
119 #if !defined(STRANGE_MALLOC) && !defined(MYMALLOC)
124 #ifdef Perl_safesysmalloc_size
125 /* Whilst it would be quite possible to move this logic around
126 (as I did in the SV code), so as to set AvMAX(av) early,
127 based on calling Perl_safesysmalloc_size() immediately after
128 allocation, I'm not convinced that it is a great idea here.
129 In an array we have to loop round setting everything to
130 &PL_sv_undef, which means writing to memory, potentially lots
131 of it, whereas for the SV buffer case we don't touch the
132 "bonus" memory. So there there is no cost in telling the
133 world about it, whereas here we have to do work before we can
134 tell the world about it, and that work involves writing to
135 memory that might never be read. So, I feel, better to keep
136 the current lazy system of only writing to it if our caller
137 has a need for more space. NWC */
138 newmax = Perl_safesysmalloc_size((void*)AvALLOC(av)) /
139 sizeof(const SV *) - 1;
144 newmax = key + AvMAX(av) / 5;
146 MEM_WRAP_CHECK_1(newmax+1, SV*, oom_array_extend);
147 #if defined(STRANGE_MALLOC) || defined(MYMALLOC)
148 Renew(AvALLOC(av),newmax+1, SV*);
150 bytes = (newmax + 1) * sizeof(const SV *);
151 #define MALLOC_OVERHEAD 16
152 itmp = MALLOC_OVERHEAD;
153 while ((MEM_SIZE)(itmp - MALLOC_OVERHEAD) < bytes)
155 itmp -= MALLOC_OVERHEAD;
156 itmp /= sizeof(const SV *);
157 assert(itmp > newmax);
159 assert(newmax >= AvMAX(av));
160 Newx(ary, newmax+1, SV*);
161 Copy(AvALLOC(av), ary, AvMAX(av)+1, SV*);
163 offer_nice_chunk(AvALLOC(av),
164 (AvMAX(av)+1) * sizeof(const SV *));
166 Safefree(AvALLOC(av));
169 #ifdef Perl_safesysmalloc_size
172 ary = AvALLOC(av) + AvMAX(av) + 1;
173 tmp = newmax - AvMAX(av);
174 if (av == PL_curstack) { /* Oops, grew stack (via av_store()?) */
175 PL_stack_sp = AvALLOC(av) + (PL_stack_sp - PL_stack_base);
176 PL_stack_base = AvALLOC(av);
177 PL_stack_max = PL_stack_base + newmax;
181 newmax = key < 3 ? 3 : key;
182 MEM_WRAP_CHECK_1(newmax+1, SV*, oom_array_extend);
183 Newx(AvALLOC(av), newmax+1, SV*);
184 ary = AvALLOC(av) + 1;
186 AvALLOC(av)[0] = &PL_sv_undef; /* For the stacks */
190 ary[--tmp] = &PL_sv_undef;
193 AvARRAY(av) = AvALLOC(av);
202 Returns the SV at the specified index in the array. The C<key> is the
203 index. If C<lval> is set then the fetch will be part of a store. Check
204 that the return value is non-null before dereferencing it to a C<SV*>.
206 See L<perlguts/"Understanding the Magic of Tied Hashes and Arrays"> for
207 more information on how to use this function on tied arrays.
213 Perl_av_fetch(pTHX_ register AV *av, I32 key, I32 lval)
217 PERL_ARGS_ASSERT_AV_FETCH;
218 assert(SvTYPE(av) == SVt_PVAV);
220 if (SvRMAGICAL(av)) {
221 const MAGIC * const tied_magic
222 = mg_find((const SV *)av, PERL_MAGIC_tied);
223 if (tied_magic || mg_find((const SV *)av, PERL_MAGIC_regdata)) {
226 I32 adjust_index = 1;
228 /* Handle negative array indices 20020222 MJD */
229 SV * const * const negative_indices_glob =
230 hv_fetch(SvSTASH(SvRV(SvTIED_obj(MUTABLE_SV(av),
232 NEGATIVE_INDICES_VAR, 16, 0);
234 if (negative_indices_glob && SvTRUE(GvSV(*negative_indices_glob)))
239 key += AvFILL(av) + 1;
246 sv_upgrade(sv, SVt_PVLV);
247 mg_copy(MUTABLE_SV(av), sv, 0, key);
249 LvTARG(sv) = sv; /* fake (SV**) */
250 return &(LvTARG(sv));
255 key += AvFILL(av) + 1;
260 if (key > AvFILLp(av)) {
263 return av_store(av,key,newSV(0));
265 if (AvARRAY(av)[key] == &PL_sv_undef) {
268 return av_store(av,key,newSV(0));
272 && (!AvARRAY(av)[key] /* eg. @_ could have freed elts */
273 || SvIS_FREED(AvARRAY(av)[key]))) {
274 AvARRAY(av)[key] = &PL_sv_undef; /* 1/2 reify */
277 return &AvARRAY(av)[key];
283 Stores an SV in an array. The array index is specified as C<key>. The
284 return value will be NULL if the operation failed or if the value did not
285 need to be actually stored within the array (as in the case of tied
286 arrays). Otherwise it can be dereferenced to get the original C<SV*>. Note
287 that the caller is responsible for suitably incrementing the reference
288 count of C<val> before the call, and decrementing it if the function
291 See L<perlguts/"Understanding the Magic of Tied Hashes and Arrays"> for
292 more information on how to use this function on tied arrays.
298 Perl_av_store(pTHX_ register AV *av, I32 key, SV *val)
303 PERL_ARGS_ASSERT_AV_STORE;
304 assert(SvTYPE(av) == SVt_PVAV);
306 /* S_regclass relies on being able to pass in a NULL sv
307 (unicode_alternate may be NULL).
313 if (SvRMAGICAL(av)) {
314 const MAGIC * const tied_magic = mg_find((const SV *)av, PERL_MAGIC_tied);
316 /* Handle negative array indices 20020222 MJD */
318 bool adjust_index = 1;
319 SV * const * const negative_indices_glob =
320 hv_fetch(SvSTASH(SvRV(SvTIED_obj(MUTABLE_SV(av),
322 NEGATIVE_INDICES_VAR, 16, 0);
323 if (negative_indices_glob
324 && SvTRUE(GvSV(*negative_indices_glob)))
327 key += AvFILL(av) + 1;
332 if (val != &PL_sv_undef) {
333 mg_copy(MUTABLE_SV(av), val, 0, key);
341 key += AvFILL(av) + 1;
346 if (SvREADONLY(av) && key >= AvFILL(av))
347 Perl_croak(aTHX_ "%s", PL_no_modify);
349 if (!AvREAL(av) && AvREIFY(av))
354 if (AvFILLp(av) < key) {
356 if (av == PL_curstack && key > PL_stack_sp - PL_stack_base)
357 PL_stack_sp = PL_stack_base + key; /* XPUSH in disguise */
359 ary[++AvFILLp(av)] = &PL_sv_undef;
360 } while (AvFILLp(av) < key);
365 SvREFCNT_dec(ary[key]);
367 if (SvSMAGICAL(av)) {
368 const MAGIC* const mg = SvMAGIC(av);
369 if (val != &PL_sv_undef) {
370 sv_magic(val, MUTABLE_SV(av), toLOWER(mg->mg_type), 0, key);
372 if (PL_delaymagic && mg->mg_type == PERL_MAGIC_isa)
373 PL_delaymagic |= DM_ARRAY;
375 mg_set(MUTABLE_SV(av));
383 Creates a new AV and populates it with a list of SVs. The SVs are copied
384 into the array, so they may be freed after the call to av_make. The new AV
385 will have a reference count of 1.
391 Perl_av_make(pTHX_ register I32 size, register SV **strp)
393 register AV * const av = MUTABLE_AV(newSV_type(SVt_PVAV));
394 /* sv_upgrade does AvREAL_only() */
395 PERL_ARGS_ASSERT_AV_MAKE;
396 assert(SvTYPE(av) == SVt_PVAV);
398 if (size) { /* "defined" was returning undef for size==0 anyway. */
404 AvFILLp(av) = AvMAX(av) = size - 1;
405 for (i = 0; i < size; i++) {
408 sv_setsv(ary[i], *strp);
418 Clears an array, making it empty. Does not free the memory used by the
425 Perl_av_clear(pTHX_ register AV *av)
430 PERL_ARGS_ASSERT_AV_CLEAR;
431 assert(SvTYPE(av) == SVt_PVAV);
434 if (SvREFCNT(av) == 0) {
435 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEBUGGING), "Attempt to clear deleted array");
440 Perl_croak(aTHX_ "%s", PL_no_modify);
442 /* Give any tie a chance to cleanup first */
443 if (SvRMAGICAL(av)) {
444 const MAGIC* const mg = SvMAGIC(av);
445 if (PL_delaymagic && mg && mg->mg_type == PERL_MAGIC_isa)
446 PL_delaymagic |= DM_ARRAY;
448 mg_clear(MUTABLE_SV(av));
455 SV** const ary = AvARRAY(av);
456 I32 index = AvFILLp(av) + 1;
458 SV * const sv = ary[--index];
459 /* undef the slot before freeing the value, because a
460 * destructor might try to modify this array */
461 ary[index] = &PL_sv_undef;
465 extra = AvARRAY(av) - AvALLOC(av);
468 AvARRAY(av) = AvALLOC(av);
477 Undefines the array. Frees the memory used by the array itself.
483 Perl_av_undef(pTHX_ register AV *av)
485 PERL_ARGS_ASSERT_AV_UNDEF;
486 assert(SvTYPE(av) == SVt_PVAV);
488 /* Give any tie a chance to cleanup first */
489 if (SvTIED_mg((const SV *)av, PERL_MAGIC_tied))
493 register I32 key = AvFILLp(av) + 1;
495 SvREFCNT_dec(AvARRAY(av)[--key]);
498 Safefree(AvALLOC(av));
501 AvMAX(av) = AvFILLp(av) = -1;
503 if(SvRMAGICAL(av)) mg_clear(MUTABLE_SV(av));
508 =for apidoc av_create_and_push
510 Push an SV onto the end of the array, creating the array if necessary.
511 A small internal helper function to remove a commonly duplicated idiom.
517 Perl_av_create_and_push(pTHX_ AV **const avp, SV *const val)
519 PERL_ARGS_ASSERT_AV_CREATE_AND_PUSH;
529 Pushes an SV onto the end of the array. The array will grow automatically
530 to accommodate the addition. Like C<av_store>, this takes ownership of one
537 Perl_av_push(pTHX_ register AV *av, SV *val)
542 PERL_ARGS_ASSERT_AV_PUSH;
543 assert(SvTYPE(av) == SVt_PVAV);
546 Perl_croak(aTHX_ "%s", PL_no_modify);
548 if ((mg = SvTIED_mg((const SV *)av, PERL_MAGIC_tied))) {
550 PUSHSTACKi(PERLSI_MAGIC);
553 PUSHs(SvTIED_obj(MUTABLE_SV(av), mg));
557 call_method("PUSH", G_SCALAR|G_DISCARD);
562 av_store(av,AvFILLp(av)+1,val);
568 Pops an SV off the end of the array. Returns C<&PL_sv_undef> if the array
575 Perl_av_pop(pTHX_ register AV *av)
581 PERL_ARGS_ASSERT_AV_POP;
582 assert(SvTYPE(av) == SVt_PVAV);
585 Perl_croak(aTHX_ "%s", PL_no_modify);
586 if ((mg = SvTIED_mg((const SV *)av, PERL_MAGIC_tied))) {
588 PUSHSTACKi(PERLSI_MAGIC);
590 XPUSHs(SvTIED_obj(MUTABLE_SV(av), mg));
593 if (call_method("POP", G_SCALAR)) {
594 retval = newSVsv(*PL_stack_sp--);
596 retval = &PL_sv_undef;
604 retval = AvARRAY(av)[AvFILLp(av)];
605 AvARRAY(av)[AvFILLp(av)--] = &PL_sv_undef;
607 mg_set(MUTABLE_SV(av));
613 =for apidoc av_create_and_unshift_one
615 Unshifts an SV onto the beginning of the array, creating the array if
617 A small internal helper function to remove a commonly duplicated idiom.
623 Perl_av_create_and_unshift_one(pTHX_ AV **const avp, SV *const val)
625 PERL_ARGS_ASSERT_AV_CREATE_AND_UNSHIFT_ONE;
630 return av_store(*avp, 0, val);
634 =for apidoc av_unshift
636 Unshift the given number of C<undef> values onto the beginning of the
637 array. The array will grow automatically to accommodate the addition. You
638 must then use C<av_store> to assign values to these new elements.
644 Perl_av_unshift(pTHX_ register AV *av, register I32 num)
650 PERL_ARGS_ASSERT_AV_UNSHIFT;
651 assert(SvTYPE(av) == SVt_PVAV);
654 Perl_croak(aTHX_ "%s", PL_no_modify);
656 if ((mg = SvTIED_mg((const SV *)av, PERL_MAGIC_tied))) {
658 PUSHSTACKi(PERLSI_MAGIC);
661 PUSHs(SvTIED_obj(MUTABLE_SV(av), mg));
667 call_method("UNSHIFT", G_SCALAR|G_DISCARD);
675 if (!AvREAL(av) && AvREIFY(av))
677 i = AvARRAY(av) - AvALLOC(av);
685 AvARRAY(av) = AvARRAY(av) - i;
689 const I32 i = AvFILLp(av);
690 /* Create extra elements */
691 const I32 slide = i > 0 ? i : 0;
693 av_extend(av, i + num);
696 Move(ary, ary + num, i + 1, SV*);
698 ary[--num] = &PL_sv_undef;
700 /* Make extra elements into a buffer */
702 AvFILLp(av) -= slide;
703 AvARRAY(av) = AvARRAY(av) + slide;
710 Shifts an SV off the beginning of the array. Returns C<&PL_sv_undef> if the
717 Perl_av_shift(pTHX_ register AV *av)
723 PERL_ARGS_ASSERT_AV_SHIFT;
724 assert(SvTYPE(av) == SVt_PVAV);
727 Perl_croak(aTHX_ "%s", PL_no_modify);
728 if ((mg = SvTIED_mg((const SV *)av, PERL_MAGIC_tied))) {
730 PUSHSTACKi(PERLSI_MAGIC);
732 XPUSHs(SvTIED_obj(MUTABLE_SV(av), mg));
735 if (call_method("SHIFT", G_SCALAR)) {
736 retval = newSVsv(*PL_stack_sp--);
738 retval = &PL_sv_undef;
746 retval = *AvARRAY(av);
748 *AvARRAY(av) = &PL_sv_undef;
749 AvARRAY(av) = AvARRAY(av) + 1;
753 mg_set(MUTABLE_SV(av));
760 Returns the highest index in the array. The number of elements in the
761 array is C<av_len(av) + 1>. Returns -1 if the array is empty.
767 Perl_av_len(pTHX_ AV *av)
769 PERL_ARGS_ASSERT_AV_LEN;
770 assert(SvTYPE(av) == SVt_PVAV);
778 Set the highest index in the array to the given number, equivalent to
779 Perl's C<$#array = $fill;>.
781 The number of elements in the an array will be C<fill + 1> after
782 av_fill() returns. If the array was previously shorter then the
783 additional elements appended are set to C<PL_sv_undef>. If the array
784 was longer, then the excess elements are freed. C<av_fill(av, -1)> is
785 the same as C<av_clear(av)>.
790 Perl_av_fill(pTHX_ register AV *av, I32 fill)
795 PERL_ARGS_ASSERT_AV_FILL;
796 assert(SvTYPE(av) == SVt_PVAV);
800 if ((mg = SvTIED_mg((const SV *)av, PERL_MAGIC_tied))) {
804 PUSHSTACKi(PERLSI_MAGIC);
807 PUSHs(SvTIED_obj(MUTABLE_SV(av), mg));
810 call_method("STORESIZE", G_SCALAR|G_DISCARD);
816 if (fill <= AvMAX(av)) {
817 I32 key = AvFILLp(av);
818 SV** const ary = AvARRAY(av);
822 SvREFCNT_dec(ary[key]);
823 ary[key--] = &PL_sv_undef;
828 ary[++key] = &PL_sv_undef;
833 mg_set(MUTABLE_SV(av));
836 (void)av_store(av,fill,&PL_sv_undef);
840 =for apidoc av_delete
842 Deletes the element indexed by C<key> from the array. Returns the
843 deleted element. If C<flags> equals C<G_DISCARD>, the element is freed
844 and null is returned.
849 Perl_av_delete(pTHX_ AV *av, I32 key, I32 flags)
854 PERL_ARGS_ASSERT_AV_DELETE;
855 assert(SvTYPE(av) == SVt_PVAV);
858 Perl_croak(aTHX_ "%s", PL_no_modify);
860 if (SvRMAGICAL(av)) {
861 const MAGIC * const tied_magic
862 = mg_find((const SV *)av, PERL_MAGIC_tied);
863 if ((tied_magic || mg_find((const SV *)av, PERL_MAGIC_regdata))) {
864 /* Handle negative array indices 20020222 MJD */
867 unsigned adjust_index = 1;
869 SV * const * const negative_indices_glob =
870 hv_fetch(SvSTASH(SvRV(SvTIED_obj(MUTABLE_SV(av),
872 NEGATIVE_INDICES_VAR, 16, 0);
873 if (negative_indices_glob
874 && SvTRUE(GvSV(*negative_indices_glob)))
878 key += AvFILL(av) + 1;
883 svp = av_fetch(av, key, TRUE);
887 if (mg_find(sv, PERL_MAGIC_tiedelem)) {
888 sv_unmagic(sv, PERL_MAGIC_tiedelem); /* No longer an element */
897 key += AvFILL(av) + 1;
902 if (key > AvFILLp(av))
905 if (!AvREAL(av) && AvREIFY(av))
907 sv = AvARRAY(av)[key];
908 if (key == AvFILLp(av)) {
909 AvARRAY(av)[key] = &PL_sv_undef;
912 } while (--key >= 0 && AvARRAY(av)[key] == &PL_sv_undef);
915 AvARRAY(av)[key] = &PL_sv_undef;
917 mg_set(MUTABLE_SV(av));
919 if (flags & G_DISCARD) {
929 =for apidoc av_exists
931 Returns true if the element indexed by C<key> has been initialized.
933 This relies on the fact that uninitialized array elements are set to
939 Perl_av_exists(pTHX_ AV *av, I32 key)
942 PERL_ARGS_ASSERT_AV_EXISTS;
943 assert(SvTYPE(av) == SVt_PVAV);
945 if (SvRMAGICAL(av)) {
946 const MAGIC * const tied_magic
947 = mg_find((const SV *)av, PERL_MAGIC_tied);
948 if (tied_magic || mg_find((const SV *)av, PERL_MAGIC_regdata)) {
949 SV * const sv = sv_newmortal();
951 /* Handle negative array indices 20020222 MJD */
953 unsigned adjust_index = 1;
955 SV * const * const negative_indices_glob =
956 hv_fetch(SvSTASH(SvRV(SvTIED_obj(MUTABLE_SV(av),
958 NEGATIVE_INDICES_VAR, 16, 0);
959 if (negative_indices_glob
960 && SvTRUE(GvSV(*negative_indices_glob)))
964 key += AvFILL(av) + 1;
970 mg_copy(MUTABLE_SV(av), sv, 0, key);
971 mg = mg_find(sv, PERL_MAGIC_tiedelem);
973 magic_existspack(sv, mg);
974 return (bool)SvTRUE(sv);
981 key += AvFILL(av) + 1;
986 if (key <= AvFILLp(av) && AvARRAY(av)[key] != &PL_sv_undef
996 S_get_aux_mg(pTHX_ AV *av) {
1000 PERL_ARGS_ASSERT_GET_AUX_MG;
1001 assert(SvTYPE(av) == SVt_PVAV);
1003 mg = mg_find((const SV *)av, PERL_MAGIC_arylen_p);
1006 mg = sv_magicext(MUTABLE_SV(av), 0, PERL_MAGIC_arylen_p,
1007 &PL_vtbl_arylen_p, 0, 0);
1009 /* sv_magicext won't set this for us because we pass in a NULL obj */
1010 mg->mg_flags |= MGf_REFCOUNTED;
1016 Perl_av_arylen_p(pTHX_ AV *av) {
1017 MAGIC *const mg = get_aux_mg(av);
1019 PERL_ARGS_ASSERT_AV_ARYLEN_P;
1020 assert(SvTYPE(av) == SVt_PVAV);
1022 return &(mg->mg_obj);
1026 Perl_av_iter_p(pTHX_ AV *av) {
1027 MAGIC *const mg = get_aux_mg(av);
1029 PERL_ARGS_ASSERT_AV_ITER_P;
1030 assert(SvTYPE(av) == SVt_PVAV);
1032 #if IVSIZE == I32SIZE
1033 return (IV *)&(mg->mg_len);
1037 mg->mg_len = IVSIZE;
1039 mg->mg_ptr = (char *) temp;
1041 return (IV *)mg->mg_ptr;
1047 * c-indentation-style: bsd
1049 * indent-tabs-mode: t
1052 * ex: set ts=8 sts=4 sw=4 noet: