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] = &PL_sv_undef;
45 SV * const sv = AvARRAY(av)[--key];
47 if (sv != &PL_sv_undef)
48 SvREFCNT_inc_simple_void_NN(sv);
50 key = AvARRAY(av) - AvALLOC(av);
52 AvALLOC(av)[--key] = &PL_sv_undef;
60 Pre-extend an array. The C<key> is the index to which the array should be
67 Perl_av_extend(pTHX_ AV *av, I32 key)
72 PERL_ARGS_ASSERT_AV_EXTEND;
73 assert(SvTYPE(av) == SVt_PVAV);
75 mg = SvTIED_mg((const SV *)av, PERL_MAGIC_tied);
77 SV *arg1 = sv_newmortal();
78 sv_setiv(arg1, (IV)(key + 1));
79 Perl_magic_methcall(aTHX_ MUTABLE_SV(av), mg, "EXTEND", G_DISCARD, 1,
83 av_extend_guts(av,key,&AvMAX(av),&AvALLOC(av),&AvARRAY(av));
86 /* The guts of av_extend. *Not* for general use! */
88 Perl_av_extend_guts(pTHX_ AV *av, I32 key, SSize_t *maxp, SV ***allocp,
93 PERL_ARGS_ASSERT_AV_EXTEND_GUTS;
100 if (av && *allocp != *arrayp) {
101 ary = *allocp + AvFILLp(av) + 1;
102 tmp = *arrayp - *allocp;
103 Move(*arrayp, *allocp, AvFILLp(av)+1, SV*);
108 ary[--tmp] = &PL_sv_undef;
110 if (key > *maxp - 10) {
111 newmax = key + *maxp;
116 #ifdef PERL_MALLOC_WRAP
117 static const char oom_array_extend[] =
118 "Out of memory during array extend"; /* Duplicated in pp_hot.c */
123 #ifdef Perl_safesysmalloc_size
124 /* Whilst it would be quite possible to move this logic around
125 (as I did in the SV code), so as to set AvMAX(av) early,
126 based on calling Perl_safesysmalloc_size() immediately after
127 allocation, I'm not convinced that it is a great idea here.
128 In an array we have to loop round setting everything to
129 &PL_sv_undef, which means writing to memory, potentially lots
130 of it, whereas for the SV buffer case we don't touch the
131 "bonus" memory. So there there is no cost in telling the
132 world about it, whereas here we have to do work before we can
133 tell the world about it, and that work involves writing to
134 memory that might never be read. So, I feel, better to keep
135 the current lazy system of only writing to it if our caller
136 has a need for more space. NWC */
137 newmax = Perl_safesysmalloc_size((void*)*allocp) /
138 sizeof(const SV *) - 1;
143 newmax = key + *maxp / 5;
145 MEM_WRAP_CHECK_1(newmax+1, SV*, oom_array_extend);
146 Renew(*allocp,newmax+1, SV*);
147 #ifdef Perl_safesysmalloc_size
150 ary = *allocp + *maxp + 1;
151 tmp = newmax - *maxp;
152 if (av == PL_curstack) { /* Oops, grew stack (via av_store()?) */
153 PL_stack_sp = *allocp + (PL_stack_sp - PL_stack_base);
154 PL_stack_base = *allocp;
155 PL_stack_max = PL_stack_base + newmax;
159 newmax = key < 3 ? 3 : key;
160 MEM_WRAP_CHECK_1(newmax+1, SV*, oom_array_extend);
161 Newx(*allocp, newmax+1, SV*);
164 *allocp[0] = &PL_sv_undef; /* For the stacks */
166 if (av && AvREAL(av)) {
168 ary[--tmp] = &PL_sv_undef;
180 Returns the SV at the specified index in the array. The C<key> is the
181 index. If lval is true, you are guaranteed to get a real SV back (in case
182 it wasn't real before), which you can then modify. Check that the return
183 value is non-null before dereferencing it to a C<SV*>.
185 See L<perlguts/"Understanding the Magic of Tied Hashes and Arrays"> for
186 more information on how to use this function on tied arrays.
188 The rough perl equivalent is C<$myarray[$idx]>.
194 S_adjust_index(pTHX_ AV *av, const MAGIC *mg, I32 *keyp)
196 bool adjust_index = 1;
198 /* Handle negative array indices 20020222 MJD */
199 SV * const ref = SvTIED_obj(MUTABLE_SV(av), mg);
201 if (SvROK(ref) && SvOBJECT(SvRV(ref))) {
202 SV * const * const negative_indices_glob =
203 hv_fetchs(SvSTASH(SvRV(ref)), NEGATIVE_INDICES_VAR, 0);
205 if (negative_indices_glob && SvTRUE(GvSV(*negative_indices_glob)))
211 *keyp += AvFILL(av) + 1;
219 Perl_av_fetch(pTHX_ AV *av, I32 key, I32 lval)
223 PERL_ARGS_ASSERT_AV_FETCH;
224 assert(SvTYPE(av) == SVt_PVAV);
226 if (SvRMAGICAL(av)) {
227 const MAGIC * const tied_magic
228 = mg_find((const SV *)av, PERL_MAGIC_tied);
229 if (tied_magic || mg_find((const SV *)av, PERL_MAGIC_regdata)) {
232 if (!S_adjust_index(aTHX_ av, tied_magic, &key))
237 sv_upgrade(sv, SVt_PVLV);
238 mg_copy(MUTABLE_SV(av), sv, 0, key);
239 if (!tied_magic) /* for regdata, force leavesub to make copies */
242 LvTARG(sv) = sv; /* fake (SV**) */
243 return &(LvTARG(sv));
248 key += AvFILL(av) + 1;
253 if (key > AvFILLp(av) || AvARRAY(av)[key] == &PL_sv_undef) {
255 return lval ? av_store(av,key,newSV(0)) : NULL;
259 && (!AvARRAY(av)[key] /* eg. @_ could have freed elts */
260 || SvIS_FREED(AvARRAY(av)[key]))) {
261 AvARRAY(av)[key] = &PL_sv_undef; /* 1/2 reify */
264 return &AvARRAY(av)[key];
270 Stores an SV in an array. The array index is specified as C<key>. The
271 return value will be NULL if the operation failed or if the value did not
272 need to be actually stored within the array (as in the case of tied
273 arrays). Otherwise, it can be dereferenced
274 to get the C<SV*> that was stored
277 Note that the caller is responsible for suitably incrementing the reference
278 count of C<val> before the call, and decrementing it if the function
281 Approximate Perl equivalent: C<$myarray[$key] = $val;>.
283 See L<perlguts/"Understanding the Magic of Tied Hashes and Arrays"> for
284 more information on how to use this function on tied arrays.
290 Perl_av_store(pTHX_ AV *av, I32 key, SV *val)
295 PERL_ARGS_ASSERT_AV_STORE;
296 assert(SvTYPE(av) == SVt_PVAV);
298 /* S_regclass relies on being able to pass in a NULL sv
299 (unicode_alternate may be NULL).
305 if (SvRMAGICAL(av)) {
306 const MAGIC * const tied_magic = mg_find((const SV *)av, PERL_MAGIC_tied);
309 if (!S_adjust_index(aTHX_ av, tied_magic, &key))
312 if (val != &PL_sv_undef) {
313 mg_copy(MUTABLE_SV(av), val, 0, key);
321 key += AvFILL(av) + 1;
326 if (SvREADONLY(av) && key >= AvFILL(av))
327 Perl_croak_no_modify();
329 if (!AvREAL(av) && AvREIFY(av))
334 if (AvFILLp(av) < key) {
336 if (av == PL_curstack && key > PL_stack_sp - PL_stack_base)
337 PL_stack_sp = PL_stack_base + key; /* XPUSH in disguise */
339 ary[++AvFILLp(av)] = &PL_sv_undef;
340 } while (AvFILLp(av) < key);
345 SvREFCNT_dec(ary[key]);
347 if (SvSMAGICAL(av)) {
348 const MAGIC *mg = SvMAGIC(av);
350 for (; mg; mg = mg->mg_moremagic) {
351 if (!isUPPER(mg->mg_type)) continue;
352 if (val != &PL_sv_undef) {
353 sv_magic(val, MUTABLE_SV(av), toLOWER(mg->mg_type), 0, key);
355 if (PL_delaymagic && mg->mg_type == PERL_MAGIC_isa) {
356 PL_delaymagic |= DM_ARRAY_ISA;
361 mg_set(MUTABLE_SV(av));
369 Creates a new AV and populates it with a list of SVs. The SVs are copied
370 into the array, so they may be freed after the call to av_make. The new AV
371 will have a reference count of 1.
373 Perl equivalent: C<my @new_array = ($scalar1, $scalar2, $scalar3...);>
379 Perl_av_make(pTHX_ I32 size, SV **strp)
381 AV * const av = MUTABLE_AV(newSV_type(SVt_PVAV));
382 /* sv_upgrade does AvREAL_only() */
383 PERL_ARGS_ASSERT_AV_MAKE;
384 assert(SvTYPE(av) == SVt_PVAV);
386 if (size) { /* "defined" was returning undef for size==0 anyway. */
392 AvMAX(av) = size - 1;
396 for (i = 0; i < size; i++) {
399 /* Don't let sv_setsv swipe, since our source array might
400 have multiple references to the same temp scalar (e.g.
401 from a list slice) */
403 SvGETMAGIC(*strp); /* before newSV, in case it dies */
406 sv_setsv_flags(ary[i], *strp,
407 SV_DO_COW_SVSETSV|SV_NOSTEAL);
410 SvREFCNT_inc_simple_void_NN(av);
419 Clears an array, making it empty. Does not free the memory the av uses to
420 store its list of scalars. If any destructors are triggered as a result,
421 the av itself may be freed when this function returns.
423 Perl equivalent: C<@myarray = ();>.
429 Perl_av_clear(pTHX_ AV *av)
435 PERL_ARGS_ASSERT_AV_CLEAR;
436 assert(SvTYPE(av) == SVt_PVAV);
439 if (SvREFCNT(av) == 0) {
440 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEBUGGING), "Attempt to clear deleted array");
445 Perl_croak_no_modify();
447 /* Give any tie a chance to cleanup first */
448 if (SvRMAGICAL(av)) {
449 const MAGIC* const mg = SvMAGIC(av);
450 if (PL_delaymagic && mg && mg->mg_type == PERL_MAGIC_isa)
451 PL_delaymagic |= DM_ARRAY_ISA;
453 mg_clear(MUTABLE_SV(av));
459 if ((real = !!AvREAL(av))) {
460 SV** const ary = AvARRAY(av);
461 I32 index = AvFILLp(av) + 1;
463 SAVEFREESV(SvREFCNT_inc_simple_NN(av));
465 SV * const sv = ary[--index];
466 /* undef the slot before freeing the value, because a
467 * destructor might try to modify this array */
468 ary[index] = &PL_sv_undef;
472 extra = AvARRAY(av) - AvALLOC(av);
475 AvARRAY(av) = AvALLOC(av);
484 Undefines the array. Frees the memory used by the av to store its list of
485 scalars. If any destructors are triggered as a result, the av itself may
492 Perl_av_undef(pTHX_ AV *av)
496 PERL_ARGS_ASSERT_AV_UNDEF;
497 assert(SvTYPE(av) == SVt_PVAV);
499 /* Give any tie a chance to cleanup first */
500 if (SvTIED_mg((const SV *)av, PERL_MAGIC_tied))
503 if ((real = !!AvREAL(av))) {
504 I32 key = AvFILLp(av) + 1;
506 SAVEFREESV(SvREFCNT_inc_simple_NN(av));
508 SvREFCNT_dec(AvARRAY(av)[--key]);
511 Safefree(AvALLOC(av));
514 AvMAX(av) = AvFILLp(av) = -1;
516 if(SvRMAGICAL(av)) mg_clear(MUTABLE_SV(av));
522 =for apidoc av_create_and_push
524 Push an SV onto the end of the array, creating the array if necessary.
525 A small internal helper function to remove a commonly duplicated idiom.
531 Perl_av_create_and_push(pTHX_ AV **const avp, SV *const val)
533 PERL_ARGS_ASSERT_AV_CREATE_AND_PUSH;
543 Pushes an SV onto the end of the array. The array will grow automatically
544 to accommodate the addition. This takes ownership of one reference count.
546 Perl equivalent: C<push @myarray, $elem;>.
552 Perl_av_push(pTHX_ AV *av, SV *val)
557 PERL_ARGS_ASSERT_AV_PUSH;
558 assert(SvTYPE(av) == SVt_PVAV);
561 Perl_croak_no_modify();
563 if ((mg = SvTIED_mg((const SV *)av, PERL_MAGIC_tied))) {
564 Perl_magic_methcall(aTHX_ MUTABLE_SV(av), mg, "PUSH", G_DISCARD, 1,
568 av_store(av,AvFILLp(av)+1,val);
574 Removes one SV from the end of the array, reducing its size by one and
575 returning the SV (transferring control of one reference count) to the
576 caller. Returns C<&PL_sv_undef> if the array is empty.
578 Perl equivalent: C<pop(@myarray);>
584 Perl_av_pop(pTHX_ AV *av)
590 PERL_ARGS_ASSERT_AV_POP;
591 assert(SvTYPE(av) == SVt_PVAV);
594 Perl_croak_no_modify();
595 if ((mg = SvTIED_mg((const SV *)av, PERL_MAGIC_tied))) {
596 retval = Perl_magic_methcall(aTHX_ MUTABLE_SV(av), mg, "POP", 0, 0);
598 retval = newSVsv(retval);
603 retval = AvARRAY(av)[AvFILLp(av)];
604 AvARRAY(av)[AvFILLp(av)--] = &PL_sv_undef;
606 mg_set(MUTABLE_SV(av));
612 =for apidoc av_create_and_unshift_one
614 Unshifts an SV onto the beginning of the array, creating the array if
616 A small internal helper function to remove a commonly duplicated idiom.
622 Perl_av_create_and_unshift_one(pTHX_ AV **const avp, SV *const val)
624 PERL_ARGS_ASSERT_AV_CREATE_AND_UNSHIFT_ONE;
629 return av_store(*avp, 0, val);
633 =for apidoc av_unshift
635 Unshift the given number of C<undef> values onto the beginning of the
636 array. The array will grow automatically to accommodate the addition. You
637 must then use C<av_store> to assign values to these new elements.
639 Perl equivalent: C<unshift @myarray, ( (undef) x $n );>
645 Perl_av_unshift(pTHX_ AV *av, I32 num)
651 PERL_ARGS_ASSERT_AV_UNSHIFT;
652 assert(SvTYPE(av) == SVt_PVAV);
655 Perl_croak_no_modify();
657 if ((mg = SvTIED_mg((const SV *)av, PERL_MAGIC_tied))) {
658 Perl_magic_methcall(aTHX_ MUTABLE_SV(av), mg, "UNSHIFT",
659 G_DISCARD | G_UNDEF_FILL, num);
665 if (!AvREAL(av) && AvREIFY(av))
667 i = AvARRAY(av) - AvALLOC(av);
675 AvARRAY(av) = AvARRAY(av) - i;
679 const I32 i = AvFILLp(av);
680 /* Create extra elements */
681 const I32 slide = i > 0 ? i : 0;
683 av_extend(av, i + num);
686 Move(ary, ary + num, i + 1, SV*);
688 ary[--num] = &PL_sv_undef;
690 /* Make extra elements into a buffer */
692 AvFILLp(av) -= slide;
693 AvARRAY(av) = AvARRAY(av) + slide;
700 Shifts an SV off the beginning of the
701 array. Returns C<&PL_sv_undef> if the
704 Perl equivalent: C<shift(@myarray);>
710 Perl_av_shift(pTHX_ AV *av)
716 PERL_ARGS_ASSERT_AV_SHIFT;
717 assert(SvTYPE(av) == SVt_PVAV);
720 Perl_croak_no_modify();
721 if ((mg = SvTIED_mg((const SV *)av, PERL_MAGIC_tied))) {
722 retval = Perl_magic_methcall(aTHX_ MUTABLE_SV(av), mg, "SHIFT", 0, 0);
724 retval = newSVsv(retval);
729 retval = *AvARRAY(av);
731 *AvARRAY(av) = &PL_sv_undef;
732 AvARRAY(av) = AvARRAY(av) + 1;
736 mg_set(MUTABLE_SV(av));
741 =for apidoc av_top_index
743 Returns the highest index in the array. The number of elements in the
744 array is C<av_top_index(av) + 1>. Returns -1 if the array is empty.
746 The Perl equivalent for this is C<$#myarray>.
748 (A slightly shorter form is C<av_tindex>.)
752 Same as L</av_top_index>. Returns the highest index in the array. Note that the
753 return value is +1 what its name implies it returns; and hence differs in
754 meaning from what the similarly named L</sv_len> returns.
760 Perl_av_len(pTHX_ AV *av)
762 PERL_ARGS_ASSERT_AV_LEN;
764 return av_top_index(av);
770 Set the highest index in the array to the given number, equivalent to
771 Perl's C<$#array = $fill;>.
773 The number of elements in the an array will be C<fill + 1> after
774 av_fill() returns. If the array was previously shorter, then the
775 additional elements appended are set to C<PL_sv_undef>. If the array
776 was longer, then the excess elements are freed. C<av_fill(av, -1)> is
777 the same as C<av_clear(av)>.
782 Perl_av_fill(pTHX_ AV *av, I32 fill)
787 PERL_ARGS_ASSERT_AV_FILL;
788 assert(SvTYPE(av) == SVt_PVAV);
792 if ((mg = SvTIED_mg((const SV *)av, PERL_MAGIC_tied))) {
793 SV *arg1 = sv_newmortal();
794 sv_setiv(arg1, (IV)(fill + 1));
795 Perl_magic_methcall(aTHX_ MUTABLE_SV(av), mg, "STORESIZE", G_DISCARD,
799 if (fill <= AvMAX(av)) {
800 I32 key = AvFILLp(av);
801 SV** const ary = AvARRAY(av);
805 SvREFCNT_dec(ary[key]);
806 ary[key--] = &PL_sv_undef;
811 ary[++key] = &PL_sv_undef;
816 mg_set(MUTABLE_SV(av));
819 (void)av_store(av,fill,&PL_sv_undef);
823 =for apidoc av_delete
825 Deletes the element indexed by C<key> from the array, makes the element mortal,
826 and returns it. If C<flags> equals C<G_DISCARD>, the element is freed and null
827 is returned. Perl equivalent: C<my $elem = delete($myarray[$idx]);> for the
828 non-C<G_DISCARD> version and a void-context C<delete($myarray[$idx]);> for the
829 C<G_DISCARD> version.
834 Perl_av_delete(pTHX_ AV *av, I32 key, I32 flags)
839 PERL_ARGS_ASSERT_AV_DELETE;
840 assert(SvTYPE(av) == SVt_PVAV);
843 Perl_croak_no_modify();
845 if (SvRMAGICAL(av)) {
846 const MAGIC * const tied_magic
847 = mg_find((const SV *)av, PERL_MAGIC_tied);
848 if ((tied_magic || mg_find((const SV *)av, PERL_MAGIC_regdata))) {
851 if (!S_adjust_index(aTHX_ av, tied_magic, &key))
854 svp = av_fetch(av, key, TRUE);
858 if (mg_find(sv, PERL_MAGIC_tiedelem)) {
859 sv_unmagic(sv, PERL_MAGIC_tiedelem); /* No longer an element */
868 key += AvFILL(av) + 1;
873 if (key > AvFILLp(av))
876 if (!AvREAL(av) && AvREIFY(av))
878 sv = AvARRAY(av)[key];
879 if (key == AvFILLp(av)) {
880 AvARRAY(av)[key] = &PL_sv_undef;
883 } while (--key >= 0 && AvARRAY(av)[key] == &PL_sv_undef);
886 AvARRAY(av)[key] = &PL_sv_undef;
888 mg_set(MUTABLE_SV(av));
890 if (flags & G_DISCARD) {
900 =for apidoc av_exists
902 Returns true if the element indexed by C<key> has been initialized.
904 This relies on the fact that uninitialized array elements are set to
907 Perl equivalent: C<exists($myarray[$key])>.
912 Perl_av_exists(pTHX_ AV *av, I32 key)
915 PERL_ARGS_ASSERT_AV_EXISTS;
916 assert(SvTYPE(av) == SVt_PVAV);
918 if (SvRMAGICAL(av)) {
919 const MAGIC * const tied_magic
920 = mg_find((const SV *)av, PERL_MAGIC_tied);
921 const MAGIC * const regdata_magic
922 = mg_find((const SV *)av, PERL_MAGIC_regdata);
923 if (tied_magic || regdata_magic) {
925 /* Handle negative array indices 20020222 MJD */
927 if (!S_adjust_index(aTHX_ av, tied_magic, &key))
931 if(key >= 0 && regdata_magic) {
932 if (key <= AvFILL(av))
938 SV * const sv = sv_newmortal();
939 mg_copy(MUTABLE_SV(av), sv, 0, key);
940 mg = mg_find(sv, PERL_MAGIC_tiedelem);
942 magic_existspack(sv, mg);
944 I32 retbool = SvTRUE_nomg_NN(sv);
945 return cBOOL(retbool);
953 key += AvFILL(av) + 1;
958 if (key <= AvFILLp(av) && AvARRAY(av)[key] != &PL_sv_undef
968 S_get_aux_mg(pTHX_ AV *av) {
972 PERL_ARGS_ASSERT_GET_AUX_MG;
973 assert(SvTYPE(av) == SVt_PVAV);
975 mg = mg_find((const SV *)av, PERL_MAGIC_arylen_p);
978 mg = sv_magicext(MUTABLE_SV(av), 0, PERL_MAGIC_arylen_p,
979 &PL_vtbl_arylen_p, 0, 0);
981 /* sv_magicext won't set this for us because we pass in a NULL obj */
982 mg->mg_flags |= MGf_REFCOUNTED;
988 Perl_av_arylen_p(pTHX_ AV *av) {
989 MAGIC *const mg = get_aux_mg(av);
991 PERL_ARGS_ASSERT_AV_ARYLEN_P;
992 assert(SvTYPE(av) == SVt_PVAV);
994 return &(mg->mg_obj);
998 Perl_av_iter_p(pTHX_ AV *av) {
999 MAGIC *const mg = get_aux_mg(av);
1001 PERL_ARGS_ASSERT_AV_ITER_P;
1002 assert(SvTYPE(av) == SVt_PVAV);
1004 #if IVSIZE == I32SIZE
1005 return (IV *)&(mg->mg_len);
1009 mg->mg_len = IVSIZE;
1011 mg->mg_ptr = (char *) temp;
1013 return (IV *)mg->mg_ptr;
1019 * c-indentation-style: bsd
1021 * indent-tabs-mode: nil
1024 * ex: set ts=8 sts=4 sw=4 et: