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>.)
763 =for apidoc av_tindex
765 Same as L</av_top_index>.
769 Same as L</av_top_index>. Note that, unlike what the name implies, it returns
770 the highest index in the array, so to get the size of the array you need to use
771 S<C<av_len(av) + 1>>. This is unlike L</sv_len>, which returns what you would
778 Perl_av_len(pTHX_ AV *av)
780 PERL_ARGS_ASSERT_AV_LEN;
782 return av_top_index(av);
788 Set the highest index in the array to the given number, equivalent to
789 Perl's C<$#array = $fill;>.
791 The number of elements in the an array will be C<fill + 1> after
792 av_fill() returns. If the array was previously shorter, then the
793 additional elements appended are set to NULL. If the array
794 was longer, then the excess elements are freed. C<av_fill(av, -1)> is
795 the same as C<av_clear(av)>.
800 Perl_av_fill(pTHX_ AV *av, SSize_t fill)
805 PERL_ARGS_ASSERT_AV_FILL;
806 assert(SvTYPE(av) == SVt_PVAV);
810 if ((mg = SvTIED_mg((const SV *)av, PERL_MAGIC_tied))) {
811 SV *arg1 = sv_newmortal();
812 sv_setiv(arg1, (IV)(fill + 1));
813 Perl_magic_methcall(aTHX_ MUTABLE_SV(av), mg, SV_CONST(STORESIZE), G_DISCARD,
817 if (fill <= AvMAX(av)) {
818 SSize_t key = AvFILLp(av);
819 SV** const ary = AvARRAY(av);
823 SvREFCNT_dec(ary[key]);
834 mg_set(MUTABLE_SV(av));
837 (void)av_store(av,fill,NULL);
841 =for apidoc av_delete
843 Deletes the element indexed by C<key> from the array, makes the element mortal,
844 and returns it. If C<flags> equals C<G_DISCARD>, the element is freed and null
845 is returned. Perl equivalent: C<my $elem = delete($myarray[$idx]);> for the
846 non-C<G_DISCARD> version and a void-context C<delete($myarray[$idx]);> for the
847 C<G_DISCARD> version.
852 Perl_av_delete(pTHX_ AV *av, SSize_t key, I32 flags)
857 PERL_ARGS_ASSERT_AV_DELETE;
858 assert(SvTYPE(av) == SVt_PVAV);
861 Perl_croak_no_modify();
863 if (SvRMAGICAL(av)) {
864 const MAGIC * const tied_magic
865 = mg_find((const SV *)av, PERL_MAGIC_tied);
866 if ((tied_magic || mg_find((const SV *)av, PERL_MAGIC_regdata))) {
869 if (!S_adjust_index(aTHX_ av, tied_magic, &key))
872 svp = av_fetch(av, key, TRUE);
876 if (mg_find(sv, PERL_MAGIC_tiedelem)) {
877 sv_unmagic(sv, PERL_MAGIC_tiedelem); /* No longer an element */
886 key += AvFILL(av) + 1;
891 if (key > AvFILLp(av))
894 if (!AvREAL(av) && AvREIFY(av))
896 sv = AvARRAY(av)[key];
897 AvARRAY(av)[key] = NULL;
898 if (key == AvFILLp(av)) {
901 } while (--key >= 0 && !AvARRAY(av)[key]);
904 mg_set(MUTABLE_SV(av));
907 if (flags & G_DISCARD) {
918 =for apidoc av_exists
920 Returns true if the element indexed by C<key> has been initialized.
922 This relies on the fact that uninitialized array elements are set to
925 Perl equivalent: C<exists($myarray[$key])>.
930 Perl_av_exists(pTHX_ AV *av, SSize_t key)
933 PERL_ARGS_ASSERT_AV_EXISTS;
934 assert(SvTYPE(av) == SVt_PVAV);
936 if (SvRMAGICAL(av)) {
937 const MAGIC * const tied_magic
938 = mg_find((const SV *)av, PERL_MAGIC_tied);
939 const MAGIC * const regdata_magic
940 = mg_find((const SV *)av, PERL_MAGIC_regdata);
941 if (tied_magic || regdata_magic) {
943 /* Handle negative array indices 20020222 MJD */
945 if (!S_adjust_index(aTHX_ av, tied_magic, &key))
949 if(key >= 0 && regdata_magic) {
950 if (key <= AvFILL(av))
956 SV * const sv = sv_newmortal();
957 mg_copy(MUTABLE_SV(av), sv, 0, key);
958 mg = mg_find(sv, PERL_MAGIC_tiedelem);
960 magic_existspack(sv, mg);
962 I32 retbool = SvTRUE_nomg_NN(sv);
963 return cBOOL(retbool);
971 key += AvFILL(av) + 1;
976 if (key <= AvFILLp(av) && AvARRAY(av)[key])
985 S_get_aux_mg(pTHX_ AV *av) {
989 PERL_ARGS_ASSERT_GET_AUX_MG;
990 assert(SvTYPE(av) == SVt_PVAV);
992 mg = mg_find((const SV *)av, PERL_MAGIC_arylen_p);
995 mg = sv_magicext(MUTABLE_SV(av), 0, PERL_MAGIC_arylen_p,
996 &PL_vtbl_arylen_p, 0, 0);
998 /* sv_magicext won't set this for us because we pass in a NULL obj */
999 mg->mg_flags |= MGf_REFCOUNTED;
1005 Perl_av_arylen_p(pTHX_ AV *av) {
1006 MAGIC *const mg = get_aux_mg(av);
1008 PERL_ARGS_ASSERT_AV_ARYLEN_P;
1009 assert(SvTYPE(av) == SVt_PVAV);
1011 return &(mg->mg_obj);
1015 Perl_av_iter_p(pTHX_ AV *av) {
1016 MAGIC *const mg = get_aux_mg(av);
1018 PERL_ARGS_ASSERT_AV_ITER_P;
1019 assert(SvTYPE(av) == SVt_PVAV);
1021 #if IVSIZE == I32SIZE
1022 return (IV *)&(mg->mg_len);
1026 mg->mg_len = IVSIZE;
1028 mg->mg_ptr = (char *) temp;
1030 return (IV *)mg->mg_ptr;
1036 * c-indentation-style: bsd
1038 * indent-tabs-mode: nil
1041 * ex: set ts=8 sts=4 sw=4 et: