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 if (key > AvMAX(av)) {
88 if (AvALLOC(av) != AvARRAY(av)) {
89 ary = AvALLOC(av) + AvFILLp(av) + 1;
90 tmp = AvARRAY(av) - AvALLOC(av);
91 Move(AvARRAY(av), AvALLOC(av), AvFILLp(av)+1, SV*);
93 AvARRAY(av) = AvALLOC(av);
96 ary[--tmp] = &PL_sv_undef;
98 if (key > AvMAX(av) - 10) {
99 newmax = key + AvMAX(av);
104 #ifdef PERL_MALLOC_WRAP
105 static const char oom_array_extend[] =
106 "Out of memory during array extend"; /* Duplicated in pp_hot.c */
110 #if !defined(STRANGE_MALLOC) && !defined(MYMALLOC)
115 #ifdef Perl_safesysmalloc_size
116 /* Whilst it would be quite possible to move this logic around
117 (as I did in the SV code), so as to set AvMAX(av) early,
118 based on calling Perl_safesysmalloc_size() immediately after
119 allocation, I'm not convinced that it is a great idea here.
120 In an array we have to loop round setting everything to
121 &PL_sv_undef, which means writing to memory, potentially lots
122 of it, whereas for the SV buffer case we don't touch the
123 "bonus" memory. So there there is no cost in telling the
124 world about it, whereas here we have to do work before we can
125 tell the world about it, and that work involves writing to
126 memory that might never be read. So, I feel, better to keep
127 the current lazy system of only writing to it if our caller
128 has a need for more space. NWC */
129 newmax = Perl_safesysmalloc_size((void*)AvALLOC(av)) /
130 sizeof(const SV *) - 1;
135 newmax = key + AvMAX(av) / 5;
137 MEM_WRAP_CHECK_1(newmax+1, SV*, oom_array_extend);
138 #if defined(STRANGE_MALLOC) || defined(MYMALLOC)
139 Renew(AvALLOC(av),newmax+1, SV*);
141 bytes = (newmax + 1) * sizeof(const SV *);
142 #define MALLOC_OVERHEAD 16
143 itmp = MALLOC_OVERHEAD;
144 while ((MEM_SIZE)(itmp - MALLOC_OVERHEAD) < bytes)
146 itmp -= MALLOC_OVERHEAD;
147 itmp /= sizeof(const SV *);
148 assert(itmp > newmax);
150 assert(newmax >= AvMAX(av));
151 Newx(ary, newmax+1, SV*);
152 Copy(AvALLOC(av), ary, AvMAX(av)+1, SV*);
153 Safefree(AvALLOC(av));
156 #ifdef Perl_safesysmalloc_size
159 ary = AvALLOC(av) + AvMAX(av) + 1;
160 tmp = newmax - AvMAX(av);
161 if (av == PL_curstack) { /* Oops, grew stack (via av_store()?) */
162 PL_stack_sp = AvALLOC(av) + (PL_stack_sp - PL_stack_base);
163 PL_stack_base = AvALLOC(av);
164 PL_stack_max = PL_stack_base + newmax;
168 newmax = key < 3 ? 3 : key;
169 MEM_WRAP_CHECK_1(newmax+1, SV*, oom_array_extend);
170 Newx(AvALLOC(av), newmax+1, SV*);
171 ary = AvALLOC(av) + 1;
173 AvALLOC(av)[0] = &PL_sv_undef; /* For the stacks */
177 ary[--tmp] = &PL_sv_undef;
180 AvARRAY(av) = AvALLOC(av);
189 Returns the SV at the specified index in the array. The C<key> is the
190 index. If lval is true, you are guaranteed to get a real SV back (in case
191 it wasn't real before), which you can then modify. Check that the return
192 value is non-null before dereferencing it to a C<SV*>.
194 See L<perlguts/"Understanding the Magic of Tied Hashes and Arrays"> for
195 more information on how to use this function on tied arrays.
197 The rough perl equivalent is C<$myarray[$idx]>.
202 Perl_av_fetch(pTHX_ register AV *av, I32 key, I32 lval)
206 PERL_ARGS_ASSERT_AV_FETCH;
207 assert(SvTYPE(av) == SVt_PVAV);
209 if (SvRMAGICAL(av)) {
210 const MAGIC * const tied_magic
211 = mg_find((const SV *)av, PERL_MAGIC_tied);
212 if (tied_magic || mg_find((const SV *)av, PERL_MAGIC_regdata)) {
215 I32 adjust_index = 1;
217 /* Handle negative array indices 20020222 MJD */
218 SV * const * const negative_indices_glob =
219 hv_fetch(SvSTASH(SvRV(SvTIED_obj(MUTABLE_SV(av),
221 NEGATIVE_INDICES_VAR, 16, 0);
223 if (negative_indices_glob && SvTRUE(GvSV(*negative_indices_glob)))
228 key += AvFILL(av) + 1;
235 sv_upgrade(sv, SVt_PVLV);
236 mg_copy(MUTABLE_SV(av), sv, 0, key);
237 if (!tied_magic) /* for regdata, force leavesub to make copies */
240 LvTARG(sv) = sv; /* fake (SV**) */
241 return &(LvTARG(sv));
246 key += AvFILL(av) + 1;
251 if (key > AvFILLp(av)) {
254 return av_store(av,key,newSV(0));
256 if (AvARRAY(av)[key] == &PL_sv_undef) {
259 return av_store(av,key,newSV(0));
263 && (!AvARRAY(av)[key] /* eg. @_ could have freed elts */
264 || SvIS_FREED(AvARRAY(av)[key]))) {
265 AvARRAY(av)[key] = &PL_sv_undef; /* 1/2 reify */
268 return &AvARRAY(av)[key];
274 Stores an SV in an array. The array index is specified as C<key>. The
275 return value will be NULL if the operation failed or if the value did not
276 need to be actually stored within the array (as in the case of tied
277 arrays). Otherwise it can be dereferenced to get the original C<SV*>. Note
278 that the caller is responsible for suitably incrementing the reference
279 count of C<val> before the call, and decrementing it if the function
282 See L<perlguts/"Understanding the Magic of Tied Hashes and Arrays"> for
283 more information on how to use this function on tied arrays.
289 Perl_av_store(pTHX_ register AV *av, I32 key, SV *val)
294 PERL_ARGS_ASSERT_AV_STORE;
295 assert(SvTYPE(av) == SVt_PVAV);
297 /* S_regclass relies on being able to pass in a NULL sv
298 (unicode_alternate may be NULL).
304 if (SvRMAGICAL(av)) {
305 const MAGIC * const tied_magic = mg_find((const SV *)av, PERL_MAGIC_tied);
307 /* Handle negative array indices 20020222 MJD */
309 bool adjust_index = 1;
310 SV * const * const negative_indices_glob =
311 hv_fetch(SvSTASH(SvRV(SvTIED_obj(MUTABLE_SV(av),
313 NEGATIVE_INDICES_VAR, 16, 0);
314 if (negative_indices_glob
315 && SvTRUE(GvSV(*negative_indices_glob)))
318 key += AvFILL(av) + 1;
323 if (val != &PL_sv_undef) {
324 mg_copy(MUTABLE_SV(av), val, 0, key);
332 key += AvFILL(av) + 1;
337 if (SvREADONLY(av) && key >= AvFILL(av))
338 Perl_croak_no_modify(aTHX);
340 if (!AvREAL(av) && AvREIFY(av))
345 if (AvFILLp(av) < key) {
347 if (av == PL_curstack && key > PL_stack_sp - PL_stack_base)
348 PL_stack_sp = PL_stack_base + key; /* XPUSH in disguise */
350 ary[++AvFILLp(av)] = &PL_sv_undef;
351 } while (AvFILLp(av) < key);
356 SvREFCNT_dec(ary[key]);
358 if (SvSMAGICAL(av)) {
359 const MAGIC* const mg = SvMAGIC(av);
360 if (val != &PL_sv_undef) {
361 sv_magic(val, MUTABLE_SV(av), toLOWER(mg->mg_type), 0, key);
363 if (PL_delaymagic && mg->mg_type == PERL_MAGIC_isa)
364 PL_delaymagic |= DM_ARRAY_ISA;
366 mg_set(MUTABLE_SV(av));
374 Creates a new AV and populates it with a list of SVs. The SVs are copied
375 into the array, so they may be freed after the call to av_make. The new AV
376 will have a reference count of 1.
378 Perl equivalent: C<my @new_array = ($scalar1, $scalar2, $scalar3...);>
384 Perl_av_make(pTHX_ register I32 size, register SV **strp)
386 register AV * const av = MUTABLE_AV(newSV_type(SVt_PVAV));
387 /* sv_upgrade does AvREAL_only() */
388 PERL_ARGS_ASSERT_AV_MAKE;
389 assert(SvTYPE(av) == SVt_PVAV);
391 if (size) { /* "defined" was returning undef for size==0 anyway. */
397 AvFILLp(av) = AvMAX(av) = size - 1;
398 for (i = 0; i < size; i++) {
401 /* Don't let sv_setsv swipe, since our source array might
402 have multiple references to the same temp scalar (e.g.
403 from a list slice) */
406 sv_setsv_flags(ary[i], *strp,
407 SV_GMAGIC|SV_DO_COW_SVSETSV|SV_NOSTEAL);
417 Clears an array, making it empty. Does not free the memory used by the
418 array itself. Perl equivalent: C<@myarray = ();>.
424 Perl_av_clear(pTHX_ register AV *av)
429 PERL_ARGS_ASSERT_AV_CLEAR;
430 assert(SvTYPE(av) == SVt_PVAV);
433 if (SvREFCNT(av) == 0) {
434 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEBUGGING), "Attempt to clear deleted array");
439 Perl_croak_no_modify(aTHX);
441 /* Give any tie a chance to cleanup first */
442 if (SvRMAGICAL(av)) {
443 const MAGIC* const mg = SvMAGIC(av);
444 if (PL_delaymagic && mg && mg->mg_type == PERL_MAGIC_isa)
445 PL_delaymagic |= DM_ARRAY_ISA;
447 mg_clear(MUTABLE_SV(av));
454 SV** const ary = AvARRAY(av);
455 I32 index = AvFILLp(av) + 1;
457 SV * const sv = ary[--index];
458 /* undef the slot before freeing the value, because a
459 * destructor might try to modify this array */
460 ary[index] = &PL_sv_undef;
464 extra = AvARRAY(av) - AvALLOC(av);
467 AvARRAY(av) = AvALLOC(av);
476 Undefines the array. Frees the memory used by the array itself.
482 Perl_av_undef(pTHX_ register AV *av)
484 PERL_ARGS_ASSERT_AV_UNDEF;
485 assert(SvTYPE(av) == SVt_PVAV);
487 /* Give any tie a chance to cleanup first */
488 if (SvTIED_mg((const SV *)av, PERL_MAGIC_tied))
492 register I32 key = AvFILLp(av) + 1;
494 SvREFCNT_dec(AvARRAY(av)[--key]);
497 Safefree(AvALLOC(av));
500 AvMAX(av) = AvFILLp(av) = -1;
502 if(SvRMAGICAL(av)) mg_clear(MUTABLE_SV(av));
507 =for apidoc av_create_and_push
509 Push an SV onto the end of the array, creating the array if necessary.
510 A small internal helper function to remove a commonly duplicated idiom.
516 Perl_av_create_and_push(pTHX_ AV **const avp, SV *const val)
518 PERL_ARGS_ASSERT_AV_CREATE_AND_PUSH;
528 Pushes an SV onto the end of the array. The array will grow automatically
529 to accommodate the addition. This takes ownership of one reference count.
535 Perl_av_push(pTHX_ register AV *av, SV *val)
540 PERL_ARGS_ASSERT_AV_PUSH;
541 assert(SvTYPE(av) == SVt_PVAV);
544 Perl_croak_no_modify(aTHX);
546 if ((mg = SvTIED_mg((const SV *)av, PERL_MAGIC_tied))) {
547 Perl_magic_methcall(aTHX_ MUTABLE_SV(av), mg, "PUSH", G_DISCARD, 1,
551 av_store(av,AvFILLp(av)+1,val);
557 Pops an SV off the end of the array. Returns C<&PL_sv_undef> if the array
564 Perl_av_pop(pTHX_ register AV *av)
570 PERL_ARGS_ASSERT_AV_POP;
571 assert(SvTYPE(av) == SVt_PVAV);
574 Perl_croak_no_modify(aTHX);
575 if ((mg = SvTIED_mg((const SV *)av, PERL_MAGIC_tied))) {
576 retval = Perl_magic_methcall(aTHX_ MUTABLE_SV(av), mg, "POP", 0, 0);
578 retval = newSVsv(retval);
583 retval = AvARRAY(av)[AvFILLp(av)];
584 AvARRAY(av)[AvFILLp(av)--] = &PL_sv_undef;
586 mg_set(MUTABLE_SV(av));
592 =for apidoc av_create_and_unshift_one
594 Unshifts an SV onto the beginning of the array, creating the array if
596 A small internal helper function to remove a commonly duplicated idiom.
602 Perl_av_create_and_unshift_one(pTHX_ AV **const avp, SV *const val)
604 PERL_ARGS_ASSERT_AV_CREATE_AND_UNSHIFT_ONE;
609 return av_store(*avp, 0, val);
613 =for apidoc av_unshift
615 Unshift the given number of C<undef> values onto the beginning of the
616 array. The array will grow automatically to accommodate the addition. You
617 must then use C<av_store> to assign values to these new elements.
623 Perl_av_unshift(pTHX_ register AV *av, register I32 num)
629 PERL_ARGS_ASSERT_AV_UNSHIFT;
630 assert(SvTYPE(av) == SVt_PVAV);
633 Perl_croak_no_modify(aTHX);
635 if ((mg = SvTIED_mg((const SV *)av, PERL_MAGIC_tied))) {
636 Perl_magic_methcall(aTHX_ MUTABLE_SV(av), mg, "UNSHIFT",
637 G_DISCARD | G_UNDEF_FILL, num);
643 if (!AvREAL(av) && AvREIFY(av))
645 i = AvARRAY(av) - AvALLOC(av);
653 AvARRAY(av) = AvARRAY(av) - i;
657 const I32 i = AvFILLp(av);
658 /* Create extra elements */
659 const I32 slide = i > 0 ? i : 0;
661 av_extend(av, i + num);
664 Move(ary, ary + num, i + 1, SV*);
666 ary[--num] = &PL_sv_undef;
668 /* Make extra elements into a buffer */
670 AvFILLp(av) -= slide;
671 AvARRAY(av) = AvARRAY(av) + slide;
678 Shifts an SV off the beginning of the array. Returns C<&PL_sv_undef> if the
685 Perl_av_shift(pTHX_ register AV *av)
691 PERL_ARGS_ASSERT_AV_SHIFT;
692 assert(SvTYPE(av) == SVt_PVAV);
695 Perl_croak_no_modify(aTHX);
696 if ((mg = SvTIED_mg((const SV *)av, PERL_MAGIC_tied))) {
697 retval = Perl_magic_methcall(aTHX_ MUTABLE_SV(av), mg, "SHIFT", 0, 0);
699 retval = newSVsv(retval);
704 retval = *AvARRAY(av);
706 *AvARRAY(av) = &PL_sv_undef;
707 AvARRAY(av) = AvARRAY(av) + 1;
711 mg_set(MUTABLE_SV(av));
718 Returns the highest index in the array. The number of elements in the
719 array is C<av_len(av) + 1>. Returns -1 if the array is empty.
721 The Perl equivalent for this is C<$#myarray>.
727 Perl_av_len(pTHX_ AV *av)
729 PERL_ARGS_ASSERT_AV_LEN;
730 assert(SvTYPE(av) == SVt_PVAV);
738 Set the highest index in the array to the given number, equivalent to
739 Perl's C<$#array = $fill;>.
741 The number of elements in the an array will be C<fill + 1> after
742 av_fill() returns. If the array was previously shorter, then the
743 additional elements appended are set to C<PL_sv_undef>. If the array
744 was longer, then the excess elements are freed. C<av_fill(av, -1)> is
745 the same as C<av_clear(av)>.
750 Perl_av_fill(pTHX_ register AV *av, I32 fill)
755 PERL_ARGS_ASSERT_AV_FILL;
756 assert(SvTYPE(av) == SVt_PVAV);
760 if ((mg = SvTIED_mg((const SV *)av, PERL_MAGIC_tied))) {
761 SV *arg1 = sv_newmortal();
762 sv_setiv(arg1, (IV)(fill + 1));
763 Perl_magic_methcall(aTHX_ MUTABLE_SV(av), mg, "STORESIZE", G_DISCARD,
767 if (fill <= AvMAX(av)) {
768 I32 key = AvFILLp(av);
769 SV** const ary = AvARRAY(av);
773 SvREFCNT_dec(ary[key]);
774 ary[key--] = &PL_sv_undef;
779 ary[++key] = &PL_sv_undef;
784 mg_set(MUTABLE_SV(av));
787 (void)av_store(av,fill,&PL_sv_undef);
791 =for apidoc av_delete
793 Deletes the element indexed by C<key> from the array, makes the element mortal,
794 and returns it. If C<flags> equals C<G_DISCARD>, the element is freed and null
795 is returned. Perl equivalent: C<my $elem = delete($myarray[$idx]);> for the
796 non-C<G_DISCARD> version and a void-context C<delete($myarray[$idx]);> for the
797 C<G_DISCARD> version.
802 Perl_av_delete(pTHX_ AV *av, I32 key, I32 flags)
807 PERL_ARGS_ASSERT_AV_DELETE;
808 assert(SvTYPE(av) == SVt_PVAV);
811 Perl_croak_no_modify(aTHX);
813 if (SvRMAGICAL(av)) {
814 const MAGIC * const tied_magic
815 = mg_find((const SV *)av, PERL_MAGIC_tied);
816 if ((tied_magic || mg_find((const SV *)av, PERL_MAGIC_regdata))) {
817 /* Handle negative array indices 20020222 MJD */
820 unsigned adjust_index = 1;
822 SV * const * const negative_indices_glob =
823 hv_fetch(SvSTASH(SvRV(SvTIED_obj(MUTABLE_SV(av),
825 NEGATIVE_INDICES_VAR, 16, 0);
826 if (negative_indices_glob
827 && SvTRUE(GvSV(*negative_indices_glob)))
831 key += AvFILL(av) + 1;
836 svp = av_fetch(av, key, TRUE);
840 if (mg_find(sv, PERL_MAGIC_tiedelem)) {
841 sv_unmagic(sv, PERL_MAGIC_tiedelem); /* No longer an element */
850 key += AvFILL(av) + 1;
855 if (key > AvFILLp(av))
858 if (!AvREAL(av) && AvREIFY(av))
860 sv = AvARRAY(av)[key];
861 if (key == AvFILLp(av)) {
862 AvARRAY(av)[key] = &PL_sv_undef;
865 } while (--key >= 0 && AvARRAY(av)[key] == &PL_sv_undef);
868 AvARRAY(av)[key] = &PL_sv_undef;
870 mg_set(MUTABLE_SV(av));
872 if (flags & G_DISCARD) {
882 =for apidoc av_exists
884 Returns true if the element indexed by C<key> has been initialized.
886 This relies on the fact that uninitialized array elements are set to
889 Perl equivalent: C<exists($myarray[$key])>.
894 Perl_av_exists(pTHX_ AV *av, I32 key)
897 PERL_ARGS_ASSERT_AV_EXISTS;
898 assert(SvTYPE(av) == SVt_PVAV);
900 if (SvRMAGICAL(av)) {
901 const MAGIC * const tied_magic
902 = mg_find((const SV *)av, PERL_MAGIC_tied);
903 const MAGIC * const regdata_magic
904 = mg_find((const SV *)av, PERL_MAGIC_regdata);
905 if (tied_magic || regdata_magic) {
906 SV * const sv = sv_newmortal();
908 /* Handle negative array indices 20020222 MJD */
910 unsigned adjust_index = 1;
912 SV * const * const negative_indices_glob =
913 hv_fetch(SvSTASH(SvRV(SvTIED_obj(MUTABLE_SV(av),
915 NEGATIVE_INDICES_VAR, 16, 0);
916 if (negative_indices_glob
917 && SvTRUE(GvSV(*negative_indices_glob)))
921 key += AvFILL(av) + 1;
929 if(key >= 0 && regdata_magic) {
930 if (key <= AvFILL(av))
936 mg_copy(MUTABLE_SV(av), sv, 0, key);
937 mg = mg_find(sv, PERL_MAGIC_tiedelem);
939 magic_existspack(sv, mg);
940 return cBOOL(SvTRUE(sv));
947 key += AvFILL(av) + 1;
952 if (key <= AvFILLp(av) && AvARRAY(av)[key] != &PL_sv_undef
962 S_get_aux_mg(pTHX_ AV *av) {
966 PERL_ARGS_ASSERT_GET_AUX_MG;
967 assert(SvTYPE(av) == SVt_PVAV);
969 mg = mg_find((const SV *)av, PERL_MAGIC_arylen_p);
972 mg = sv_magicext(MUTABLE_SV(av), 0, PERL_MAGIC_arylen_p,
973 &PL_vtbl_arylen_p, 0, 0);
975 /* sv_magicext won't set this for us because we pass in a NULL obj */
976 mg->mg_flags |= MGf_REFCOUNTED;
982 Perl_av_arylen_p(pTHX_ AV *av) {
983 MAGIC *const mg = get_aux_mg(av);
985 PERL_ARGS_ASSERT_AV_ARYLEN_P;
986 assert(SvTYPE(av) == SVt_PVAV);
988 return &(mg->mg_obj);
992 Perl_av_iter_p(pTHX_ AV *av) {
993 MAGIC *const mg = get_aux_mg(av);
995 PERL_ARGS_ASSERT_AV_ITER_P;
996 assert(SvTYPE(av) == SVt_PVAV);
998 #if IVSIZE == I32SIZE
999 return (IV *)&(mg->mg_len);
1003 mg->mg_len = IVSIZE;
1005 mg->mg_ptr = (char *) temp;
1007 return (IV *)mg->mg_ptr;
1013 * c-indentation-style: bsd
1015 * indent-tabs-mode: t
1018 * ex: set ts=8 sts=4 sw=4 noet: