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 magic_methcall(MUTABLE_SV(av), mg, "EXTEND", G_DISCARD, 1, arg1, NULL);
82 if (key > AvMAX(av)) {
87 if (AvALLOC(av) != AvARRAY(av)) {
88 ary = AvALLOC(av) + AvFILLp(av) + 1;
89 tmp = AvARRAY(av) - AvALLOC(av);
90 Move(AvARRAY(av), AvALLOC(av), AvFILLp(av)+1, SV*);
92 AvARRAY(av) = AvALLOC(av);
95 ary[--tmp] = &PL_sv_undef;
97 if (key > AvMAX(av) - 10) {
98 newmax = key + AvMAX(av);
103 #ifdef PERL_MALLOC_WRAP
104 static const char oom_array_extend[] =
105 "Out of memory during array extend"; /* Duplicated in pp_hot.c */
109 #if !defined(STRANGE_MALLOC) && !defined(MYMALLOC)
114 #ifdef Perl_safesysmalloc_size
115 /* Whilst it would be quite possible to move this logic around
116 (as I did in the SV code), so as to set AvMAX(av) early,
117 based on calling Perl_safesysmalloc_size() immediately after
118 allocation, I'm not convinced that it is a great idea here.
119 In an array we have to loop round setting everything to
120 &PL_sv_undef, which means writing to memory, potentially lots
121 of it, whereas for the SV buffer case we don't touch the
122 "bonus" memory. So there there is no cost in telling the
123 world about it, whereas here we have to do work before we can
124 tell the world about it, and that work involves writing to
125 memory that might never be read. So, I feel, better to keep
126 the current lazy system of only writing to it if our caller
127 has a need for more space. NWC */
128 newmax = Perl_safesysmalloc_size((void*)AvALLOC(av)) /
129 sizeof(const SV *) - 1;
134 newmax = key + AvMAX(av) / 5;
136 MEM_WRAP_CHECK_1(newmax+1, SV*, oom_array_extend);
137 #if defined(STRANGE_MALLOC) || defined(MYMALLOC)
138 Renew(AvALLOC(av),newmax+1, SV*);
140 bytes = (newmax + 1) * sizeof(const SV *);
141 #define MALLOC_OVERHEAD 16
142 itmp = MALLOC_OVERHEAD;
143 while ((MEM_SIZE)(itmp - MALLOC_OVERHEAD) < bytes)
145 itmp -= MALLOC_OVERHEAD;
146 itmp /= sizeof(const SV *);
147 assert(itmp > newmax);
149 assert(newmax >= AvMAX(av));
150 Newx(ary, newmax+1, SV*);
151 Copy(AvALLOC(av), ary, AvMAX(av)+1, SV*);
153 offer_nice_chunk(AvALLOC(av),
154 (AvMAX(av)+1) * sizeof(const SV *));
156 Safefree(AvALLOC(av));
159 #ifdef Perl_safesysmalloc_size
162 ary = AvALLOC(av) + AvMAX(av) + 1;
163 tmp = newmax - AvMAX(av);
164 if (av == PL_curstack) { /* Oops, grew stack (via av_store()?) */
165 PL_stack_sp = AvALLOC(av) + (PL_stack_sp - PL_stack_base);
166 PL_stack_base = AvALLOC(av);
167 PL_stack_max = PL_stack_base + newmax;
171 newmax = key < 3 ? 3 : key;
172 MEM_WRAP_CHECK_1(newmax+1, SV*, oom_array_extend);
173 Newx(AvALLOC(av), newmax+1, SV*);
174 ary = AvALLOC(av) + 1;
176 AvALLOC(av)[0] = &PL_sv_undef; /* For the stacks */
180 ary[--tmp] = &PL_sv_undef;
183 AvARRAY(av) = AvALLOC(av);
192 Returns the SV at the specified index in the array. The C<key> is the
193 index. If C<lval> is set then the fetch will be part of a store. Check
194 that the return value is non-null before dereferencing it to a C<SV*>.
196 See L<perlguts/"Understanding the Magic of Tied Hashes and Arrays"> for
197 more information on how to use this function on tied arrays.
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 original C<SV*>. Note
279 that the caller is responsible for suitably incrementing the reference
280 count of C<val> before the call, and decrementing it if the function
283 See L<perlguts/"Understanding the Magic of Tied Hashes and Arrays"> for
284 more information on how to use this function on tied arrays.
290 Perl_av_store(pTHX_ register AV *av, I32 key, SV *val)
295 PERL_ARGS_ASSERT_AV_STORE;
296 assert(SvTYPE(av) == SVt_PVAV);
298 /* S_regclass relies on being able to pass in a NULL sv
299 (unicode_alternate may be NULL).
305 if (SvRMAGICAL(av)) {
306 const MAGIC * const tied_magic = mg_find((const SV *)av, PERL_MAGIC_tied);
308 /* Handle negative array indices 20020222 MJD */
310 bool adjust_index = 1;
311 SV * const * const negative_indices_glob =
312 hv_fetch(SvSTASH(SvRV(SvTIED_obj(MUTABLE_SV(av),
314 NEGATIVE_INDICES_VAR, 16, 0);
315 if (negative_indices_glob
316 && SvTRUE(GvSV(*negative_indices_glob)))
319 key += AvFILL(av) + 1;
324 if (val != &PL_sv_undef) {
325 mg_copy(MUTABLE_SV(av), val, 0, key);
333 key += AvFILL(av) + 1;
338 if (SvREADONLY(av) && key >= AvFILL(av))
339 Perl_croak(aTHX_ "%s", PL_no_modify);
341 if (!AvREAL(av) && AvREIFY(av))
346 if (AvFILLp(av) < key) {
348 if (av == PL_curstack && key > PL_stack_sp - PL_stack_base)
349 PL_stack_sp = PL_stack_base + key; /* XPUSH in disguise */
351 ary[++AvFILLp(av)] = &PL_sv_undef;
352 } while (AvFILLp(av) < key);
357 SvREFCNT_dec(ary[key]);
359 if (SvSMAGICAL(av)) {
360 const MAGIC* const mg = SvMAGIC(av);
361 if (val != &PL_sv_undef) {
362 sv_magic(val, MUTABLE_SV(av), toLOWER(mg->mg_type), 0, key);
364 if (PL_delaymagic && mg->mg_type == PERL_MAGIC_isa)
365 PL_delaymagic |= DM_ARRAY;
367 mg_set(MUTABLE_SV(av));
375 Creates a new AV and populates it with a list of SVs. The SVs are copied
376 into the array, so they may be freed after the call to av_make. The new AV
377 will have a reference count of 1.
383 Perl_av_make(pTHX_ register I32 size, register SV **strp)
385 register AV * const av = MUTABLE_AV(newSV_type(SVt_PVAV));
386 /* sv_upgrade does AvREAL_only() */
387 PERL_ARGS_ASSERT_AV_MAKE;
388 assert(SvTYPE(av) == SVt_PVAV);
390 if (size) { /* "defined" was returning undef for size==0 anyway. */
396 AvFILLp(av) = AvMAX(av) = size - 1;
397 for (i = 0; i < size; i++) {
400 /* Don't let sv_setsv swipe, since our source array might
401 have multiple references to the same temp scalar (e.g.
402 from a list slice) */
405 sv_setsv_flags(ary[i], *strp,
406 SV_GMAGIC|SV_DO_COW_SVSETSV|SV_NOSTEAL);
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) {
433 Perl_ck_warner_d(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. Like C<av_store>, this takes ownership of one
535 Perl_av_push(pTHX_ register AV *av, SV *val)
540 PERL_ARGS_ASSERT_AV_PUSH;
541 assert(SvTYPE(av) == SVt_PVAV);
544 Perl_croak(aTHX_ "%s", PL_no_modify);
546 if ((mg = SvTIED_mg((const SV *)av, PERL_MAGIC_tied))) {
547 magic_methcall(MUTABLE_SV(av), mg, "PUSH", G_DISCARD, 1, val, NULL);
550 av_store(av,AvFILLp(av)+1,val);
556 Pops an SV off the end of the array. Returns C<&PL_sv_undef> if the array
563 Perl_av_pop(pTHX_ register AV *av)
569 PERL_ARGS_ASSERT_AV_POP;
570 assert(SvTYPE(av) == SVt_PVAV);
573 Perl_croak(aTHX_ "%s", PL_no_modify);
574 if ((mg = SvTIED_mg((const SV *)av, PERL_MAGIC_tied))) {
575 retval = magic_methcall(MUTABLE_SV(av), mg, "POP", 0, 0, NULL, NULL);
577 retval = newSVsv(retval);
582 retval = AvARRAY(av)[AvFILLp(av)];
583 AvARRAY(av)[AvFILLp(av)--] = &PL_sv_undef;
585 mg_set(MUTABLE_SV(av));
591 =for apidoc av_create_and_unshift_one
593 Unshifts an SV onto the beginning of the array, creating the array if
595 A small internal helper function to remove a commonly duplicated idiom.
601 Perl_av_create_and_unshift_one(pTHX_ AV **const avp, SV *const val)
603 PERL_ARGS_ASSERT_AV_CREATE_AND_UNSHIFT_ONE;
608 return av_store(*avp, 0, val);
612 =for apidoc av_unshift
614 Unshift the given number of C<undef> values onto the beginning of the
615 array. The array will grow automatically to accommodate the addition. You
616 must then use C<av_store> to assign values to these new elements.
622 Perl_av_unshift(pTHX_ register AV *av, register I32 num)
628 PERL_ARGS_ASSERT_AV_UNSHIFT;
629 assert(SvTYPE(av) == SVt_PVAV);
632 Perl_croak(aTHX_ "%s", PL_no_modify);
634 if ((mg = SvTIED_mg((const SV *)av, PERL_MAGIC_tied))) {
635 magic_methcall(MUTABLE_SV(av), mg, "UNSHIFT", G_DISCARD | G_UNDEF_FILL,
642 if (!AvREAL(av) && AvREIFY(av))
644 i = AvARRAY(av) - AvALLOC(av);
652 AvARRAY(av) = AvARRAY(av) - i;
656 const I32 i = AvFILLp(av);
657 /* Create extra elements */
658 const I32 slide = i > 0 ? i : 0;
660 av_extend(av, i + num);
663 Move(ary, ary + num, i + 1, SV*);
665 ary[--num] = &PL_sv_undef;
667 /* Make extra elements into a buffer */
669 AvFILLp(av) -= slide;
670 AvARRAY(av) = AvARRAY(av) + slide;
677 Shifts an SV off the beginning of the array. Returns C<&PL_sv_undef> if the
684 Perl_av_shift(pTHX_ register AV *av)
690 PERL_ARGS_ASSERT_AV_SHIFT;
691 assert(SvTYPE(av) == SVt_PVAV);
694 Perl_croak(aTHX_ "%s", PL_no_modify);
695 if ((mg = SvTIED_mg((const SV *)av, PERL_MAGIC_tied))) {
696 retval = magic_methcall(MUTABLE_SV(av), mg, "SHIFT", 0, 0, NULL, NULL);
698 retval = newSVsv(retval);
703 retval = *AvARRAY(av);
705 *AvARRAY(av) = &PL_sv_undef;
706 AvARRAY(av) = AvARRAY(av) + 1;
710 mg_set(MUTABLE_SV(av));
717 Returns the highest index in the array. The number of elements in the
718 array is C<av_len(av) + 1>. Returns -1 if the array is empty.
724 Perl_av_len(pTHX_ AV *av)
726 PERL_ARGS_ASSERT_AV_LEN;
727 assert(SvTYPE(av) == SVt_PVAV);
735 Set the highest index in the array to the given number, equivalent to
736 Perl's C<$#array = $fill;>.
738 The number of elements in the an array will be C<fill + 1> after
739 av_fill() returns. If the array was previously shorter then the
740 additional elements appended are set to C<PL_sv_undef>. If the array
741 was longer, then the excess elements are freed. C<av_fill(av, -1)> is
742 the same as C<av_clear(av)>.
747 Perl_av_fill(pTHX_ register AV *av, I32 fill)
752 PERL_ARGS_ASSERT_AV_FILL;
753 assert(SvTYPE(av) == SVt_PVAV);
757 if ((mg = SvTIED_mg((const SV *)av, PERL_MAGIC_tied))) {
758 SV *arg1 = sv_newmortal();
759 sv_setiv(arg1, (IV)(fill + 1));
760 magic_methcall(MUTABLE_SV(av), mg, "STORESIZE", G_DISCARD,
764 if (fill <= AvMAX(av)) {
765 I32 key = AvFILLp(av);
766 SV** const ary = AvARRAY(av);
770 SvREFCNT_dec(ary[key]);
771 ary[key--] = &PL_sv_undef;
776 ary[++key] = &PL_sv_undef;
781 mg_set(MUTABLE_SV(av));
784 (void)av_store(av,fill,&PL_sv_undef);
788 =for apidoc av_delete
790 Deletes the element indexed by C<key> from the array. Returns the
791 deleted element. If C<flags> equals C<G_DISCARD>, the element is freed
792 and null is returned.
797 Perl_av_delete(pTHX_ AV *av, I32 key, I32 flags)
802 PERL_ARGS_ASSERT_AV_DELETE;
803 assert(SvTYPE(av) == SVt_PVAV);
806 Perl_croak(aTHX_ "%s", PL_no_modify);
808 if (SvRMAGICAL(av)) {
809 const MAGIC * const tied_magic
810 = mg_find((const SV *)av, PERL_MAGIC_tied);
811 if ((tied_magic || mg_find((const SV *)av, PERL_MAGIC_regdata))) {
812 /* Handle negative array indices 20020222 MJD */
815 unsigned adjust_index = 1;
817 SV * const * const negative_indices_glob =
818 hv_fetch(SvSTASH(SvRV(SvTIED_obj(MUTABLE_SV(av),
820 NEGATIVE_INDICES_VAR, 16, 0);
821 if (negative_indices_glob
822 && SvTRUE(GvSV(*negative_indices_glob)))
826 key += AvFILL(av) + 1;
831 svp = av_fetch(av, key, TRUE);
835 if (mg_find(sv, PERL_MAGIC_tiedelem)) {
836 sv_unmagic(sv, PERL_MAGIC_tiedelem); /* No longer an element */
845 key += AvFILL(av) + 1;
850 if (key > AvFILLp(av))
853 if (!AvREAL(av) && AvREIFY(av))
855 sv = AvARRAY(av)[key];
856 if (key == AvFILLp(av)) {
857 AvARRAY(av)[key] = &PL_sv_undef;
860 } while (--key >= 0 && AvARRAY(av)[key] == &PL_sv_undef);
863 AvARRAY(av)[key] = &PL_sv_undef;
865 mg_set(MUTABLE_SV(av));
867 if (flags & G_DISCARD) {
877 =for apidoc av_exists
879 Returns true if the element indexed by C<key> has been initialized.
881 This relies on the fact that uninitialized array elements are set to
887 Perl_av_exists(pTHX_ AV *av, I32 key)
890 PERL_ARGS_ASSERT_AV_EXISTS;
891 assert(SvTYPE(av) == SVt_PVAV);
893 if (SvRMAGICAL(av)) {
894 const MAGIC * const tied_magic
895 = mg_find((const SV *)av, PERL_MAGIC_tied);
896 if (tied_magic || mg_find((const SV *)av, PERL_MAGIC_regdata)) {
897 SV * const sv = sv_newmortal();
899 /* Handle negative array indices 20020222 MJD */
901 unsigned adjust_index = 1;
903 SV * const * const negative_indices_glob =
904 hv_fetch(SvSTASH(SvRV(SvTIED_obj(MUTABLE_SV(av),
906 NEGATIVE_INDICES_VAR, 16, 0);
907 if (negative_indices_glob
908 && SvTRUE(GvSV(*negative_indices_glob)))
912 key += AvFILL(av) + 1;
918 mg_copy(MUTABLE_SV(av), sv, 0, key);
919 mg = mg_find(sv, PERL_MAGIC_tiedelem);
921 magic_existspack(sv, mg);
922 return cBOOL(SvTRUE(sv));
929 key += AvFILL(av) + 1;
934 if (key <= AvFILLp(av) && AvARRAY(av)[key] != &PL_sv_undef
944 S_get_aux_mg(pTHX_ AV *av) {
948 PERL_ARGS_ASSERT_GET_AUX_MG;
949 assert(SvTYPE(av) == SVt_PVAV);
951 mg = mg_find((const SV *)av, PERL_MAGIC_arylen_p);
954 mg = sv_magicext(MUTABLE_SV(av), 0, PERL_MAGIC_arylen_p,
955 &PL_vtbl_arylen_p, 0, 0);
957 /* sv_magicext won't set this for us because we pass in a NULL obj */
958 mg->mg_flags |= MGf_REFCOUNTED;
964 Perl_av_arylen_p(pTHX_ AV *av) {
965 MAGIC *const mg = get_aux_mg(av);
967 PERL_ARGS_ASSERT_AV_ARYLEN_P;
968 assert(SvTYPE(av) == SVt_PVAV);
970 return &(mg->mg_obj);
974 Perl_av_iter_p(pTHX_ AV *av) {
975 MAGIC *const mg = get_aux_mg(av);
977 PERL_ARGS_ASSERT_AV_ITER_P;
978 assert(SvTYPE(av) == SVt_PVAV);
980 #if IVSIZE == I32SIZE
981 return (IV *)&(mg->mg_len);
987 mg->mg_ptr = (char *) temp;
989 return (IV *)mg->mg_ptr;
995 * c-indentation-style: bsd
997 * indent-tabs-mode: t
1000 * ex: set ts=8 sts=4 sw=4 noet: