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, SSize_t 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, SSize_t 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;
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 newmax = key + *maxp / 5;
140 #ifdef PERL_MALLOC_WRAP /* Duplicated in pp_hot.c */
141 static const char oom_array_extend[] =
142 "Out of memory during array extend";
144 MEM_WRAP_CHECK_1(newmax+1, SV*, oom_array_extend);
146 #ifdef STRESS_REALLOC
148 SV ** const old_alloc = *allocp;
149 Newx(*allocp, newmax+1, SV*);
150 Copy(old_alloc, *allocp, *maxp + 1, SV*);
154 Renew(*allocp,newmax+1, SV*);
156 #ifdef Perl_safesysmalloc_size
159 ary = *allocp + *maxp + 1;
160 tmp = newmax - *maxp;
161 if (av == PL_curstack) { /* Oops, grew stack (via av_store()?) */
162 PL_stack_sp = *allocp + (PL_stack_sp - PL_stack_base);
163 PL_stack_base = *allocp;
164 PL_stack_max = PL_stack_base + newmax;
168 newmax = key < 3 ? 3 : key;
170 #ifdef PERL_MALLOC_WRAP /* Duplicated in pp_hot.c */
171 static const char oom_array_extend[] =
172 "Out of memory during array extend";
174 MEM_WRAP_CHECK_1(newmax+1, SV*, oom_array_extend);
176 Newx(*allocp, newmax+1, SV*);
179 *allocp[0] = NULL; /* For the stacks */
181 if (av && AvREAL(av)) {
195 Returns the SV at the specified index in the array. The C<key> is the
196 index. If lval is true, you are guaranteed to get a real SV back (in case
197 it wasn't real before), which you can then modify. Check that the return
198 value is non-null before dereferencing it to a C<SV*>.
200 See L<perlguts/"Understanding the Magic of Tied Hashes and Arrays"> for
201 more information on how to use this function on tied arrays.
203 The rough perl equivalent is C<$myarray[$idx]>.
209 S_adjust_index(pTHX_ AV *av, const MAGIC *mg, SSize_t *keyp)
211 bool adjust_index = 1;
213 /* Handle negative array indices 20020222 MJD */
214 SV * const ref = SvTIED_obj(MUTABLE_SV(av), mg);
216 if (SvROK(ref) && SvOBJECT(SvRV(ref))) {
217 SV * const * const negative_indices_glob =
218 hv_fetchs(SvSTASH(SvRV(ref)), NEGATIVE_INDICES_VAR, 0);
220 if (negative_indices_glob && isGV(*negative_indices_glob)
221 && SvTRUE(GvSV(*negative_indices_glob)))
227 *keyp += AvFILL(av) + 1;
235 Perl_av_fetch(pTHX_ AV *av, SSize_t key, I32 lval)
239 PERL_ARGS_ASSERT_AV_FETCH;
240 assert(SvTYPE(av) == SVt_PVAV);
242 if (SvRMAGICAL(av)) {
243 const MAGIC * const tied_magic
244 = mg_find((const SV *)av, PERL_MAGIC_tied);
245 if (tied_magic || mg_find((const SV *)av, PERL_MAGIC_regdata)) {
248 if (!S_adjust_index(aTHX_ av, tied_magic, &key))
253 sv_upgrade(sv, SVt_PVLV);
254 mg_copy(MUTABLE_SV(av), sv, 0, key);
255 if (!tied_magic) /* for regdata, force leavesub to make copies */
258 LvTARG(sv) = sv; /* fake (SV**) */
259 return &(LvTARG(sv));
264 key += AvFILL(av) + 1;
269 if (key > AvFILLp(av) || !AvARRAY(av)[key]) {
271 return lval ? av_store(av,key,newSV(0)) : NULL;
275 && (!AvARRAY(av)[key] /* eg. @_ could have freed elts */
276 || SvIS_FREED(AvARRAY(av)[key]))) {
277 AvARRAY(av)[key] = NULL; /* 1/2 reify */
280 return &AvARRAY(av)[key];
286 Stores an SV in an array. The array index is specified as C<key>. The
287 return value will be NULL if the operation failed or if the value did not
288 need to be actually stored within the array (as in the case of tied
289 arrays). Otherwise, it can be dereferenced
290 to get the C<SV*> that was stored
293 Note that the caller is responsible for suitably incrementing the reference
294 count of C<val> before the call, and decrementing it if the function
297 Approximate Perl equivalent: C<$myarray[$key] = $val;>.
299 See L<perlguts/"Understanding the Magic of Tied Hashes and Arrays"> for
300 more information on how to use this function on tied arrays.
306 Perl_av_store(pTHX_ AV *av, SSize_t key, SV *val)
311 PERL_ARGS_ASSERT_AV_STORE;
312 assert(SvTYPE(av) == SVt_PVAV);
314 /* S_regclass relies on being able to pass in a NULL sv
315 (unicode_alternate may be NULL).
318 if (SvRMAGICAL(av)) {
319 const MAGIC * const tied_magic = mg_find((const SV *)av, PERL_MAGIC_tied);
322 if (!S_adjust_index(aTHX_ av, tied_magic, &key))
326 mg_copy(MUTABLE_SV(av), val, 0, key);
334 key += AvFILL(av) + 1;
339 if (SvREADONLY(av) && key >= AvFILL(av))
340 Perl_croak_no_modify();
342 if (!AvREAL(av) && AvREIFY(av))
347 if (AvFILLp(av) < key) {
349 if (av == PL_curstack && key > PL_stack_sp - PL_stack_base)
350 PL_stack_sp = PL_stack_base + key; /* XPUSH in disguise */
352 ary[++AvFILLp(av)] = NULL;
353 } while (AvFILLp(av) < key);
358 SvREFCNT_dec(ary[key]);
360 if (SvSMAGICAL(av)) {
361 const MAGIC *mg = SvMAGIC(av);
363 for (; mg; mg = mg->mg_moremagic) {
364 if (!isUPPER(mg->mg_type)) continue;
366 sv_magic(val, MUTABLE_SV(av), toLOWER(mg->mg_type), 0, key);
368 if (PL_delaymagic && mg->mg_type == PERL_MAGIC_isa) {
369 PL_delaymagic |= DM_ARRAY_ISA;
374 mg_set(MUTABLE_SV(av));
382 Creates a new AV and populates it with a list of SVs. The SVs are copied
383 into the array, so they may be freed after the call to av_make. The new AV
384 will have a reference count of 1.
386 Perl equivalent: C<my @new_array = ($scalar1, $scalar2, $scalar3...);>
392 Perl_av_make(pTHX_ SSize_t size, SV **strp)
394 AV * const av = MUTABLE_AV(newSV_type(SVt_PVAV));
395 /* sv_upgrade does AvREAL_only() */
396 PERL_ARGS_ASSERT_AV_MAKE;
397 assert(SvTYPE(av) == SVt_PVAV);
399 if (size) { /* "defined" was returning undef for size==0 anyway. */
405 AvMAX(av) = size - 1;
409 for (i = 0; i < size; i++) {
412 /* Don't let sv_setsv swipe, since our source array might
413 have multiple references to the same temp scalar (e.g.
414 from a list slice) */
416 SvGETMAGIC(*strp); /* before newSV, in case it dies */
419 sv_setsv_flags(ary[i], *strp,
420 SV_DO_COW_SVSETSV|SV_NOSTEAL);
423 SvREFCNT_inc_simple_void_NN(av);
432 Clears an array, making it empty. Does not free the memory the av uses to
433 store its list of scalars. If any destructors are triggered as a result,
434 the av itself may be freed when this function returns.
436 Perl equivalent: C<@myarray = ();>.
442 Perl_av_clear(pTHX_ AV *av)
448 PERL_ARGS_ASSERT_AV_CLEAR;
449 assert(SvTYPE(av) == SVt_PVAV);
452 if (SvREFCNT(av) == 0) {
453 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEBUGGING), "Attempt to clear deleted array");
458 Perl_croak_no_modify();
460 /* Give any tie a chance to cleanup first */
461 if (SvRMAGICAL(av)) {
462 const MAGIC* const mg = SvMAGIC(av);
463 if (PL_delaymagic && mg && mg->mg_type == PERL_MAGIC_isa)
464 PL_delaymagic |= DM_ARRAY_ISA;
466 mg_clear(MUTABLE_SV(av));
472 if ((real = !!AvREAL(av))) {
473 SV** const ary = AvARRAY(av);
474 SSize_t index = AvFILLp(av) + 1;
476 SAVEFREESV(SvREFCNT_inc_simple_NN(av));
478 SV * const sv = ary[--index];
479 /* undef the slot before freeing the value, because a
480 * destructor might try to modify this array */
485 extra = AvARRAY(av) - AvALLOC(av);
488 AvARRAY(av) = AvALLOC(av);
497 Undefines the array. Frees the memory used by the av to store its list of
498 scalars. If any destructors are triggered as a result, the av itself may
505 Perl_av_undef(pTHX_ AV *av)
509 PERL_ARGS_ASSERT_AV_UNDEF;
510 assert(SvTYPE(av) == SVt_PVAV);
512 /* Give any tie a chance to cleanup first */
513 if (SvTIED_mg((const SV *)av, PERL_MAGIC_tied))
516 if ((real = !!AvREAL(av))) {
517 SSize_t key = AvFILLp(av) + 1;
519 SAVEFREESV(SvREFCNT_inc_simple_NN(av));
521 SvREFCNT_dec(AvARRAY(av)[--key]);
524 Safefree(AvALLOC(av));
527 AvMAX(av) = AvFILLp(av) = -1;
529 if(SvRMAGICAL(av)) mg_clear(MUTABLE_SV(av));
535 =for apidoc av_create_and_push
537 Push an SV onto the end of the array, creating the array if necessary.
538 A small internal helper function to remove a commonly duplicated idiom.
544 Perl_av_create_and_push(pTHX_ AV **const avp, SV *const val)
546 PERL_ARGS_ASSERT_AV_CREATE_AND_PUSH;
556 Pushes an SV onto the end of the array. The array will grow automatically
557 to accommodate the addition. This takes ownership of one reference count.
559 Perl equivalent: C<push @myarray, $elem;>.
565 Perl_av_push(pTHX_ AV *av, SV *val)
570 PERL_ARGS_ASSERT_AV_PUSH;
571 assert(SvTYPE(av) == SVt_PVAV);
574 Perl_croak_no_modify();
576 if ((mg = SvTIED_mg((const SV *)av, PERL_MAGIC_tied))) {
577 Perl_magic_methcall(aTHX_ MUTABLE_SV(av), mg, SV_CONST(PUSH), G_DISCARD, 1,
581 av_store(av,AvFILLp(av)+1,val);
587 Removes one SV from the end of the array, reducing its size by one and
588 returning the SV (transferring control of one reference count) to the
589 caller. Returns C<&PL_sv_undef> if the array is empty.
591 Perl equivalent: C<pop(@myarray);>
597 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)
664 PERL_ARGS_ASSERT_AV_UNSHIFT;
665 assert(SvTYPE(av) == SVt_PVAV);
668 Perl_croak_no_modify();
670 if ((mg = SvTIED_mg((const SV *)av, PERL_MAGIC_tied))) {
671 Perl_magic_methcall(aTHX_ MUTABLE_SV(av), mg, SV_CONST(UNSHIFT),
672 G_DISCARD | G_UNDEF_FILL, num);
678 if (!AvREAL(av) && AvREIFY(av))
680 i = AvARRAY(av) - AvALLOC(av);
688 AvARRAY(av) = AvARRAY(av) - i;
692 const SSize_t i = AvFILLp(av);
693 /* Create extra elements */
694 const SSize_t slide = i > 0 ? i : 0;
696 av_extend(av, i + num);
699 Move(ary, ary + num, i + 1, SV*);
703 /* Make extra elements into a buffer */
705 AvFILLp(av) -= slide;
706 AvARRAY(av) = AvARRAY(av) + slide;
713 Removes one SV from the start of the array, reducing its size by one and
714 returning the SV (transferring control of one reference count) to the
715 caller. Returns C<&PL_sv_undef> if the array is empty.
717 Perl equivalent: C<shift(@myarray);>
723 Perl_av_shift(pTHX_ AV *av)
729 PERL_ARGS_ASSERT_AV_SHIFT;
730 assert(SvTYPE(av) == SVt_PVAV);
733 Perl_croak_no_modify();
734 if ((mg = SvTIED_mg((const SV *)av, PERL_MAGIC_tied))) {
735 retval = Perl_magic_methcall(aTHX_ MUTABLE_SV(av), mg, SV_CONST(SHIFT), 0, 0);
737 retval = newSVsv(retval);
742 retval = *AvARRAY(av);
745 AvARRAY(av) = AvARRAY(av) + 1;
749 mg_set(MUTABLE_SV(av));
750 return retval ? retval : &PL_sv_undef;
754 =for apidoc av_top_index
756 Returns the highest index in the array. The number of elements in the
757 array is C<av_top_index(av) + 1>. Returns -1 if the array is empty.
759 The Perl equivalent for this is C<$#myarray>.
761 (A slightly shorter form is C<av_tindex>.)
765 Same as L</av_top_index>. Returns the highest index in the array. Note that the
766 return value is +1 what its name implies it returns; and hence differs in
767 meaning from what the similarly named L</sv_len> returns.
773 Perl_av_len(pTHX_ AV *av)
775 PERL_ARGS_ASSERT_AV_LEN;
777 return av_top_index(av);
783 Set the highest index in the array to the given number, equivalent to
784 Perl's C<$#array = $fill;>.
786 The number of elements in the an array will be C<fill + 1> after
787 av_fill() returns. If the array was previously shorter, then the
788 additional elements appended are set to NULL. If the array
789 was longer, then the excess elements are freed. C<av_fill(av, -1)> is
790 the same as C<av_clear(av)>.
795 Perl_av_fill(pTHX_ AV *av, SSize_t fill)
800 PERL_ARGS_ASSERT_AV_FILL;
801 assert(SvTYPE(av) == SVt_PVAV);
805 if ((mg = SvTIED_mg((const SV *)av, PERL_MAGIC_tied))) {
806 SV *arg1 = sv_newmortal();
807 sv_setiv(arg1, (IV)(fill + 1));
808 Perl_magic_methcall(aTHX_ MUTABLE_SV(av), mg, SV_CONST(STORESIZE), G_DISCARD,
812 if (fill <= AvMAX(av)) {
813 SSize_t key = AvFILLp(av);
814 SV** const ary = AvARRAY(av);
818 SvREFCNT_dec(ary[key]);
829 mg_set(MUTABLE_SV(av));
832 (void)av_store(av,fill,NULL);
836 =for apidoc av_delete
838 Deletes the element indexed by C<key> from the array, makes the element mortal,
839 and returns it. If C<flags> equals C<G_DISCARD>, the element is freed and null
840 is returned. Perl equivalent: C<my $elem = delete($myarray[$idx]);> for the
841 non-C<G_DISCARD> version and a void-context C<delete($myarray[$idx]);> for the
842 C<G_DISCARD> version.
847 Perl_av_delete(pTHX_ AV *av, SSize_t key, I32 flags)
852 PERL_ARGS_ASSERT_AV_DELETE;
853 assert(SvTYPE(av) == SVt_PVAV);
856 Perl_croak_no_modify();
858 if (SvRMAGICAL(av)) {
859 const MAGIC * const tied_magic
860 = mg_find((const SV *)av, PERL_MAGIC_tied);
861 if ((tied_magic || mg_find((const SV *)av, PERL_MAGIC_regdata))) {
864 if (!S_adjust_index(aTHX_ av, tied_magic, &key))
867 svp = av_fetch(av, key, TRUE);
871 if (mg_find(sv, PERL_MAGIC_tiedelem)) {
872 sv_unmagic(sv, PERL_MAGIC_tiedelem); /* No longer an element */
881 key += AvFILL(av) + 1;
886 if (key > AvFILLp(av))
889 if (!AvREAL(av) && AvREIFY(av))
891 sv = AvARRAY(av)[key];
892 if (key == AvFILLp(av)) {
893 AvARRAY(av)[key] = NULL;
896 } while (--key >= 0 && !AvARRAY(av)[key]);
899 AvARRAY(av)[key] = NULL;
901 mg_set(MUTABLE_SV(av));
903 if (flags & G_DISCARD) {
913 =for apidoc av_exists
915 Returns true if the element indexed by C<key> has been initialized.
917 This relies on the fact that uninitialized array elements are set to
920 Perl equivalent: C<exists($myarray[$key])>.
925 Perl_av_exists(pTHX_ AV *av, SSize_t key)
928 PERL_ARGS_ASSERT_AV_EXISTS;
929 assert(SvTYPE(av) == SVt_PVAV);
931 if (SvRMAGICAL(av)) {
932 const MAGIC * const tied_magic
933 = mg_find((const SV *)av, PERL_MAGIC_tied);
934 const MAGIC * const regdata_magic
935 = mg_find((const SV *)av, PERL_MAGIC_regdata);
936 if (tied_magic || regdata_magic) {
938 /* Handle negative array indices 20020222 MJD */
940 if (!S_adjust_index(aTHX_ av, tied_magic, &key))
944 if(key >= 0 && regdata_magic) {
945 if (key <= AvFILL(av))
951 SV * const sv = sv_newmortal();
952 mg_copy(MUTABLE_SV(av), sv, 0, key);
953 mg = mg_find(sv, PERL_MAGIC_tiedelem);
955 magic_existspack(sv, mg);
957 I32 retbool = SvTRUE_nomg_NN(sv);
958 return cBOOL(retbool);
966 key += AvFILL(av) + 1;
971 if (key <= AvFILLp(av) && AvARRAY(av)[key])
980 S_get_aux_mg(pTHX_ AV *av) {
984 PERL_ARGS_ASSERT_GET_AUX_MG;
985 assert(SvTYPE(av) == SVt_PVAV);
987 mg = mg_find((const SV *)av, PERL_MAGIC_arylen_p);
990 mg = sv_magicext(MUTABLE_SV(av), 0, PERL_MAGIC_arylen_p,
991 &PL_vtbl_arylen_p, 0, 0);
993 /* sv_magicext won't set this for us because we pass in a NULL obj */
994 mg->mg_flags |= MGf_REFCOUNTED;
1000 Perl_av_arylen_p(pTHX_ AV *av) {
1001 MAGIC *const mg = get_aux_mg(av);
1003 PERL_ARGS_ASSERT_AV_ARYLEN_P;
1004 assert(SvTYPE(av) == SVt_PVAV);
1006 return &(mg->mg_obj);
1010 Perl_av_iter_p(pTHX_ AV *av) {
1011 MAGIC *const mg = get_aux_mg(av);
1013 PERL_ARGS_ASSERT_AV_ITER_P;
1014 assert(SvTYPE(av) == SVt_PVAV);
1016 #if IVSIZE == I32SIZE
1017 return (IV *)&(mg->mg_len);
1021 mg->mg_len = IVSIZE;
1023 mg->mg_ptr = (char *) temp;
1025 return (IV *)mg->mg_ptr;
1031 * c-indentation-style: bsd
1033 * indent-tabs-mode: nil
1036 * ex: set ts=8 sts=4 sw=4 et: