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;
115 #ifdef PERL_MALLOC_WRAP
116 static const char oom_array_extend[] =
117 "Out of memory during array extend"; /* Duplicated in pp_hot.c */
122 #ifdef Perl_safesysmalloc_size
123 /* Whilst it would be quite possible to move this logic around
124 (as I did in the SV code), so as to set AvMAX(av) early,
125 based on calling Perl_safesysmalloc_size() immediately after
126 allocation, I'm not convinced that it is a great idea here.
127 In an array we have to loop round setting everything to
128 NULL, which means writing to memory, potentially lots
129 of it, whereas for the SV buffer case we don't touch the
130 "bonus" memory. So there there is no cost in telling the
131 world about it, whereas here we have to do work before we can
132 tell the world about it, and that work involves writing to
133 memory that might never be read. So, I feel, better to keep
134 the current lazy system of only writing to it if our caller
135 has a need for more space. NWC */
136 newmax = Perl_safesysmalloc_size((void*)*allocp) /
137 sizeof(const SV *) - 1;
142 newmax = key + *maxp / 5;
144 MEM_WRAP_CHECK_1(newmax+1, SV*, oom_array_extend);
145 Renew(*allocp,newmax+1, SV*);
146 #ifdef Perl_safesysmalloc_size
149 ary = *allocp + *maxp + 1;
150 tmp = newmax - *maxp;
151 if (av == PL_curstack) { /* Oops, grew stack (via av_store()?) */
152 PL_stack_sp = *allocp + (PL_stack_sp - PL_stack_base);
153 PL_stack_base = *allocp;
154 PL_stack_max = PL_stack_base + newmax;
158 newmax = key < 3 ? 3 : key;
159 MEM_WRAP_CHECK_1(newmax+1, SV*, oom_array_extend);
160 Newx(*allocp, newmax+1, SV*);
163 *allocp[0] = NULL; /* For the stacks */
165 if (av && AvREAL(av)) {
179 Returns the SV at the specified index in the array. The C<key> is the
180 index. If lval is true, you are guaranteed to get a real SV back (in case
181 it wasn't real before), which you can then modify. Check that the return
182 value is non-null before dereferencing it to a C<SV*>.
184 See L<perlguts/"Understanding the Magic of Tied Hashes and Arrays"> for
185 more information on how to use this function on tied arrays.
187 The rough perl equivalent is C<$myarray[$idx]>.
193 S_adjust_index(pTHX_ AV *av, const MAGIC *mg, SSize_t *keyp)
195 bool adjust_index = 1;
197 /* Handle negative array indices 20020222 MJD */
198 SV * const ref = SvTIED_obj(MUTABLE_SV(av), mg);
200 if (SvROK(ref) && SvOBJECT(SvRV(ref))) {
201 SV * const * const negative_indices_glob =
202 hv_fetchs(SvSTASH(SvRV(ref)), NEGATIVE_INDICES_VAR, 0);
204 if (negative_indices_glob && isGV(*negative_indices_glob)
205 && SvTRUE(GvSV(*negative_indices_glob)))
211 *keyp += AvFILL(av) + 1;
219 Perl_av_fetch(pTHX_ AV *av, SSize_t 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]) {
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] = NULL; /* 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, SSize_t 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).
302 if (SvRMAGICAL(av)) {
303 const MAGIC * const tied_magic = mg_find((const SV *)av, PERL_MAGIC_tied);
306 if (!S_adjust_index(aTHX_ av, tied_magic, &key))
310 mg_copy(MUTABLE_SV(av), val, 0, key);
318 key += AvFILL(av) + 1;
323 if (SvREADONLY(av) && key >= AvFILL(av))
324 Perl_croak_no_modify();
326 if (!AvREAL(av) && AvREIFY(av))
331 if (AvFILLp(av) < key) {
333 if (av == PL_curstack && key > PL_stack_sp - PL_stack_base)
334 PL_stack_sp = PL_stack_base + key; /* XPUSH in disguise */
336 ary[++AvFILLp(av)] = NULL;
337 } while (AvFILLp(av) < key);
342 SvREFCNT_dec(ary[key]);
344 if (SvSMAGICAL(av)) {
345 const MAGIC *mg = SvMAGIC(av);
347 for (; mg; mg = mg->mg_moremagic) {
348 if (!isUPPER(mg->mg_type)) continue;
350 sv_magic(val, MUTABLE_SV(av), toLOWER(mg->mg_type), 0, key);
352 if (PL_delaymagic && mg->mg_type == PERL_MAGIC_isa) {
353 PL_delaymagic |= DM_ARRAY_ISA;
358 mg_set(MUTABLE_SV(av));
366 Creates a new AV and populates it with a list of SVs. The SVs are copied
367 into the array, so they may be freed after the call to av_make. The new AV
368 will have a reference count of 1.
370 Perl equivalent: C<my @new_array = ($scalar1, $scalar2, $scalar3...);>
376 Perl_av_make(pTHX_ SSize_t size, SV **strp)
378 AV * const av = MUTABLE_AV(newSV_type(SVt_PVAV));
379 /* sv_upgrade does AvREAL_only() */
380 PERL_ARGS_ASSERT_AV_MAKE;
381 assert(SvTYPE(av) == SVt_PVAV);
383 if (size) { /* "defined" was returning undef for size==0 anyway. */
389 AvMAX(av) = size - 1;
393 for (i = 0; i < size; i++) {
396 /* Don't let sv_setsv swipe, since our source array might
397 have multiple references to the same temp scalar (e.g.
398 from a list slice) */
400 SvGETMAGIC(*strp); /* before newSV, in case it dies */
403 sv_setsv_flags(ary[i], *strp,
404 SV_DO_COW_SVSETSV|SV_NOSTEAL);
407 SvREFCNT_inc_simple_void_NN(av);
416 Clears an array, making it empty. Does not free the memory the av uses to
417 store its list of scalars. If any destructors are triggered as a result,
418 the av itself may be freed when this function returns.
420 Perl equivalent: C<@myarray = ();>.
426 Perl_av_clear(pTHX_ AV *av)
432 PERL_ARGS_ASSERT_AV_CLEAR;
433 assert(SvTYPE(av) == SVt_PVAV);
436 if (SvREFCNT(av) == 0) {
437 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEBUGGING), "Attempt to clear deleted array");
442 Perl_croak_no_modify();
444 /* Give any tie a chance to cleanup first */
445 if (SvRMAGICAL(av)) {
446 const MAGIC* const mg = SvMAGIC(av);
447 if (PL_delaymagic && mg && mg->mg_type == PERL_MAGIC_isa)
448 PL_delaymagic |= DM_ARRAY_ISA;
450 mg_clear(MUTABLE_SV(av));
456 if ((real = !!AvREAL(av))) {
457 SV** const ary = AvARRAY(av);
458 SSize_t index = AvFILLp(av) + 1;
460 SAVEFREESV(SvREFCNT_inc_simple_NN(av));
462 SV * const sv = ary[--index];
463 /* undef the slot before freeing the value, because a
464 * destructor might try to modify this array */
469 extra = AvARRAY(av) - AvALLOC(av);
472 AvARRAY(av) = AvALLOC(av);
481 Undefines the array. Frees the memory used by the av to store its list of
482 scalars. If any destructors are triggered as a result, the av itself may
489 Perl_av_undef(pTHX_ AV *av)
493 PERL_ARGS_ASSERT_AV_UNDEF;
494 assert(SvTYPE(av) == SVt_PVAV);
496 /* Give any tie a chance to cleanup first */
497 if (SvTIED_mg((const SV *)av, PERL_MAGIC_tied))
500 if ((real = !!AvREAL(av))) {
501 SSize_t key = AvFILLp(av) + 1;
503 SAVEFREESV(SvREFCNT_inc_simple_NN(av));
505 SvREFCNT_dec(AvARRAY(av)[--key]);
508 Safefree(AvALLOC(av));
511 AvMAX(av) = AvFILLp(av) = -1;
513 if(SvRMAGICAL(av)) mg_clear(MUTABLE_SV(av));
519 =for apidoc av_create_and_push
521 Push an SV onto the end of the array, creating the array if necessary.
522 A small internal helper function to remove a commonly duplicated idiom.
528 Perl_av_create_and_push(pTHX_ AV **const avp, SV *const val)
530 PERL_ARGS_ASSERT_AV_CREATE_AND_PUSH;
540 Pushes an SV onto the end of the array. The array will grow automatically
541 to accommodate the addition. This takes ownership of one reference count.
543 Perl equivalent: C<push @myarray, $elem;>.
549 Perl_av_push(pTHX_ AV *av, SV *val)
554 PERL_ARGS_ASSERT_AV_PUSH;
555 assert(SvTYPE(av) == SVt_PVAV);
558 Perl_croak_no_modify();
560 if ((mg = SvTIED_mg((const SV *)av, PERL_MAGIC_tied))) {
561 Perl_magic_methcall(aTHX_ MUTABLE_SV(av), mg, SV_CONST(PUSH), G_DISCARD, 1,
565 av_store(av,AvFILLp(av)+1,val);
571 Removes one SV from the end of the array, reducing its size by one and
572 returning the SV (transferring control of one reference count) to the
573 caller. Returns C<&PL_sv_undef> if the array is empty.
575 Perl equivalent: C<pop(@myarray);>
581 Perl_av_pop(pTHX_ AV *av)
587 PERL_ARGS_ASSERT_AV_POP;
588 assert(SvTYPE(av) == SVt_PVAV);
591 Perl_croak_no_modify();
592 if ((mg = SvTIED_mg((const SV *)av, PERL_MAGIC_tied))) {
593 retval = Perl_magic_methcall(aTHX_ MUTABLE_SV(av), mg, SV_CONST(POP), 0, 0);
595 retval = newSVsv(retval);
600 retval = AvARRAY(av)[AvFILLp(av)];
601 AvARRAY(av)[AvFILLp(av)--] = NULL;
603 mg_set(MUTABLE_SV(av));
604 return retval ? retval : &PL_sv_undef;
609 =for apidoc av_create_and_unshift_one
611 Unshifts an SV onto the beginning of the array, creating the array if
613 A small internal helper function to remove a commonly duplicated idiom.
619 Perl_av_create_and_unshift_one(pTHX_ AV **const avp, SV *const val)
621 PERL_ARGS_ASSERT_AV_CREATE_AND_UNSHIFT_ONE;
626 return av_store(*avp, 0, val);
630 =for apidoc av_unshift
632 Unshift the given number of C<undef> values onto the beginning of the
633 array. The array will grow automatically to accommodate the addition. You
634 must then use C<av_store> to assign values to these new elements.
636 Perl equivalent: C<unshift @myarray, ( (undef) x $n );>
642 Perl_av_unshift(pTHX_ AV *av, SSize_t num)
648 PERL_ARGS_ASSERT_AV_UNSHIFT;
649 assert(SvTYPE(av) == SVt_PVAV);
652 Perl_croak_no_modify();
654 if ((mg = SvTIED_mg((const SV *)av, PERL_MAGIC_tied))) {
655 Perl_magic_methcall(aTHX_ MUTABLE_SV(av), mg, SV_CONST(UNSHIFT),
656 G_DISCARD | G_UNDEF_FILL, num);
662 if (!AvREAL(av) && AvREIFY(av))
664 i = AvARRAY(av) - AvALLOC(av);
672 AvARRAY(av) = AvARRAY(av) - i;
676 const SSize_t i = AvFILLp(av);
677 /* Create extra elements */
678 const SSize_t slide = i > 0 ? i : 0;
680 av_extend(av, i + num);
683 Move(ary, ary + num, i + 1, SV*);
687 /* Make extra elements into a buffer */
689 AvFILLp(av) -= slide;
690 AvARRAY(av) = AvARRAY(av) + slide;
697 Removes one SV from the start of the array, reducing its size by one and
698 returning the SV (transferring control of one reference count) to the
699 caller. Returns C<&PL_sv_undef> if the array is empty.
701 Perl equivalent: C<shift(@myarray);>
707 Perl_av_shift(pTHX_ AV *av)
713 PERL_ARGS_ASSERT_AV_SHIFT;
714 assert(SvTYPE(av) == SVt_PVAV);
717 Perl_croak_no_modify();
718 if ((mg = SvTIED_mg((const SV *)av, PERL_MAGIC_tied))) {
719 retval = Perl_magic_methcall(aTHX_ MUTABLE_SV(av), mg, SV_CONST(SHIFT), 0, 0);
721 retval = newSVsv(retval);
726 retval = *AvARRAY(av);
729 AvARRAY(av) = AvARRAY(av) + 1;
733 mg_set(MUTABLE_SV(av));
734 return retval ? retval : &PL_sv_undef;
738 =for apidoc av_top_index
740 Returns the highest index in the array. The number of elements in the
741 array is C<av_top_index(av) + 1>. Returns -1 if the array is empty.
743 The Perl equivalent for this is C<$#myarray>.
745 (A slightly shorter form is C<av_tindex>.)
749 Same as L</av_top_index>. Returns the highest index in the array. Note that the
750 return value is +1 what its name implies it returns; and hence differs in
751 meaning from what the similarly named L</sv_len> returns.
757 Perl_av_len(pTHX_ AV *av)
759 PERL_ARGS_ASSERT_AV_LEN;
761 return av_top_index(av);
767 Set the highest index in the array to the given number, equivalent to
768 Perl's C<$#array = $fill;>.
770 The number of elements in the an array will be C<fill + 1> after
771 av_fill() returns. If the array was previously shorter, then the
772 additional elements appended are set to NULL. If the array
773 was longer, then the excess elements are freed. C<av_fill(av, -1)> is
774 the same as C<av_clear(av)>.
779 Perl_av_fill(pTHX_ AV *av, SSize_t fill)
784 PERL_ARGS_ASSERT_AV_FILL;
785 assert(SvTYPE(av) == SVt_PVAV);
789 if ((mg = SvTIED_mg((const SV *)av, PERL_MAGIC_tied))) {
790 SV *arg1 = sv_newmortal();
791 sv_setiv(arg1, (IV)(fill + 1));
792 Perl_magic_methcall(aTHX_ MUTABLE_SV(av), mg, SV_CONST(STORESIZE), G_DISCARD,
796 if (fill <= AvMAX(av)) {
797 SSize_t key = AvFILLp(av);
798 SV** const ary = AvARRAY(av);
802 SvREFCNT_dec(ary[key]);
813 mg_set(MUTABLE_SV(av));
816 (void)av_store(av,fill,NULL);
820 =for apidoc av_delete
822 Deletes the element indexed by C<key> from the array, makes the element mortal,
823 and returns it. If C<flags> equals C<G_DISCARD>, the element is freed and null
824 is returned. Perl equivalent: C<my $elem = delete($myarray[$idx]);> for the
825 non-C<G_DISCARD> version and a void-context C<delete($myarray[$idx]);> for the
826 C<G_DISCARD> version.
831 Perl_av_delete(pTHX_ AV *av, SSize_t key, I32 flags)
836 PERL_ARGS_ASSERT_AV_DELETE;
837 assert(SvTYPE(av) == SVt_PVAV);
840 Perl_croak_no_modify();
842 if (SvRMAGICAL(av)) {
843 const MAGIC * const tied_magic
844 = mg_find((const SV *)av, PERL_MAGIC_tied);
845 if ((tied_magic || mg_find((const SV *)av, PERL_MAGIC_regdata))) {
848 if (!S_adjust_index(aTHX_ av, tied_magic, &key))
851 svp = av_fetch(av, key, TRUE);
855 if (mg_find(sv, PERL_MAGIC_tiedelem)) {
856 sv_unmagic(sv, PERL_MAGIC_tiedelem); /* No longer an element */
865 key += AvFILL(av) + 1;
870 if (key > AvFILLp(av))
873 if (!AvREAL(av) && AvREIFY(av))
875 sv = AvARRAY(av)[key];
876 if (key == AvFILLp(av)) {
877 AvARRAY(av)[key] = NULL;
880 } while (--key >= 0 && !AvARRAY(av)[key]);
883 AvARRAY(av)[key] = NULL;
885 mg_set(MUTABLE_SV(av));
887 if (flags & G_DISCARD) {
897 =for apidoc av_exists
899 Returns true if the element indexed by C<key> has been initialized.
901 This relies on the fact that uninitialized array elements are set to
904 Perl equivalent: C<exists($myarray[$key])>.
909 Perl_av_exists(pTHX_ AV *av, SSize_t key)
912 PERL_ARGS_ASSERT_AV_EXISTS;
913 assert(SvTYPE(av) == SVt_PVAV);
915 if (SvRMAGICAL(av)) {
916 const MAGIC * const tied_magic
917 = mg_find((const SV *)av, PERL_MAGIC_tied);
918 const MAGIC * const regdata_magic
919 = mg_find((const SV *)av, PERL_MAGIC_regdata);
920 if (tied_magic || regdata_magic) {
922 /* Handle negative array indices 20020222 MJD */
924 if (!S_adjust_index(aTHX_ av, tied_magic, &key))
928 if(key >= 0 && regdata_magic) {
929 if (key <= AvFILL(av))
935 SV * const sv = sv_newmortal();
936 mg_copy(MUTABLE_SV(av), sv, 0, key);
937 mg = mg_find(sv, PERL_MAGIC_tiedelem);
939 magic_existspack(sv, mg);
941 I32 retbool = SvTRUE_nomg_NN(sv);
942 return cBOOL(retbool);
950 key += AvFILL(av) + 1;
955 if (key <= AvFILLp(av) && AvARRAY(av)[key])
964 S_get_aux_mg(pTHX_ AV *av) {
968 PERL_ARGS_ASSERT_GET_AUX_MG;
969 assert(SvTYPE(av) == SVt_PVAV);
971 mg = mg_find((const SV *)av, PERL_MAGIC_arylen_p);
974 mg = sv_magicext(MUTABLE_SV(av), 0, PERL_MAGIC_arylen_p,
975 &PL_vtbl_arylen_p, 0, 0);
977 /* sv_magicext won't set this for us because we pass in a NULL obj */
978 mg->mg_flags |= MGf_REFCOUNTED;
984 Perl_av_arylen_p(pTHX_ AV *av) {
985 MAGIC *const mg = get_aux_mg(av);
987 PERL_ARGS_ASSERT_AV_ARYLEN_P;
988 assert(SvTYPE(av) == SVt_PVAV);
990 return &(mg->mg_obj);
994 Perl_av_iter_p(pTHX_ AV *av) {
995 MAGIC *const mg = get_aux_mg(av);
997 PERL_ARGS_ASSERT_AV_ITER_P;
998 assert(SvTYPE(av) == SVt_PVAV);
1000 #if IVSIZE == I32SIZE
1001 return (IV *)&(mg->mg_len);
1005 mg->mg_len = IVSIZE;
1007 mg->mg_ptr = (char *) temp;
1009 return (IV *)mg->mg_ptr;
1015 * c-indentation-style: bsd
1017 * indent-tabs-mode: nil
1020 * ex: set ts=8 sts=4 sw=4 et: