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)
120 #ifdef Perl_safesysmalloc_size
121 /* Whilst it would be quite possible to move this logic around
122 (as I did in the SV code), so as to set AvMAX(av) early,
123 based on calling Perl_safesysmalloc_size() immediately after
124 allocation, I'm not convinced that it is a great idea here.
125 In an array we have to loop round setting everything to
126 &PL_sv_undef, which means writing to memory, potentially lots
127 of it, whereas for the SV buffer case we don't touch the
128 "bonus" memory. So there there is no cost in telling the
129 world about it, whereas here we have to do work before we can
130 tell the world about it, and that work involves writing to
131 memory that might never be read. So, I feel, better to keep
132 the current lazy system of only writing to it if our caller
133 has a need for more space. NWC */
134 newmax = Perl_safesysmalloc_size((void*)AvALLOC(av)) /
140 newmax = key + AvMAX(av) / 5;
142 MEM_WRAP_CHECK_1(newmax+1, SV*, oom_array_extend);
143 #if defined(STRANGE_MALLOC) || defined(MYMALLOC)
144 Renew(AvALLOC(av),newmax+1, SV*);
146 bytes = (newmax + 1) * sizeof(SV*);
147 #define MALLOC_OVERHEAD 16
148 itmp = MALLOC_OVERHEAD;
149 while ((MEM_SIZE)(itmp - MALLOC_OVERHEAD) < bytes)
151 itmp -= MALLOC_OVERHEAD;
153 assert(itmp > newmax);
155 assert(newmax >= AvMAX(av));
156 Newx(ary, newmax+1, SV*);
157 Copy(AvALLOC(av), ary, AvMAX(av)+1, SV*);
159 offer_nice_chunk(AvALLOC(av), (AvMAX(av)+1) * sizeof(SV*));
161 Safefree(AvALLOC(av));
164 #ifdef Perl_safesysmalloc_size
167 ary = AvALLOC(av) + AvMAX(av) + 1;
168 tmp = newmax - AvMAX(av);
169 if (av == PL_curstack) { /* Oops, grew stack (via av_store()?) */
170 PL_stack_sp = AvALLOC(av) + (PL_stack_sp - PL_stack_base);
171 PL_stack_base = AvALLOC(av);
172 PL_stack_max = PL_stack_base + newmax;
176 newmax = key < 3 ? 3 : key;
177 MEM_WRAP_CHECK_1(newmax+1, SV*, oom_array_extend);
178 Newx(AvALLOC(av), newmax+1, SV*);
179 ary = AvALLOC(av) + 1;
181 AvALLOC(av)[0] = &PL_sv_undef; /* For the stacks */
185 ary[--tmp] = &PL_sv_undef;
188 AvARRAY(av) = AvALLOC(av);
197 Returns the SV at the specified index in the array. The C<key> is the
198 index. If C<lval> is set then the fetch will be part of a store. Check
199 that the return value is non-null before dereferencing it to a C<SV*>.
201 See L<perlguts/"Understanding the Magic of Tied Hashes and Arrays"> for
202 more information on how to use this function on tied arrays.
208 Perl_av_fetch(pTHX_ register AV *av, I32 key, I32 lval)
212 PERL_ARGS_ASSERT_AV_FETCH;
214 if (SvRMAGICAL(av)) {
215 const MAGIC * const tied_magic = mg_find((SV*)av, PERL_MAGIC_tied);
216 if (tied_magic || mg_find((SV*)av, PERL_MAGIC_regdata)) {
219 I32 adjust_index = 1;
221 /* Handle negative array indices 20020222 MJD */
222 SV * const * const negative_indices_glob =
223 hv_fetch(SvSTASH(SvRV(SvTIED_obj((SV *)av, tied_magic))),
224 NEGATIVE_INDICES_VAR, 16, 0);
226 if (negative_indices_glob && SvTRUE(GvSV(*negative_indices_glob)))
231 key += AvFILL(av) + 1;
238 sv_upgrade(sv, SVt_PVLV);
239 mg_copy((SV*)av, sv, 0, key);
241 LvTARG(sv) = sv; /* fake (SV**) */
242 return &(LvTARG(sv));
247 key += AvFILL(av) + 1;
252 if (key > AvFILLp(av)) {
255 return av_store(av,key,newSV(0));
257 if (AvARRAY(av)[key] == &PL_sv_undef) {
260 return av_store(av,key,newSV(0));
264 && (!AvARRAY(av)[key] /* eg. @_ could have freed elts */
265 || SvIS_FREED(AvARRAY(av)[key]))) {
266 AvARRAY(av)[key] = &PL_sv_undef; /* 1/2 reify */
269 return &AvARRAY(av)[key];
275 Stores an SV in an array. The array index is specified as C<key>. The
276 return value will be NULL if the operation failed or if the value did not
277 need to be actually stored within the array (as in the case of tied
278 arrays). Otherwise it can be dereferenced to get the original C<SV*>. Note
279 that the caller is responsible for suitably incrementing the reference
280 count of C<val> before the call, and decrementing it if the function
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_ register AV *av, I32 key, SV *val)
295 PERL_ARGS_ASSERT_AV_STORE;
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((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((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((SV*)av, val, 0, key);
332 key += AvFILL(av) + 1;
337 if (SvREADONLY(av) && key >= AvFILL(av))
338 Perl_croak(aTHX_ PL_no_modify);
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, (SV*)av, toLOWER(mg->mg_type), 0, key);
363 if (PL_delaymagic && mg->mg_type == PERL_MAGIC_isa)
364 PL_delaymagic |= DM_ARRAY;
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.
382 Perl_av_make(pTHX_ register I32 size, register SV **strp)
384 register AV * const av = (AV*)newSV_type(SVt_PVAV);
385 /* sv_upgrade does AvREAL_only() */
386 PERL_ARGS_ASSERT_AV_MAKE;
387 if (size) { /* "defined" was returning undef for size==0 anyway. */
393 AvFILLp(av) = AvMAX(av) = size - 1;
394 for (i = 0; i < size; i++) {
397 sv_setsv(ary[i], *strp);
407 Clears an array, making it empty. Does not free the memory used by the
414 Perl_av_clear(pTHX_ register AV *av)
419 PERL_ARGS_ASSERT_AV_CLEAR;
421 if (SvREFCNT(av) == 0 && ckWARN_d(WARN_DEBUGGING)) {
422 Perl_warner(aTHX_ packWARN(WARN_DEBUGGING), "Attempt to clear deleted array");
427 Perl_croak(aTHX_ PL_no_modify);
429 /* Give any tie a chance to cleanup first */
430 if (SvRMAGICAL(av)) {
431 const MAGIC* const mg = SvMAGIC(av);
432 if (PL_delaymagic && mg->mg_type == PERL_MAGIC_isa)
433 PL_delaymagic |= DM_ARRAY;
442 SV** const ary = AvARRAY(av);
443 I32 index = AvFILLp(av) + 1;
445 SV * const sv = ary[--index];
446 /* undef the slot before freeing the value, because a
447 * destructor might try to modify this array */
448 ary[index] = &PL_sv_undef;
452 extra = AvARRAY(av) - AvALLOC(av);
455 AvARRAY(av) = AvALLOC(av);
464 Undefines the array. Frees the memory used by the array itself.
470 Perl_av_undef(pTHX_ register AV *av)
472 PERL_ARGS_ASSERT_AV_UNDEF;
474 /* Give any tie a chance to cleanup first */
475 if (SvTIED_mg((SV*)av, PERL_MAGIC_tied))
479 register I32 key = AvFILLp(av) + 1;
481 SvREFCNT_dec(AvARRAY(av)[--key]);
484 Safefree(AvALLOC(av));
487 AvMAX(av) = AvFILLp(av) = -1;
489 if(SvRMAGICAL(av)) mg_clear((SV*)av);
494 =for apidoc av_create_and_push
496 Push an SV onto the end of the array, creating the array if necessary.
497 A small internal helper function to remove a commonly duplicated idiom.
503 Perl_av_create_and_push(pTHX_ AV **const avp, SV *const val)
505 PERL_ARGS_ASSERT_AV_CREATE_AND_PUSH;
514 Pushes an SV onto the end of the array. The array will grow automatically
515 to accommodate the addition.
521 Perl_av_push(pTHX_ register AV *av, SV *val)
526 PERL_ARGS_ASSERT_AV_PUSH;
529 Perl_croak(aTHX_ PL_no_modify);
531 if ((mg = SvTIED_mg((SV*)av, PERL_MAGIC_tied))) {
533 PUSHSTACKi(PERLSI_MAGIC);
536 PUSHs(SvTIED_obj((SV*)av, mg));
540 call_method("PUSH", G_SCALAR|G_DISCARD);
545 av_store(av,AvFILLp(av)+1,val);
551 Pops an SV off the end of the array. Returns C<&PL_sv_undef> if the array
558 Perl_av_pop(pTHX_ register AV *av)
564 PERL_ARGS_ASSERT_AV_POP;
567 Perl_croak(aTHX_ PL_no_modify);
568 if ((mg = SvTIED_mg((SV*)av, PERL_MAGIC_tied))) {
570 PUSHSTACKi(PERLSI_MAGIC);
572 XPUSHs(SvTIED_obj((SV*)av, mg));
575 if (call_method("POP", G_SCALAR)) {
576 retval = newSVsv(*PL_stack_sp--);
578 retval = &PL_sv_undef;
586 retval = AvARRAY(av)[AvFILLp(av)];
587 AvARRAY(av)[AvFILLp(av)--] = &PL_sv_undef;
595 =for apidoc av_create_and_unshift_one
597 Unshifts an SV onto the beginning of the array, creating the array if
599 A small internal helper function to remove a commonly duplicated idiom.
605 Perl_av_create_and_unshift_one(pTHX_ AV **const avp, SV *const val)
607 PERL_ARGS_ASSERT_AV_CREATE_AND_UNSHIFT_ONE;
611 return av_store(*avp, 0, val);
615 =for apidoc av_unshift
617 Unshift the given number of C<undef> values onto the beginning of the
618 array. The array will grow automatically to accommodate the addition. You
619 must then use C<av_store> to assign values to these new elements.
625 Perl_av_unshift(pTHX_ register AV *av, register I32 num)
631 PERL_ARGS_ASSERT_AV_UNSHIFT;
634 Perl_croak(aTHX_ PL_no_modify);
636 if ((mg = SvTIED_mg((SV*)av, PERL_MAGIC_tied))) {
638 PUSHSTACKi(PERLSI_MAGIC);
641 PUSHs(SvTIED_obj((SV*)av, mg));
647 call_method("UNSHIFT", G_SCALAR|G_DISCARD);
655 if (!AvREAL(av) && AvREIFY(av))
657 i = AvARRAY(av) - AvALLOC(av);
665 AvARRAY(av) = AvARRAY(av) - i;
669 const I32 i = AvFILLp(av);
670 /* Create extra elements */
671 const I32 slide = i > 0 ? i : 0;
673 av_extend(av, i + num);
676 Move(ary, ary + num, i + 1, SV*);
678 ary[--num] = &PL_sv_undef;
680 /* Make extra elements into a buffer */
682 AvFILLp(av) -= slide;
683 AvARRAY(av) = AvARRAY(av) + slide;
690 Shifts an SV off the beginning of the array.
696 Perl_av_shift(pTHX_ register AV *av)
702 PERL_ARGS_ASSERT_AV_SHIFT;
705 Perl_croak(aTHX_ PL_no_modify);
706 if ((mg = SvTIED_mg((SV*)av, PERL_MAGIC_tied))) {
708 PUSHSTACKi(PERLSI_MAGIC);
710 XPUSHs(SvTIED_obj((SV*)av, mg));
713 if (call_method("SHIFT", G_SCALAR)) {
714 retval = newSVsv(*PL_stack_sp--);
716 retval = &PL_sv_undef;
724 retval = *AvARRAY(av);
726 *AvARRAY(av) = &PL_sv_undef;
727 AvARRAY(av) = AvARRAY(av) + 1;
738 Returns the highest index in the array. The number of elements in the
739 array is C<av_len(av) + 1>. Returns -1 if the array is empty.
745 Perl_av_len(pTHX_ register const AV *av)
747 PERL_ARGS_ASSERT_AV_LEN;
754 Set the highest index in the array to the given number, equivalent to
755 Perl's C<$#array = $fill;>.
757 The number of elements in the an array will be C<fill + 1> after
758 av_fill() returns. If the array was previously shorter then the
759 additional elements appended are set to C<PL_sv_undef>. If the array
760 was longer, then the excess elements are freed. C<av_fill(av, -1)> is
761 the same as C<av_clear(av)>.
766 Perl_av_fill(pTHX_ register AV *av, I32 fill)
771 PERL_ARGS_ASSERT_AV_FILL;
775 if ((mg = SvTIED_mg((SV*)av, PERL_MAGIC_tied))) {
779 PUSHSTACKi(PERLSI_MAGIC);
782 PUSHs(SvTIED_obj((SV*)av, mg));
785 call_method("STORESIZE", G_SCALAR|G_DISCARD);
791 if (fill <= AvMAX(av)) {
792 I32 key = AvFILLp(av);
793 SV** const ary = AvARRAY(av);
797 SvREFCNT_dec(ary[key]);
798 ary[key--] = &PL_sv_undef;
803 ary[++key] = &PL_sv_undef;
811 (void)av_store(av,fill,&PL_sv_undef);
815 =for apidoc av_delete
817 Deletes the element indexed by C<key> from the array. Returns the
818 deleted element. If C<flags> equals C<G_DISCARD>, the element is freed
819 and null is returned.
824 Perl_av_delete(pTHX_ AV *av, I32 key, I32 flags)
829 PERL_ARGS_ASSERT_AV_DELETE;
832 Perl_croak(aTHX_ PL_no_modify);
834 if (SvRMAGICAL(av)) {
835 const MAGIC * const tied_magic = mg_find((SV*)av, PERL_MAGIC_tied);
836 if ((tied_magic || mg_find((SV*)av, PERL_MAGIC_regdata))) {
837 /* Handle negative array indices 20020222 MJD */
840 unsigned adjust_index = 1;
842 SV * const * const negative_indices_glob =
843 hv_fetch(SvSTASH(SvRV(SvTIED_obj((SV *)av,
845 NEGATIVE_INDICES_VAR, 16, 0);
846 if (negative_indices_glob
847 && SvTRUE(GvSV(*negative_indices_glob)))
851 key += AvFILL(av) + 1;
856 svp = av_fetch(av, key, TRUE);
860 if (mg_find(sv, PERL_MAGIC_tiedelem)) {
861 sv_unmagic(sv, PERL_MAGIC_tiedelem); /* No longer an element */
870 key += AvFILL(av) + 1;
875 if (key > AvFILLp(av))
878 if (!AvREAL(av) && AvREIFY(av))
880 sv = AvARRAY(av)[key];
881 if (key == AvFILLp(av)) {
882 AvARRAY(av)[key] = &PL_sv_undef;
885 } while (--key >= 0 && AvARRAY(av)[key] == &PL_sv_undef);
888 AvARRAY(av)[key] = &PL_sv_undef;
892 if (flags & G_DISCARD) {
902 =for apidoc av_exists
904 Returns true if the element indexed by C<key> has been initialized.
906 This relies on the fact that uninitialized array elements are set to
912 Perl_av_exists(pTHX_ AV *av, I32 key)
915 PERL_ARGS_ASSERT_AV_EXISTS;
917 if (SvRMAGICAL(av)) {
918 const MAGIC * const tied_magic = mg_find((SV*)av, PERL_MAGIC_tied);
919 if (tied_magic || mg_find((SV*)av, PERL_MAGIC_regdata)) {
920 SV * const sv = sv_newmortal();
922 /* Handle negative array indices 20020222 MJD */
924 unsigned adjust_index = 1;
926 SV * const * const negative_indices_glob =
927 hv_fetch(SvSTASH(SvRV(SvTIED_obj((SV *)av,
929 NEGATIVE_INDICES_VAR, 16, 0);
930 if (negative_indices_glob
931 && SvTRUE(GvSV(*negative_indices_glob)))
935 key += AvFILL(av) + 1;
941 mg_copy((SV*)av, sv, 0, key);
942 mg = mg_find(sv, PERL_MAGIC_tiedelem);
944 magic_existspack(sv, mg);
945 return (bool)SvTRUE(sv);
952 key += AvFILL(av) + 1;
957 if (key <= AvFILLp(av) && AvARRAY(av)[key] != &PL_sv_undef
967 S_get_aux_mg(pTHX_ AV *av) {
971 PERL_ARGS_ASSERT_GET_AUX_MG;
973 mg = mg_find((SV*)av, PERL_MAGIC_arylen_p);
976 mg = sv_magicext((SV*)av, 0, PERL_MAGIC_arylen_p, &PL_vtbl_arylen_p,
979 /* sv_magicext won't set this for us because we pass in a NULL obj */
980 mg->mg_flags |= MGf_REFCOUNTED;
986 Perl_av_arylen_p(pTHX_ AV *av) {
987 MAGIC *const mg = get_aux_mg(av);
989 PERL_ARGS_ASSERT_AV_ARYLEN_P;
991 return &(mg->mg_obj);
995 Perl_av_iter_p(pTHX_ AV *av) {
996 MAGIC *const mg = get_aux_mg(av);
998 PERL_ARGS_ASSERT_AV_ITER_P;
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: t
1020 * ex: set ts=8 sts=4 sw=4 noet: