3 * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
4 * 2000, 2001, 2002, 2003, 2004, 2005, 2006, 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)
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)
71 mg = SvTIED_mg((SV*)av, PERL_MAGIC_tied);
76 PUSHSTACKi(PERLSI_MAGIC);
79 PUSHs(SvTIED_obj((SV*)av, mg));
80 PUSHs(sv_2mortal(newSViv(key+1)));
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 SvPV_set(av, (char*)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 SvPV_set(av, (char*)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)
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)
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 if (val != &PL_sv_undef) {
346 const MAGIC* const mg = SvMAGIC(av);
347 sv_magic(val, (SV*)av, toLOWER(mg->mg_type), 0, key);
357 Creates a new AV. The reference count is set to 1.
365 register AV * const av = (AV*)newSV(0);
367 sv_upgrade((SV *)av, SVt_PVAV);
368 /* sv_upgrade does AvREAL_only() */
371 AvMAX(av) = AvFILLp(av) = -1;
378 Creates a new AV and populates it with a list of SVs. The SVs are copied
379 into the array, so they may be freed after the call to av_make. The new AV
380 will have a reference count of 1.
386 Perl_av_make(pTHX_ register I32 size, register SV **strp)
388 register AV * const av = (AV*)newSV(0);
390 sv_upgrade((SV *) av,SVt_PVAV);
391 /* sv_upgrade does AvREAL_only() */
392 if (size) { /* "defined" was returning undef for size==0 anyway. */
397 SvPV_set(av, (char*)ary);
398 AvFILLp(av) = size - 1;
399 AvMAX(av) = size - 1;
400 for (i = 0; i < size; i++) {
403 sv_setsv(ary[i], *strp);
413 Clears an array, making it empty. Does not free the memory used by the
420 Perl_av_clear(pTHX_ register AV *av)
427 if (SvREFCNT(av) == 0 && ckWARN_d(WARN_DEBUGGING)) {
428 Perl_warner(aTHX_ packWARN(WARN_DEBUGGING), "Attempt to clear deleted array");
433 Perl_croak(aTHX_ PL_no_modify);
435 /* Give any tie a chance to cleanup first */
443 SV** const ary = AvARRAY(av);
444 I32 index = AvFILLp(av) + 1;
446 SV * const sv = ary[--index];
447 /* undef the slot before freeing the value, because a
448 * destructor might try to modify this array */
449 ary[index] = &PL_sv_undef;
453 extra = AvARRAY(av) - AvALLOC(av);
456 SvPV_set(av, (char*)AvALLOC(av));
465 Undefines the array. Frees the memory used by the array itself.
471 Perl_av_undef(pTHX_ register AV *av)
475 /* Give any tie a chance to cleanup first */
476 if (SvTIED_mg((SV*)av, PERL_MAGIC_tied))
477 av_fill(av, -1); /* mg_clear() ? */
480 register I32 key = AvFILLp(av) + 1;
482 SvREFCNT_dec(AvARRAY(av)[--key]);
484 Safefree(AvALLOC(av));
487 AvMAX(av) = AvFILLp(av) = -1;
493 Pushes an SV onto the end of the array. The array will grow automatically
494 to accommodate the addition.
500 Perl_av_push(pTHX_ register AV *av, SV *val)
507 Perl_croak(aTHX_ PL_no_modify);
509 if ((mg = SvTIED_mg((SV*)av, PERL_MAGIC_tied))) {
511 PUSHSTACKi(PERLSI_MAGIC);
514 PUSHs(SvTIED_obj((SV*)av, mg));
518 call_method("PUSH", G_SCALAR|G_DISCARD);
523 av_store(av,AvFILLp(av)+1,val);
529 Pops an SV off the end of the array. Returns C<&PL_sv_undef> if the array
536 Perl_av_pop(pTHX_ register AV *av)
545 Perl_croak(aTHX_ PL_no_modify);
546 if ((mg = SvTIED_mg((SV*)av, PERL_MAGIC_tied))) {
548 PUSHSTACKi(PERLSI_MAGIC);
550 XPUSHs(SvTIED_obj((SV*)av, mg));
553 if (call_method("POP", G_SCALAR)) {
554 retval = newSVsv(*PL_stack_sp--);
556 retval = &PL_sv_undef;
564 retval = AvARRAY(av)[AvFILLp(av)];
565 AvARRAY(av)[AvFILLp(av)--] = &PL_sv_undef;
572 =for apidoc av_unshift
574 Unshift the given number of C<undef> values onto the beginning of the
575 array. The array will grow automatically to accommodate the addition. You
576 must then use C<av_store> to assign values to these new elements.
582 Perl_av_unshift(pTHX_ register AV *av, register I32 num)
591 Perl_croak(aTHX_ PL_no_modify);
593 if ((mg = SvTIED_mg((SV*)av, PERL_MAGIC_tied))) {
595 PUSHSTACKi(PERLSI_MAGIC);
598 PUSHs(SvTIED_obj((SV*)av, mg));
604 call_method("UNSHIFT", G_SCALAR|G_DISCARD);
612 if (!AvREAL(av) && AvREIFY(av))
614 i = AvARRAY(av) - AvALLOC(av);
622 SvPV_set(av, (char*)(AvARRAY(av) - i));
628 /* Create extra elements */
629 slide = i > 0 ? i : 0;
631 av_extend(av, i + num);
634 Move(ary, ary + num, i + 1, SV*);
636 ary[--num] = &PL_sv_undef;
638 /* Make extra elements into a buffer */
640 AvFILLp(av) -= slide;
641 SvPV_set(av, (char*)(AvARRAY(av) + slide));
648 Shifts an SV off the beginning of the array.
654 Perl_av_shift(pTHX_ register AV *av)
663 Perl_croak(aTHX_ PL_no_modify);
664 if ((mg = SvTIED_mg((SV*)av, PERL_MAGIC_tied))) {
666 PUSHSTACKi(PERLSI_MAGIC);
668 XPUSHs(SvTIED_obj((SV*)av, mg));
671 if (call_method("SHIFT", G_SCALAR)) {
672 retval = newSVsv(*PL_stack_sp--);
674 retval = &PL_sv_undef;
682 retval = *AvARRAY(av);
684 *AvARRAY(av) = &PL_sv_undef;
685 SvPV_set(av, (char*)(AvARRAY(av) + 1));
696 Returns the highest index in the array. Returns -1 if the array is
703 Perl_av_len(pTHX_ register const AV *av)
712 Ensure than an array has a given number of elements, equivalent to
713 Perl's C<$#array = $fill;>.
718 Perl_av_fill(pTHX_ register AV *av, I32 fill)
727 if ((mg = SvTIED_mg((SV*)av, PERL_MAGIC_tied))) {
731 PUSHSTACKi(PERLSI_MAGIC);
734 PUSHs(SvTIED_obj((SV*)av, mg));
735 PUSHs(sv_2mortal(newSViv(fill+1)));
737 call_method("STORESIZE", G_SCALAR|G_DISCARD);
743 if (fill <= AvMAX(av)) {
744 I32 key = AvFILLp(av);
745 SV** const ary = AvARRAY(av);
749 SvREFCNT_dec(ary[key]);
750 ary[key--] = &PL_sv_undef;
755 ary[++key] = &PL_sv_undef;
763 (void)av_store(av,fill,&PL_sv_undef);
767 =for apidoc av_delete
769 Deletes the element indexed by C<key> from the array. Returns the
770 deleted element. If C<flags> equals C<G_DISCARD>, the element is freed
771 and null is returned.
776 Perl_av_delete(pTHX_ AV *av, I32 key, I32 flags)
784 Perl_croak(aTHX_ PL_no_modify);
786 if (SvRMAGICAL(av)) {
787 const MAGIC * const tied_magic = mg_find((SV*)av, PERL_MAGIC_tied);
788 if ((tied_magic || mg_find((SV*)av, PERL_MAGIC_regdata))) {
789 /* Handle negative array indices 20020222 MJD */
792 unsigned adjust_index = 1;
794 SV * const * const negative_indices_glob =
795 hv_fetch(SvSTASH(SvRV(SvTIED_obj((SV *)av,
797 NEGATIVE_INDICES_VAR, 16, 0);
798 if (negative_indices_glob
799 && SvTRUE(GvSV(*negative_indices_glob)))
803 key += AvFILL(av) + 1;
808 svp = av_fetch(av, key, TRUE);
812 if (mg_find(sv, PERL_MAGIC_tiedelem)) {
813 sv_unmagic(sv, PERL_MAGIC_tiedelem); /* No longer an element */
822 key += AvFILL(av) + 1;
827 if (key > AvFILLp(av))
830 if (!AvREAL(av) && AvREIFY(av))
832 sv = AvARRAY(av)[key];
833 if (key == AvFILLp(av)) {
834 AvARRAY(av)[key] = &PL_sv_undef;
837 } while (--key >= 0 && AvARRAY(av)[key] == &PL_sv_undef);
840 AvARRAY(av)[key] = &PL_sv_undef;
844 if (flags & G_DISCARD) {
854 =for apidoc av_exists
856 Returns true if the element indexed by C<key> has been initialized.
858 This relies on the fact that uninitialized array elements are set to
864 Perl_av_exists(pTHX_ AV *av, I32 key)
869 if (SvRMAGICAL(av)) {
870 const MAGIC * const tied_magic = mg_find((SV*)av, PERL_MAGIC_tied);
871 if (tied_magic || mg_find((SV*)av, PERL_MAGIC_regdata)) {
872 SV * const sv = sv_newmortal();
874 /* Handle negative array indices 20020222 MJD */
876 unsigned adjust_index = 1;
878 SV * const * const negative_indices_glob =
879 hv_fetch(SvSTASH(SvRV(SvTIED_obj((SV *)av,
881 NEGATIVE_INDICES_VAR, 16, 0);
882 if (negative_indices_glob
883 && SvTRUE(GvSV(*negative_indices_glob)))
887 key += AvFILL(av) + 1;
893 mg_copy((SV*)av, sv, 0, key);
894 mg = mg_find(sv, PERL_MAGIC_tiedelem);
896 magic_existspack(sv, mg);
897 return (bool)SvTRUE(sv);
904 key += AvFILL(av) + 1;
909 if (key <= AvFILLp(av) && AvARRAY(av)[key] != &PL_sv_undef
919 Perl_av_arylen_p(pTHX_ AV *av) {
925 mg = mg_find((SV*)av, PERL_MAGIC_arylen_p);
928 mg = sv_magicext((SV*)av, 0, PERL_MAGIC_arylen_p, &PL_vtbl_arylen_p,
931 /* sv_magicext won't set this for us because we pass in a NULL obj */
932 mg->mg_flags |= MGf_REFCOUNTED;
934 return &(mg->mg_obj);
939 * c-indentation-style: bsd
941 * indent-tabs-mode: t
944 * ex: set ts=8 sts=4 sw=4 noet: