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;
90 if (key < -1) /* -1 is legal */
92 "panic: av_extend_guts() negative count (%"IVdf")", (IV)key);
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 /* overflow-safe version of newmax = key + *maxp/5 */
139 newmax = (key > SSize_t_MAX - newmax)
140 ? SSize_t_MAX : key + newmax;
143 #ifdef PERL_MALLOC_WRAP /* Duplicated in pp_hot.c */
144 static const char oom_array_extend[] =
145 "Out of memory during array extend";
147 /* it should really be newmax+1 here, but if newmax
148 * happens to equal SSize_t_MAX, then newmax+1 is
149 * undefined. This means technically we croak one
150 * index lower than we should in theory; in practice
151 * its unlikely the system has SSize_t_MAX/sizeof(SV*)
153 MEM_WRAP_CHECK_1(newmax, SV*, oom_array_extend);
155 #ifdef STRESS_REALLOC
157 SV ** const old_alloc = *allocp;
158 Newx(*allocp, newmax+1, SV*);
159 Copy(old_alloc, *allocp, *maxp + 1, SV*);
163 Renew(*allocp,newmax+1, SV*);
165 #ifdef Perl_safesysmalloc_size
168 ary = *allocp + *maxp + 1;
169 tmp = newmax - *maxp;
170 if (av == PL_curstack) { /* Oops, grew stack (via av_store()?) */
171 PL_stack_sp = *allocp + (PL_stack_sp - PL_stack_base);
172 PL_stack_base = *allocp;
173 PL_stack_max = PL_stack_base + newmax;
177 newmax = key < 3 ? 3 : key;
179 #ifdef PERL_MALLOC_WRAP /* Duplicated in pp_hot.c */
180 static const char oom_array_extend[] =
181 "Out of memory during array extend";
183 /* see comment above about newmax+1*/
184 MEM_WRAP_CHECK_1(newmax, SV*, oom_array_extend);
186 Newx(*allocp, newmax+1, SV*);
189 *allocp[0] = NULL; /* For the stacks */
191 if (av && AvREAL(av)) {
205 Returns the SV at the specified index in the array. The C<key> is the
206 index. If lval is true, you are guaranteed to get a real SV back (in case
207 it wasn't real before), which you can then modify. Check that the return
208 value is non-null before dereferencing it to a C<SV*>.
210 See L<perlguts/"Understanding the Magic of Tied Hashes and Arrays"> for
211 more information on how to use this function on tied arrays.
213 The rough perl equivalent is C<$myarray[$idx]>.
219 S_adjust_index(pTHX_ AV *av, const MAGIC *mg, SSize_t *keyp)
221 bool adjust_index = 1;
223 /* Handle negative array indices 20020222 MJD */
224 SV * const ref = SvTIED_obj(MUTABLE_SV(av), mg);
226 if (SvROK(ref) && SvOBJECT(SvRV(ref))) {
227 SV * const * const negative_indices_glob =
228 hv_fetchs(SvSTASH(SvRV(ref)), NEGATIVE_INDICES_VAR, 0);
230 if (negative_indices_glob && isGV(*negative_indices_glob)
231 && SvTRUE(GvSV(*negative_indices_glob)))
237 *keyp += AvFILL(av) + 1;
245 Perl_av_fetch(pTHX_ AV *av, SSize_t key, I32 lval)
247 PERL_ARGS_ASSERT_AV_FETCH;
248 assert(SvTYPE(av) == SVt_PVAV);
250 if (SvRMAGICAL(av)) {
251 const MAGIC * const tied_magic
252 = mg_find((const SV *)av, PERL_MAGIC_tied);
253 if (tied_magic || mg_find((const SV *)av, PERL_MAGIC_regdata)) {
256 if (!S_adjust_index(aTHX_ av, tied_magic, &key))
261 sv_upgrade(sv, SVt_PVLV);
262 mg_copy(MUTABLE_SV(av), sv, 0, key);
263 if (!tied_magic) /* for regdata, force leavesub to make copies */
266 LvTARG(sv) = sv; /* fake (SV**) */
267 return &(LvTARG(sv));
272 key += AvFILL(av) + 1;
277 if (key > AvFILLp(av) || !AvARRAY(av)[key]) {
279 return lval ? av_store(av,key,newSV(0)) : NULL;
283 && (!AvARRAY(av)[key] /* eg. @_ could have freed elts */
284 || SvIS_FREED(AvARRAY(av)[key]))) {
285 AvARRAY(av)[key] = NULL; /* 1/2 reify */
288 return &AvARRAY(av)[key];
294 Stores an SV in an array. The array index is specified as C<key>. The
295 return value will be C<NULL> if the operation failed or if the value did not
296 need to be actually stored within the array (as in the case of tied
297 arrays). Otherwise, it can be dereferenced
298 to get the C<SV*> that was stored
301 Note that the caller is responsible for suitably incrementing the reference
302 count of C<val> before the call, and decrementing it if the function
305 Approximate Perl equivalent: C<$myarray[$key] = $val;>.
307 See L<perlguts/"Understanding the Magic of Tied Hashes and Arrays"> for
308 more information on how to use this function on tied arrays.
314 Perl_av_store(pTHX_ AV *av, SSize_t key, SV *val)
318 PERL_ARGS_ASSERT_AV_STORE;
319 assert(SvTYPE(av) == SVt_PVAV);
321 /* S_regclass relies on being able to pass in a NULL sv
322 (unicode_alternate may be NULL).
325 if (SvRMAGICAL(av)) {
326 const MAGIC * const tied_magic = mg_find((const SV *)av, PERL_MAGIC_tied);
329 if (!S_adjust_index(aTHX_ av, tied_magic, &key))
333 mg_copy(MUTABLE_SV(av), val, 0, key);
341 key += AvFILL(av) + 1;
346 if (SvREADONLY(av) && key >= AvFILL(av))
347 Perl_croak_no_modify();
349 if (!AvREAL(av) && AvREIFY(av))
354 if (AvFILLp(av) < key) {
356 if (av == PL_curstack && key > PL_stack_sp - PL_stack_base)
357 PL_stack_sp = PL_stack_base + key; /* XPUSH in disguise */
359 ary[++AvFILLp(av)] = NULL;
360 } while (AvFILLp(av) < key);
365 SvREFCNT_dec(ary[key]);
367 if (SvSMAGICAL(av)) {
368 const MAGIC *mg = SvMAGIC(av);
370 for (; mg; mg = mg->mg_moremagic) {
371 if (!isUPPER(mg->mg_type)) continue;
373 sv_magic(val, MUTABLE_SV(av), toLOWER(mg->mg_type), 0, key);
375 if (PL_delaymagic && mg->mg_type == PERL_MAGIC_isa) {
376 PL_delaymagic |= DM_ARRAY_ISA;
381 mg_set(MUTABLE_SV(av));
389 Creates a new AV and populates it with a list of SVs. The SVs are copied
390 into the array, so they may be freed after the call to C<av_make>. The new AV
391 will have a reference count of 1.
393 Perl equivalent: C<my @new_array = ($scalar1, $scalar2, $scalar3...);>
399 Perl_av_make(pTHX_ SSize_t size, SV **strp)
401 AV * const av = MUTABLE_AV(newSV_type(SVt_PVAV));
402 /* sv_upgrade does AvREAL_only() */
403 PERL_ARGS_ASSERT_AV_MAKE;
404 assert(SvTYPE(av) == SVt_PVAV);
406 if (size) { /* "defined" was returning undef for size==0 anyway. */
412 AvMAX(av) = size - 1;
416 for (i = 0; i < size; i++) {
419 /* Don't let sv_setsv swipe, since our source array might
420 have multiple references to the same temp scalar (e.g.
421 from a list slice) */
423 SvGETMAGIC(*strp); /* before newSV, in case it dies */
426 sv_setsv_flags(ary[i], *strp,
427 SV_DO_COW_SVSETSV|SV_NOSTEAL);
430 SvREFCNT_inc_simple_void_NN(av);
439 Frees the all the elements of an array, leaving it empty.
440 The XS equivalent of C<@array = ()>. See also L</av_undef>.
442 Note that it is possible that the actions of a destructor called directly
443 or indirectly by freeing an element of the array could cause the reference
444 count of the array itself to be reduced (e.g. by deleting an entry in the
445 symbol table). So it is a possibility that the AV could have been freed
446 (or even reallocated) on return from the call unless you hold a reference
453 Perl_av_clear(pTHX_ AV *av)
458 PERL_ARGS_ASSERT_AV_CLEAR;
459 assert(SvTYPE(av) == SVt_PVAV);
462 if (SvREFCNT(av) == 0) {
463 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEBUGGING), "Attempt to clear deleted array");
468 Perl_croak_no_modify();
470 /* Give any tie a chance to cleanup first */
471 if (SvRMAGICAL(av)) {
472 const MAGIC* const mg = SvMAGIC(av);
473 if (PL_delaymagic && mg && mg->mg_type == PERL_MAGIC_isa)
474 PL_delaymagic |= DM_ARRAY_ISA;
476 mg_clear(MUTABLE_SV(av));
482 if ((real = !!AvREAL(av))) {
483 SV** const ary = AvARRAY(av);
484 SSize_t index = AvFILLp(av) + 1;
486 SAVEFREESV(SvREFCNT_inc_simple_NN(av));
488 SV * const sv = ary[--index];
489 /* undef the slot before freeing the value, because a
490 * destructor might try to modify this array */
495 extra = AvARRAY(av) - AvALLOC(av);
498 AvARRAY(av) = AvALLOC(av);
507 Undefines the array. The XS equivalent of C<undef(@array)>.
509 As well as freeing all the elements of the array (like C<av_clear()>), this
510 also frees the memory used by the av to store its list of scalars.
512 See L</av_clear> for a note about the array possibly being invalid on
519 Perl_av_undef(pTHX_ AV *av)
523 PERL_ARGS_ASSERT_AV_UNDEF;
524 assert(SvTYPE(av) == SVt_PVAV);
526 /* Give any tie a chance to cleanup first */
527 if (SvTIED_mg((const SV *)av, PERL_MAGIC_tied))
530 if ((real = !!AvREAL(av))) {
531 SSize_t key = AvFILLp(av) + 1;
533 SAVEFREESV(SvREFCNT_inc_simple_NN(av));
535 SvREFCNT_dec(AvARRAY(av)[--key]);
538 Safefree(AvALLOC(av));
541 AvMAX(av) = AvFILLp(av) = -1;
543 if(SvRMAGICAL(av)) mg_clear(MUTABLE_SV(av));
549 =for apidoc av_create_and_push
551 Push an SV onto the end of the array, creating the array if necessary.
552 A small internal helper function to remove a commonly duplicated idiom.
558 Perl_av_create_and_push(pTHX_ AV **const avp, SV *const val)
560 PERL_ARGS_ASSERT_AV_CREATE_AND_PUSH;
570 Pushes an SV onto the end of the array. The array will grow automatically
571 to accommodate the addition. This takes ownership of one reference count.
573 Perl equivalent: C<push @myarray, $elem;>.
579 Perl_av_push(pTHX_ AV *av, SV *val)
583 PERL_ARGS_ASSERT_AV_PUSH;
584 assert(SvTYPE(av) == SVt_PVAV);
587 Perl_croak_no_modify();
589 if ((mg = SvTIED_mg((const SV *)av, PERL_MAGIC_tied))) {
590 Perl_magic_methcall(aTHX_ MUTABLE_SV(av), mg, SV_CONST(PUSH), G_DISCARD, 1,
594 av_store(av,AvFILLp(av)+1,val);
600 Removes one SV from the end of the array, reducing its size by one and
601 returning the SV (transferring control of one reference count) to the
602 caller. Returns C<&PL_sv_undef> if the array is empty.
604 Perl equivalent: C<pop(@myarray);>
610 Perl_av_pop(pTHX_ AV *av)
615 PERL_ARGS_ASSERT_AV_POP;
616 assert(SvTYPE(av) == SVt_PVAV);
619 Perl_croak_no_modify();
620 if ((mg = SvTIED_mg((const SV *)av, PERL_MAGIC_tied))) {
621 retval = Perl_magic_methcall(aTHX_ MUTABLE_SV(av), mg, SV_CONST(POP), 0, 0);
623 retval = newSVsv(retval);
628 retval = AvARRAY(av)[AvFILLp(av)];
629 AvARRAY(av)[AvFILLp(av)--] = NULL;
631 mg_set(MUTABLE_SV(av));
632 return retval ? retval : &PL_sv_undef;
637 =for apidoc av_create_and_unshift_one
639 Unshifts an SV onto the beginning of the array, creating the array if
641 A small internal helper function to remove a commonly duplicated idiom.
647 Perl_av_create_and_unshift_one(pTHX_ AV **const avp, SV *const val)
649 PERL_ARGS_ASSERT_AV_CREATE_AND_UNSHIFT_ONE;
654 return av_store(*avp, 0, val);
658 =for apidoc av_unshift
660 Unshift the given number of C<undef> values onto the beginning of the
661 array. The array will grow automatically to accommodate the addition. You
662 must then use C<av_store> to assign values to these new elements.
664 Perl equivalent: S<C<unshift @myarray, ( (undef) x $n );>>
670 Perl_av_unshift(pTHX_ AV *av, SSize_t num)
675 PERL_ARGS_ASSERT_AV_UNSHIFT;
676 assert(SvTYPE(av) == SVt_PVAV);
679 Perl_croak_no_modify();
681 if ((mg = SvTIED_mg((const SV *)av, PERL_MAGIC_tied))) {
682 Perl_magic_methcall(aTHX_ MUTABLE_SV(av), mg, SV_CONST(UNSHIFT),
683 G_DISCARD | G_UNDEF_FILL, num);
689 if (!AvREAL(av) && AvREIFY(av))
691 i = AvARRAY(av) - AvALLOC(av);
699 AvARRAY(av) = AvARRAY(av) - i;
703 const SSize_t i = AvFILLp(av);
704 /* Create extra elements */
705 const SSize_t slide = i > 0 ? i : 0;
707 av_extend(av, i + num);
710 Move(ary, ary + num, i + 1, SV*);
714 /* Make extra elements into a buffer */
716 AvFILLp(av) -= slide;
717 AvARRAY(av) = AvARRAY(av) + slide;
724 Removes one SV from the start of the array, reducing its size by one and
725 returning the SV (transferring control of one reference count) to the
726 caller. Returns C<&PL_sv_undef> if the array is empty.
728 Perl equivalent: C<shift(@myarray);>
734 Perl_av_shift(pTHX_ AV *av)
739 PERL_ARGS_ASSERT_AV_SHIFT;
740 assert(SvTYPE(av) == SVt_PVAV);
743 Perl_croak_no_modify();
744 if ((mg = SvTIED_mg((const SV *)av, PERL_MAGIC_tied))) {
745 retval = Perl_magic_methcall(aTHX_ MUTABLE_SV(av), mg, SV_CONST(SHIFT), 0, 0);
747 retval = newSVsv(retval);
752 retval = *AvARRAY(av);
755 AvARRAY(av) = AvARRAY(av) + 1;
759 mg_set(MUTABLE_SV(av));
760 return retval ? retval : &PL_sv_undef;
764 =for apidoc av_top_index
766 Returns the highest index in the array. The number of elements in the
767 array is S<C<av_top_index(av) + 1>>. Returns -1 if the array is empty.
769 The Perl equivalent for this is C<$#myarray>.
771 (A slightly shorter form is C<av_tindex>.)
775 Same as L</av_top_index>. Note that, unlike what the name implies, it returns
776 the highest index in the array, so to get the size of the array you need to use
777 S<C<av_len(av) + 1>>. This is unlike L</sv_len>, which returns what you would
784 Perl_av_len(pTHX_ AV *av)
786 PERL_ARGS_ASSERT_AV_LEN;
788 return av_top_index(av);
794 Set the highest index in the array to the given number, equivalent to
795 Perl's S<C<$#array = $fill;>>.
797 The number of elements in the array will be S<C<fill + 1>> after
798 C<av_fill()> returns. If the array was previously shorter, then the
799 additional elements appended are set to NULL. If the array
800 was longer, then the excess elements are freed. S<C<av_fill(av, -1)>> is
801 the same as C<av_clear(av)>.
806 Perl_av_fill(pTHX_ AV *av, SSize_t fill)
810 PERL_ARGS_ASSERT_AV_FILL;
811 assert(SvTYPE(av) == SVt_PVAV);
815 if ((mg = SvTIED_mg((const SV *)av, PERL_MAGIC_tied))) {
816 SV *arg1 = sv_newmortal();
817 sv_setiv(arg1, (IV)(fill + 1));
818 Perl_magic_methcall(aTHX_ MUTABLE_SV(av), mg, SV_CONST(STORESIZE), G_DISCARD,
822 if (fill <= AvMAX(av)) {
823 SSize_t key = AvFILLp(av);
824 SV** const ary = AvARRAY(av);
828 SvREFCNT_dec(ary[key]);
839 mg_set(MUTABLE_SV(av));
842 (void)av_store(av,fill,NULL);
846 =for apidoc av_delete
848 Deletes the element indexed by C<key> from the array, makes the element mortal,
849 and returns it. If C<flags> equals C<G_DISCARD>, the element is freed and null
850 is returned. Perl equivalent: S<C<my $elem = delete($myarray[$idx]);>> for the
851 non-C<G_DISCARD> version and a void-context S<C<delete($myarray[$idx]);>> for the
852 C<G_DISCARD> version.
857 Perl_av_delete(pTHX_ AV *av, SSize_t key, I32 flags)
861 PERL_ARGS_ASSERT_AV_DELETE;
862 assert(SvTYPE(av) == SVt_PVAV);
865 Perl_croak_no_modify();
867 if (SvRMAGICAL(av)) {
868 const MAGIC * const tied_magic
869 = mg_find((const SV *)av, PERL_MAGIC_tied);
870 if ((tied_magic || mg_find((const SV *)av, PERL_MAGIC_regdata))) {
873 if (!S_adjust_index(aTHX_ av, tied_magic, &key))
876 svp = av_fetch(av, key, TRUE);
880 if (mg_find(sv, PERL_MAGIC_tiedelem)) {
881 sv_unmagic(sv, PERL_MAGIC_tiedelem); /* No longer an element */
890 key += AvFILL(av) + 1;
895 if (key > AvFILLp(av))
898 if (!AvREAL(av) && AvREIFY(av))
900 sv = AvARRAY(av)[key];
901 AvARRAY(av)[key] = NULL;
902 if (key == AvFILLp(av)) {
905 } while (--key >= 0 && !AvARRAY(av)[key]);
908 mg_set(MUTABLE_SV(av));
911 if (flags & G_DISCARD) {
922 =for apidoc av_exists
924 Returns true if the element indexed by C<key> has been initialized.
926 This relies on the fact that uninitialized array elements are set to
929 Perl equivalent: C<exists($myarray[$key])>.
934 Perl_av_exists(pTHX_ AV *av, SSize_t key)
936 PERL_ARGS_ASSERT_AV_EXISTS;
937 assert(SvTYPE(av) == SVt_PVAV);
939 if (SvRMAGICAL(av)) {
940 const MAGIC * const tied_magic
941 = mg_find((const SV *)av, PERL_MAGIC_tied);
942 const MAGIC * const regdata_magic
943 = mg_find((const SV *)av, PERL_MAGIC_regdata);
944 if (tied_magic || regdata_magic) {
946 /* Handle negative array indices 20020222 MJD */
948 if (!S_adjust_index(aTHX_ av, tied_magic, &key))
952 if(key >= 0 && regdata_magic) {
953 if (key <= AvFILL(av))
959 SV * const sv = sv_newmortal();
960 mg_copy(MUTABLE_SV(av), sv, 0, key);
961 mg = mg_find(sv, PERL_MAGIC_tiedelem);
963 magic_existspack(sv, mg);
965 I32 retbool = SvTRUE_nomg_NN(sv);
966 return cBOOL(retbool);
974 key += AvFILL(av) + 1;
979 if (key <= AvFILLp(av) && AvARRAY(av)[key])
988 S_get_aux_mg(pTHX_ AV *av) {
991 PERL_ARGS_ASSERT_GET_AUX_MG;
992 assert(SvTYPE(av) == SVt_PVAV);
994 mg = mg_find((const SV *)av, PERL_MAGIC_arylen_p);
997 mg = sv_magicext(MUTABLE_SV(av), 0, PERL_MAGIC_arylen_p,
998 &PL_vtbl_arylen_p, 0, 0);
1000 /* sv_magicext won't set this for us because we pass in a NULL obj */
1001 mg->mg_flags |= MGf_REFCOUNTED;
1007 Perl_av_arylen_p(pTHX_ AV *av) {
1008 MAGIC *const mg = get_aux_mg(av);
1010 PERL_ARGS_ASSERT_AV_ARYLEN_P;
1011 assert(SvTYPE(av) == SVt_PVAV);
1013 return &(mg->mg_obj);
1017 Perl_av_iter_p(pTHX_ AV *av) {
1018 MAGIC *const mg = get_aux_mg(av);
1020 PERL_ARGS_ASSERT_AV_ITER_P;
1021 assert(SvTYPE(av) == SVt_PVAV);
1023 #if IVSIZE == I32SIZE
1024 return (IV *)&(mg->mg_len);
1028 mg->mg_len = IVSIZE;
1030 mg->mg_ptr = (char *) temp;
1032 return (IV *)mg->mg_ptr;
1037 * ex: set ts=8 sts=4 sw=4 et: