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)
31 PERL_ARGS_ASSERT_AV_REIFY;
32 assert(SvTYPE(av) == SVt_PVAV);
37 if (SvTIED_mg((const SV *)av, PERL_MAGIC_tied))
38 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEBUGGING), "av_reify called on tied array");
41 while (key > AvFILLp(av) + 1)
42 AvARRAY(av)[--key] = NULL;
44 SV * const sv = AvARRAY(av)[--key];
45 if (sv != &PL_sv_undef)
46 SvREFCNT_inc_simple_void(sv);
48 key = AvARRAY(av) - AvALLOC(av);
50 AvALLOC(av)[--key] = NULL;
58 Pre-extend an array. The C<key> is the index to which the array should be
65 Perl_av_extend(pTHX_ AV *av, SSize_t key)
69 PERL_ARGS_ASSERT_AV_EXTEND;
70 assert(SvTYPE(av) == SVt_PVAV);
72 mg = SvTIED_mg((const SV *)av, PERL_MAGIC_tied);
74 SV *arg1 = sv_newmortal();
75 sv_setiv(arg1, (IV)(key + 1));
76 Perl_magic_methcall(aTHX_ MUTABLE_SV(av), mg, SV_CONST(EXTEND), G_DISCARD, 1,
80 av_extend_guts(av,key,&AvMAX(av),&AvALLOC(av),&AvARRAY(av));
83 /* The guts of av_extend. *Not* for general use! */
85 Perl_av_extend_guts(pTHX_ AV *av, SSize_t key, SSize_t *maxp, SV ***allocp,
88 PERL_ARGS_ASSERT_AV_EXTEND_GUTS;
90 if (key < -1) /* -1 is legal */
92 "panic: av_extend_guts() negative count (%"IVdf")", (IV)key);
99 if (av && *allocp != *arrayp) {
100 ary = *allocp + AvFILLp(av) + 1;
101 tmp = *arrayp - *allocp;
102 Move(*arrayp, *allocp, AvFILLp(av)+1, SV*);
109 if (key > *maxp - 10) {
110 newmax = key + *maxp;
117 #ifdef Perl_safesysmalloc_size
118 /* Whilst it would be quite possible to move this logic around
119 (as I did in the SV code), so as to set AvMAX(av) early,
120 based on calling Perl_safesysmalloc_size() immediately after
121 allocation, I'm not convinced that it is a great idea here.
122 In an array we have to loop round setting everything to
123 NULL, which means writing to memory, potentially lots
124 of it, whereas for the SV buffer case we don't touch the
125 "bonus" memory. So there there is no cost in telling the
126 world about it, whereas here we have to do work before we can
127 tell the world about it, and that work involves writing to
128 memory that might never be read. So, I feel, better to keep
129 the current lazy system of only writing to it if our caller
130 has a need for more space. NWC */
131 newmax = Perl_safesysmalloc_size((void*)*allocp) /
132 sizeof(const SV *) - 1;
137 /* overflow-safe version of newmax = key + *maxp/5 */
139 newmax = (key > SSize_t_MAX - newmax)
140 ? SSize_t_MAX : key + newmax;
143 #ifdef PERL_MALLOC_WRAP /* Duplicated in pp_hot.c */
144 static const char oom_array_extend[] =
145 "Out of memory during array extend";
147 /* it should really be newmax+1 here, but if newmax
148 * happens to equal SSize_t_MAX, then newmax+1 is
149 * undefined. This means technically we croak one
150 * index lower than we should in theory; in practice
151 * its unlikely the system has SSize_t_MAX/sizeof(SV*)
153 MEM_WRAP_CHECK_1(newmax, SV*, oom_array_extend);
155 #ifdef STRESS_REALLOC
157 SV ** const old_alloc = *allocp;
158 Newx(*allocp, newmax+1, SV*);
159 Copy(old_alloc, *allocp, *maxp + 1, SV*);
163 Renew(*allocp,newmax+1, SV*);
165 #ifdef Perl_safesysmalloc_size
168 ary = *allocp + *maxp + 1;
169 tmp = newmax - *maxp;
170 if (av == PL_curstack) { /* Oops, grew stack (via av_store()?) */
171 PL_stack_sp = *allocp + (PL_stack_sp - PL_stack_base);
172 PL_stack_base = *allocp;
173 PL_stack_max = PL_stack_base + newmax;
177 newmax = key < 3 ? 3 : key;
179 #ifdef PERL_MALLOC_WRAP /* Duplicated in pp_hot.c */
180 static const char oom_array_extend[] =
181 "Out of memory during array extend";
183 /* see comment above about newmax+1*/
184 MEM_WRAP_CHECK_1(newmax, SV*, oom_array_extend);
186 Newx(*allocp, newmax+1, SV*);
189 *allocp[0] = NULL; /* For the stacks */
191 if (av && AvREAL(av)) {
205 Returns the SV at the specified index in the array. The C<key> is the
206 index. If lval is true, you are guaranteed to get a real SV back (in case
207 it wasn't real before), which you can then modify. Check that the return
208 value is non-null before dereferencing it to a C<SV*>.
210 See L<perlguts/"Understanding the Magic of Tied Hashes and Arrays"> for
211 more information on how to use this function on tied arrays.
213 The rough perl equivalent is C<$myarray[$key]>.
219 S_adjust_index(pTHX_ AV *av, const MAGIC *mg, SSize_t *keyp)
221 bool adjust_index = 1;
223 /* Handle negative array indices 20020222 MJD */
224 SV * const ref = SvTIED_obj(MUTABLE_SV(av), mg);
226 if (SvROK(ref) && SvOBJECT(SvRV(ref))) {
227 SV * const * const negative_indices_glob =
228 hv_fetchs(SvSTASH(SvRV(ref)), NEGATIVE_INDICES_VAR, 0);
230 if (negative_indices_glob && isGV(*negative_indices_glob)
231 && SvTRUE(GvSV(*negative_indices_glob)))
237 *keyp += AvFILL(av) + 1;
245 Perl_av_fetch(pTHX_ AV *av, SSize_t key, I32 lval)
250 PERL_ARGS_ASSERT_AV_FETCH;
251 assert(SvTYPE(av) == SVt_PVAV);
253 if (UNLIKELY(SvRMAGICAL(av))) {
254 const MAGIC * const tied_magic
255 = mg_find((const SV *)av, PERL_MAGIC_tied);
256 if (tied_magic || mg_find((const SV *)av, PERL_MAGIC_regdata)) {
259 if (!S_adjust_index(aTHX_ av, tied_magic, &key))
264 sv_upgrade(sv, SVt_PVLV);
265 mg_copy(MUTABLE_SV(av), sv, 0, key);
266 if (!tied_magic) /* for regdata, force leavesub to make copies */
269 LvTARG(sv) = sv; /* fake (SV**) */
270 return &(LvTARG(sv));
275 size = AvFILLp(av) + 1;
276 key += neg * size; /* handle negative index without using branch */
278 /* the cast from SSize_t to Size_t allows both (key < 0) and (key >= size)
279 * to be tested as a single condition */
280 if ((Size_t)key >= (Size_t)size) {
286 if (!AvARRAY(av)[key]) {
288 return lval ? av_store(av,key,newSV(0)) : NULL;
291 return &AvARRAY(av)[key];
297 Stores an SV in an array. The array index is specified as C<key>. The
298 return value will be C<NULL> if the operation failed or if the value did not
299 need to be actually stored within the array (as in the case of tied
300 arrays). Otherwise, it can be dereferenced
301 to get the C<SV*> that was stored
304 Note that the caller is responsible for suitably incrementing the reference
305 count of C<val> before the call, and decrementing it if the function
308 Approximate Perl equivalent: C<splice(@myarray, $key, 1, $val)>.
310 See L<perlguts/"Understanding the Magic of Tied Hashes and Arrays"> for
311 more information on how to use this function on tied arrays.
317 Perl_av_store(pTHX_ AV *av, SSize_t key, SV *val)
321 PERL_ARGS_ASSERT_AV_STORE;
322 assert(SvTYPE(av) == SVt_PVAV);
324 /* S_regclass relies on being able to pass in a NULL sv
325 (unicode_alternate may be NULL).
328 if (SvRMAGICAL(av)) {
329 const MAGIC * const tied_magic = mg_find((const SV *)av, PERL_MAGIC_tied);
332 if (!S_adjust_index(aTHX_ av, tied_magic, &key))
336 mg_copy(MUTABLE_SV(av), val, 0, key);
344 key += AvFILL(av) + 1;
349 if (SvREADONLY(av) && key >= AvFILL(av))
350 Perl_croak_no_modify();
352 if (!AvREAL(av) && AvREIFY(av))
357 if (AvFILLp(av) < key) {
359 if (av == PL_curstack && key > PL_stack_sp - PL_stack_base)
360 PL_stack_sp = PL_stack_base + key; /* XPUSH in disguise */
362 ary[++AvFILLp(av)] = NULL;
363 } while (AvFILLp(av) < key);
368 SvREFCNT_dec(ary[key]);
370 if (SvSMAGICAL(av)) {
371 const MAGIC *mg = SvMAGIC(av);
373 for (; mg; mg = mg->mg_moremagic) {
374 if (!isUPPER(mg->mg_type)) continue;
376 sv_magic(val, MUTABLE_SV(av), toLOWER(mg->mg_type), 0, key);
378 if (PL_delaymagic && mg->mg_type == PERL_MAGIC_isa) {
379 PL_delaymagic |= DM_ARRAY_ISA;
384 mg_set(MUTABLE_SV(av));
392 Creates a new AV and populates it with a list of SVs. The SVs are copied
393 into the array, so they may be freed after the call to C<av_make>. The new AV
394 will have a reference count of 1.
396 Perl equivalent: C<my @new_array = ($scalar1, $scalar2, $scalar3...);>
402 Perl_av_make(pTHX_ SSize_t size, SV **strp)
404 AV * const av = MUTABLE_AV(newSV_type(SVt_PVAV));
405 /* sv_upgrade does AvREAL_only() */
406 PERL_ARGS_ASSERT_AV_MAKE;
407 assert(SvTYPE(av) == SVt_PVAV);
409 if (size) { /* "defined" was returning undef for size==0 anyway. */
415 AvMAX(av) = size - 1;
419 for (i = 0; i < size; i++) {
422 /* Don't let sv_setsv swipe, since our source array might
423 have multiple references to the same temp scalar (e.g.
424 from a list slice) */
426 SvGETMAGIC(*strp); /* before newSV, in case it dies */
429 sv_setsv_flags(ary[i], *strp,
430 SV_DO_COW_SVSETSV|SV_NOSTEAL);
433 SvREFCNT_inc_simple_void_NN(av);
442 Frees the all the elements of an array, leaving it empty.
443 The XS equivalent of C<@array = ()>. See also L</av_undef>.
445 Note that it is possible that the actions of a destructor called directly
446 or indirectly by freeing an element of the array could cause the reference
447 count of the array itself to be reduced (e.g. by deleting an entry in the
448 symbol table). So it is a possibility that the AV could have been freed
449 (or even reallocated) on return from the call unless you hold a reference
456 Perl_av_clear(pTHX_ AV *av)
461 PERL_ARGS_ASSERT_AV_CLEAR;
462 assert(SvTYPE(av) == SVt_PVAV);
465 if (SvREFCNT(av) == 0) {
466 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEBUGGING), "Attempt to clear deleted array");
471 Perl_croak_no_modify();
473 /* Give any tie a chance to cleanup first */
474 if (SvRMAGICAL(av)) {
475 const MAGIC* const mg = SvMAGIC(av);
476 if (PL_delaymagic && mg && mg->mg_type == PERL_MAGIC_isa)
477 PL_delaymagic |= DM_ARRAY_ISA;
479 mg_clear(MUTABLE_SV(av));
485 if ((real = !!AvREAL(av))) {
486 SV** const ary = AvARRAY(av);
487 SSize_t index = AvFILLp(av) + 1;
489 SAVEFREESV(SvREFCNT_inc_simple_NN(av));
491 SV * const sv = ary[--index];
492 /* undef the slot before freeing the value, because a
493 * destructor might try to modify this array */
498 extra = AvARRAY(av) - AvALLOC(av);
501 AvARRAY(av) = AvALLOC(av);
510 Undefines the array. The XS equivalent of C<undef(@array)>.
512 As well as freeing all the elements of the array (like C<av_clear()>), this
513 also frees the memory used by the av to store its list of scalars.
515 See L</av_clear> for a note about the array possibly being invalid on
522 Perl_av_undef(pTHX_ AV *av)
526 PERL_ARGS_ASSERT_AV_UNDEF;
527 assert(SvTYPE(av) == SVt_PVAV);
529 /* Give any tie a chance to cleanup first */
530 if (SvTIED_mg((const SV *)av, PERL_MAGIC_tied))
533 if ((real = !!AvREAL(av))) {
534 SSize_t key = AvFILLp(av) + 1;
536 SAVEFREESV(SvREFCNT_inc_simple_NN(av));
538 SvREFCNT_dec(AvARRAY(av)[--key]);
541 Safefree(AvALLOC(av));
544 AvMAX(av) = AvFILLp(av) = -1;
546 if(SvRMAGICAL(av)) mg_clear(MUTABLE_SV(av));
552 =for apidoc av_create_and_push
554 Push an SV onto the end of the array, creating the array if necessary.
555 A small internal helper function to remove a commonly duplicated idiom.
561 Perl_av_create_and_push(pTHX_ AV **const avp, SV *const val)
563 PERL_ARGS_ASSERT_AV_CREATE_AND_PUSH;
573 Pushes an SV (transferring control of one reference count) onto the end of the
574 array. The array will grow automatically to accommodate the addition.
576 Perl equivalent: C<push @myarray, $val;>.
582 Perl_av_push(pTHX_ AV *av, SV *val)
586 PERL_ARGS_ASSERT_AV_PUSH;
587 assert(SvTYPE(av) == SVt_PVAV);
590 Perl_croak_no_modify();
592 if ((mg = SvTIED_mg((const SV *)av, PERL_MAGIC_tied))) {
593 Perl_magic_methcall(aTHX_ MUTABLE_SV(av), mg, SV_CONST(PUSH), G_DISCARD, 1,
597 av_store(av,AvFILLp(av)+1,val);
603 Removes one SV from the end of the array, reducing its size by one and
604 returning the SV (transferring control of one reference count) to the
605 caller. Returns C<&PL_sv_undef> if the array is empty.
607 Perl equivalent: C<pop(@myarray);>
613 Perl_av_pop(pTHX_ AV *av)
618 PERL_ARGS_ASSERT_AV_POP;
619 assert(SvTYPE(av) == SVt_PVAV);
622 Perl_croak_no_modify();
623 if ((mg = SvTIED_mg((const SV *)av, PERL_MAGIC_tied))) {
624 retval = Perl_magic_methcall(aTHX_ MUTABLE_SV(av), mg, SV_CONST(POP), 0, 0);
626 retval = newSVsv(retval);
631 retval = AvARRAY(av)[AvFILLp(av)];
632 AvARRAY(av)[AvFILLp(av)--] = NULL;
634 mg_set(MUTABLE_SV(av));
635 return retval ? retval : &PL_sv_undef;
640 =for apidoc av_create_and_unshift_one
642 Unshifts an SV onto the beginning of the array, creating the array if
644 A small internal helper function to remove a commonly duplicated idiom.
650 Perl_av_create_and_unshift_one(pTHX_ AV **const avp, SV *const val)
652 PERL_ARGS_ASSERT_AV_CREATE_AND_UNSHIFT_ONE;
657 return av_store(*avp, 0, val);
661 =for apidoc av_unshift
663 Unshift the given number of C<undef> values onto the beginning of the
664 array. The array will grow automatically to accommodate the addition.
666 Perl equivalent: S<C<unshift @myarray, ((undef) x $num);>>
672 Perl_av_unshift(pTHX_ AV *av, SSize_t num)
677 PERL_ARGS_ASSERT_AV_UNSHIFT;
678 assert(SvTYPE(av) == SVt_PVAV);
681 Perl_croak_no_modify();
683 if ((mg = SvTIED_mg((const SV *)av, PERL_MAGIC_tied))) {
684 Perl_magic_methcall(aTHX_ MUTABLE_SV(av), mg, SV_CONST(UNSHIFT),
685 G_DISCARD | G_UNDEF_FILL, num);
691 if (!AvREAL(av) && AvREIFY(av))
693 i = AvARRAY(av) - AvALLOC(av);
701 AvARRAY(av) = AvARRAY(av) - i;
705 const SSize_t i = AvFILLp(av);
706 /* Create extra elements */
707 const SSize_t slide = i > 0 ? i : 0;
709 av_extend(av, i + num);
712 Move(ary, ary + num, i + 1, SV*);
716 /* Make extra elements into a buffer */
718 AvFILLp(av) -= slide;
719 AvARRAY(av) = AvARRAY(av) + slide;
726 Removes one SV from the start of the array, reducing its size by one and
727 returning the SV (transferring control of one reference count) to the
728 caller. Returns C<&PL_sv_undef> if the array is empty.
730 Perl equivalent: C<shift(@myarray);>
736 Perl_av_shift(pTHX_ AV *av)
741 PERL_ARGS_ASSERT_AV_SHIFT;
742 assert(SvTYPE(av) == SVt_PVAV);
745 Perl_croak_no_modify();
746 if ((mg = SvTIED_mg((const SV *)av, PERL_MAGIC_tied))) {
747 retval = Perl_magic_methcall(aTHX_ MUTABLE_SV(av), mg, SV_CONST(SHIFT), 0, 0);
749 retval = newSVsv(retval);
754 retval = *AvARRAY(av);
757 AvARRAY(av) = AvARRAY(av) + 1;
761 mg_set(MUTABLE_SV(av));
762 return retval ? retval : &PL_sv_undef;
766 =for apidoc av_top_index
768 Returns the highest index in the array. The number of elements in the
769 array is S<C<av_top_index(av) + 1>>. Returns -1 if the array is empty.
771 The Perl equivalent for this is C<$#myarray>.
773 (A slightly shorter form is C<av_tindex>.)
777 Same as L</av_top_index>. Note that, unlike what the name implies, it returns
778 the highest index in the array, so to get the size of the array you need to use
779 S<C<av_len(av) + 1>>. This is unlike L</sv_len>, which returns what you would
786 Perl_av_len(pTHX_ AV *av)
788 PERL_ARGS_ASSERT_AV_LEN;
790 return av_top_index(av);
796 Set the highest index in the array to the given number, equivalent to
797 Perl's S<C<$#array = $fill;>>.
799 The number of elements in the array will be S<C<fill + 1>> after
800 C<av_fill()> returns. If the array was previously shorter, then the
801 additional elements appended are set to NULL. If the array
802 was longer, then the excess elements are freed. S<C<av_fill(av, -1)>> is
803 the same as C<av_clear(av)>.
808 Perl_av_fill(pTHX_ AV *av, SSize_t fill)
812 PERL_ARGS_ASSERT_AV_FILL;
813 assert(SvTYPE(av) == SVt_PVAV);
817 if ((mg = SvTIED_mg((const SV *)av, PERL_MAGIC_tied))) {
818 SV *arg1 = sv_newmortal();
819 sv_setiv(arg1, (IV)(fill + 1));
820 Perl_magic_methcall(aTHX_ MUTABLE_SV(av), mg, SV_CONST(STORESIZE), G_DISCARD,
824 if (fill <= AvMAX(av)) {
825 SSize_t key = AvFILLp(av);
826 SV** const ary = AvARRAY(av);
830 SvREFCNT_dec(ary[key]);
841 mg_set(MUTABLE_SV(av));
844 (void)av_store(av,fill,NULL);
848 =for apidoc av_delete
850 Deletes the element indexed by C<key> from the array, makes the element
851 mortal, and returns it. If C<flags> equals C<G_DISCARD>, the element is
852 freed and NULL is returned. NULL is also returned if C<key> is out of
855 Perl equivalent: S<C<splice(@myarray, $key, 1, undef)>> (with the
856 C<splice> in void context if C<G_DISCARD> is present).
861 Perl_av_delete(pTHX_ AV *av, SSize_t key, I32 flags)
865 PERL_ARGS_ASSERT_AV_DELETE;
866 assert(SvTYPE(av) == SVt_PVAV);
869 Perl_croak_no_modify();
871 if (SvRMAGICAL(av)) {
872 const MAGIC * const tied_magic
873 = mg_find((const SV *)av, PERL_MAGIC_tied);
874 if ((tied_magic || mg_find((const SV *)av, PERL_MAGIC_regdata))) {
877 if (!S_adjust_index(aTHX_ av, tied_magic, &key))
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 AvARRAY(av)[key] = NULL;
906 if (key == AvFILLp(av)) {
909 } while (--key >= 0 && !AvARRAY(av)[key]);
912 mg_set(MUTABLE_SV(av));
915 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
933 Perl equivalent: C<exists($myarray[$key])>.
938 Perl_av_exists(pTHX_ AV *av, SSize_t key)
940 PERL_ARGS_ASSERT_AV_EXISTS;
941 assert(SvTYPE(av) == SVt_PVAV);
943 if (SvRMAGICAL(av)) {
944 const MAGIC * const tied_magic
945 = mg_find((const SV *)av, PERL_MAGIC_tied);
946 const MAGIC * const regdata_magic
947 = mg_find((const SV *)av, PERL_MAGIC_regdata);
948 if (tied_magic || regdata_magic) {
950 /* Handle negative array indices 20020222 MJD */
952 if (!S_adjust_index(aTHX_ av, tied_magic, &key))
956 if(key >= 0 && regdata_magic) {
957 if (key <= AvFILL(av))
963 SV * const sv = sv_newmortal();
964 mg_copy(MUTABLE_SV(av), sv, 0, key);
965 mg = mg_find(sv, PERL_MAGIC_tiedelem);
967 magic_existspack(sv, mg);
969 I32 retbool = SvTRUE_nomg_NN(sv);
970 return cBOOL(retbool);
978 key += AvFILL(av) + 1;
983 if (key <= AvFILLp(av) && AvARRAY(av)[key])
992 S_get_aux_mg(pTHX_ AV *av) {
995 PERL_ARGS_ASSERT_GET_AUX_MG;
996 assert(SvTYPE(av) == SVt_PVAV);
998 mg = mg_find((const SV *)av, PERL_MAGIC_arylen_p);
1001 mg = sv_magicext(MUTABLE_SV(av), 0, PERL_MAGIC_arylen_p,
1002 &PL_vtbl_arylen_p, 0, 0);
1004 /* sv_magicext won't set this for us because we pass in a NULL obj */
1005 mg->mg_flags |= MGf_REFCOUNTED;
1011 Perl_av_arylen_p(pTHX_ AV *av) {
1012 MAGIC *const mg = get_aux_mg(av);
1014 PERL_ARGS_ASSERT_AV_ARYLEN_P;
1015 assert(SvTYPE(av) == SVt_PVAV);
1017 return &(mg->mg_obj);
1021 Perl_av_iter_p(pTHX_ AV *av) {
1022 MAGIC *const mg = get_aux_mg(av);
1024 PERL_ARGS_ASSERT_AV_ITER_P;
1025 assert(SvTYPE(av) == SVt_PVAV);
1027 #if IVSIZE == I32SIZE
1028 return (IV *)&(mg->mg_len);
1032 mg->mg_len = IVSIZE;
1034 mg->mg_ptr = (char *) temp;
1036 return (IV *)mg->mg_ptr;
1041 * ex: set ts=8 sts=4 sw=4 et: