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;
95 if (av && *allocp != *arrayp) {
96 ary = *allocp + AvFILLp(av) + 1;
97 tmp = *arrayp - *allocp;
98 Move(*arrayp, *allocp, AvFILLp(av)+1, SV*);
105 if (key > *maxp - 10) {
106 newmax = key + *maxp;
113 #ifdef Perl_safesysmalloc_size
114 /* Whilst it would be quite possible to move this logic around
115 (as I did in the SV code), so as to set AvMAX(av) early,
116 based on calling Perl_safesysmalloc_size() immediately after
117 allocation, I'm not convinced that it is a great idea here.
118 In an array we have to loop round setting everything to
119 NULL, which means writing to memory, potentially lots
120 of it, whereas for the SV buffer case we don't touch the
121 "bonus" memory. So there there is no cost in telling the
122 world about it, whereas here we have to do work before we can
123 tell the world about it, and that work involves writing to
124 memory that might never be read. So, I feel, better to keep
125 the current lazy system of only writing to it if our caller
126 has a need for more space. NWC */
127 newmax = Perl_safesysmalloc_size((void*)*allocp) /
128 sizeof(const SV *) - 1;
133 /* overflow-safe version of newmax = key + *maxp/5 */
135 newmax = (key > SSize_t_MAX - newmax)
136 ? SSize_t_MAX : key + newmax;
139 #ifdef PERL_MALLOC_WRAP /* Duplicated in pp_hot.c */
140 static const char oom_array_extend[] =
141 "Out of memory during array extend";
143 /* it should really be newmax+1 here, but if newmax
144 * happens to equal SSize_t_MAX, then newmax+1 is
145 * undefined. This means technically we croak one
146 * index lower than we should in theory; in practice
147 * its unlikely the system has SSize_t_MAX/sizeof(SV*)
149 MEM_WRAP_CHECK_1(newmax, SV*, oom_array_extend);
151 #ifdef STRESS_REALLOC
153 SV ** const old_alloc = *allocp;
154 Newx(*allocp, newmax+1, SV*);
155 Copy(old_alloc, *allocp, *maxp + 1, SV*);
159 Renew(*allocp,newmax+1, SV*);
161 #ifdef Perl_safesysmalloc_size
164 ary = *allocp + *maxp + 1;
165 tmp = newmax - *maxp;
166 if (av == PL_curstack) { /* Oops, grew stack (via av_store()?) */
167 PL_stack_sp = *allocp + (PL_stack_sp - PL_stack_base);
168 PL_stack_base = *allocp;
169 PL_stack_max = PL_stack_base + newmax;
173 newmax = key < 3 ? 3 : key;
175 #ifdef PERL_MALLOC_WRAP /* Duplicated in pp_hot.c */
176 static const char oom_array_extend[] =
177 "Out of memory during array extend";
179 /* see comment above about newmax+1*/
180 MEM_WRAP_CHECK_1(newmax, SV*, oom_array_extend);
182 Newx(*allocp, newmax+1, SV*);
185 *allocp[0] = NULL; /* For the stacks */
187 if (av && AvREAL(av)) {
201 Returns the SV at the specified index in the array. The C<key> is the
202 index. If lval is true, you are guaranteed to get a real SV back (in case
203 it wasn't real before), which you can then modify. Check that the return
204 value is non-null before dereferencing it to a C<SV*>.
206 See L<perlguts/"Understanding the Magic of Tied Hashes and Arrays"> for
207 more information on how to use this function on tied arrays.
209 The rough perl equivalent is C<$myarray[$idx]>.
215 S_adjust_index(pTHX_ AV *av, const MAGIC *mg, SSize_t *keyp)
217 bool adjust_index = 1;
219 /* Handle negative array indices 20020222 MJD */
220 SV * const ref = SvTIED_obj(MUTABLE_SV(av), mg);
222 if (SvROK(ref) && SvOBJECT(SvRV(ref))) {
223 SV * const * const negative_indices_glob =
224 hv_fetchs(SvSTASH(SvRV(ref)), NEGATIVE_INDICES_VAR, 0);
226 if (negative_indices_glob && isGV(*negative_indices_glob)
227 && SvTRUE(GvSV(*negative_indices_glob)))
233 *keyp += AvFILL(av) + 1;
241 Perl_av_fetch(pTHX_ AV *av, SSize_t key, I32 lval)
243 PERL_ARGS_ASSERT_AV_FETCH;
244 assert(SvTYPE(av) == SVt_PVAV);
246 if (SvRMAGICAL(av)) {
247 const MAGIC * const tied_magic
248 = mg_find((const SV *)av, PERL_MAGIC_tied);
249 if (tied_magic || mg_find((const SV *)av, PERL_MAGIC_regdata)) {
252 if (!S_adjust_index(aTHX_ av, tied_magic, &key))
257 sv_upgrade(sv, SVt_PVLV);
258 mg_copy(MUTABLE_SV(av), sv, 0, key);
259 if (!tied_magic) /* for regdata, force leavesub to make copies */
262 LvTARG(sv) = sv; /* fake (SV**) */
263 return &(LvTARG(sv));
268 key += AvFILL(av) + 1;
273 if (key > AvFILLp(av) || !AvARRAY(av)[key]) {
275 return lval ? av_store(av,key,newSV(0)) : NULL;
279 && (!AvARRAY(av)[key] /* eg. @_ could have freed elts */
280 || SvIS_FREED(AvARRAY(av)[key]))) {
281 AvARRAY(av)[key] = NULL; /* 1/2 reify */
284 return &AvARRAY(av)[key];
290 Stores an SV in an array. The array index is specified as C<key>. The
291 return value will be NULL if the operation failed or if the value did not
292 need to be actually stored within the array (as in the case of tied
293 arrays). Otherwise, it can be dereferenced
294 to get the C<SV*> that was stored
297 Note that the caller is responsible for suitably incrementing the reference
298 count of C<val> before the call, and decrementing it if the function
301 Approximate Perl equivalent: C<$myarray[$key] = $val;>.
303 See L<perlguts/"Understanding the Magic of Tied Hashes and Arrays"> for
304 more information on how to use this function on tied arrays.
310 Perl_av_store(pTHX_ AV *av, SSize_t key, SV *val)
314 PERL_ARGS_ASSERT_AV_STORE;
315 assert(SvTYPE(av) == SVt_PVAV);
317 /* S_regclass relies on being able to pass in a NULL sv
318 (unicode_alternate may be NULL).
321 if (SvRMAGICAL(av)) {
322 const MAGIC * const tied_magic = mg_find((const SV *)av, PERL_MAGIC_tied);
325 if (!S_adjust_index(aTHX_ av, tied_magic, &key))
329 mg_copy(MUTABLE_SV(av), val, 0, key);
337 key += AvFILL(av) + 1;
342 if (SvREADONLY(av) && key >= AvFILL(av))
343 Perl_croak_no_modify();
345 if (!AvREAL(av) && AvREIFY(av))
350 if (AvFILLp(av) < key) {
352 if (av == PL_curstack && key > PL_stack_sp - PL_stack_base)
353 PL_stack_sp = PL_stack_base + key; /* XPUSH in disguise */
355 ary[++AvFILLp(av)] = NULL;
356 } while (AvFILLp(av) < key);
361 SvREFCNT_dec(ary[key]);
363 if (SvSMAGICAL(av)) {
364 const MAGIC *mg = SvMAGIC(av);
366 for (; mg; mg = mg->mg_moremagic) {
367 if (!isUPPER(mg->mg_type)) continue;
369 sv_magic(val, MUTABLE_SV(av), toLOWER(mg->mg_type), 0, key);
371 if (PL_delaymagic && mg->mg_type == PERL_MAGIC_isa) {
372 PL_delaymagic |= DM_ARRAY_ISA;
377 mg_set(MUTABLE_SV(av));
385 Creates a new AV and populates it with a list of SVs. The SVs are copied
386 into the array, so they may be freed after the call to av_make. The new AV
387 will have a reference count of 1.
389 Perl equivalent: C<my @new_array = ($scalar1, $scalar2, $scalar3...);>
395 Perl_av_make(pTHX_ SSize_t size, SV **strp)
397 AV * const av = MUTABLE_AV(newSV_type(SVt_PVAV));
398 /* sv_upgrade does AvREAL_only() */
399 PERL_ARGS_ASSERT_AV_MAKE;
400 assert(SvTYPE(av) == SVt_PVAV);
402 if (size) { /* "defined" was returning undef for size==0 anyway. */
408 AvMAX(av) = size - 1;
412 for (i = 0; i < size; i++) {
415 /* Don't let sv_setsv swipe, since our source array might
416 have multiple references to the same temp scalar (e.g.
417 from a list slice) */
419 SvGETMAGIC(*strp); /* before newSV, in case it dies */
422 sv_setsv_flags(ary[i], *strp,
423 SV_DO_COW_SVSETSV|SV_NOSTEAL);
426 SvREFCNT_inc_simple_void_NN(av);
435 Clears an array, making it empty. Does not free the memory the av uses to
436 store its list of scalars. If any destructors are triggered as a result,
437 the av itself may be freed when this function returns.
439 Perl equivalent: C<@myarray = ();>.
445 Perl_av_clear(pTHX_ AV *av)
450 PERL_ARGS_ASSERT_AV_CLEAR;
451 assert(SvTYPE(av) == SVt_PVAV);
454 if (SvREFCNT(av) == 0) {
455 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEBUGGING), "Attempt to clear deleted array");
460 Perl_croak_no_modify();
462 /* Give any tie a chance to cleanup first */
463 if (SvRMAGICAL(av)) {
464 const MAGIC* const mg = SvMAGIC(av);
465 if (PL_delaymagic && mg && mg->mg_type == PERL_MAGIC_isa)
466 PL_delaymagic |= DM_ARRAY_ISA;
468 mg_clear(MUTABLE_SV(av));
474 if ((real = !!AvREAL(av))) {
475 SV** const ary = AvARRAY(av);
476 SSize_t index = AvFILLp(av) + 1;
478 SAVEFREESV(SvREFCNT_inc_simple_NN(av));
480 SV * const sv = ary[--index];
481 /* undef the slot before freeing the value, because a
482 * destructor might try to modify this array */
487 extra = AvARRAY(av) - AvALLOC(av);
490 AvARRAY(av) = AvALLOC(av);
499 Undefines the array. Frees the memory used by the av to store its list of
500 scalars. If any destructors are triggered as a result, the av itself may
507 Perl_av_undef(pTHX_ AV *av)
511 PERL_ARGS_ASSERT_AV_UNDEF;
512 assert(SvTYPE(av) == SVt_PVAV);
514 /* Give any tie a chance to cleanup first */
515 if (SvTIED_mg((const SV *)av, PERL_MAGIC_tied))
518 if ((real = !!AvREAL(av))) {
519 SSize_t key = AvFILLp(av) + 1;
521 SAVEFREESV(SvREFCNT_inc_simple_NN(av));
523 SvREFCNT_dec(AvARRAY(av)[--key]);
526 Safefree(AvALLOC(av));
529 AvMAX(av) = AvFILLp(av) = -1;
531 if(SvRMAGICAL(av)) mg_clear(MUTABLE_SV(av));
537 =for apidoc av_create_and_push
539 Push an SV onto the end of the array, creating the array if necessary.
540 A small internal helper function to remove a commonly duplicated idiom.
546 Perl_av_create_and_push(pTHX_ AV **const avp, SV *const val)
548 PERL_ARGS_ASSERT_AV_CREATE_AND_PUSH;
558 Pushes an SV onto the end of the array. The array will grow automatically
559 to accommodate the addition. This takes ownership of one reference count.
561 Perl equivalent: C<push @myarray, $elem;>.
567 Perl_av_push(pTHX_ AV *av, SV *val)
571 PERL_ARGS_ASSERT_AV_PUSH;
572 assert(SvTYPE(av) == SVt_PVAV);
575 Perl_croak_no_modify();
577 if ((mg = SvTIED_mg((const SV *)av, PERL_MAGIC_tied))) {
578 Perl_magic_methcall(aTHX_ MUTABLE_SV(av), mg, SV_CONST(PUSH), G_DISCARD, 1,
582 av_store(av,AvFILLp(av)+1,val);
588 Removes one SV from the end of the array, reducing its size by one and
589 returning the SV (transferring control of one reference count) to the
590 caller. Returns C<&PL_sv_undef> if the array is empty.
592 Perl equivalent: C<pop(@myarray);>
598 Perl_av_pop(pTHX_ AV *av)
603 PERL_ARGS_ASSERT_AV_POP;
604 assert(SvTYPE(av) == SVt_PVAV);
607 Perl_croak_no_modify();
608 if ((mg = SvTIED_mg((const SV *)av, PERL_MAGIC_tied))) {
609 retval = Perl_magic_methcall(aTHX_ MUTABLE_SV(av), mg, SV_CONST(POP), 0, 0);
611 retval = newSVsv(retval);
616 retval = AvARRAY(av)[AvFILLp(av)];
617 AvARRAY(av)[AvFILLp(av)--] = NULL;
619 mg_set(MUTABLE_SV(av));
620 return retval ? retval : &PL_sv_undef;
625 =for apidoc av_create_and_unshift_one
627 Unshifts an SV onto the beginning of the array, creating the array if
629 A small internal helper function to remove a commonly duplicated idiom.
635 Perl_av_create_and_unshift_one(pTHX_ AV **const avp, SV *const val)
637 PERL_ARGS_ASSERT_AV_CREATE_AND_UNSHIFT_ONE;
642 return av_store(*avp, 0, val);
646 =for apidoc av_unshift
648 Unshift the given number of C<undef> values onto the beginning of the
649 array. The array will grow automatically to accommodate the addition. You
650 must then use C<av_store> to assign values to these new elements.
652 Perl equivalent: C<unshift @myarray, ( (undef) x $n );>
658 Perl_av_unshift(pTHX_ AV *av, SSize_t num)
663 PERL_ARGS_ASSERT_AV_UNSHIFT;
664 assert(SvTYPE(av) == SVt_PVAV);
667 Perl_croak_no_modify();
669 if ((mg = SvTIED_mg((const SV *)av, PERL_MAGIC_tied))) {
670 Perl_magic_methcall(aTHX_ MUTABLE_SV(av), mg, SV_CONST(UNSHIFT),
671 G_DISCARD | G_UNDEF_FILL, num);
677 if (!AvREAL(av) && AvREIFY(av))
679 i = AvARRAY(av) - AvALLOC(av);
687 AvARRAY(av) = AvARRAY(av) - i;
691 const SSize_t i = AvFILLp(av);
692 /* Create extra elements */
693 const SSize_t slide = i > 0 ? i : 0;
695 av_extend(av, i + num);
698 Move(ary, ary + num, i + 1, SV*);
702 /* Make extra elements into a buffer */
704 AvFILLp(av) -= slide;
705 AvARRAY(av) = AvARRAY(av) + slide;
712 Removes one SV from the start of the array, reducing its size by one and
713 returning the SV (transferring control of one reference count) to the
714 caller. Returns C<&PL_sv_undef> if the array is empty.
716 Perl equivalent: C<shift(@myarray);>
722 Perl_av_shift(pTHX_ AV *av)
727 PERL_ARGS_ASSERT_AV_SHIFT;
728 assert(SvTYPE(av) == SVt_PVAV);
731 Perl_croak_no_modify();
732 if ((mg = SvTIED_mg((const SV *)av, PERL_MAGIC_tied))) {
733 retval = Perl_magic_methcall(aTHX_ MUTABLE_SV(av), mg, SV_CONST(SHIFT), 0, 0);
735 retval = newSVsv(retval);
740 retval = *AvARRAY(av);
743 AvARRAY(av) = AvARRAY(av) + 1;
747 mg_set(MUTABLE_SV(av));
748 return retval ? retval : &PL_sv_undef;
752 =for apidoc av_top_index
754 Returns the highest index in the array. The number of elements in the
755 array is C<av_top_index(av) + 1>. Returns -1 if the array is empty.
757 The Perl equivalent for this is C<$#myarray>.
759 (A slightly shorter form is C<av_tindex>.)
763 Same as L</av_top_index>. Note that, unlike what the name implies, it returns
764 the highest index in the array, so to get the size of the array you need to use
765 S<C<av_len(av) + 1>>. This is unlike L</sv_len>, which returns what you would
772 Perl_av_len(pTHX_ AV *av)
774 PERL_ARGS_ASSERT_AV_LEN;
776 return av_top_index(av);
782 Set the highest index in the array to the given number, equivalent to
783 Perl's C<$#array = $fill;>.
785 The number of elements in the array will be C<fill + 1> after
786 av_fill() returns. If the array was previously shorter, then the
787 additional elements appended are set to NULL. If the array
788 was longer, then the excess elements are freed. C<av_fill(av, -1)> is
789 the same as C<av_clear(av)>.
794 Perl_av_fill(pTHX_ AV *av, SSize_t fill)
798 PERL_ARGS_ASSERT_AV_FILL;
799 assert(SvTYPE(av) == SVt_PVAV);
803 if ((mg = SvTIED_mg((const SV *)av, PERL_MAGIC_tied))) {
804 SV *arg1 = sv_newmortal();
805 sv_setiv(arg1, (IV)(fill + 1));
806 Perl_magic_methcall(aTHX_ MUTABLE_SV(av), mg, SV_CONST(STORESIZE), G_DISCARD,
810 if (fill <= AvMAX(av)) {
811 SSize_t key = AvFILLp(av);
812 SV** const ary = AvARRAY(av);
816 SvREFCNT_dec(ary[key]);
827 mg_set(MUTABLE_SV(av));
830 (void)av_store(av,fill,NULL);
834 =for apidoc av_delete
836 Deletes the element indexed by C<key> from the array, makes the element mortal,
837 and returns it. If C<flags> equals C<G_DISCARD>, the element is freed and null
838 is returned. Perl equivalent: C<my $elem = delete($myarray[$idx]);> for the
839 non-C<G_DISCARD> version and a void-context C<delete($myarray[$idx]);> for the
840 C<G_DISCARD> version.
845 Perl_av_delete(pTHX_ AV *av, SSize_t key, I32 flags)
849 PERL_ARGS_ASSERT_AV_DELETE;
850 assert(SvTYPE(av) == SVt_PVAV);
853 Perl_croak_no_modify();
855 if (SvRMAGICAL(av)) {
856 const MAGIC * const tied_magic
857 = mg_find((const SV *)av, PERL_MAGIC_tied);
858 if ((tied_magic || mg_find((const SV *)av, PERL_MAGIC_regdata))) {
861 if (!S_adjust_index(aTHX_ av, tied_magic, &key))
864 svp = av_fetch(av, key, TRUE);
868 if (mg_find(sv, PERL_MAGIC_tiedelem)) {
869 sv_unmagic(sv, PERL_MAGIC_tiedelem); /* No longer an element */
878 key += AvFILL(av) + 1;
883 if (key > AvFILLp(av))
886 if (!AvREAL(av) && AvREIFY(av))
888 sv = AvARRAY(av)[key];
889 AvARRAY(av)[key] = NULL;
890 if (key == AvFILLp(av)) {
893 } while (--key >= 0 && !AvARRAY(av)[key]);
896 mg_set(MUTABLE_SV(av));
899 if (flags & G_DISCARD) {
910 =for apidoc av_exists
912 Returns true if the element indexed by C<key> has been initialized.
914 This relies on the fact that uninitialized array elements are set to
917 Perl equivalent: C<exists($myarray[$key])>.
922 Perl_av_exists(pTHX_ AV *av, SSize_t key)
924 PERL_ARGS_ASSERT_AV_EXISTS;
925 assert(SvTYPE(av) == SVt_PVAV);
927 if (SvRMAGICAL(av)) {
928 const MAGIC * const tied_magic
929 = mg_find((const SV *)av, PERL_MAGIC_tied);
930 const MAGIC * const regdata_magic
931 = mg_find((const SV *)av, PERL_MAGIC_regdata);
932 if (tied_magic || regdata_magic) {
934 /* Handle negative array indices 20020222 MJD */
936 if (!S_adjust_index(aTHX_ av, tied_magic, &key))
940 if(key >= 0 && regdata_magic) {
941 if (key <= AvFILL(av))
947 SV * const sv = sv_newmortal();
948 mg_copy(MUTABLE_SV(av), sv, 0, key);
949 mg = mg_find(sv, PERL_MAGIC_tiedelem);
951 magic_existspack(sv, mg);
953 I32 retbool = SvTRUE_nomg_NN(sv);
954 return cBOOL(retbool);
962 key += AvFILL(av) + 1;
967 if (key <= AvFILLp(av) && AvARRAY(av)[key])
976 S_get_aux_mg(pTHX_ AV *av) {
979 PERL_ARGS_ASSERT_GET_AUX_MG;
980 assert(SvTYPE(av) == SVt_PVAV);
982 mg = mg_find((const SV *)av, PERL_MAGIC_arylen_p);
985 mg = sv_magicext(MUTABLE_SV(av), 0, PERL_MAGIC_arylen_p,
986 &PL_vtbl_arylen_p, 0, 0);
988 /* sv_magicext won't set this for us because we pass in a NULL obj */
989 mg->mg_flags |= MGf_REFCOUNTED;
995 Perl_av_arylen_p(pTHX_ AV *av) {
996 MAGIC *const mg = get_aux_mg(av);
998 PERL_ARGS_ASSERT_AV_ARYLEN_P;
999 assert(SvTYPE(av) == SVt_PVAV);
1001 return &(mg->mg_obj);
1005 Perl_av_iter_p(pTHX_ AV *av) {
1006 MAGIC *const mg = get_aux_mg(av);
1008 PERL_ARGS_ASSERT_AV_ITER_P;
1009 assert(SvTYPE(av) == SVt_PVAV);
1011 #if IVSIZE == I32SIZE
1012 return (IV *)&(mg->mg_len);
1016 mg->mg_len = IVSIZE;
1018 mg->mg_ptr = (char *) temp;
1020 return (IV *)mg->mg_ptr;
1026 * c-indentation-style: bsd
1028 * indent-tabs-mode: nil
1031 * ex: set ts=8 sts=4 sw=4 et: