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)
34 if (SvTIED_mg((SV*)av, PERL_MAGIC_tied) && ckWARN_d(WARN_DEBUGGING))
35 Perl_warner(aTHX_ packWARN(WARN_DEBUGGING), "av_reify called on tied array");
38 while (key > AvFILLp(av) + 1)
39 AvARRAY(av)[--key] = &PL_sv_undef;
41 SV * const sv = AvARRAY(av)[--key];
43 if (sv != &PL_sv_undef)
44 (void)SvREFCNT_inc(sv);
46 key = AvARRAY(av) - AvALLOC(av);
48 AvALLOC(av)[--key] = &PL_sv_undef;
56 Pre-extend an array. The C<key> is the index to which the array should be
63 Perl_av_extend(pTHX_ AV *av, I32 key)
67 MAGIC * const mg = SvTIED_mg((SV*)av, PERL_MAGIC_tied);
72 PUSHSTACKi(PERLSI_MAGIC);
75 PUSHs(SvTIED_obj((SV*)av, mg));
76 PUSHs(sv_2mortal(newSViv(key+1)));
78 call_method("EXTEND", G_SCALAR|G_DISCARD);
84 if (key > AvMAX(av)) {
89 if (AvALLOC(av) != AvARRAY(av)) {
90 ary = AvALLOC(av) + AvFILLp(av) + 1;
91 tmp = AvARRAY(av) - AvALLOC(av);
92 Move(AvARRAY(av), AvALLOC(av), AvFILLp(av)+1, SV*);
94 SvPV_set(av, (char*)AvALLOC(av));
97 ary[--tmp] = &PL_sv_undef;
99 if (key > AvMAX(av) - 10) {
100 newmax = key + AvMAX(av);
105 #ifdef PERL_MALLOC_WRAP
106 static const char oom_array_extend[] =
107 "Out of memory during array extend"; /* Duplicated in pp_hot.c */
111 #if !defined(STRANGE_MALLOC) && !defined(MYMALLOC)
117 newmax = malloced_size((void*)AvALLOC(av))/sizeof(SV*) - 1;
122 newmax = key + AvMAX(av) / 5;
124 MEM_WRAP_CHECK_1(newmax+1, SV*, oom_array_extend);
125 #if defined(STRANGE_MALLOC) || defined(MYMALLOC)
126 Renew(AvALLOC(av),newmax+1, SV*);
128 bytes = (newmax + 1) * sizeof(SV*);
129 #define MALLOC_OVERHEAD 16
130 itmp = MALLOC_OVERHEAD;
131 while ((MEM_SIZE)(itmp - MALLOC_OVERHEAD) < bytes)
133 itmp -= MALLOC_OVERHEAD;
135 assert(itmp > newmax);
137 assert(newmax >= AvMAX(av));
138 Newx(ary, newmax+1, SV*);
139 Copy(AvALLOC(av), ary, AvMAX(av)+1, SV*);
141 offer_nice_chunk(AvALLOC(av), (AvMAX(av)+1) * sizeof(SV*));
143 Safefree(AvALLOC(av));
149 ary = AvALLOC(av) + AvMAX(av) + 1;
150 tmp = newmax - AvMAX(av);
151 if (av == PL_curstack) { /* Oops, grew stack (via av_store()?) */
152 PL_stack_sp = AvALLOC(av) + (PL_stack_sp - PL_stack_base);
153 PL_stack_base = AvALLOC(av);
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(AvALLOC(av), newmax+1, SV*);
161 ary = AvALLOC(av) + 1;
163 AvALLOC(av)[0] = &PL_sv_undef; /* For the stacks */
167 ary[--tmp] = &PL_sv_undef;
170 SvPV_set(av, (char*)AvALLOC(av));
179 Returns the SV at the specified index in the array. The C<key> is the
180 index. If C<lval> is set then the fetch will be part of a store. Check
181 that the return value is non-null before dereferencing it to a C<SV*>.
183 See L<perlguts/"Understanding the Magic of Tied Hashes and Arrays"> for
184 more information on how to use this function on tied arrays.
190 Perl_av_fetch(pTHX_ register AV *av, I32 key, I32 lval)
196 if (SvRMAGICAL(av)) {
197 const MAGIC * const tied_magic = mg_find((SV*)av, PERL_MAGIC_tied);
198 if (tied_magic || mg_find((SV*)av, PERL_MAGIC_regdata)) {
199 U32 adjust_index = 1;
201 if (tied_magic && key < 0) {
202 /* Handle negative array indices 20020222 MJD */
203 SV * const * const negative_indices_glob =
204 hv_fetch(SvSTASH(SvRV(SvTIED_obj((SV *)av,
206 NEGATIVE_INDICES_VAR, 16, 0);
208 if (negative_indices_glob
209 && SvTRUE(GvSV(*negative_indices_glob)))
213 if (key < 0 && adjust_index) {
214 key += AvFILL(av) + 1;
220 sv_upgrade(sv, SVt_PVLV);
221 mg_copy((SV*)av, sv, 0, key);
223 LvTARG(sv) = sv; /* fake (SV**) */
224 return &(LvTARG(sv));
229 key += AvFILL(av) + 1;
234 if (key > AvFILLp(av)) {
238 return av_store(av,key,sv);
240 if (AvARRAY(av)[key] == &PL_sv_undef) {
244 return av_store(av,key,sv);
249 && (!AvARRAY(av)[key] /* eg. @_ could have freed elts */
250 || SvIS_FREED(AvARRAY(av)[key]))) {
251 AvARRAY(av)[key] = &PL_sv_undef; /* 1/2 reify */
254 return &AvARRAY(av)[key];
260 Stores an SV in an array. The array index is specified as C<key>. The
261 return value will be NULL if the operation failed or if the value did not
262 need to be actually stored within the array (as in the case of tied
263 arrays). Otherwise it can be dereferenced to get the original C<SV*>. Note
264 that the caller is responsible for suitably incrementing the reference
265 count of C<val> before the call, and decrementing it if the function
268 See L<perlguts/"Understanding the Magic of Tied Hashes and Arrays"> for
269 more information on how to use this function on tied arrays.
275 Perl_av_store(pTHX_ register AV *av, I32 key, SV *val)
284 if (SvRMAGICAL(av)) {
285 const MAGIC * const tied_magic = mg_find((SV*)av, PERL_MAGIC_tied);
287 /* Handle negative array indices 20020222 MJD */
289 unsigned adjust_index = 1;
290 SV * const * const negative_indices_glob =
291 hv_fetch(SvSTASH(SvRV(SvTIED_obj((SV *)av,
293 NEGATIVE_INDICES_VAR, 16, 0);
294 if (negative_indices_glob
295 && SvTRUE(GvSV(*negative_indices_glob)))
298 key += AvFILL(av) + 1;
303 if (val != &PL_sv_undef) {
304 mg_copy((SV*)av, val, 0, key);
312 key += AvFILL(av) + 1;
317 if (SvREADONLY(av) && key >= AvFILL(av))
318 Perl_croak(aTHX_ PL_no_modify);
320 if (!AvREAL(av) && AvREIFY(av))
325 if (AvFILLp(av) < key) {
327 if (av == PL_curstack && key > PL_stack_sp - PL_stack_base)
328 PL_stack_sp = PL_stack_base + key; /* XPUSH in disguise */
330 ary[++AvFILLp(av)] = &PL_sv_undef;
331 while (AvFILLp(av) < key);
336 SvREFCNT_dec(ary[key]);
338 if (SvSMAGICAL(av)) {
339 if (val != &PL_sv_undef) {
340 const MAGIC* const mg = SvMAGIC(av);
341 sv_magic(val, (SV*)av, toLOWER(mg->mg_type), 0, key);
351 Creates a new AV. The reference count is set to 1.
359 register AV * const av = (AV*)NEWSV(3,0);
361 sv_upgrade((SV *)av, SVt_PVAV);
362 /* sv_upgrade does AvREAL_only() */
364 SvPV_set(av, (char*)0);
365 AvMAX(av) = AvFILLp(av) = -1;
372 Creates a new AV and populates it with a list of SVs. The SVs are copied
373 into the array, so they may be freed after the call to av_make. The new AV
374 will have a reference count of 1.
380 Perl_av_make(pTHX_ register I32 size, register SV **strp)
382 register AV * const av = (AV*)NEWSV(8,0);
384 sv_upgrade((SV *) av,SVt_PVAV);
385 /* sv_upgrade does AvREAL_only() */
386 if (size) { /* "defined" was returning undef for size==0 anyway. */
391 SvPV_set(av, (char*)ary);
392 AvFILLp(av) = size - 1;
393 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)
420 /* XXX Should av_clear really be NN? */
422 if (SvREFCNT(av) == 0 && ckWARN_d(WARN_DEBUGGING)) {
423 Perl_warner(aTHX_ packWARN(WARN_DEBUGGING), "Attempt to clear deleted array");
428 Perl_croak(aTHX_ PL_no_modify);
430 /* Give any tie a chance to cleanup first */
438 SV** const ary = AvARRAY(av);
439 key = AvFILLp(av) + 1;
441 SV * const sv = ary[--key];
442 /* undef the slot before freeing the value, because a
443 * destructor might try to modify this arrray */
444 ary[key] = &PL_sv_undef;
448 if ((key = AvARRAY(av) - AvALLOC(av))) {
450 SvPV_set(av, (char*)AvALLOC(av));
459 Undefines the array. Frees the memory used by the array itself.
465 Perl_av_undef(pTHX_ register AV *av)
469 /* Give any tie a chance to cleanup first */
470 if (SvTIED_mg((SV*)av, PERL_MAGIC_tied))
471 av_fill(av, -1); /* mg_clear() ? */
474 register I32 key = AvFILLp(av) + 1;
476 SvREFCNT_dec(AvARRAY(av)[--key]);
478 Safefree(AvALLOC(av));
480 SvPV_set(av, (char*)0);
481 AvMAX(av) = AvFILLp(av) = -1;
487 Pushes an SV onto the end of the array. The array will grow automatically
488 to accommodate the addition.
494 Perl_av_push(pTHX_ register AV *av, SV *val)
501 Perl_croak(aTHX_ PL_no_modify);
503 if ((mg = SvTIED_mg((SV*)av, PERL_MAGIC_tied))) {
505 PUSHSTACKi(PERLSI_MAGIC);
508 PUSHs(SvTIED_obj((SV*)av, mg));
512 call_method("PUSH", G_SCALAR|G_DISCARD);
517 av_store(av,AvFILLp(av)+1,val);
523 Pops an SV off the end of the array. Returns C<&PL_sv_undef> if the array
530 Perl_av_pop(pTHX_ register AV *av)
539 Perl_croak(aTHX_ PL_no_modify);
540 if ((mg = SvTIED_mg((SV*)av, PERL_MAGIC_tied))) {
542 PUSHSTACKi(PERLSI_MAGIC);
544 XPUSHs(SvTIED_obj((SV*)av, mg));
547 if (call_method("POP", G_SCALAR)) {
548 retval = newSVsv(*PL_stack_sp--);
550 retval = &PL_sv_undef;
558 retval = AvARRAY(av)[AvFILLp(av)];
559 AvARRAY(av)[AvFILLp(av)--] = &PL_sv_undef;
566 =for apidoc av_unshift
568 Unshift the given number of C<undef> values onto the beginning of the
569 array. The array will grow automatically to accommodate the addition. You
570 must then use C<av_store> to assign values to these new elements.
576 Perl_av_unshift(pTHX_ register AV *av, register I32 num)
585 Perl_croak(aTHX_ PL_no_modify);
587 if ((mg = SvTIED_mg((SV*)av, PERL_MAGIC_tied))) {
589 PUSHSTACKi(PERLSI_MAGIC);
592 PUSHs(SvTIED_obj((SV*)av, mg));
598 call_method("UNSHIFT", G_SCALAR|G_DISCARD);
606 if (!AvREAL(av) && AvREIFY(av))
608 i = AvARRAY(av) - AvALLOC(av);
616 SvPV_set(av, (char*)(AvARRAY(av) - i));
622 /* Create extra elements */
623 slide = i > 0 ? i : 0;
625 av_extend(av, i + num);
628 Move(ary, ary + num, i + 1, SV*);
630 ary[--num] = &PL_sv_undef;
632 /* Make extra elements into a buffer */
634 AvFILLp(av) -= slide;
635 SvPV_set(av, (char*)(AvARRAY(av) + slide));
642 Shifts an SV off the beginning of the array.
648 Perl_av_shift(pTHX_ register AV *av)
657 Perl_croak(aTHX_ PL_no_modify);
658 if ((mg = SvTIED_mg((SV*)av, PERL_MAGIC_tied))) {
660 PUSHSTACKi(PERLSI_MAGIC);
662 XPUSHs(SvTIED_obj((SV*)av, mg));
665 if (call_method("SHIFT", G_SCALAR)) {
666 retval = newSVsv(*PL_stack_sp--);
668 retval = &PL_sv_undef;
676 retval = *AvARRAY(av);
678 *AvARRAY(av) = &PL_sv_undef;
679 SvPV_set(av, (char*)(AvARRAY(av) + 1));
690 Returns the highest index in the array. Returns -1 if the array is
697 Perl_av_len(pTHX_ register const AV *av)
706 Ensure than an array has a given number of elements, equivalent to
707 Perl's C<$#array = $fill;>.
712 Perl_av_fill(pTHX_ register AV *av, I32 fill)
721 if ((mg = SvTIED_mg((SV*)av, PERL_MAGIC_tied))) {
725 PUSHSTACKi(PERLSI_MAGIC);
728 PUSHs(SvTIED_obj((SV*)av, mg));
729 PUSHs(sv_2mortal(newSViv(fill+1)));
731 call_method("STORESIZE", G_SCALAR|G_DISCARD);
737 if (fill <= AvMAX(av)) {
738 I32 key = AvFILLp(av);
739 SV** const ary = AvARRAY(av);
743 SvREFCNT_dec(ary[key]);
744 ary[key--] = &PL_sv_undef;
749 ary[++key] = &PL_sv_undef;
757 (void)av_store(av,fill,&PL_sv_undef);
761 =for apidoc av_delete
763 Deletes the element indexed by C<key> from the array. Returns the
764 deleted element. If C<flags> equals C<G_DISCARD>, the element is freed
765 and null is returned.
770 Perl_av_delete(pTHX_ AV *av, I32 key, I32 flags)
777 Perl_croak(aTHX_ PL_no_modify);
779 if (SvRMAGICAL(av)) {
780 const MAGIC * const tied_magic = mg_find((SV*)av, PERL_MAGIC_tied);
781 if ((tied_magic || mg_find((SV*)av, PERL_MAGIC_regdata))) {
782 /* Handle negative array indices 20020222 MJD */
785 unsigned adjust_index = 1;
787 SV * const * const negative_indices_glob =
788 hv_fetch(SvSTASH(SvRV(SvTIED_obj((SV *)av,
790 NEGATIVE_INDICES_VAR, 16, 0);
791 if (negative_indices_glob
792 && SvTRUE(GvSV(*negative_indices_glob)))
796 key += AvFILL(av) + 1;
801 svp = av_fetch(av, key, TRUE);
805 if (mg_find(sv, PERL_MAGIC_tiedelem)) {
806 sv_unmagic(sv, PERL_MAGIC_tiedelem); /* No longer an element */
815 key += AvFILL(av) + 1;
820 if (key > AvFILLp(av))
823 if (!AvREAL(av) && AvREIFY(av))
825 sv = AvARRAY(av)[key];
826 if (key == AvFILLp(av)) {
827 AvARRAY(av)[key] = &PL_sv_undef;
830 } while (--key >= 0 && AvARRAY(av)[key] == &PL_sv_undef);
833 AvARRAY(av)[key] = &PL_sv_undef;
837 if (flags & G_DISCARD) {
847 =for apidoc av_exists
849 Returns true if the element indexed by C<key> has been initialized.
851 This relies on the fact that uninitialized array elements are set to
857 Perl_av_exists(pTHX_ AV *av, I32 key)
861 if (SvRMAGICAL(av)) {
862 const MAGIC * const tied_magic = mg_find((SV*)av, PERL_MAGIC_tied);
863 if (tied_magic || mg_find((SV*)av, PERL_MAGIC_regdata)) {
864 SV * const sv = sv_newmortal();
866 /* Handle negative array indices 20020222 MJD */
868 unsigned adjust_index = 1;
870 SV * const * const negative_indices_glob =
871 hv_fetch(SvSTASH(SvRV(SvTIED_obj((SV *)av,
873 NEGATIVE_INDICES_VAR, 16, 0);
874 if (negative_indices_glob
875 && SvTRUE(GvSV(*negative_indices_glob)))
879 key += AvFILL(av) + 1;
885 mg_copy((SV*)av, sv, 0, key);
886 mg = mg_find(sv, PERL_MAGIC_tiedelem);
888 magic_existspack(sv, mg);
889 return (bool)SvTRUE(sv);
896 key += AvFILL(av) + 1;
901 if (key <= AvFILLp(av) && AvARRAY(av)[key] != &PL_sv_undef
911 Perl_av_arylen_p(pTHX_ AV *av) {
917 mg = mg_find((SV*)av, PERL_MAGIC_arylen_p);
920 mg = sv_magicext((SV*)av, 0, PERL_MAGIC_arylen_p, &PL_vtbl_arylen_p,
924 Perl_die(aTHX_ "panic: av_arylen_p");
926 /* sv_magicext won't set this for us because we pass in a NULL obj */
927 mg->mg_flags |= MGf_REFCOUNTED;
929 return &(mg->mg_obj);
934 * c-indentation-style: bsd
936 * indent-tabs-mode: t
939 * ex: set ts=8 sts=4 sw=4 noet: