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 newmax = key + *maxp / 5;
136 #ifdef PERL_MALLOC_WRAP /* Duplicated in pp_hot.c */
137 static const char oom_array_extend[] =
138 "Out of memory during array extend";
140 MEM_WRAP_CHECK_1(newmax+1, SV*, oom_array_extend);
142 #ifdef STRESS_REALLOC
144 SV ** const old_alloc = *allocp;
145 Newx(*allocp, newmax+1, SV*);
146 Copy(old_alloc, *allocp, *maxp + 1, SV*);
150 Renew(*allocp,newmax+1, SV*);
152 #ifdef Perl_safesysmalloc_size
155 ary = *allocp + *maxp + 1;
156 tmp = newmax - *maxp;
157 if (av == PL_curstack) { /* Oops, grew stack (via av_store()?) */
158 PL_stack_sp = *allocp + (PL_stack_sp - PL_stack_base);
159 PL_stack_base = *allocp;
160 PL_stack_max = PL_stack_base + newmax;
164 newmax = key < 3 ? 3 : key;
166 #ifdef PERL_MALLOC_WRAP /* Duplicated in pp_hot.c */
167 static const char oom_array_extend[] =
168 "Out of memory during array extend";
170 MEM_WRAP_CHECK_1(newmax+1, SV*, oom_array_extend);
172 Newx(*allocp, newmax+1, SV*);
175 *allocp[0] = NULL; /* For the stacks */
177 if (av && AvREAL(av)) {
191 Returns the SV at the specified index in the array. The C<key> is the
192 index. If lval is true, you are guaranteed to get a real SV back (in case
193 it wasn't real before), which you can then modify. Check that the return
194 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.
199 The rough perl equivalent is C<$myarray[$idx]>.
205 S_adjust_index(pTHX_ AV *av, const MAGIC *mg, SSize_t *keyp)
207 bool adjust_index = 1;
209 /* Handle negative array indices 20020222 MJD */
210 SV * const ref = SvTIED_obj(MUTABLE_SV(av), mg);
212 if (SvROK(ref) && SvOBJECT(SvRV(ref))) {
213 SV * const * const negative_indices_glob =
214 hv_fetchs(SvSTASH(SvRV(ref)), NEGATIVE_INDICES_VAR, 0);
216 if (negative_indices_glob && isGV(*negative_indices_glob)
217 && SvTRUE(GvSV(*negative_indices_glob)))
223 *keyp += AvFILL(av) + 1;
231 Perl_av_fetch(pTHX_ AV *av, SSize_t key, I32 lval)
233 PERL_ARGS_ASSERT_AV_FETCH;
234 assert(SvTYPE(av) == SVt_PVAV);
236 if (SvRMAGICAL(av)) {
237 const MAGIC * const tied_magic
238 = mg_find((const SV *)av, PERL_MAGIC_tied);
239 if (tied_magic || mg_find((const SV *)av, PERL_MAGIC_regdata)) {
242 if (!S_adjust_index(aTHX_ av, tied_magic, &key))
247 sv_upgrade(sv, SVt_PVLV);
248 mg_copy(MUTABLE_SV(av), sv, 0, key);
249 if (!tied_magic) /* for regdata, force leavesub to make copies */
252 LvTARG(sv) = sv; /* fake (SV**) */
253 return &(LvTARG(sv));
258 key += AvFILL(av) + 1;
263 if (key > AvFILLp(av) || !AvARRAY(av)[key]) {
265 return lval ? av_store(av,key,newSV(0)) : NULL;
269 && (!AvARRAY(av)[key] /* eg. @_ could have freed elts */
270 || SvIS_FREED(AvARRAY(av)[key]))) {
271 AvARRAY(av)[key] = NULL; /* 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
284 to get the C<SV*> that was stored
287 Note that the caller is responsible for suitably incrementing the reference
288 count of C<val> before the call, and decrementing it if the function
291 Approximate Perl equivalent: C<$myarray[$key] = $val;>.
293 See L<perlguts/"Understanding the Magic of Tied Hashes and Arrays"> for
294 more information on how to use this function on tied arrays.
300 Perl_av_store(pTHX_ AV *av, SSize_t key, SV *val)
304 PERL_ARGS_ASSERT_AV_STORE;
305 assert(SvTYPE(av) == SVt_PVAV);
307 /* S_regclass relies on being able to pass in a NULL sv
308 (unicode_alternate may be NULL).
311 if (SvRMAGICAL(av)) {
312 const MAGIC * const tied_magic = mg_find((const SV *)av, PERL_MAGIC_tied);
315 if (!S_adjust_index(aTHX_ av, tied_magic, &key))
319 mg_copy(MUTABLE_SV(av), val, 0, key);
327 key += AvFILL(av) + 1;
332 if (SvREADONLY(av) && key >= AvFILL(av))
333 Perl_croak_no_modify();
335 if (!AvREAL(av) && AvREIFY(av))
340 if (AvFILLp(av) < key) {
342 if (av == PL_curstack && key > PL_stack_sp - PL_stack_base)
343 PL_stack_sp = PL_stack_base + key; /* XPUSH in disguise */
345 ary[++AvFILLp(av)] = NULL;
346 } while (AvFILLp(av) < key);
351 SvREFCNT_dec(ary[key]);
353 if (SvSMAGICAL(av)) {
354 const MAGIC *mg = SvMAGIC(av);
356 for (; mg; mg = mg->mg_moremagic) {
357 if (!isUPPER(mg->mg_type)) continue;
359 sv_magic(val, MUTABLE_SV(av), toLOWER(mg->mg_type), 0, key);
361 if (PL_delaymagic && mg->mg_type == PERL_MAGIC_isa) {
362 PL_delaymagic |= DM_ARRAY_ISA;
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.
379 Perl equivalent: C<my @new_array = ($scalar1, $scalar2, $scalar3...);>
385 Perl_av_make(pTHX_ SSize_t size, SV **strp)
387 AV * const av = MUTABLE_AV(newSV_type(SVt_PVAV));
388 /* sv_upgrade does AvREAL_only() */
389 PERL_ARGS_ASSERT_AV_MAKE;
390 assert(SvTYPE(av) == SVt_PVAV);
392 if (size) { /* "defined" was returning undef for size==0 anyway. */
398 AvMAX(av) = size - 1;
402 for (i = 0; i < size; i++) {
405 /* Don't let sv_setsv swipe, since our source array might
406 have multiple references to the same temp scalar (e.g.
407 from a list slice) */
409 SvGETMAGIC(*strp); /* before newSV, in case it dies */
412 sv_setsv_flags(ary[i], *strp,
413 SV_DO_COW_SVSETSV|SV_NOSTEAL);
416 SvREFCNT_inc_simple_void_NN(av);
425 Clears an array, making it empty. Does not free the memory the av uses to
426 store its list of scalars. If any destructors are triggered as a result,
427 the av itself may be freed when this function returns.
429 Perl equivalent: C<@myarray = ();>.
435 Perl_av_clear(pTHX_ AV *av)
440 PERL_ARGS_ASSERT_AV_CLEAR;
441 assert(SvTYPE(av) == SVt_PVAV);
444 if (SvREFCNT(av) == 0) {
445 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEBUGGING), "Attempt to clear deleted array");
450 Perl_croak_no_modify();
452 /* Give any tie a chance to cleanup first */
453 if (SvRMAGICAL(av)) {
454 const MAGIC* const mg = SvMAGIC(av);
455 if (PL_delaymagic && mg && mg->mg_type == PERL_MAGIC_isa)
456 PL_delaymagic |= DM_ARRAY_ISA;
458 mg_clear(MUTABLE_SV(av));
464 if ((real = !!AvREAL(av))) {
465 SV** const ary = AvARRAY(av);
466 SSize_t index = AvFILLp(av) + 1;
468 SAVEFREESV(SvREFCNT_inc_simple_NN(av));
470 SV * const sv = ary[--index];
471 /* undef the slot before freeing the value, because a
472 * destructor might try to modify this array */
477 extra = AvARRAY(av) - AvALLOC(av);
480 AvARRAY(av) = AvALLOC(av);
489 Undefines the array. Frees the memory used by the av to store its list of
490 scalars. If any destructors are triggered as a result, the av itself may
497 Perl_av_undef(pTHX_ AV *av)
501 PERL_ARGS_ASSERT_AV_UNDEF;
502 assert(SvTYPE(av) == SVt_PVAV);
504 /* Give any tie a chance to cleanup first */
505 if (SvTIED_mg((const SV *)av, PERL_MAGIC_tied))
508 if ((real = !!AvREAL(av))) {
509 SSize_t key = AvFILLp(av) + 1;
511 SAVEFREESV(SvREFCNT_inc_simple_NN(av));
513 SvREFCNT_dec(AvARRAY(av)[--key]);
516 Safefree(AvALLOC(av));
519 AvMAX(av) = AvFILLp(av) = -1;
521 if(SvRMAGICAL(av)) mg_clear(MUTABLE_SV(av));
527 =for apidoc av_create_and_push
529 Push an SV onto the end of the array, creating the array if necessary.
530 A small internal helper function to remove a commonly duplicated idiom.
536 Perl_av_create_and_push(pTHX_ AV **const avp, SV *const val)
538 PERL_ARGS_ASSERT_AV_CREATE_AND_PUSH;
548 Pushes an SV onto the end of the array. The array will grow automatically
549 to accommodate the addition. This takes ownership of one reference count.
551 Perl equivalent: C<push @myarray, $elem;>.
557 Perl_av_push(pTHX_ AV *av, SV *val)
561 PERL_ARGS_ASSERT_AV_PUSH;
562 assert(SvTYPE(av) == SVt_PVAV);
565 Perl_croak_no_modify();
567 if ((mg = SvTIED_mg((const SV *)av, PERL_MAGIC_tied))) {
568 Perl_magic_methcall(aTHX_ MUTABLE_SV(av), mg, SV_CONST(PUSH), G_DISCARD, 1,
572 av_store(av,AvFILLp(av)+1,val);
578 Removes one SV from the end of the array, reducing its size by one and
579 returning the SV (transferring control of one reference count) to the
580 caller. Returns C<&PL_sv_undef> if the array is empty.
582 Perl equivalent: C<pop(@myarray);>
588 Perl_av_pop(pTHX_ AV *av)
593 PERL_ARGS_ASSERT_AV_POP;
594 assert(SvTYPE(av) == SVt_PVAV);
597 Perl_croak_no_modify();
598 if ((mg = SvTIED_mg((const SV *)av, PERL_MAGIC_tied))) {
599 retval = Perl_magic_methcall(aTHX_ MUTABLE_SV(av), mg, SV_CONST(POP), 0, 0);
601 retval = newSVsv(retval);
606 retval = AvARRAY(av)[AvFILLp(av)];
607 AvARRAY(av)[AvFILLp(av)--] = NULL;
609 mg_set(MUTABLE_SV(av));
610 return retval ? retval : &PL_sv_undef;
615 =for apidoc av_create_and_unshift_one
617 Unshifts an SV onto the beginning of the array, creating the array if
619 A small internal helper function to remove a commonly duplicated idiom.
625 Perl_av_create_and_unshift_one(pTHX_ AV **const avp, SV *const val)
627 PERL_ARGS_ASSERT_AV_CREATE_AND_UNSHIFT_ONE;
632 return av_store(*avp, 0, val);
636 =for apidoc av_unshift
638 Unshift the given number of C<undef> values onto the beginning of the
639 array. The array will grow automatically to accommodate the addition. You
640 must then use C<av_store> to assign values to these new elements.
642 Perl equivalent: C<unshift @myarray, ( (undef) x $n );>
648 Perl_av_unshift(pTHX_ AV *av, SSize_t num)
653 PERL_ARGS_ASSERT_AV_UNSHIFT;
654 assert(SvTYPE(av) == SVt_PVAV);
657 Perl_croak_no_modify();
659 if ((mg = SvTIED_mg((const SV *)av, PERL_MAGIC_tied))) {
660 Perl_magic_methcall(aTHX_ MUTABLE_SV(av), mg, SV_CONST(UNSHIFT),
661 G_DISCARD | G_UNDEF_FILL, num);
667 if (!AvREAL(av) && AvREIFY(av))
669 i = AvARRAY(av) - AvALLOC(av);
677 AvARRAY(av) = AvARRAY(av) - i;
681 const SSize_t i = AvFILLp(av);
682 /* Create extra elements */
683 const SSize_t slide = i > 0 ? i : 0;
685 av_extend(av, i + num);
688 Move(ary, ary + num, i + 1, SV*);
692 /* Make extra elements into a buffer */
694 AvFILLp(av) -= slide;
695 AvARRAY(av) = AvARRAY(av) + slide;
702 Removes one SV from the start of the array, reducing its size by one and
703 returning the SV (transferring control of one reference count) to the
704 caller. Returns C<&PL_sv_undef> if the array is empty.
706 Perl equivalent: C<shift(@myarray);>
712 Perl_av_shift(pTHX_ AV *av)
717 PERL_ARGS_ASSERT_AV_SHIFT;
718 assert(SvTYPE(av) == SVt_PVAV);
721 Perl_croak_no_modify();
722 if ((mg = SvTIED_mg((const SV *)av, PERL_MAGIC_tied))) {
723 retval = Perl_magic_methcall(aTHX_ MUTABLE_SV(av), mg, SV_CONST(SHIFT), 0, 0);
725 retval = newSVsv(retval);
730 retval = *AvARRAY(av);
733 AvARRAY(av) = AvARRAY(av) + 1;
737 mg_set(MUTABLE_SV(av));
738 return retval ? retval : &PL_sv_undef;
742 =for apidoc av_top_index
744 Returns the highest index in the array. The number of elements in the
745 array is C<av_top_index(av) + 1>. Returns -1 if the array is empty.
747 The Perl equivalent for this is C<$#myarray>.
749 (A slightly shorter form is C<av_tindex>.)
751 =for apidoc av_tindex
753 Same as L</av_top_index>.
757 Same as L</av_top_index>. Note that, unlike what the name implies, it returns
758 the highest index in the array, so to get the size of the array you need to use
759 S<C<av_len(av) + 1>>. This is unlike L</sv_len>, which returns what you would
766 Perl_av_len(pTHX_ AV *av)
768 PERL_ARGS_ASSERT_AV_LEN;
770 return av_top_index(av);
776 Set the highest index in the array to the given number, equivalent to
777 Perl's C<$#array = $fill;>.
779 The number of elements in the array will be C<fill + 1> after
780 av_fill() returns. If the array was previously shorter, then the
781 additional elements appended are set to NULL. If the array
782 was longer, then the excess elements are freed. C<av_fill(av, -1)> is
783 the same as C<av_clear(av)>.
788 Perl_av_fill(pTHX_ AV *av, SSize_t fill)
792 PERL_ARGS_ASSERT_AV_FILL;
793 assert(SvTYPE(av) == SVt_PVAV);
797 if ((mg = SvTIED_mg((const SV *)av, PERL_MAGIC_tied))) {
798 SV *arg1 = sv_newmortal();
799 sv_setiv(arg1, (IV)(fill + 1));
800 Perl_magic_methcall(aTHX_ MUTABLE_SV(av), mg, SV_CONST(STORESIZE), G_DISCARD,
804 if (fill <= AvMAX(av)) {
805 SSize_t key = AvFILLp(av);
806 SV** const ary = AvARRAY(av);
810 SvREFCNT_dec(ary[key]);
821 mg_set(MUTABLE_SV(av));
824 (void)av_store(av,fill,NULL);
828 =for apidoc av_delete
830 Deletes the element indexed by C<key> from the array, makes the element mortal,
831 and returns it. If C<flags> equals C<G_DISCARD>, the element is freed and null
832 is returned. Perl equivalent: C<my $elem = delete($myarray[$idx]);> for the
833 non-C<G_DISCARD> version and a void-context C<delete($myarray[$idx]);> for the
834 C<G_DISCARD> version.
839 Perl_av_delete(pTHX_ AV *av, SSize_t key, I32 flags)
843 PERL_ARGS_ASSERT_AV_DELETE;
844 assert(SvTYPE(av) == SVt_PVAV);
847 Perl_croak_no_modify();
849 if (SvRMAGICAL(av)) {
850 const MAGIC * const tied_magic
851 = mg_find((const SV *)av, PERL_MAGIC_tied);
852 if ((tied_magic || mg_find((const SV *)av, PERL_MAGIC_regdata))) {
855 if (!S_adjust_index(aTHX_ av, tied_magic, &key))
858 svp = av_fetch(av, key, TRUE);
862 if (mg_find(sv, PERL_MAGIC_tiedelem)) {
863 sv_unmagic(sv, PERL_MAGIC_tiedelem); /* No longer an element */
872 key += AvFILL(av) + 1;
877 if (key > AvFILLp(av))
880 if (!AvREAL(av) && AvREIFY(av))
882 sv = AvARRAY(av)[key];
883 AvARRAY(av)[key] = NULL;
884 if (key == AvFILLp(av)) {
887 } while (--key >= 0 && !AvARRAY(av)[key]);
890 mg_set(MUTABLE_SV(av));
893 if (flags & G_DISCARD) {
904 =for apidoc av_exists
906 Returns true if the element indexed by C<key> has been initialized.
908 This relies on the fact that uninitialized array elements are set to
911 Perl equivalent: C<exists($myarray[$key])>.
916 Perl_av_exists(pTHX_ AV *av, SSize_t key)
918 PERL_ARGS_ASSERT_AV_EXISTS;
919 assert(SvTYPE(av) == SVt_PVAV);
921 if (SvRMAGICAL(av)) {
922 const MAGIC * const tied_magic
923 = mg_find((const SV *)av, PERL_MAGIC_tied);
924 const MAGIC * const regdata_magic
925 = mg_find((const SV *)av, PERL_MAGIC_regdata);
926 if (tied_magic || regdata_magic) {
928 /* Handle negative array indices 20020222 MJD */
930 if (!S_adjust_index(aTHX_ av, tied_magic, &key))
934 if(key >= 0 && regdata_magic) {
935 if (key <= AvFILL(av))
941 SV * const sv = sv_newmortal();
942 mg_copy(MUTABLE_SV(av), sv, 0, key);
943 mg = mg_find(sv, PERL_MAGIC_tiedelem);
945 magic_existspack(sv, mg);
947 I32 retbool = SvTRUE_nomg_NN(sv);
948 return cBOOL(retbool);
956 key += AvFILL(av) + 1;
961 if (key <= AvFILLp(av) && AvARRAY(av)[key])
970 S_get_aux_mg(pTHX_ AV *av) {
973 PERL_ARGS_ASSERT_GET_AUX_MG;
974 assert(SvTYPE(av) == SVt_PVAV);
976 mg = mg_find((const SV *)av, PERL_MAGIC_arylen_p);
979 mg = sv_magicext(MUTABLE_SV(av), 0, PERL_MAGIC_arylen_p,
980 &PL_vtbl_arylen_p, 0, 0);
982 /* sv_magicext won't set this for us because we pass in a NULL obj */
983 mg->mg_flags |= MGf_REFCOUNTED;
989 Perl_av_arylen_p(pTHX_ AV *av) {
990 MAGIC *const mg = get_aux_mg(av);
992 PERL_ARGS_ASSERT_AV_ARYLEN_P;
993 assert(SvTYPE(av) == SVt_PVAV);
995 return &(mg->mg_obj);
999 Perl_av_iter_p(pTHX_ AV *av) {
1000 MAGIC *const mg = get_aux_mg(av);
1002 PERL_ARGS_ASSERT_AV_ITER_P;
1003 assert(SvTYPE(av) == SVt_PVAV);
1005 #if IVSIZE == I32SIZE
1006 return (IV *)&(mg->mg_len);
1010 mg->mg_len = IVSIZE;
1012 mg->mg_ptr = (char *) temp;
1014 return (IV *)mg->mg_ptr;
1020 * c-indentation-style: bsd
1022 * indent-tabs-mode: nil
1025 * ex: set ts=8 sts=4 sw=4 et: