3 * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
4 * 2000, 2001, 2002, 2003, 2004, 2005 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)
32 if (SvTIED_mg((SV*)av, PERL_MAGIC_tied) && ckWARN_d(WARN_DEBUGGING))
33 Perl_warner(aTHX_ packWARN(WARN_DEBUGGING), "av_reify called on tied array");
36 while (key > AvFILLp(av) + 1)
37 AvARRAY(av)[--key] = &PL_sv_undef;
39 SV * const sv = AvARRAY(av)[--key];
41 if (sv != &PL_sv_undef)
42 (void)SvREFCNT_inc(sv);
44 key = AvARRAY(av) - AvALLOC(av);
46 AvALLOC(av)[--key] = &PL_sv_undef;
54 Pre-extend an array. The C<key> is the index to which the array should be
61 Perl_av_extend(pTHX_ AV *av, I32 key)
63 MAGIC * const mg = SvTIED_mg((SV*)av, PERL_MAGIC_tied);
68 PUSHSTACKi(PERLSI_MAGIC);
71 PUSHs(SvTIED_obj((SV*)av, mg));
72 PUSHs(sv_2mortal(newSViv(key+1)));
74 call_method("EXTEND", G_SCALAR|G_DISCARD);
80 if (key > AvMAX(av)) {
85 if (AvALLOC(av) != AvARRAY(av)) {
86 ary = AvALLOC(av) + AvFILLp(av) + 1;
87 tmp = AvARRAY(av) - AvALLOC(av);
88 Move(AvARRAY(av), AvALLOC(av), AvFILLp(av)+1, SV*);
90 SvPV_set(av, (char*)AvALLOC(av));
93 ary[--tmp] = &PL_sv_undef;
95 if (key > AvMAX(av) - 10) {
96 newmax = key + AvMAX(av);
101 #ifdef PERL_MALLOC_WRAP
102 static const char oom_array_extend[] =
103 "Out of memory during array extend"; /* Duplicated in pp_hot.c */
107 #if !defined(STRANGE_MALLOC) && !defined(MYMALLOC)
113 newmax = malloced_size((void*)AvALLOC(av))/sizeof(SV*) - 1;
118 newmax = key + AvMAX(av) / 5;
120 MEM_WRAP_CHECK_1(newmax+1, SV*, oom_array_extend);
121 #if defined(STRANGE_MALLOC) || defined(MYMALLOC)
122 Renew(AvALLOC(av),newmax+1, SV*);
124 bytes = (newmax + 1) * sizeof(SV*);
125 #define MALLOC_OVERHEAD 16
126 itmp = MALLOC_OVERHEAD;
127 while ((MEM_SIZE)(itmp - MALLOC_OVERHEAD) < bytes)
129 itmp -= MALLOC_OVERHEAD;
131 assert(itmp > newmax);
133 assert(newmax >= AvMAX(av));
134 Newx(ary, newmax+1, SV*);
135 Copy(AvALLOC(av), ary, AvMAX(av)+1, SV*);
137 offer_nice_chunk(AvALLOC(av), (AvMAX(av)+1) * sizeof(SV*));
139 Safefree(AvALLOC(av));
145 ary = AvALLOC(av) + AvMAX(av) + 1;
146 tmp = newmax - AvMAX(av);
147 if (av == PL_curstack) { /* Oops, grew stack (via av_store()?) */
148 PL_stack_sp = AvALLOC(av) + (PL_stack_sp - PL_stack_base);
149 PL_stack_base = AvALLOC(av);
150 PL_stack_max = PL_stack_base + newmax;
154 newmax = key < 3 ? 3 : key;
155 MEM_WRAP_CHECK_1(newmax+1, SV*, oom_array_extend);
156 Newx(AvALLOC(av), newmax+1, SV*);
157 ary = AvALLOC(av) + 1;
159 AvALLOC(av)[0] = &PL_sv_undef; /* For the stacks */
163 ary[--tmp] = &PL_sv_undef;
166 SvPV_set(av, (char*)AvALLOC(av));
175 Returns the SV at the specified index in the array. The C<key> is the
176 index. If C<lval> is set then the fetch will be part of a store. Check
177 that the return value is non-null before dereferencing it to a C<SV*>.
179 See L<perlguts/"Understanding the Magic of Tied Hashes and Arrays"> for
180 more information on how to use this function on tied arrays.
186 Perl_av_fetch(pTHX_ register AV *av, I32 key, I32 lval)
193 if (SvRMAGICAL(av)) {
194 const MAGIC * const tied_magic = mg_find((SV*)av, PERL_MAGIC_tied);
195 if (tied_magic || mg_find((SV*)av, PERL_MAGIC_regdata)) {
196 U32 adjust_index = 1;
198 if (tied_magic && key < 0) {
199 /* Handle negative array indices 20020222 MJD */
200 SV * const * const negative_indices_glob =
201 hv_fetch(SvSTASH(SvRV(SvTIED_obj((SV *)av,
203 NEGATIVE_INDICES_VAR, 16, 0);
205 if (negative_indices_glob
206 && SvTRUE(GvSV(*negative_indices_glob)))
210 if (key < 0 && adjust_index) {
211 key += AvFILL(av) + 1;
217 sv_upgrade(sv, SVt_PVLV);
218 mg_copy((SV*)av, sv, 0, key);
220 LvTARG(sv) = sv; /* fake (SV**) */
221 return &(LvTARG(sv));
226 key += AvFILL(av) + 1;
231 if (key > AvFILLp(av)) {
235 return av_store(av,key,sv);
237 if (AvARRAY(av)[key] == &PL_sv_undef) {
241 return av_store(av,key,sv);
246 && (!AvARRAY(av)[key] /* eg. @_ could have freed elts */
247 || SvIS_FREED(AvARRAY(av)[key]))) {
248 AvARRAY(av)[key] = &PL_sv_undef; /* 1/2 reify */
251 return &AvARRAY(av)[key];
257 Stores an SV in an array. The array index is specified as C<key>. The
258 return value will be NULL if the operation failed or if the value did not
259 need to be actually stored within the array (as in the case of tied
260 arrays). Otherwise it can be dereferenced to get the original C<SV*>. Note
261 that the caller is responsible for suitably incrementing the reference
262 count of C<val> before the call, and decrementing it if the function
265 See L<perlguts/"Understanding the Magic of Tied Hashes and Arrays"> for
266 more information on how to use this function on tied arrays.
272 Perl_av_store(pTHX_ register AV *av, I32 key, SV *val)
281 if (SvRMAGICAL(av)) {
282 const MAGIC * const tied_magic = mg_find((SV*)av, PERL_MAGIC_tied);
284 /* Handle negative array indices 20020222 MJD */
286 unsigned adjust_index = 1;
287 SV * const * const negative_indices_glob =
288 hv_fetch(SvSTASH(SvRV(SvTIED_obj((SV *)av,
290 NEGATIVE_INDICES_VAR, 16, 0);
291 if (negative_indices_glob
292 && SvTRUE(GvSV(*negative_indices_glob)))
295 key += AvFILL(av) + 1;
300 if (val != &PL_sv_undef) {
301 mg_copy((SV*)av, val, 0, key);
309 key += AvFILL(av) + 1;
314 if (SvREADONLY(av) && key >= AvFILL(av))
315 Perl_croak(aTHX_ PL_no_modify);
317 if (!AvREAL(av) && AvREIFY(av))
322 if (AvFILLp(av) < key) {
324 if (av == PL_curstack && key > PL_stack_sp - PL_stack_base)
325 PL_stack_sp = PL_stack_base + key; /* XPUSH in disguise */
327 ary[++AvFILLp(av)] = &PL_sv_undef;
328 while (AvFILLp(av) < key);
333 SvREFCNT_dec(ary[key]);
335 if (SvSMAGICAL(av)) {
336 if (val != &PL_sv_undef) {
337 const MAGIC* const mg = SvMAGIC(av);
338 sv_magic(val, (SV*)av, toLOWER(mg->mg_type), 0, key);
348 Creates a new AV. The reference count is set to 1.
356 register AV * const av = (AV*)NEWSV(3,0);
358 sv_upgrade((SV *)av, SVt_PVAV);
359 /* sv_upgrade does AvREAL_only() */
361 SvPV_set(av, (char*)0);
362 AvMAX(av) = AvFILLp(av) = -1;
369 Creates a new AV and populates it with a list of SVs. The SVs are copied
370 into the array, so they may be freed after the call to av_make. The new AV
371 will have a reference count of 1.
377 Perl_av_make(pTHX_ register I32 size, register SV **strp)
379 register AV * const av = (AV*)NEWSV(8,0);
381 sv_upgrade((SV *) av,SVt_PVAV);
382 /* sv_upgrade does AvREAL_only() */
383 if (size) { /* "defined" was returning undef for size==0 anyway. */
388 SvPV_set(av, (char*)ary);
389 AvFILLp(av) = size - 1;
390 AvMAX(av) = size - 1;
391 for (i = 0; i < size; i++) {
394 sv_setsv(ary[i], *strp);
404 Clears an array, making it empty. Does not free the memory used by the
411 Perl_av_clear(pTHX_ register AV *av)
415 /* XXX Should av_clear really be NN? */
417 if (SvREFCNT(av) == 0 && ckWARN_d(WARN_DEBUGGING)) {
418 Perl_warner(aTHX_ packWARN(WARN_DEBUGGING), "Attempt to clear deleted array");
425 Perl_croak(aTHX_ PL_no_modify);
427 /* Give any tie a chance to cleanup first */
435 SV** const ary = AvARRAY(av);
436 key = AvFILLp(av) + 1;
438 SV * const sv = ary[--key];
439 /* undef the slot before freeing the value, because a
440 * destructor might try to modify this arrray */
441 ary[key] = &PL_sv_undef;
445 if ((key = AvARRAY(av) - AvALLOC(av))) {
447 SvPV_set(av, (char*)AvALLOC(av));
456 Undefines the array. Frees the memory used by the array itself.
462 Perl_av_undef(pTHX_ register AV *av)
467 /* Give any tie a chance to cleanup first */
468 if (SvTIED_mg((SV*)av, PERL_MAGIC_tied))
469 av_fill(av, -1); /* mg_clear() ? */
472 register I32 key = AvFILLp(av) + 1;
474 SvREFCNT_dec(AvARRAY(av)[--key]);
476 Safefree(AvALLOC(av));
478 SvPV_set(av, (char*)0);
479 AvMAX(av) = AvFILLp(av) = -1;
485 Pushes an SV onto the end of the array. The array will grow automatically
486 to accommodate the addition.
492 Perl_av_push(pTHX_ register AV *av, SV *val)
499 Perl_croak(aTHX_ PL_no_modify);
501 if ((mg = SvTIED_mg((SV*)av, PERL_MAGIC_tied))) {
503 PUSHSTACKi(PERLSI_MAGIC);
506 PUSHs(SvTIED_obj((SV*)av, mg));
510 call_method("PUSH", G_SCALAR|G_DISCARD);
515 av_store(av,AvFILLp(av)+1,val);
521 Pops an SV off the end of the array. Returns C<&PL_sv_undef> if the array
528 Perl_av_pop(pTHX_ register AV *av)
537 Perl_croak(aTHX_ PL_no_modify);
538 if ((mg = SvTIED_mg((SV*)av, PERL_MAGIC_tied))) {
540 PUSHSTACKi(PERLSI_MAGIC);
542 XPUSHs(SvTIED_obj((SV*)av, mg));
545 if (call_method("POP", G_SCALAR)) {
546 retval = newSVsv(*PL_stack_sp--);
548 retval = &PL_sv_undef;
556 retval = AvARRAY(av)[AvFILLp(av)];
557 AvARRAY(av)[AvFILLp(av)--] = &PL_sv_undef;
564 =for apidoc av_unshift
566 Unshift the given number of C<undef> values onto the beginning of the
567 array. The array will grow automatically to accommodate the addition. You
568 must then use C<av_store> to assign values to these new elements.
574 Perl_av_unshift(pTHX_ register AV *av, register I32 num)
583 Perl_croak(aTHX_ PL_no_modify);
585 if ((mg = SvTIED_mg((SV*)av, PERL_MAGIC_tied))) {
587 PUSHSTACKi(PERLSI_MAGIC);
590 PUSHs(SvTIED_obj((SV*)av, mg));
596 call_method("UNSHIFT", G_SCALAR|G_DISCARD);
604 if (!AvREAL(av) && AvREIFY(av))
606 i = AvARRAY(av) - AvALLOC(av);
614 SvPV_set(av, (char*)(AvARRAY(av) - i));
620 /* Create extra elements */
621 slide = i > 0 ? i : 0;
623 av_extend(av, i + num);
626 Move(ary, ary + num, i + 1, SV*);
628 ary[--num] = &PL_sv_undef;
630 /* Make extra elements into a buffer */
632 AvFILLp(av) -= slide;
633 SvPV_set(av, (char*)(AvARRAY(av) + slide));
640 Shifts an SV off the beginning of the array.
646 Perl_av_shift(pTHX_ register AV *av)
655 Perl_croak(aTHX_ PL_no_modify);
656 if ((mg = SvTIED_mg((SV*)av, PERL_MAGIC_tied))) {
658 PUSHSTACKi(PERLSI_MAGIC);
660 XPUSHs(SvTIED_obj((SV*)av, mg));
663 if (call_method("SHIFT", G_SCALAR)) {
664 retval = newSVsv(*PL_stack_sp--);
666 retval = &PL_sv_undef;
674 retval = *AvARRAY(av);
676 *AvARRAY(av) = &PL_sv_undef;
677 SvPV_set(av, (char*)(AvARRAY(av) + 1));
688 Returns the highest index in the array. Returns -1 if the array is
695 Perl_av_len(pTHX_ register const AV *av)
703 Ensure than an array has a given number of elements, equivalent to
704 Perl's C<$#array = $fill;>.
709 Perl_av_fill(pTHX_ register AV *av, I32 fill)
714 Perl_croak(aTHX_ "panic: null array");
717 if ((mg = SvTIED_mg((SV*)av, PERL_MAGIC_tied))) {
721 PUSHSTACKi(PERLSI_MAGIC);
724 PUSHs(SvTIED_obj((SV*)av, mg));
725 PUSHs(sv_2mortal(newSViv(fill+1)));
727 call_method("STORESIZE", G_SCALAR|G_DISCARD);
733 if (fill <= AvMAX(av)) {
734 I32 key = AvFILLp(av);
735 SV** const ary = AvARRAY(av);
739 SvREFCNT_dec(ary[key]);
740 ary[key--] = &PL_sv_undef;
745 ary[++key] = &PL_sv_undef;
753 (void)av_store(av,fill,&PL_sv_undef);
757 =for apidoc av_delete
759 Deletes the element indexed by C<key> from the array. Returns the
760 deleted element. If C<flags> equals C<G_DISCARD>, the element is freed
761 and null is returned.
766 Perl_av_delete(pTHX_ AV *av, I32 key, I32 flags)
773 Perl_croak(aTHX_ PL_no_modify);
775 if (SvRMAGICAL(av)) {
776 const MAGIC * const tied_magic = mg_find((SV*)av, PERL_MAGIC_tied);
777 if ((tied_magic || mg_find((SV*)av, PERL_MAGIC_regdata))) {
778 /* Handle negative array indices 20020222 MJD */
781 unsigned adjust_index = 1;
783 SV * const * const negative_indices_glob =
784 hv_fetch(SvSTASH(SvRV(SvTIED_obj((SV *)av,
786 NEGATIVE_INDICES_VAR, 16, 0);
787 if (negative_indices_glob
788 && SvTRUE(GvSV(*negative_indices_glob)))
792 key += AvFILL(av) + 1;
797 svp = av_fetch(av, key, TRUE);
801 if (mg_find(sv, PERL_MAGIC_tiedelem)) {
802 sv_unmagic(sv, PERL_MAGIC_tiedelem); /* No longer an element */
811 key += AvFILL(av) + 1;
816 if (key > AvFILLp(av))
819 if (!AvREAL(av) && AvREIFY(av))
821 sv = AvARRAY(av)[key];
822 if (key == AvFILLp(av)) {
823 AvARRAY(av)[key] = &PL_sv_undef;
826 } while (--key >= 0 && AvARRAY(av)[key] == &PL_sv_undef);
829 AvARRAY(av)[key] = &PL_sv_undef;
833 if (flags & G_DISCARD) {
843 =for apidoc av_exists
845 Returns true if the element indexed by C<key> has been initialized.
847 This relies on the fact that uninitialized array elements are set to
853 Perl_av_exists(pTHX_ AV *av, I32 key)
859 if (SvRMAGICAL(av)) {
860 const MAGIC * const tied_magic = mg_find((SV*)av, PERL_MAGIC_tied);
861 if (tied_magic || mg_find((SV*)av, PERL_MAGIC_regdata)) {
862 SV * const sv = sv_newmortal();
864 /* Handle negative array indices 20020222 MJD */
866 unsigned adjust_index = 1;
868 SV * const * const negative_indices_glob =
869 hv_fetch(SvSTASH(SvRV(SvTIED_obj((SV *)av,
871 NEGATIVE_INDICES_VAR, 16, 0);
872 if (negative_indices_glob
873 && SvTRUE(GvSV(*negative_indices_glob)))
877 key += AvFILL(av) + 1;
883 mg_copy((SV*)av, sv, 0, key);
884 mg = mg_find(sv, PERL_MAGIC_tiedelem);
886 magic_existspack(sv, mg);
887 return (bool)SvTRUE(sv);
894 key += AvFILL(av) + 1;
899 if (key <= AvFILLp(av) && AvARRAY(av)[key] != &PL_sv_undef
909 Perl_av_arylen_p(pTHX_ AV *av) {
911 MAGIC *mg = mg_find((SV*)av, PERL_MAGIC_arylen_p);
914 mg = sv_magicext((SV*)av, 0, PERL_MAGIC_arylen_p, &PL_vtbl_arylen_p,
918 Perl_die(aTHX_ "panic: av_arylen_p");
920 /* sv_magicext won't set this for us because we pass in a NULL obj */
921 mg->mg_flags |= MGf_REFCOUNTED;
923 return &(mg->mg_obj);
928 * c-indentation-style: bsd
930 * indent-tabs-mode: t
933 * ex: set ts=8 sts=4 sw=4 noet: