3 * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
4 * 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 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
17 =head1 Array Manipulation Functions
25 Perl_av_reify(pTHX_ AV *av)
30 PERL_ARGS_ASSERT_AV_REIFY;
35 if (SvTIED_mg((SV*)av, PERL_MAGIC_tied) && ckWARN_d(WARN_DEBUGGING))
36 Perl_warner(aTHX_ packWARN(WARN_DEBUGGING), "av_reify called on tied array");
39 while (key > AvFILLp(av) + 1)
40 AvARRAY(av)[--key] = &PL_sv_undef;
42 SV * const sv = AvARRAY(av)[--key];
44 if (sv != &PL_sv_undef)
45 SvREFCNT_inc_simple_void_NN(sv);
47 key = AvARRAY(av) - AvALLOC(av);
49 AvALLOC(av)[--key] = &PL_sv_undef;
57 Pre-extend an array. The C<key> is the index to which the array should be
64 Perl_av_extend(pTHX_ AV *av, I32 key)
69 PERL_ARGS_ASSERT_AV_EXTEND;
71 mg = SvTIED_mg((SV*)av, PERL_MAGIC_tied);
76 PUSHSTACKi(PERLSI_MAGIC);
79 PUSHs(SvTIED_obj((SV*)av, mg));
82 call_method("EXTEND", G_SCALAR|G_DISCARD);
88 if (key > AvMAX(av)) {
93 if (AvALLOC(av) != AvARRAY(av)) {
94 ary = AvALLOC(av) + AvFILLp(av) + 1;
95 tmp = AvARRAY(av) - AvALLOC(av);
96 Move(AvARRAY(av), AvALLOC(av), AvFILLp(av)+1, SV*);
98 AvARRAY(av) = AvALLOC(av);
101 ary[--tmp] = &PL_sv_undef;
103 if (key > AvMAX(av) - 10) {
104 newmax = key + AvMAX(av);
109 #ifdef PERL_MALLOC_WRAP
110 static const char oom_array_extend[] =
111 "Out of memory during array extend"; /* Duplicated in pp_hot.c */
115 #if !defined(STRANGE_MALLOC) && !defined(MYMALLOC)
121 newmax = malloced_size((void*)AvALLOC(av))/sizeof(SV*) - 1;
126 newmax = key + AvMAX(av) / 5;
128 MEM_WRAP_CHECK_1(newmax+1, SV*, oom_array_extend);
129 #if defined(STRANGE_MALLOC) || defined(MYMALLOC)
130 Renew(AvALLOC(av),newmax+1, SV*);
132 bytes = (newmax + 1) * sizeof(SV*);
133 #define MALLOC_OVERHEAD 16
134 itmp = MALLOC_OVERHEAD;
135 while ((MEM_SIZE)(itmp - MALLOC_OVERHEAD) < bytes)
137 itmp -= MALLOC_OVERHEAD;
139 assert(itmp > newmax);
141 assert(newmax >= AvMAX(av));
142 Newx(ary, newmax+1, SV*);
143 Copy(AvALLOC(av), ary, AvMAX(av)+1, SV*);
145 offer_nice_chunk(AvALLOC(av), (AvMAX(av)+1) * sizeof(SV*));
147 Safefree(AvALLOC(av));
153 ary = AvALLOC(av) + AvMAX(av) + 1;
154 tmp = newmax - AvMAX(av);
155 if (av == PL_curstack) { /* Oops, grew stack (via av_store()?) */
156 PL_stack_sp = AvALLOC(av) + (PL_stack_sp - PL_stack_base);
157 PL_stack_base = AvALLOC(av);
158 PL_stack_max = PL_stack_base + newmax;
162 newmax = key < 3 ? 3 : key;
163 MEM_WRAP_CHECK_1(newmax+1, SV*, oom_array_extend);
164 Newx(AvALLOC(av), newmax+1, SV*);
165 ary = AvALLOC(av) + 1;
167 AvALLOC(av)[0] = &PL_sv_undef; /* For the stacks */
171 ary[--tmp] = &PL_sv_undef;
174 AvARRAY(av) = AvALLOC(av);
183 Returns the SV at the specified index in the array. The C<key> is the
184 index. If C<lval> is set then the fetch will be part of a store. Check
185 that the return value is non-null before dereferencing it to a C<SV*>.
187 See L<perlguts/"Understanding the Magic of Tied Hashes and Arrays"> for
188 more information on how to use this function on tied arrays.
194 Perl_av_fetch(pTHX_ register AV *av, I32 key, I32 lval)
198 PERL_ARGS_ASSERT_AV_FETCH;
200 if (SvRMAGICAL(av)) {
201 const MAGIC * const tied_magic = mg_find((SV*)av, PERL_MAGIC_tied);
202 if (tied_magic || mg_find((SV*)av, PERL_MAGIC_regdata)) {
205 I32 adjust_index = 1;
207 /* Handle negative array indices 20020222 MJD */
208 SV * const * const negative_indices_glob =
209 hv_fetch(SvSTASH(SvRV(SvTIED_obj((SV *)av, tied_magic))),
210 NEGATIVE_INDICES_VAR, 16, 0);
212 if (negative_indices_glob && SvTRUE(GvSV(*negative_indices_glob)))
217 key += AvFILL(av) + 1;
224 sv_upgrade(sv, SVt_PVLV);
225 mg_copy((SV*)av, sv, 0, key);
227 LvTARG(sv) = sv; /* fake (SV**) */
228 return &(LvTARG(sv));
233 key += AvFILL(av) + 1;
238 if (key > AvFILLp(av)) {
241 return av_store(av,key,newSV(0));
243 if (AvARRAY(av)[key] == &PL_sv_undef) {
246 return av_store(av,key,newSV(0));
250 && (!AvARRAY(av)[key] /* eg. @_ could have freed elts */
251 || SvIS_FREED(AvARRAY(av)[key]))) {
252 AvARRAY(av)[key] = &PL_sv_undef; /* 1/2 reify */
255 return &AvARRAY(av)[key];
261 Stores an SV in an array. The array index is specified as C<key>. The
262 return value will be NULL if the operation failed or if the value did not
263 need to be actually stored within the array (as in the case of tied
264 arrays). Otherwise it can be dereferenced to get the original C<SV*>. Note
265 that the caller is responsible for suitably incrementing the reference
266 count of C<val> before the call, and decrementing it if the function
269 See L<perlguts/"Understanding the Magic of Tied Hashes and Arrays"> for
270 more information on how to use this function on tied arrays.
276 Perl_av_store(pTHX_ register AV *av, I32 key, SV *val)
281 PERL_ARGS_ASSERT_AV_STORE;
283 /* S_regclass relies on being able to pass in a NULL sv
284 (unicode_alternate may be NULL).
290 if (SvRMAGICAL(av)) {
291 const MAGIC * const tied_magic = mg_find((SV*)av, PERL_MAGIC_tied);
293 /* Handle negative array indices 20020222 MJD */
295 bool adjust_index = 1;
296 SV * const * const negative_indices_glob =
297 hv_fetch(SvSTASH(SvRV(SvTIED_obj((SV *)av,
299 NEGATIVE_INDICES_VAR, 16, 0);
300 if (negative_indices_glob
301 && SvTRUE(GvSV(*negative_indices_glob)))
304 key += AvFILL(av) + 1;
309 if (val != &PL_sv_undef) {
310 mg_copy((SV*)av, val, 0, key);
318 key += AvFILL(av) + 1;
323 if (SvREADONLY(av) && key >= AvFILL(av))
324 Perl_croak(aTHX_ PL_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)] = &PL_sv_undef;
337 } while (AvFILLp(av) < key);
342 SvREFCNT_dec(ary[key]);
344 if (SvSMAGICAL(av)) {
345 const MAGIC* const mg = SvMAGIC(av);
346 if (val != &PL_sv_undef) {
347 sv_magic(val, (SV*)av, toLOWER(mg->mg_type), 0, key);
349 if (PL_delaymagic && mg->mg_type == PERL_MAGIC_isa)
350 PL_delaymagic |= DM_ARRAY;
360 Creates a new AV and populates it with a list of SVs. The SVs are copied
361 into the array, so they may be freed after the call to av_make. The new AV
362 will have a reference count of 1.
368 Perl_av_make(pTHX_ register I32 size, register SV **strp)
370 register AV * const av = (AV*)newSV_type(SVt_PVAV);
371 /* sv_upgrade does AvREAL_only() */
372 PERL_ARGS_ASSERT_AV_MAKE;
373 if (size) { /* "defined" was returning undef for size==0 anyway. */
379 AvFILLp(av) = AvMAX(av) = size - 1;
380 for (i = 0; i < size; i++) {
383 sv_setsv(ary[i], *strp);
393 Clears an array, making it empty. Does not free the memory used by the
400 Perl_av_clear(pTHX_ register AV *av)
405 PERL_ARGS_ASSERT_AV_CLEAR;
407 if (SvREFCNT(av) == 0 && ckWARN_d(WARN_DEBUGGING)) {
408 Perl_warner(aTHX_ packWARN(WARN_DEBUGGING), "Attempt to clear deleted array");
413 Perl_croak(aTHX_ PL_no_modify);
415 /* Give any tie a chance to cleanup first */
416 if (SvRMAGICAL(av)) {
417 const MAGIC* const mg = SvMAGIC(av);
418 if (PL_delaymagic && mg->mg_type == PERL_MAGIC_isa)
419 PL_delaymagic |= DM_ARRAY;
428 SV** const ary = AvARRAY(av);
429 I32 index = AvFILLp(av) + 1;
431 SV * const sv = ary[--index];
432 /* undef the slot before freeing the value, because a
433 * destructor might try to modify this array */
434 ary[index] = &PL_sv_undef;
438 extra = AvARRAY(av) - AvALLOC(av);
441 AvARRAY(av) = AvALLOC(av);
450 Undefines the array. Frees the memory used by the array itself.
456 Perl_av_undef(pTHX_ register AV *av)
458 PERL_ARGS_ASSERT_AV_UNDEF;
460 /* Give any tie a chance to cleanup first */
461 if (SvTIED_mg((SV*)av, PERL_MAGIC_tied))
465 register I32 key = AvFILLp(av) + 1;
467 SvREFCNT_dec(AvARRAY(av)[--key]);
470 Safefree(AvALLOC(av));
473 AvMAX(av) = AvFILLp(av) = -1;
475 if(SvRMAGICAL(av)) mg_clear((SV*)av);
480 =for apidoc av_create_and_push
482 Push an SV onto the end of the array, creating the array if necessary.
483 A small internal helper function to remove a commonly duplicated idiom.
489 Perl_av_create_and_push(pTHX_ AV **const avp, SV *const val)
491 PERL_ARGS_ASSERT_AV_CREATE_AND_PUSH;
500 Pushes an SV onto the end of the array. The array will grow automatically
501 to accommodate the addition.
507 Perl_av_push(pTHX_ register AV *av, SV *val)
512 PERL_ARGS_ASSERT_AV_PUSH;
515 Perl_croak(aTHX_ PL_no_modify);
517 if ((mg = SvTIED_mg((SV*)av, PERL_MAGIC_tied))) {
519 PUSHSTACKi(PERLSI_MAGIC);
522 PUSHs(SvTIED_obj((SV*)av, mg));
526 call_method("PUSH", G_SCALAR|G_DISCARD);
531 av_store(av,AvFILLp(av)+1,val);
537 Pops an SV off the end of the array. Returns C<&PL_sv_undef> if the array
544 Perl_av_pop(pTHX_ register AV *av)
550 PERL_ARGS_ASSERT_AV_POP;
553 Perl_croak(aTHX_ PL_no_modify);
554 if ((mg = SvTIED_mg((SV*)av, PERL_MAGIC_tied))) {
556 PUSHSTACKi(PERLSI_MAGIC);
558 XPUSHs(SvTIED_obj((SV*)av, mg));
561 if (call_method("POP", G_SCALAR)) {
562 retval = newSVsv(*PL_stack_sp--);
564 retval = &PL_sv_undef;
572 retval = AvARRAY(av)[AvFILLp(av)];
573 AvARRAY(av)[AvFILLp(av)--] = &PL_sv_undef;
581 =for apidoc av_create_and_unshift_one
583 Unshifts an SV onto the beginning of the array, creating the array if
585 A small internal helper function to remove a commonly duplicated idiom.
591 Perl_av_create_and_unshift_one(pTHX_ AV **const avp, SV *const val)
593 PERL_ARGS_ASSERT_AV_CREATE_AND_UNSHIFT_ONE;
597 return av_store(*avp, 0, val);
601 =for apidoc av_unshift
603 Unshift the given number of C<undef> values onto the beginning of the
604 array. The array will grow automatically to accommodate the addition. You
605 must then use C<av_store> to assign values to these new elements.
611 Perl_av_unshift(pTHX_ register AV *av, register I32 num)
617 PERL_ARGS_ASSERT_AV_UNSHIFT;
620 Perl_croak(aTHX_ PL_no_modify);
622 if ((mg = SvTIED_mg((SV*)av, PERL_MAGIC_tied))) {
624 PUSHSTACKi(PERLSI_MAGIC);
627 PUSHs(SvTIED_obj((SV*)av, mg));
633 call_method("UNSHIFT", G_SCALAR|G_DISCARD);
641 if (!AvREAL(av) && AvREIFY(av))
643 i = AvARRAY(av) - AvALLOC(av);
651 AvARRAY(av) = AvARRAY(av) - i;
655 const I32 i = AvFILLp(av);
656 /* Create extra elements */
657 const I32 slide = i > 0 ? i : 0;
659 av_extend(av, i + num);
662 Move(ary, ary + num, i + 1, SV*);
664 ary[--num] = &PL_sv_undef;
666 /* Make extra elements into a buffer */
668 AvFILLp(av) -= slide;
669 AvARRAY(av) = AvARRAY(av) + slide;
676 Shifts an SV off the beginning of the array.
682 Perl_av_shift(pTHX_ register AV *av)
688 PERL_ARGS_ASSERT_AV_SHIFT;
691 Perl_croak(aTHX_ PL_no_modify);
692 if ((mg = SvTIED_mg((SV*)av, PERL_MAGIC_tied))) {
694 PUSHSTACKi(PERLSI_MAGIC);
696 XPUSHs(SvTIED_obj((SV*)av, mg));
699 if (call_method("SHIFT", G_SCALAR)) {
700 retval = newSVsv(*PL_stack_sp--);
702 retval = &PL_sv_undef;
710 retval = *AvARRAY(av);
712 *AvARRAY(av) = &PL_sv_undef;
713 AvARRAY(av) = AvARRAY(av) + 1;
724 Returns the highest index in the array. The number of elements in the
725 array is C<av_len(av) + 1>. Returns -1 if the array is empty.
731 Perl_av_len(pTHX_ register const AV *av)
733 PERL_ARGS_ASSERT_AV_LEN;
740 Set the highest index in the array to the given number, equivalent to
741 Perl's C<$#array = $fill;>.
743 The number of elements in the an array will be C<fill + 1> after
744 av_fill() returns. If the array was previously shorter then the
745 additional elements appended are set to C<PL_sv_undef>. If the array
746 was longer, then the excess elements are freed. C<av_fill(av, -1)> is
747 the same as C<av_clear(av)>.
752 Perl_av_fill(pTHX_ register AV *av, I32 fill)
757 PERL_ARGS_ASSERT_AV_FILL;
761 if ((mg = SvTIED_mg((SV*)av, PERL_MAGIC_tied))) {
765 PUSHSTACKi(PERLSI_MAGIC);
768 PUSHs(SvTIED_obj((SV*)av, mg));
771 call_method("STORESIZE", G_SCALAR|G_DISCARD);
777 if (fill <= AvMAX(av)) {
778 I32 key = AvFILLp(av);
779 SV** const ary = AvARRAY(av);
783 SvREFCNT_dec(ary[key]);
784 ary[key--] = &PL_sv_undef;
789 ary[++key] = &PL_sv_undef;
797 (void)av_store(av,fill,&PL_sv_undef);
801 =for apidoc av_delete
803 Deletes the element indexed by C<key> from the array. Returns the
804 deleted element. If C<flags> equals C<G_DISCARD>, the element is freed
805 and null is returned.
810 Perl_av_delete(pTHX_ AV *av, I32 key, I32 flags)
815 PERL_ARGS_ASSERT_AV_DELETE;
818 Perl_croak(aTHX_ PL_no_modify);
820 if (SvRMAGICAL(av)) {
821 const MAGIC * const tied_magic = mg_find((SV*)av, PERL_MAGIC_tied);
822 if ((tied_magic || mg_find((SV*)av, PERL_MAGIC_regdata))) {
823 /* Handle negative array indices 20020222 MJD */
826 unsigned adjust_index = 1;
828 SV * const * const negative_indices_glob =
829 hv_fetch(SvSTASH(SvRV(SvTIED_obj((SV *)av,
831 NEGATIVE_INDICES_VAR, 16, 0);
832 if (negative_indices_glob
833 && SvTRUE(GvSV(*negative_indices_glob)))
837 key += AvFILL(av) + 1;
842 svp = av_fetch(av, key, TRUE);
846 if (mg_find(sv, PERL_MAGIC_tiedelem)) {
847 sv_unmagic(sv, PERL_MAGIC_tiedelem); /* No longer an element */
856 key += AvFILL(av) + 1;
861 if (key > AvFILLp(av))
864 if (!AvREAL(av) && AvREIFY(av))
866 sv = AvARRAY(av)[key];
867 if (key == AvFILLp(av)) {
868 AvARRAY(av)[key] = &PL_sv_undef;
871 } while (--key >= 0 && AvARRAY(av)[key] == &PL_sv_undef);
874 AvARRAY(av)[key] = &PL_sv_undef;
878 if (flags & G_DISCARD) {
888 =for apidoc av_exists
890 Returns true if the element indexed by C<key> has been initialized.
892 This relies on the fact that uninitialized array elements are set to
898 Perl_av_exists(pTHX_ AV *av, I32 key)
901 PERL_ARGS_ASSERT_AV_EXISTS;
903 if (SvRMAGICAL(av)) {
904 const MAGIC * const tied_magic = mg_find((SV*)av, PERL_MAGIC_tied);
905 if (tied_magic || mg_find((SV*)av, PERL_MAGIC_regdata)) {
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((SV *)av,
915 NEGATIVE_INDICES_VAR, 16, 0);
916 if (negative_indices_glob
917 && SvTRUE(GvSV(*negative_indices_glob)))
921 key += AvFILL(av) + 1;
927 mg_copy((SV*)av, sv, 0, key);
928 mg = mg_find(sv, PERL_MAGIC_tiedelem);
930 magic_existspack(sv, mg);
931 return (bool)SvTRUE(sv);
938 key += AvFILL(av) + 1;
943 if (key <= AvFILLp(av) && AvARRAY(av)[key] != &PL_sv_undef
953 S_get_aux_mg(pTHX_ AV *av) {
957 PERL_ARGS_ASSERT_GET_AUX_MG;
959 mg = mg_find((SV*)av, PERL_MAGIC_arylen_p);
962 mg = sv_magicext((SV*)av, 0, PERL_MAGIC_arylen_p, &PL_vtbl_arylen_p,
965 /* sv_magicext won't set this for us because we pass in a NULL obj */
966 mg->mg_flags |= MGf_REFCOUNTED;
972 Perl_av_arylen_p(pTHX_ AV *av) {
973 MAGIC *const mg = get_aux_mg(av);
975 PERL_ARGS_ASSERT_AV_ARYLEN_P;
977 return &(mg->mg_obj);
981 Perl_av_iter_p(pTHX_ AV *av) {
982 MAGIC *const mg = get_aux_mg(av);
984 PERL_ARGS_ASSERT_AV_ITER_P;
986 #if IVSIZE == I32SIZE
987 return (IV *)&(mg->mg_len);
993 mg->mg_ptr = (char *) temp;
995 return (IV *)mg->mg_ptr;
1001 * c-indentation-style: bsd
1003 * indent-tabs-mode: t
1006 * ex: set ts=8 sts=4 sw=4 noet: