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
17 =head1 Array Manipulation Functions
25 Perl_av_reify(pTHX_ AV *av)
30 PERL_ARGS_ASSERT_AV_REIFY;
31 assert(SvTYPE(av) == SVt_PVAV);
36 if (SvTIED_mg((const SV *)av, PERL_MAGIC_tied) && ckWARN_d(WARN_DEBUGGING))
37 Perl_warner(aTHX_ packWARN(WARN_DEBUGGING), "av_reify called on tied array");
40 while (key > AvFILLp(av) + 1)
41 AvARRAY(av)[--key] = &PL_sv_undef;
43 SV * const sv = AvARRAY(av)[--key];
45 if (sv != &PL_sv_undef)
46 SvREFCNT_inc_simple_void_NN(sv);
48 key = AvARRAY(av) - AvALLOC(av);
50 AvALLOC(av)[--key] = &PL_sv_undef;
58 Pre-extend an array. The C<key> is the index to which the array should be
65 Perl_av_extend(pTHX_ AV *av, I32 key)
70 PERL_ARGS_ASSERT_AV_EXTEND;
71 assert(SvTYPE(av) == SVt_PVAV);
73 mg = SvTIED_mg((const SV *)av, PERL_MAGIC_tied);
78 PUSHSTACKi(PERLSI_MAGIC);
81 PUSHs(SvTIED_obj(MUTABLE_SV(av), mg));
84 call_method("EXTEND", G_SCALAR|G_DISCARD);
90 if (key > AvMAX(av)) {
95 if (AvALLOC(av) != AvARRAY(av)) {
96 ary = AvALLOC(av) + AvFILLp(av) + 1;
97 tmp = AvARRAY(av) - AvALLOC(av);
98 Move(AvARRAY(av), AvALLOC(av), AvFILLp(av)+1, SV*);
100 AvARRAY(av) = AvALLOC(av);
103 ary[--tmp] = &PL_sv_undef;
105 if (key > AvMAX(av) - 10) {
106 newmax = key + AvMAX(av);
111 #ifdef PERL_MALLOC_WRAP
112 static const char oom_array_extend[] =
113 "Out of memory during array extend"; /* Duplicated in pp_hot.c */
117 #if !defined(STRANGE_MALLOC) && !defined(MYMALLOC)
122 #ifdef Perl_safesysmalloc_size
123 /* Whilst it would be quite possible to move this logic around
124 (as I did in the SV code), so as to set AvMAX(av) early,
125 based on calling Perl_safesysmalloc_size() immediately after
126 allocation, I'm not convinced that it is a great idea here.
127 In an array we have to loop round setting everything to
128 &PL_sv_undef, which means writing to memory, potentially lots
129 of it, whereas for the SV buffer case we don't touch the
130 "bonus" memory. So there there is no cost in telling the
131 world about it, whereas here we have to do work before we can
132 tell the world about it, and that work involves writing to
133 memory that might never be read. So, I feel, better to keep
134 the current lazy system of only writing to it if our caller
135 has a need for more space. NWC */
136 newmax = Perl_safesysmalloc_size((void*)AvALLOC(av)) /
137 sizeof(const SV *) - 1;
142 newmax = key + AvMAX(av) / 5;
144 MEM_WRAP_CHECK_1(newmax+1, SV*, oom_array_extend);
145 #if defined(STRANGE_MALLOC) || defined(MYMALLOC)
146 Renew(AvALLOC(av),newmax+1, SV*);
148 bytes = (newmax + 1) * sizeof(const SV *);
149 #define MALLOC_OVERHEAD 16
150 itmp = MALLOC_OVERHEAD;
151 while ((MEM_SIZE)(itmp - MALLOC_OVERHEAD) < bytes)
153 itmp -= MALLOC_OVERHEAD;
154 itmp /= sizeof(const SV *);
155 assert(itmp > newmax);
157 assert(newmax >= AvMAX(av));
158 Newx(ary, newmax+1, SV*);
159 Copy(AvALLOC(av), ary, AvMAX(av)+1, SV*);
161 offer_nice_chunk(AvALLOC(av),
162 (AvMAX(av)+1) * sizeof(const SV *));
164 Safefree(AvALLOC(av));
167 #ifdef Perl_safesysmalloc_size
170 ary = AvALLOC(av) + AvMAX(av) + 1;
171 tmp = newmax - AvMAX(av);
172 if (av == PL_curstack) { /* Oops, grew stack (via av_store()?) */
173 PL_stack_sp = AvALLOC(av) + (PL_stack_sp - PL_stack_base);
174 PL_stack_base = AvALLOC(av);
175 PL_stack_max = PL_stack_base + newmax;
179 newmax = key < 3 ? 3 : key;
180 MEM_WRAP_CHECK_1(newmax+1, SV*, oom_array_extend);
181 Newx(AvALLOC(av), newmax+1, SV*);
182 ary = AvALLOC(av) + 1;
184 AvALLOC(av)[0] = &PL_sv_undef; /* For the stacks */
188 ary[--tmp] = &PL_sv_undef;
191 AvARRAY(av) = AvALLOC(av);
200 Returns the SV at the specified index in the array. The C<key> is the
201 index. If C<lval> is set then the fetch will be part of a store. Check
202 that the return value is non-null before dereferencing it to a C<SV*>.
204 See L<perlguts/"Understanding the Magic of Tied Hashes and Arrays"> for
205 more information on how to use this function on tied arrays.
211 Perl_av_fetch(pTHX_ register AV *av, I32 key, I32 lval)
215 PERL_ARGS_ASSERT_AV_FETCH;
216 assert(SvTYPE(av) == SVt_PVAV);
218 if (SvRMAGICAL(av)) {
219 const MAGIC * const tied_magic
220 = mg_find((const SV *)av, PERL_MAGIC_tied);
221 if (tied_magic || mg_find((const SV *)av, PERL_MAGIC_regdata)) {
224 I32 adjust_index = 1;
226 /* Handle negative array indices 20020222 MJD */
227 SV * const * const negative_indices_glob =
228 hv_fetch(SvSTASH(SvRV(SvTIED_obj(MUTABLE_SV(av),
230 NEGATIVE_INDICES_VAR, 16, 0);
232 if (negative_indices_glob && SvTRUE(GvSV(*negative_indices_glob)))
237 key += AvFILL(av) + 1;
244 sv_upgrade(sv, SVt_PVLV);
245 mg_copy(MUTABLE_SV(av), sv, 0, key);
247 LvTARG(sv) = sv; /* fake (SV**) */
248 return &(LvTARG(sv));
253 key += AvFILL(av) + 1;
258 if (key > AvFILLp(av)) {
261 return av_store(av,key,newSV(0));
263 if (AvARRAY(av)[key] == &PL_sv_undef) {
266 return av_store(av,key,newSV(0));
270 && (!AvARRAY(av)[key] /* eg. @_ could have freed elts */
271 || SvIS_FREED(AvARRAY(av)[key]))) {
272 AvARRAY(av)[key] = &PL_sv_undef; /* 1/2 reify */
275 return &AvARRAY(av)[key];
281 Stores an SV in an array. The array index is specified as C<key>. The
282 return value will be NULL if the operation failed or if the value did not
283 need to be actually stored within the array (as in the case of tied
284 arrays). Otherwise it can be dereferenced to get the original C<SV*>. Note
285 that the caller is responsible for suitably incrementing the reference
286 count of C<val> before the call, and decrementing it if the function
289 See L<perlguts/"Understanding the Magic of Tied Hashes and Arrays"> for
290 more information on how to use this function on tied arrays.
296 Perl_av_store(pTHX_ register AV *av, I32 key, SV *val)
301 PERL_ARGS_ASSERT_AV_STORE;
302 assert(SvTYPE(av) == SVt_PVAV);
304 /* S_regclass relies on being able to pass in a NULL sv
305 (unicode_alternate may be NULL).
311 if (SvRMAGICAL(av)) {
312 const MAGIC * const tied_magic = mg_find((const SV *)av, PERL_MAGIC_tied);
314 /* Handle negative array indices 20020222 MJD */
316 bool adjust_index = 1;
317 SV * const * const negative_indices_glob =
318 hv_fetch(SvSTASH(SvRV(SvTIED_obj(MUTABLE_SV(av),
320 NEGATIVE_INDICES_VAR, 16, 0);
321 if (negative_indices_glob
322 && SvTRUE(GvSV(*negative_indices_glob)))
325 key += AvFILL(av) + 1;
330 if (val != &PL_sv_undef) {
331 mg_copy(MUTABLE_SV(av), val, 0, key);
339 key += AvFILL(av) + 1;
344 if (SvREADONLY(av) && key >= AvFILL(av))
345 Perl_croak(aTHX_ "%s", PL_no_modify);
347 if (!AvREAL(av) && AvREIFY(av))
352 if (AvFILLp(av) < key) {
354 if (av == PL_curstack && key > PL_stack_sp - PL_stack_base)
355 PL_stack_sp = PL_stack_base + key; /* XPUSH in disguise */
357 ary[++AvFILLp(av)] = &PL_sv_undef;
358 } while (AvFILLp(av) < key);
363 SvREFCNT_dec(ary[key]);
365 if (SvSMAGICAL(av)) {
366 const MAGIC* const mg = SvMAGIC(av);
367 if (val != &PL_sv_undef) {
368 sv_magic(val, MUTABLE_SV(av), toLOWER(mg->mg_type), 0, key);
370 if (PL_delaymagic && mg->mg_type == PERL_MAGIC_isa)
371 PL_delaymagic |= DM_ARRAY;
373 mg_set(MUTABLE_SV(av));
381 Creates a new AV and populates it with a list of SVs. The SVs are copied
382 into the array, so they may be freed after the call to av_make. The new AV
383 will have a reference count of 1.
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 sv_setsv(ary[i], *strp);
416 Clears an array, making it empty. Does not free the memory used by the
423 Perl_av_clear(pTHX_ register AV *av)
428 PERL_ARGS_ASSERT_AV_CLEAR;
429 assert(SvTYPE(av) == SVt_PVAV);
432 if (SvREFCNT(av) == 0 && ckWARN_d(WARN_DEBUGGING)) {
433 Perl_warner(aTHX_ packWARN(WARN_DEBUGGING), "Attempt to clear deleted array");
438 Perl_croak(aTHX_ "%s", PL_no_modify);
440 /* Give any tie a chance to cleanup first */
441 if (SvRMAGICAL(av)) {
442 const MAGIC* const mg = SvMAGIC(av);
443 if (PL_delaymagic && mg && mg->mg_type == PERL_MAGIC_isa)
444 PL_delaymagic |= DM_ARRAY;
446 mg_clear(MUTABLE_SV(av));
453 SV** const ary = AvARRAY(av);
454 I32 index = AvFILLp(av) + 1;
456 SV * const sv = ary[--index];
457 /* undef the slot before freeing the value, because a
458 * destructor might try to modify this array */
459 ary[index] = &PL_sv_undef;
463 extra = AvARRAY(av) - AvALLOC(av);
466 AvARRAY(av) = AvALLOC(av);
475 Undefines the array. Frees the memory used by the array itself.
481 Perl_av_undef(pTHX_ register AV *av)
483 PERL_ARGS_ASSERT_AV_UNDEF;
484 assert(SvTYPE(av) == SVt_PVAV);
486 /* Give any tie a chance to cleanup first */
487 if (SvTIED_mg((const SV *)av, PERL_MAGIC_tied))
491 register I32 key = AvFILLp(av) + 1;
493 SvREFCNT_dec(AvARRAY(av)[--key]);
496 Safefree(AvALLOC(av));
499 AvMAX(av) = AvFILLp(av) = -1;
501 if(SvRMAGICAL(av)) mg_clear(MUTABLE_SV(av));
506 =for apidoc av_create_and_push
508 Push an SV onto the end of the array, creating the array if necessary.
509 A small internal helper function to remove a commonly duplicated idiom.
515 Perl_av_create_and_push(pTHX_ AV **const avp, SV *const val)
517 PERL_ARGS_ASSERT_AV_CREATE_AND_PUSH;
527 Pushes an SV onto the end of the array. The array will grow automatically
528 to accommodate the addition.
534 Perl_av_push(pTHX_ register AV *av, SV *val)
539 PERL_ARGS_ASSERT_AV_PUSH;
540 assert(SvTYPE(av) == SVt_PVAV);
543 Perl_croak(aTHX_ "%s", PL_no_modify);
545 if ((mg = SvTIED_mg((const SV *)av, PERL_MAGIC_tied))) {
547 PUSHSTACKi(PERLSI_MAGIC);
550 PUSHs(SvTIED_obj(MUTABLE_SV(av), mg));
554 call_method("PUSH", G_SCALAR|G_DISCARD);
559 av_store(av,AvFILLp(av)+1,val);
565 Pops an SV off the end of the array. Returns C<&PL_sv_undef> if the array
572 Perl_av_pop(pTHX_ register AV *av)
578 PERL_ARGS_ASSERT_AV_POP;
579 assert(SvTYPE(av) == SVt_PVAV);
582 Perl_croak(aTHX_ "%s", PL_no_modify);
583 if ((mg = SvTIED_mg((const SV *)av, PERL_MAGIC_tied))) {
585 PUSHSTACKi(PERLSI_MAGIC);
587 XPUSHs(SvTIED_obj(MUTABLE_SV(av), mg));
590 if (call_method("POP", G_SCALAR)) {
591 retval = newSVsv(*PL_stack_sp--);
593 retval = &PL_sv_undef;
601 retval = AvARRAY(av)[AvFILLp(av)];
602 AvARRAY(av)[AvFILLp(av)--] = &PL_sv_undef;
604 mg_set(MUTABLE_SV(av));
610 =for apidoc av_create_and_unshift_one
612 Unshifts an SV onto the beginning of the array, creating the array if
614 A small internal helper function to remove a commonly duplicated idiom.
620 Perl_av_create_and_unshift_one(pTHX_ AV **const avp, SV *const val)
622 PERL_ARGS_ASSERT_AV_CREATE_AND_UNSHIFT_ONE;
627 return av_store(*avp, 0, val);
631 =for apidoc av_unshift
633 Unshift the given number of C<undef> values onto the beginning of the
634 array. The array will grow automatically to accommodate the addition. You
635 must then use C<av_store> to assign values to these new elements.
641 Perl_av_unshift(pTHX_ register AV *av, register I32 num)
647 PERL_ARGS_ASSERT_AV_UNSHIFT;
648 assert(SvTYPE(av) == SVt_PVAV);
651 Perl_croak(aTHX_ "%s", PL_no_modify);
653 if ((mg = SvTIED_mg((const SV *)av, PERL_MAGIC_tied))) {
655 PUSHSTACKi(PERLSI_MAGIC);
658 PUSHs(SvTIED_obj(MUTABLE_SV(av), mg));
664 call_method("UNSHIFT", G_SCALAR|G_DISCARD);
672 if (!AvREAL(av) && AvREIFY(av))
674 i = AvARRAY(av) - AvALLOC(av);
682 AvARRAY(av) = AvARRAY(av) - i;
686 const I32 i = AvFILLp(av);
687 /* Create extra elements */
688 const I32 slide = i > 0 ? i : 0;
690 av_extend(av, i + num);
693 Move(ary, ary + num, i + 1, SV*);
695 ary[--num] = &PL_sv_undef;
697 /* Make extra elements into a buffer */
699 AvFILLp(av) -= slide;
700 AvARRAY(av) = AvARRAY(av) + slide;
707 Shifts an SV off the beginning of the array. Returns C<&PL_sv_undef> if the
714 Perl_av_shift(pTHX_ register AV *av)
720 PERL_ARGS_ASSERT_AV_SHIFT;
721 assert(SvTYPE(av) == SVt_PVAV);
724 Perl_croak(aTHX_ "%s", PL_no_modify);
725 if ((mg = SvTIED_mg((const SV *)av, PERL_MAGIC_tied))) {
727 PUSHSTACKi(PERLSI_MAGIC);
729 XPUSHs(SvTIED_obj(MUTABLE_SV(av), mg));
732 if (call_method("SHIFT", G_SCALAR)) {
733 retval = newSVsv(*PL_stack_sp--);
735 retval = &PL_sv_undef;
743 retval = *AvARRAY(av);
745 *AvARRAY(av) = &PL_sv_undef;
746 AvARRAY(av) = AvARRAY(av) + 1;
750 mg_set(MUTABLE_SV(av));
757 Returns the highest index in the array. The number of elements in the
758 array is C<av_len(av) + 1>. Returns -1 if the array is empty.
764 Perl_av_len(pTHX_ AV *av)
766 PERL_ARGS_ASSERT_AV_LEN;
767 assert(SvTYPE(av) == SVt_PVAV);
775 Set the highest index in the array to the given number, equivalent to
776 Perl's C<$#array = $fill;>.
778 The number of elements in the an array will be C<fill + 1> after
779 av_fill() returns. If the array was previously shorter then the
780 additional elements appended are set to C<PL_sv_undef>. If the array
781 was longer, then the excess elements are freed. C<av_fill(av, -1)> is
782 the same as C<av_clear(av)>.
787 Perl_av_fill(pTHX_ register AV *av, I32 fill)
792 PERL_ARGS_ASSERT_AV_FILL;
793 assert(SvTYPE(av) == SVt_PVAV);
797 if ((mg = SvTIED_mg((const SV *)av, PERL_MAGIC_tied))) {
801 PUSHSTACKi(PERLSI_MAGIC);
804 PUSHs(SvTIED_obj(MUTABLE_SV(av), mg));
807 call_method("STORESIZE", G_SCALAR|G_DISCARD);
813 if (fill <= AvMAX(av)) {
814 I32 key = AvFILLp(av);
815 SV** const ary = AvARRAY(av);
819 SvREFCNT_dec(ary[key]);
820 ary[key--] = &PL_sv_undef;
825 ary[++key] = &PL_sv_undef;
830 mg_set(MUTABLE_SV(av));
833 (void)av_store(av,fill,&PL_sv_undef);
837 =for apidoc av_delete
839 Deletes the element indexed by C<key> from the array. Returns the
840 deleted element. If C<flags> equals C<G_DISCARD>, the element is freed
841 and null is returned.
846 Perl_av_delete(pTHX_ AV *av, I32 key, I32 flags)
851 PERL_ARGS_ASSERT_AV_DELETE;
852 assert(SvTYPE(av) == SVt_PVAV);
855 Perl_croak(aTHX_ "%s", PL_no_modify);
857 if (SvRMAGICAL(av)) {
858 const MAGIC * const tied_magic
859 = mg_find((const SV *)av, PERL_MAGIC_tied);
860 if ((tied_magic || mg_find((const SV *)av, PERL_MAGIC_regdata))) {
861 /* Handle negative array indices 20020222 MJD */
864 unsigned adjust_index = 1;
866 SV * const * const negative_indices_glob =
867 hv_fetch(SvSTASH(SvRV(SvTIED_obj(MUTABLE_SV(av),
869 NEGATIVE_INDICES_VAR, 16, 0);
870 if (negative_indices_glob
871 && SvTRUE(GvSV(*negative_indices_glob)))
875 key += AvFILL(av) + 1;
880 svp = av_fetch(av, key, TRUE);
884 if (mg_find(sv, PERL_MAGIC_tiedelem)) {
885 sv_unmagic(sv, PERL_MAGIC_tiedelem); /* No longer an element */
894 key += AvFILL(av) + 1;
899 if (key > AvFILLp(av))
902 if (!AvREAL(av) && AvREIFY(av))
904 sv = AvARRAY(av)[key];
905 if (key == AvFILLp(av)) {
906 AvARRAY(av)[key] = &PL_sv_undef;
909 } while (--key >= 0 && AvARRAY(av)[key] == &PL_sv_undef);
912 AvARRAY(av)[key] = &PL_sv_undef;
914 mg_set(MUTABLE_SV(av));
916 if (flags & G_DISCARD) {
926 =for apidoc av_exists
928 Returns true if the element indexed by C<key> has been initialized.
930 This relies on the fact that uninitialized array elements are set to
936 Perl_av_exists(pTHX_ AV *av, I32 key)
939 PERL_ARGS_ASSERT_AV_EXISTS;
940 assert(SvTYPE(av) == SVt_PVAV);
942 if (SvRMAGICAL(av)) {
943 const MAGIC * const tied_magic
944 = mg_find((const SV *)av, PERL_MAGIC_tied);
945 if (tied_magic || mg_find((const SV *)av, PERL_MAGIC_regdata)) {
946 SV * const sv = sv_newmortal();
948 /* Handle negative array indices 20020222 MJD */
950 unsigned adjust_index = 1;
952 SV * const * const negative_indices_glob =
953 hv_fetch(SvSTASH(SvRV(SvTIED_obj(MUTABLE_SV(av),
955 NEGATIVE_INDICES_VAR, 16, 0);
956 if (negative_indices_glob
957 && SvTRUE(GvSV(*negative_indices_glob)))
961 key += AvFILL(av) + 1;
967 mg_copy(MUTABLE_SV(av), sv, 0, key);
968 mg = mg_find(sv, PERL_MAGIC_tiedelem);
970 magic_existspack(sv, mg);
971 return (bool)SvTRUE(sv);
978 key += AvFILL(av) + 1;
983 if (key <= AvFILLp(av) && AvARRAY(av)[key] != &PL_sv_undef
993 S_get_aux_mg(pTHX_ AV *av) {
997 PERL_ARGS_ASSERT_GET_AUX_MG;
998 assert(SvTYPE(av) == SVt_PVAV);
1000 mg = mg_find((const SV *)av, PERL_MAGIC_arylen_p);
1003 mg = sv_magicext(MUTABLE_SV(av), 0, PERL_MAGIC_arylen_p,
1004 &PL_vtbl_arylen_p, 0, 0);
1006 /* sv_magicext won't set this for us because we pass in a NULL obj */
1007 mg->mg_flags |= MGf_REFCOUNTED;
1013 Perl_av_arylen_p(pTHX_ AV *av) {
1014 MAGIC *const mg = get_aux_mg(av);
1016 PERL_ARGS_ASSERT_AV_ARYLEN_P;
1017 assert(SvTYPE(av) == SVt_PVAV);
1019 return &(mg->mg_obj);
1023 Perl_av_iter_p(pTHX_ AV *av) {
1024 MAGIC *const mg = get_aux_mg(av);
1026 PERL_ARGS_ASSERT_AV_ITER_P;
1027 assert(SvTYPE(av) == SVt_PVAV);
1029 #if IVSIZE == I32SIZE
1030 return (IV *)&(mg->mg_len);
1034 mg->mg_len = IVSIZE;
1036 mg->mg_ptr = (char *) temp;
1038 return (IV *)mg->mg_ptr;
1044 * c-indentation-style: bsd
1046 * indent-tabs-mode: t
1049 * ex: set ts=8 sts=4 sw=4 noet: