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)) /
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(SV*);
149 #define MALLOC_OVERHEAD 16
150 itmp = MALLOC_OVERHEAD;
151 while ((MEM_SIZE)(itmp - MALLOC_OVERHEAD) < bytes)
153 itmp -= MALLOC_OVERHEAD;
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), (AvMAX(av)+1) * sizeof(SV*));
163 Safefree(AvALLOC(av));
166 #ifdef Perl_safesysmalloc_size
169 ary = AvALLOC(av) + AvMAX(av) + 1;
170 tmp = newmax - AvMAX(av);
171 if (av == PL_curstack) { /* Oops, grew stack (via av_store()?) */
172 PL_stack_sp = AvALLOC(av) + (PL_stack_sp - PL_stack_base);
173 PL_stack_base = AvALLOC(av);
174 PL_stack_max = PL_stack_base + newmax;
178 newmax = key < 3 ? 3 : key;
179 MEM_WRAP_CHECK_1(newmax+1, SV*, oom_array_extend);
180 Newx(AvALLOC(av), newmax+1, SV*);
181 ary = AvALLOC(av) + 1;
183 AvALLOC(av)[0] = &PL_sv_undef; /* For the stacks */
187 ary[--tmp] = &PL_sv_undef;
190 AvARRAY(av) = AvALLOC(av);
199 Returns the SV at the specified index in the array. The C<key> is the
200 index. If C<lval> is set then the fetch will be part of a store. Check
201 that the return value is non-null before dereferencing it to a C<SV*>.
203 See L<perlguts/"Understanding the Magic of Tied Hashes and Arrays"> for
204 more information on how to use this function on tied arrays.
210 Perl_av_fetch(pTHX_ register AV *av, I32 key, I32 lval)
214 PERL_ARGS_ASSERT_AV_FETCH;
215 assert(SvTYPE(av) == SVt_PVAV);
217 if (SvRMAGICAL(av)) {
218 const MAGIC * const tied_magic
219 = mg_find((const SV *)av, PERL_MAGIC_tied);
220 if (tied_magic || mg_find((const SV *)av, PERL_MAGIC_regdata)) {
223 I32 adjust_index = 1;
225 /* Handle negative array indices 20020222 MJD */
226 SV * const * const negative_indices_glob =
227 hv_fetch(SvSTASH(SvRV(SvTIED_obj(MUTABLE_SV(av),
229 NEGATIVE_INDICES_VAR, 16, 0);
231 if (negative_indices_glob && SvTRUE(GvSV(*negative_indices_glob)))
236 key += AvFILL(av) + 1;
243 sv_upgrade(sv, SVt_PVLV);
244 mg_copy(MUTABLE_SV(av), sv, 0, key);
246 LvTARG(sv) = sv; /* fake (SV**) */
247 return &(LvTARG(sv));
252 key += AvFILL(av) + 1;
257 if (key > AvFILLp(av)) {
260 return av_store(av,key,newSV(0));
262 if (AvARRAY(av)[key] == &PL_sv_undef) {
265 return av_store(av,key,newSV(0));
269 && (!AvARRAY(av)[key] /* eg. @_ could have freed elts */
270 || SvIS_FREED(AvARRAY(av)[key]))) {
271 AvARRAY(av)[key] = &PL_sv_undef; /* 1/2 reify */
274 return &AvARRAY(av)[key];
280 Stores an SV in an array. The array index is specified as C<key>. The
281 return value will be NULL if the operation failed or if the value did not
282 need to be actually stored within the array (as in the case of tied
283 arrays). Otherwise it can be dereferenced to get the original C<SV*>. Note
284 that the caller is responsible for suitably incrementing the reference
285 count of C<val> before the call, and decrementing it if the function
288 See L<perlguts/"Understanding the Magic of Tied Hashes and Arrays"> for
289 more information on how to use this function on tied arrays.
295 Perl_av_store(pTHX_ register AV *av, I32 key, SV *val)
300 PERL_ARGS_ASSERT_AV_STORE;
301 assert(SvTYPE(av) == SVt_PVAV);
303 /* S_regclass relies on being able to pass in a NULL sv
304 (unicode_alternate may be NULL).
310 if (SvRMAGICAL(av)) {
311 const MAGIC * const tied_magic = mg_find((const SV *)av, PERL_MAGIC_tied);
313 /* Handle negative array indices 20020222 MJD */
315 bool adjust_index = 1;
316 SV * const * const negative_indices_glob =
317 hv_fetch(SvSTASH(SvRV(SvTIED_obj(MUTABLE_SV(av),
319 NEGATIVE_INDICES_VAR, 16, 0);
320 if (negative_indices_glob
321 && SvTRUE(GvSV(*negative_indices_glob)))
324 key += AvFILL(av) + 1;
329 if (val != &PL_sv_undef) {
330 mg_copy(MUTABLE_SV(av), val, 0, key);
338 key += AvFILL(av) + 1;
343 if (SvREADONLY(av) && key >= AvFILL(av))
344 Perl_croak(aTHX_ PL_no_modify);
346 if (!AvREAL(av) && AvREIFY(av))
351 if (AvFILLp(av) < key) {
353 if (av == PL_curstack && key > PL_stack_sp - PL_stack_base)
354 PL_stack_sp = PL_stack_base + key; /* XPUSH in disguise */
356 ary[++AvFILLp(av)] = &PL_sv_undef;
357 } while (AvFILLp(av) < key);
362 SvREFCNT_dec(ary[key]);
364 if (SvSMAGICAL(av)) {
365 const MAGIC* const mg = SvMAGIC(av);
366 if (val != &PL_sv_undef) {
367 sv_magic(val, MUTABLE_SV(av), toLOWER(mg->mg_type), 0, key);
369 if (PL_delaymagic && mg->mg_type == PERL_MAGIC_isa)
370 PL_delaymagic |= DM_ARRAY;
372 mg_set(MUTABLE_SV(av));
380 Creates a new AV and populates it with a list of SVs. The SVs are copied
381 into the array, so they may be freed after the call to av_make. The new AV
382 will have a reference count of 1.
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 sv_setsv(ary[i], *strp);
415 Clears an array, making it empty. Does not free the memory used by the
422 Perl_av_clear(pTHX_ register AV *av)
427 PERL_ARGS_ASSERT_AV_CLEAR;
428 assert(SvTYPE(av) == SVt_PVAV);
431 if (SvREFCNT(av) == 0 && ckWARN_d(WARN_DEBUGGING)) {
432 Perl_warner(aTHX_ packWARN(WARN_DEBUGGING), "Attempt to clear deleted array");
437 Perl_croak(aTHX_ PL_no_modify);
439 /* Give any tie a chance to cleanup first */
440 if (SvRMAGICAL(av)) {
441 const MAGIC* const mg = SvMAGIC(av);
442 if (PL_delaymagic && mg && mg->mg_type == PERL_MAGIC_isa)
443 PL_delaymagic |= DM_ARRAY;
445 mg_clear(MUTABLE_SV(av));
452 SV** const ary = AvARRAY(av);
453 I32 index = AvFILLp(av) + 1;
455 SV * const sv = ary[--index];
456 /* undef the slot before freeing the value, because a
457 * destructor might try to modify this array */
458 ary[index] = &PL_sv_undef;
462 extra = AvARRAY(av) - AvALLOC(av);
465 AvARRAY(av) = AvALLOC(av);
474 Undefines the array. Frees the memory used by the array itself.
480 Perl_av_undef(pTHX_ register AV *av)
482 PERL_ARGS_ASSERT_AV_UNDEF;
483 assert(SvTYPE(av) == SVt_PVAV);
485 /* Give any tie a chance to cleanup first */
486 if (SvTIED_mg((const SV *)av, PERL_MAGIC_tied))
490 register I32 key = AvFILLp(av) + 1;
492 SvREFCNT_dec(AvARRAY(av)[--key]);
495 Safefree(AvALLOC(av));
498 AvMAX(av) = AvFILLp(av) = -1;
500 if(SvRMAGICAL(av)) mg_clear(MUTABLE_SV(av));
505 =for apidoc av_create_and_push
507 Push an SV onto the end of the array, creating the array if necessary.
508 A small internal helper function to remove a commonly duplicated idiom.
514 Perl_av_create_and_push(pTHX_ AV **const avp, SV *const val)
516 PERL_ARGS_ASSERT_AV_CREATE_AND_PUSH;
526 Pushes an SV onto the end of the array. The array will grow automatically
527 to accommodate the addition.
533 Perl_av_push(pTHX_ register AV *av, SV *val)
538 PERL_ARGS_ASSERT_AV_PUSH;
539 assert(SvTYPE(av) == SVt_PVAV);
542 Perl_croak(aTHX_ PL_no_modify);
544 if ((mg = SvTIED_mg((const SV *)av, PERL_MAGIC_tied))) {
546 PUSHSTACKi(PERLSI_MAGIC);
549 PUSHs(SvTIED_obj(MUTABLE_SV(av), mg));
553 call_method("PUSH", G_SCALAR|G_DISCARD);
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
571 Perl_av_pop(pTHX_ register AV *av)
577 PERL_ARGS_ASSERT_AV_POP;
578 assert(SvTYPE(av) == SVt_PVAV);
581 Perl_croak(aTHX_ PL_no_modify);
582 if ((mg = SvTIED_mg((const SV *)av, PERL_MAGIC_tied))) {
584 PUSHSTACKi(PERLSI_MAGIC);
586 XPUSHs(SvTIED_obj(MUTABLE_SV(av), mg));
589 if (call_method("POP", G_SCALAR)) {
590 retval = newSVsv(*PL_stack_sp--);
592 retval = &PL_sv_undef;
600 retval = AvARRAY(av)[AvFILLp(av)];
601 AvARRAY(av)[AvFILLp(av)--] = &PL_sv_undef;
603 mg_set(MUTABLE_SV(av));
609 =for apidoc av_create_and_unshift_one
611 Unshifts an SV onto the beginning of the array, creating the array if
613 A small internal helper function to remove a commonly duplicated idiom.
619 Perl_av_create_and_unshift_one(pTHX_ AV **const avp, SV *const val)
621 PERL_ARGS_ASSERT_AV_CREATE_AND_UNSHIFT_ONE;
626 return av_store(*avp, 0, val);
630 =for apidoc av_unshift
632 Unshift the given number of C<undef> values onto the beginning of the
633 array. The array will grow automatically to accommodate the addition. You
634 must then use C<av_store> to assign values to these new elements.
640 Perl_av_unshift(pTHX_ register AV *av, register I32 num)
646 PERL_ARGS_ASSERT_AV_UNSHIFT;
647 assert(SvTYPE(av) == SVt_PVAV);
650 Perl_croak(aTHX_ PL_no_modify);
652 if ((mg = SvTIED_mg((const SV *)av, PERL_MAGIC_tied))) {
654 PUSHSTACKi(PERLSI_MAGIC);
657 PUSHs(SvTIED_obj(MUTABLE_SV(av), mg));
663 call_method("UNSHIFT", G_SCALAR|G_DISCARD);
671 if (!AvREAL(av) && AvREIFY(av))
673 i = AvARRAY(av) - AvALLOC(av);
681 AvARRAY(av) = AvARRAY(av) - i;
685 const I32 i = AvFILLp(av);
686 /* Create extra elements */
687 const I32 slide = i > 0 ? i : 0;
689 av_extend(av, i + num);
692 Move(ary, ary + num, i + 1, SV*);
694 ary[--num] = &PL_sv_undef;
696 /* Make extra elements into a buffer */
698 AvFILLp(av) -= slide;
699 AvARRAY(av) = AvARRAY(av) + slide;
706 Shifts an SV off the beginning of the array. Returns C<&PL_sv_undef> if the
713 Perl_av_shift(pTHX_ register AV *av)
719 PERL_ARGS_ASSERT_AV_SHIFT;
720 assert(SvTYPE(av) == SVt_PVAV);
723 Perl_croak(aTHX_ PL_no_modify);
724 if ((mg = SvTIED_mg((const SV *)av, PERL_MAGIC_tied))) {
726 PUSHSTACKi(PERLSI_MAGIC);
728 XPUSHs(SvTIED_obj(MUTABLE_SV(av), mg));
731 if (call_method("SHIFT", G_SCALAR)) {
732 retval = newSVsv(*PL_stack_sp--);
734 retval = &PL_sv_undef;
742 retval = *AvARRAY(av);
744 *AvARRAY(av) = &PL_sv_undef;
745 AvARRAY(av) = AvARRAY(av) + 1;
749 mg_set(MUTABLE_SV(av));
756 Returns the highest index in the array. The number of elements in the
757 array is C<av_len(av) + 1>. Returns -1 if the array is empty.
763 Perl_av_len(pTHX_ AV *av)
765 PERL_ARGS_ASSERT_AV_LEN;
766 assert(SvTYPE(av) == SVt_PVAV);
774 Set the highest index in the array to the given number, equivalent to
775 Perl's C<$#array = $fill;>.
777 The number of elements in the an array will be C<fill + 1> after
778 av_fill() returns. If the array was previously shorter then the
779 additional elements appended are set to C<PL_sv_undef>. If the array
780 was longer, then the excess elements are freed. C<av_fill(av, -1)> is
781 the same as C<av_clear(av)>.
786 Perl_av_fill(pTHX_ register AV *av, I32 fill)
791 PERL_ARGS_ASSERT_AV_FILL;
792 assert(SvTYPE(av) == SVt_PVAV);
796 if ((mg = SvTIED_mg((const SV *)av, PERL_MAGIC_tied))) {
800 PUSHSTACKi(PERLSI_MAGIC);
803 PUSHs(SvTIED_obj(MUTABLE_SV(av), mg));
806 call_method("STORESIZE", G_SCALAR|G_DISCARD);
812 if (fill <= AvMAX(av)) {
813 I32 key = AvFILLp(av);
814 SV** const ary = AvARRAY(av);
818 SvREFCNT_dec(ary[key]);
819 ary[key--] = &PL_sv_undef;
824 ary[++key] = &PL_sv_undef;
829 mg_set(MUTABLE_SV(av));
832 (void)av_store(av,fill,&PL_sv_undef);
836 =for apidoc av_delete
838 Deletes the element indexed by C<key> from the array. Returns the
839 deleted element. If C<flags> equals C<G_DISCARD>, the element is freed
840 and null is returned.
845 Perl_av_delete(pTHX_ AV *av, I32 key, I32 flags)
850 PERL_ARGS_ASSERT_AV_DELETE;
851 assert(SvTYPE(av) == SVt_PVAV);
854 Perl_croak(aTHX_ PL_no_modify);
856 if (SvRMAGICAL(av)) {
857 const MAGIC * const tied_magic
858 = mg_find((const SV *)av, PERL_MAGIC_tied);
859 if ((tied_magic || mg_find((const SV *)av, PERL_MAGIC_regdata))) {
860 /* Handle negative array indices 20020222 MJD */
863 unsigned adjust_index = 1;
865 SV * const * const negative_indices_glob =
866 hv_fetch(SvSTASH(SvRV(SvTIED_obj(MUTABLE_SV(av),
868 NEGATIVE_INDICES_VAR, 16, 0);
869 if (negative_indices_glob
870 && SvTRUE(GvSV(*negative_indices_glob)))
874 key += AvFILL(av) + 1;
879 svp = av_fetch(av, key, TRUE);
883 if (mg_find(sv, PERL_MAGIC_tiedelem)) {
884 sv_unmagic(sv, PERL_MAGIC_tiedelem); /* No longer an element */
893 key += AvFILL(av) + 1;
898 if (key > AvFILLp(av))
901 if (!AvREAL(av) && AvREIFY(av))
903 sv = AvARRAY(av)[key];
904 if (key == AvFILLp(av)) {
905 AvARRAY(av)[key] = &PL_sv_undef;
908 } while (--key >= 0 && AvARRAY(av)[key] == &PL_sv_undef);
911 AvARRAY(av)[key] = &PL_sv_undef;
913 mg_set(MUTABLE_SV(av));
915 if (flags & G_DISCARD) {
925 =for apidoc av_exists
927 Returns true if the element indexed by C<key> has been initialized.
929 This relies on the fact that uninitialized array elements are set to
935 Perl_av_exists(pTHX_ AV *av, I32 key)
938 PERL_ARGS_ASSERT_AV_EXISTS;
939 assert(SvTYPE(av) == SVt_PVAV);
941 if (SvRMAGICAL(av)) {
942 const MAGIC * const tied_magic
943 = mg_find((const SV *)av, PERL_MAGIC_tied);
944 if (tied_magic || mg_find((const SV *)av, PERL_MAGIC_regdata)) {
945 SV * const sv = sv_newmortal();
947 /* Handle negative array indices 20020222 MJD */
949 unsigned adjust_index = 1;
951 SV * const * const negative_indices_glob =
952 hv_fetch(SvSTASH(SvRV(SvTIED_obj(MUTABLE_SV(av),
954 NEGATIVE_INDICES_VAR, 16, 0);
955 if (negative_indices_glob
956 && SvTRUE(GvSV(*negative_indices_glob)))
960 key += AvFILL(av) + 1;
966 mg_copy(MUTABLE_SV(av), sv, 0, key);
967 mg = mg_find(sv, PERL_MAGIC_tiedelem);
969 magic_existspack(sv, mg);
970 return (bool)SvTRUE(sv);
977 key += AvFILL(av) + 1;
982 if (key <= AvFILLp(av) && AvARRAY(av)[key] != &PL_sv_undef
992 S_get_aux_mg(pTHX_ AV *av) {
996 PERL_ARGS_ASSERT_GET_AUX_MG;
997 assert(SvTYPE(av) == SVt_PVAV);
999 mg = mg_find((const SV *)av, PERL_MAGIC_arylen_p);
1002 mg = sv_magicext(MUTABLE_SV(av), 0, PERL_MAGIC_arylen_p,
1003 &PL_vtbl_arylen_p, 0, 0);
1005 /* sv_magicext won't set this for us because we pass in a NULL obj */
1006 mg->mg_flags |= MGf_REFCOUNTED;
1012 Perl_av_arylen_p(pTHX_ AV *av) {
1013 MAGIC *const mg = get_aux_mg(av);
1015 PERL_ARGS_ASSERT_AV_ARYLEN_P;
1016 assert(SvTYPE(av) == SVt_PVAV);
1018 return &(mg->mg_obj);
1022 Perl_av_iter_p(pTHX_ AV *av) {
1023 MAGIC *const mg = get_aux_mg(av);
1025 PERL_ARGS_ASSERT_AV_ITER_P;
1026 assert(SvTYPE(av) == SVt_PVAV);
1028 #if IVSIZE == I32SIZE
1029 return (IV *)&(mg->mg_len);
1033 mg->mg_len = IVSIZE;
1035 mg->mg_ptr = (char *) temp;
1037 return (IV *)mg->mg_ptr;
1043 * c-indentation-style: bsd
1045 * indent-tabs-mode: t
1048 * ex: set ts=8 sts=4 sw=4 noet: