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] = NULL;
45 SV * const sv = AvARRAY(av)[--key];
46 if (sv != &PL_sv_undef)
47 SvREFCNT_inc_simple_void(sv);
49 key = AvARRAY(av) - AvALLOC(av);
51 AvALLOC(av)[--key] = NULL;
59 Pre-extend an array. The C<key> is the index to which the array should be
66 Perl_av_extend(pTHX_ AV *av, I32 key)
71 PERL_ARGS_ASSERT_AV_EXTEND;
72 assert(SvTYPE(av) == SVt_PVAV);
74 mg = SvTIED_mg((const SV *)av, PERL_MAGIC_tied);
76 SV *arg1 = sv_newmortal();
77 sv_setiv(arg1, (IV)(key + 1));
78 Perl_magic_methcall(aTHX_ MUTABLE_SV(av), mg, SV_CONST(EXTEND), G_DISCARD, 1,
82 av_extend_guts(av,key,&AvMAX(av),&AvALLOC(av),&AvARRAY(av));
85 /* The guts of av_extend. *Not* for general use! */
87 Perl_av_extend_guts(pTHX_ AV *av, I32 key, SSize_t *maxp, SV ***allocp,
92 PERL_ARGS_ASSERT_AV_EXTEND_GUTS;
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;
115 #ifdef PERL_MALLOC_WRAP
116 static const char oom_array_extend[] =
117 "Out of memory during array extend"; /* Duplicated in pp_hot.c */
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 NULL, 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*)*allocp) /
137 sizeof(const SV *) - 1;
142 newmax = key + *maxp / 5;
144 MEM_WRAP_CHECK_1(newmax+1, SV*, oom_array_extend);
145 Renew(*allocp,newmax+1, SV*);
146 #ifdef Perl_safesysmalloc_size
149 ary = *allocp + *maxp + 1;
150 tmp = newmax - *maxp;
151 if (av == PL_curstack) { /* Oops, grew stack (via av_store()?) */
152 PL_stack_sp = *allocp + (PL_stack_sp - PL_stack_base);
153 PL_stack_base = *allocp;
154 PL_stack_max = PL_stack_base + newmax;
158 newmax = key < 3 ? 3 : key;
159 MEM_WRAP_CHECK_1(newmax+1, SV*, oom_array_extend);
160 Newx(*allocp, newmax+1, SV*);
163 *allocp[0] = NULL; /* For the stacks */
165 if (av && AvREAL(av)) {
179 Returns the SV at the specified index in the array. The C<key> is the
180 index. If lval is true, you are guaranteed to get a real SV back (in case
181 it wasn't real before), which you can then modify. Check that the return
182 value is non-null before dereferencing it to a C<SV*>.
184 See L<perlguts/"Understanding the Magic of Tied Hashes and Arrays"> for
185 more information on how to use this function on tied arrays.
187 The rough perl equivalent is C<$myarray[$idx]>.
193 S_adjust_index(pTHX_ AV *av, const MAGIC *mg, I32 *keyp)
195 bool adjust_index = 1;
197 /* Handle negative array indices 20020222 MJD */
198 SV * const ref = SvTIED_obj(MUTABLE_SV(av), mg);
200 if (SvROK(ref) && SvOBJECT(SvRV(ref))) {
201 SV * const * const negative_indices_glob =
202 hv_fetchs(SvSTASH(SvRV(ref)), NEGATIVE_INDICES_VAR, 0);
204 if (negative_indices_glob && SvTRUE(GvSV(*negative_indices_glob)))
210 *keyp += AvFILL(av) + 1;
218 Perl_av_fetch(pTHX_ AV *av, I32 key, I32 lval)
222 PERL_ARGS_ASSERT_AV_FETCH;
223 assert(SvTYPE(av) == SVt_PVAV);
225 if (SvRMAGICAL(av)) {
226 const MAGIC * const tied_magic
227 = mg_find((const SV *)av, PERL_MAGIC_tied);
228 if (tied_magic || mg_find((const SV *)av, PERL_MAGIC_regdata)) {
231 if (!S_adjust_index(aTHX_ av, tied_magic, &key))
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) || !AvARRAY(av)[key]) {
254 return lval ? av_store(av,key,newSV(0)) : NULL;
258 && (!AvARRAY(av)[key] /* eg. @_ could have freed elts */
259 || SvIS_FREED(AvARRAY(av)[key]))) {
260 AvARRAY(av)[key] = NULL; /* 1/2 reify */
263 return &AvARRAY(av)[key];
269 Stores an SV in an array. The array index is specified as C<key>. The
270 return value will be NULL if the operation failed or if the value did not
271 need to be actually stored within the array (as in the case of tied
272 arrays). Otherwise, it can be dereferenced
273 to get the C<SV*> that was stored
276 Note that the caller is responsible for suitably incrementing the reference
277 count of C<val> before the call, and decrementing it if the function
280 Approximate Perl equivalent: C<$myarray[$key] = $val;>.
282 See L<perlguts/"Understanding the Magic of Tied Hashes and Arrays"> for
283 more information on how to use this function on tied arrays.
289 Perl_av_store(pTHX_ AV *av, I32 key, SV *val)
294 PERL_ARGS_ASSERT_AV_STORE;
295 assert(SvTYPE(av) == SVt_PVAV);
297 /* S_regclass relies on being able to pass in a NULL sv
298 (unicode_alternate may be NULL).
301 if (SvRMAGICAL(av)) {
302 const MAGIC * const tied_magic = mg_find((const SV *)av, PERL_MAGIC_tied);
305 if (!S_adjust_index(aTHX_ av, tied_magic, &key))
309 mg_copy(MUTABLE_SV(av), val, 0, key);
317 key += AvFILL(av) + 1;
322 if (SvREADONLY(av) && key >= AvFILL(av))
323 Perl_croak_no_modify();
325 if (!AvREAL(av) && AvREIFY(av))
330 if (AvFILLp(av) < key) {
332 if (av == PL_curstack && key > PL_stack_sp - PL_stack_base)
333 PL_stack_sp = PL_stack_base + key; /* XPUSH in disguise */
335 ary[++AvFILLp(av)] = NULL;
336 } while (AvFILLp(av) < key);
341 SvREFCNT_dec(ary[key]);
343 if (SvSMAGICAL(av)) {
344 const MAGIC *mg = SvMAGIC(av);
346 for (; mg; mg = mg->mg_moremagic) {
347 if (!isUPPER(mg->mg_type)) continue;
349 sv_magic(val, MUTABLE_SV(av), toLOWER(mg->mg_type), 0, key);
351 if (PL_delaymagic && mg->mg_type == PERL_MAGIC_isa) {
352 PL_delaymagic |= DM_ARRAY_ISA;
357 mg_set(MUTABLE_SV(av));
365 Creates a new AV and populates it with a list of SVs. The SVs are copied
366 into the array, so they may be freed after the call to av_make. The new AV
367 will have a reference count of 1.
369 Perl equivalent: C<my @new_array = ($scalar1, $scalar2, $scalar3...);>
375 Perl_av_make(pTHX_ I32 size, SV **strp)
377 AV * const av = MUTABLE_AV(newSV_type(SVt_PVAV));
378 /* sv_upgrade does AvREAL_only() */
379 PERL_ARGS_ASSERT_AV_MAKE;
380 assert(SvTYPE(av) == SVt_PVAV);
382 if (size) { /* "defined" was returning undef for size==0 anyway. */
388 AvMAX(av) = size - 1;
392 for (i = 0; i < size; i++) {
395 /* Don't let sv_setsv swipe, since our source array might
396 have multiple references to the same temp scalar (e.g.
397 from a list slice) */
399 SvGETMAGIC(*strp); /* before newSV, in case it dies */
402 sv_setsv_flags(ary[i], *strp,
403 SV_DO_COW_SVSETSV|SV_NOSTEAL);
406 SvREFCNT_inc_simple_void_NN(av);
415 Clears an array, making it empty. Does not free the memory the av uses to
416 store its list of scalars. If any destructors are triggered as a result,
417 the av itself may be freed when this function returns.
419 Perl equivalent: C<@myarray = ();>.
425 Perl_av_clear(pTHX_ AV *av)
431 PERL_ARGS_ASSERT_AV_CLEAR;
432 assert(SvTYPE(av) == SVt_PVAV);
435 if (SvREFCNT(av) == 0) {
436 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEBUGGING), "Attempt to clear deleted array");
441 Perl_croak_no_modify();
443 /* Give any tie a chance to cleanup first */
444 if (SvRMAGICAL(av)) {
445 const MAGIC* const mg = SvMAGIC(av);
446 if (PL_delaymagic && mg && mg->mg_type == PERL_MAGIC_isa)
447 PL_delaymagic |= DM_ARRAY_ISA;
449 mg_clear(MUTABLE_SV(av));
455 if ((real = !!AvREAL(av))) {
456 SV** const ary = AvARRAY(av);
457 I32 index = AvFILLp(av) + 1;
459 SAVEFREESV(SvREFCNT_inc_simple_NN(av));
461 SV * const sv = ary[--index];
462 /* undef the slot before freeing the value, because a
463 * destructor might try to modify this array */
468 extra = AvARRAY(av) - AvALLOC(av);
471 AvARRAY(av) = AvALLOC(av);
480 Undefines the array. Frees the memory used by the av to store its list of
481 scalars. If any destructors are triggered as a result, the av itself may
488 Perl_av_undef(pTHX_ AV *av)
492 PERL_ARGS_ASSERT_AV_UNDEF;
493 assert(SvTYPE(av) == SVt_PVAV);
495 /* Give any tie a chance to cleanup first */
496 if (SvTIED_mg((const SV *)av, PERL_MAGIC_tied))
499 if ((real = !!AvREAL(av))) {
500 I32 key = AvFILLp(av) + 1;
502 SAVEFREESV(SvREFCNT_inc_simple_NN(av));
504 SvREFCNT_dec(AvARRAY(av)[--key]);
507 Safefree(AvALLOC(av));
510 AvMAX(av) = AvFILLp(av) = -1;
512 if(SvRMAGICAL(av)) mg_clear(MUTABLE_SV(av));
518 =for apidoc av_create_and_push
520 Push an SV onto the end of the array, creating the array if necessary.
521 A small internal helper function to remove a commonly duplicated idiom.
527 Perl_av_create_and_push(pTHX_ AV **const avp, SV *const val)
529 PERL_ARGS_ASSERT_AV_CREATE_AND_PUSH;
539 Pushes an SV onto the end of the array. The array will grow automatically
540 to accommodate the addition. This takes ownership of one reference count.
542 Perl equivalent: C<push @myarray, $elem;>.
548 Perl_av_push(pTHX_ AV *av, SV *val)
553 PERL_ARGS_ASSERT_AV_PUSH;
554 assert(SvTYPE(av) == SVt_PVAV);
557 Perl_croak_no_modify();
559 if ((mg = SvTIED_mg((const SV *)av, PERL_MAGIC_tied))) {
560 Perl_magic_methcall(aTHX_ MUTABLE_SV(av), mg, SV_CONST(PUSH), G_DISCARD, 1,
564 av_store(av,AvFILLp(av)+1,val);
570 Removes one SV from the end of the array, reducing its size by one and
571 returning the SV (transferring control of one reference count) to the
572 caller. Returns C<&PL_sv_undef> if the array is empty.
574 Perl equivalent: C<pop(@myarray);>
580 Perl_av_pop(pTHX_ AV *av)
586 PERL_ARGS_ASSERT_AV_POP;
587 assert(SvTYPE(av) == SVt_PVAV);
590 Perl_croak_no_modify();
591 if ((mg = SvTIED_mg((const SV *)av, PERL_MAGIC_tied))) {
592 retval = Perl_magic_methcall(aTHX_ MUTABLE_SV(av), mg, SV_CONST(POP), 0, 0);
594 retval = newSVsv(retval);
599 retval = AvARRAY(av)[AvFILLp(av)];
600 AvARRAY(av)[AvFILLp(av)--] = NULL;
602 mg_set(MUTABLE_SV(av));
603 return retval ? retval : &PL_sv_undef;
608 =for apidoc av_create_and_unshift_one
610 Unshifts an SV onto the beginning of the array, creating the array if
612 A small internal helper function to remove a commonly duplicated idiom.
618 Perl_av_create_and_unshift_one(pTHX_ AV **const avp, SV *const val)
620 PERL_ARGS_ASSERT_AV_CREATE_AND_UNSHIFT_ONE;
625 return av_store(*avp, 0, val);
629 =for apidoc av_unshift
631 Unshift the given number of C<undef> values onto the beginning of the
632 array. The array will grow automatically to accommodate the addition. You
633 must then use C<av_store> to assign values to these new elements.
635 Perl equivalent: C<unshift @myarray, ( (undef) x $n );>
641 Perl_av_unshift(pTHX_ AV *av, I32 num)
647 PERL_ARGS_ASSERT_AV_UNSHIFT;
648 assert(SvTYPE(av) == SVt_PVAV);
651 Perl_croak_no_modify();
653 if ((mg = SvTIED_mg((const SV *)av, PERL_MAGIC_tied))) {
654 Perl_magic_methcall(aTHX_ MUTABLE_SV(av), mg, SV_CONST(UNSHIFT),
655 G_DISCARD | G_UNDEF_FILL, num);
661 if (!AvREAL(av) && AvREIFY(av))
663 i = AvARRAY(av) - AvALLOC(av);
671 AvARRAY(av) = AvARRAY(av) - i;
675 const I32 i = AvFILLp(av);
676 /* Create extra elements */
677 const I32 slide = i > 0 ? i : 0;
679 av_extend(av, i + num);
682 Move(ary, ary + num, i + 1, SV*);
686 /* Make extra elements into a buffer */
688 AvFILLp(av) -= slide;
689 AvARRAY(av) = AvARRAY(av) + slide;
696 Removes one SV from the start of the array, reducing its size by one and
697 returning the SV (transferring control of one reference count) to the
698 caller. Returns C<&PL_sv_undef> if the array is empty.
700 Perl equivalent: C<shift(@myarray);>
706 Perl_av_shift(pTHX_ AV *av)
712 PERL_ARGS_ASSERT_AV_SHIFT;
713 assert(SvTYPE(av) == SVt_PVAV);
716 Perl_croak_no_modify();
717 if ((mg = SvTIED_mg((const SV *)av, PERL_MAGIC_tied))) {
718 retval = Perl_magic_methcall(aTHX_ MUTABLE_SV(av), mg, SV_CONST(SHIFT), 0, 0);
720 retval = newSVsv(retval);
725 retval = *AvARRAY(av);
728 AvARRAY(av) = AvARRAY(av) + 1;
732 mg_set(MUTABLE_SV(av));
733 return retval ? retval : &PL_sv_undef;
737 =for apidoc av_top_index
739 Returns the highest index in the array. The number of elements in the
740 array is C<av_top_index(av) + 1>. Returns -1 if the array is empty.
742 The Perl equivalent for this is C<$#myarray>.
744 (A slightly shorter form is C<av_tindex>.)
748 Same as L</av_top_index>. Returns the highest index in the array. Note that the
749 return value is +1 what its name implies it returns; and hence differs in
750 meaning from what the similarly named L</sv_len> returns.
756 Perl_av_len(pTHX_ AV *av)
758 PERL_ARGS_ASSERT_AV_LEN;
760 return av_top_index(av);
766 Set the highest index in the array to the given number, equivalent to
767 Perl's C<$#array = $fill;>.
769 The number of elements in the an array will be C<fill + 1> after
770 av_fill() returns. If the array was previously shorter, then the
771 additional elements appended are set to NULL. If the array
772 was longer, then the excess elements are freed. C<av_fill(av, -1)> is
773 the same as C<av_clear(av)>.
778 Perl_av_fill(pTHX_ AV *av, I32 fill)
783 PERL_ARGS_ASSERT_AV_FILL;
784 assert(SvTYPE(av) == SVt_PVAV);
788 if ((mg = SvTIED_mg((const SV *)av, PERL_MAGIC_tied))) {
789 SV *arg1 = sv_newmortal();
790 sv_setiv(arg1, (IV)(fill + 1));
791 Perl_magic_methcall(aTHX_ MUTABLE_SV(av), mg, SV_CONST(STORESIZE), G_DISCARD,
795 if (fill <= AvMAX(av)) {
796 I32 key = AvFILLp(av);
797 SV** const ary = AvARRAY(av);
801 SvREFCNT_dec(ary[key]);
812 mg_set(MUTABLE_SV(av));
815 (void)av_store(av,fill,NULL);
819 =for apidoc av_delete
821 Deletes the element indexed by C<key> from the array, makes the element mortal,
822 and returns it. If C<flags> equals C<G_DISCARD>, the element is freed and null
823 is returned. Perl equivalent: C<my $elem = delete($myarray[$idx]);> for the
824 non-C<G_DISCARD> version and a void-context C<delete($myarray[$idx]);> for the
825 C<G_DISCARD> version.
830 Perl_av_delete(pTHX_ AV *av, I32 key, I32 flags)
835 PERL_ARGS_ASSERT_AV_DELETE;
836 assert(SvTYPE(av) == SVt_PVAV);
839 Perl_croak_no_modify();
841 if (SvRMAGICAL(av)) {
842 const MAGIC * const tied_magic
843 = mg_find((const SV *)av, PERL_MAGIC_tied);
844 if ((tied_magic || mg_find((const SV *)av, PERL_MAGIC_regdata))) {
847 if (!S_adjust_index(aTHX_ av, tied_magic, &key))
850 svp = av_fetch(av, key, TRUE);
854 if (mg_find(sv, PERL_MAGIC_tiedelem)) {
855 sv_unmagic(sv, PERL_MAGIC_tiedelem); /* No longer an element */
864 key += AvFILL(av) + 1;
869 if (key > AvFILLp(av))
872 if (!AvREAL(av) && AvREIFY(av))
874 sv = AvARRAY(av)[key];
875 if (key == AvFILLp(av)) {
876 AvARRAY(av)[key] = NULL;
879 } while (--key >= 0 && !AvARRAY(av)[key]);
882 AvARRAY(av)[key] = NULL;
884 mg_set(MUTABLE_SV(av));
886 if (flags & G_DISCARD) {
896 =for apidoc av_exists
898 Returns true if the element indexed by C<key> has been initialized.
900 This relies on the fact that uninitialized array elements are set to
903 Perl equivalent: C<exists($myarray[$key])>.
908 Perl_av_exists(pTHX_ AV *av, I32 key)
911 PERL_ARGS_ASSERT_AV_EXISTS;
912 assert(SvTYPE(av) == SVt_PVAV);
914 if (SvRMAGICAL(av)) {
915 const MAGIC * const tied_magic
916 = mg_find((const SV *)av, PERL_MAGIC_tied);
917 const MAGIC * const regdata_magic
918 = mg_find((const SV *)av, PERL_MAGIC_regdata);
919 if (tied_magic || regdata_magic) {
921 /* Handle negative array indices 20020222 MJD */
923 if (!S_adjust_index(aTHX_ av, tied_magic, &key))
927 if(key >= 0 && regdata_magic) {
928 if (key <= AvFILL(av))
934 SV * const sv = sv_newmortal();
935 mg_copy(MUTABLE_SV(av), sv, 0, key);
936 mg = mg_find(sv, PERL_MAGIC_tiedelem);
938 magic_existspack(sv, mg);
940 I32 retbool = SvTRUE_nomg_NN(sv);
941 return cBOOL(retbool);
949 key += AvFILL(av) + 1;
954 if (key <= AvFILLp(av) && AvARRAY(av)[key])
963 S_get_aux_mg(pTHX_ AV *av) {
967 PERL_ARGS_ASSERT_GET_AUX_MG;
968 assert(SvTYPE(av) == SVt_PVAV);
970 mg = mg_find((const SV *)av, PERL_MAGIC_arylen_p);
973 mg = sv_magicext(MUTABLE_SV(av), 0, PERL_MAGIC_arylen_p,
974 &PL_vtbl_arylen_p, 0, 0);
976 /* sv_magicext won't set this for us because we pass in a NULL obj */
977 mg->mg_flags |= MGf_REFCOUNTED;
983 Perl_av_arylen_p(pTHX_ AV *av) {
984 MAGIC *const mg = get_aux_mg(av);
986 PERL_ARGS_ASSERT_AV_ARYLEN_P;
987 assert(SvTYPE(av) == SVt_PVAV);
989 return &(mg->mg_obj);
993 Perl_av_iter_p(pTHX_ AV *av) {
994 MAGIC *const mg = get_aux_mg(av);
996 PERL_ARGS_ASSERT_AV_ITER_P;
997 assert(SvTYPE(av) == SVt_PVAV);
999 #if IVSIZE == I32SIZE
1000 return (IV *)&(mg->mg_len);
1004 mg->mg_len = IVSIZE;
1006 mg->mg_ptr = (char *) temp;
1008 return (IV *)mg->mg_ptr;
1014 * c-indentation-style: bsd
1016 * indent-tabs-mode: nil
1019 * ex: set ts=8 sts=4 sw=4 et: