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)
33 if (SvTIED_mg((SV*)av, PERL_MAGIC_tied) && ckWARN_d(WARN_DEBUGGING))
34 Perl_warner(aTHX_ packWARN(WARN_DEBUGGING), "av_reify called on tied array");
37 while (key > AvFILLp(av) + 1)
38 AvARRAY(av)[--key] = &PL_sv_undef;
40 sv = AvARRAY(av)[--key];
42 if (sv != &PL_sv_undef)
43 (void)SvREFCNT_inc(sv);
45 key = AvARRAY(av) - AvALLOC(av);
47 AvALLOC(av)[--key] = &PL_sv_undef;
55 Pre-extend an array. The C<key> is the index to which the array should be
62 Perl_av_extend(pTHX_ AV *av, I32 key)
65 if ((mg = SvTIED_mg((SV*)av, PERL_MAGIC_tied))) {
69 PUSHSTACKi(PERLSI_MAGIC);
72 PUSHs(SvTIED_obj((SV*)av, mg));
73 PUSHs(sv_2mortal(newSViv(key+1)));
75 call_method("EXTEND", G_SCALAR|G_DISCARD);
81 if (key > AvMAX(av)) {
86 if (AvALLOC(av) != AvARRAY(av)) {
87 ary = AvALLOC(av) + AvFILLp(av) + 1;
88 tmp = AvARRAY(av) - AvALLOC(av);
89 Move(AvARRAY(av), AvALLOC(av), AvFILLp(av)+1, SV*);
91 SvPV_set(av, (char*)AvALLOC(av));
94 ary[--tmp] = &PL_sv_undef;
97 if (key > AvMAX(av) - 10) {
98 newmax = key + AvMAX(av);
103 #ifdef PERL_MALLOC_WRAP
104 static const char oom_array_extend[] =
105 "Out of memory during array extend"; /* Duplicated in pp_hot.c */
109 #if !defined(STRANGE_MALLOC) && !defined(MYMALLOC)
115 newmax = malloced_size((void*)AvALLOC(av))/sizeof(SV*) - 1;
120 newmax = key + AvMAX(av) / 5;
122 MEM_WRAP_CHECK_1(newmax+1, SV*, oom_array_extend);
123 #if defined(STRANGE_MALLOC) || defined(MYMALLOC)
124 Renew(AvALLOC(av),newmax+1, SV*);
126 bytes = (newmax + 1) * sizeof(SV*);
127 #define MALLOC_OVERHEAD 16
128 itmp = MALLOC_OVERHEAD;
129 while ((MEM_SIZE)(itmp - MALLOC_OVERHEAD) < bytes)
131 itmp -= MALLOC_OVERHEAD;
133 assert(itmp > newmax);
135 assert(newmax >= AvMAX(av));
136 New(2,ary, newmax+1, SV*);
137 Copy(AvALLOC(av), ary, AvMAX(av)+1, SV*);
139 offer_nice_chunk(AvALLOC(av), (AvMAX(av)+1) * sizeof(SV*));
141 Safefree(AvALLOC(av));
147 ary = AvALLOC(av) + AvMAX(av) + 1;
148 tmp = newmax - AvMAX(av);
149 if (av == PL_curstack) { /* Oops, grew stack (via av_store()?) */
150 PL_stack_sp = AvALLOC(av) + (PL_stack_sp - PL_stack_base);
151 PL_stack_base = AvALLOC(av);
152 PL_stack_max = PL_stack_base + newmax;
156 newmax = key < 3 ? 3 : key;
157 MEM_WRAP_CHECK_1(newmax+1, SV*, oom_array_extend);
158 New(2,AvALLOC(av), newmax+1, SV*);
159 ary = AvALLOC(av) + 1;
161 AvALLOC(av)[0] = &PL_sv_undef; /* For the stacks */
165 ary[--tmp] = &PL_sv_undef;
168 SvPV_set(av, (char*)AvALLOC(av));
177 Returns the SV at the specified index in the array. The C<key> is the
178 index. If C<lval> is set then the fetch will be part of a store. Check
179 that the return value is non-null before dereferencing it to a C<SV*>.
181 See L<perlguts/"Understanding the Magic of Tied Hashes and Arrays"> for
182 more information on how to use this function on tied arrays.
188 Perl_av_fetch(pTHX_ register AV *av, I32 key, I32 lval)
195 if (SvRMAGICAL(av)) {
196 const MAGIC * const tied_magic = mg_find((SV*)av, PERL_MAGIC_tied);
197 if (tied_magic || mg_find((SV*)av, PERL_MAGIC_regdata)) {
198 U32 adjust_index = 1;
200 if (tied_magic && key < 0) {
201 /* Handle negative array indices 20020222 MJD */
202 SV **negative_indices_glob =
203 hv_fetch(SvSTASH(SvRV(SvTIED_obj((SV *)av,
205 NEGATIVE_INDICES_VAR, 16, 0);
207 if (negative_indices_glob
208 && SvTRUE(GvSV(*negative_indices_glob)))
212 if (key < 0 && adjust_index) {
213 key += AvFILL(av) + 1;
219 sv_upgrade(sv, SVt_PVLV);
220 mg_copy((SV*)av, sv, 0, key);
222 LvTARG(sv) = sv; /* fake (SV**) */
223 return &(LvTARG(sv));
228 key += AvFILL(av) + 1;
233 if (key > AvFILLp(av)) {
237 return av_store(av,key,sv);
239 if (AvARRAY(av)[key] == &PL_sv_undef) {
243 return av_store(av,key,sv);
248 && (!AvARRAY(av)[key] /* eg. @_ could have freed elts */
249 || SvTYPE(AvARRAY(av)[key]) == SVTYPEMASK)) {
250 AvARRAY(av)[key] = &PL_sv_undef; /* 1/2 reify */
253 return &AvARRAY(av)[key];
259 Stores an SV in an array. The array index is specified as C<key>. The
260 return value will be NULL if the operation failed or if the value did not
261 need to be actually stored within the array (as in the case of tied
262 arrays). Otherwise it can be dereferenced to get the original C<SV*>. Note
263 that the caller is responsible for suitably incrementing the reference
264 count of C<val> before the call, and decrementing it if the function
267 See L<perlguts/"Understanding the Magic of Tied Hashes and Arrays"> for
268 more information on how to use this function on tied arrays.
274 Perl_av_store(pTHX_ register AV *av, I32 key, SV *val)
283 if (SvRMAGICAL(av)) {
284 const MAGIC * const tied_magic = mg_find((SV*)av, PERL_MAGIC_tied);
286 /* Handle negative array indices 20020222 MJD */
288 unsigned adjust_index = 1;
289 SV **negative_indices_glob =
290 hv_fetch(SvSTASH(SvRV(SvTIED_obj((SV *)av,
292 NEGATIVE_INDICES_VAR, 16, 0);
293 if (negative_indices_glob
294 && SvTRUE(GvSV(*negative_indices_glob)))
297 key += AvFILL(av) + 1;
302 if (val != &PL_sv_undef) {
303 mg_copy((SV*)av, val, 0, key);
311 key += AvFILL(av) + 1;
316 if (SvREADONLY(av) && key >= AvFILL(av))
317 Perl_croak(aTHX_ PL_no_modify);
319 if (!AvREAL(av) && AvREIFY(av))
324 if (AvFILLp(av) < key) {
326 if (av == PL_curstack && key > PL_stack_sp - PL_stack_base)
327 PL_stack_sp = PL_stack_base + key; /* XPUSH in disguise */
329 ary[++AvFILLp(av)] = &PL_sv_undef;
330 while (AvFILLp(av) < key);
335 SvREFCNT_dec(ary[key]);
337 if (SvSMAGICAL(av)) {
338 if (val != &PL_sv_undef) {
339 MAGIC* mg = SvMAGIC(av);
340 sv_magic(val, (SV*)av, toLOWER(mg->mg_type), 0, key);
350 Creates a new AV. The reference count is set to 1.
360 av = (AV*)NEWSV(3,0);
361 sv_upgrade((SV *)av, SVt_PVAV);
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)
384 av = (AV*)NEWSV(8,0);
385 sv_upgrade((SV *) av,SVt_PVAV);
386 AvFLAGS(av) = AVf_REAL;
387 if (size) { /* `defined' was returning undef for size==0 anyway. */
392 SvPV_set(av, (char*)ary);
393 AvFILLp(av) = size - 1;
394 AvMAX(av) = size - 1;
395 for (i = 0; i < size; i++) {
398 sv_setsv(ary[i], *strp);
406 Perl_av_fake(pTHX_ register I32 size, register SV **strp)
411 av = (AV*)NEWSV(9,0);
412 sv_upgrade((SV *)av, SVt_PVAV);
413 New(4,ary,size+1,SV*);
415 Copy(strp,ary,size,SV*);
416 AvFLAGS(av) = AVf_REIFY;
417 SvPV_set(av, (char*)ary);
418 AvFILLp(av) = size - 1;
419 AvMAX(av) = size - 1;
431 Clears an array, making it empty. Does not free the memory used by the
438 Perl_av_clear(pTHX_ register AV *av)
443 if (SvREFCNT(av) == 0 && ckWARN_d(WARN_DEBUGGING)) {
444 Perl_warner(aTHX_ packWARN(WARN_DEBUGGING), "Attempt to clear deleted array");
452 Perl_croak(aTHX_ PL_no_modify);
454 /* Give any tie a chance to cleanup first */
462 SV** ary = AvARRAY(av);
463 key = AvFILLp(av) + 1;
465 SV * sv = ary[--key];
466 /* undef the slot before freeing the value, because a
467 * destructor might try to modify this arrray */
468 ary[key] = &PL_sv_undef;
472 if ((key = AvARRAY(av) - AvALLOC(av))) {
474 SvPV_set(av, (char*)AvALLOC(av));
483 Undefines the array. Frees the memory used by the array itself.
489 Perl_av_undef(pTHX_ register AV *av)
497 /* Give any tie a chance to cleanup first */
498 if (SvTIED_mg((SV*)av, PERL_MAGIC_tied))
499 av_fill(av, -1); /* mg_clear() ? */
502 key = AvFILLp(av) + 1;
504 SvREFCNT_dec(AvARRAY(av)[--key]);
506 Safefree(AvALLOC(av));
508 SvPV_set(av, (char*)0);
509 AvMAX(av) = AvFILLp(av) = -1;
511 SvREFCNT_dec(AvARYLEN(av));
519 Pushes an SV onto the end of the array. The array will grow automatically
520 to accommodate the addition.
526 Perl_av_push(pTHX_ register AV *av, SV *val)
533 Perl_croak(aTHX_ PL_no_modify);
535 if ((mg = SvTIED_mg((SV*)av, PERL_MAGIC_tied))) {
537 PUSHSTACKi(PERLSI_MAGIC);
540 PUSHs(SvTIED_obj((SV*)av, mg));
544 call_method("PUSH", G_SCALAR|G_DISCARD);
549 av_store(av,AvFILLp(av)+1,val);
555 Pops an SV off the end of the array. Returns C<&PL_sv_undef> if the array
562 Perl_av_pop(pTHX_ register AV *av)
571 Perl_croak(aTHX_ PL_no_modify);
572 if ((mg = SvTIED_mg((SV*)av, PERL_MAGIC_tied))) {
574 PUSHSTACKi(PERLSI_MAGIC);
576 XPUSHs(SvTIED_obj((SV*)av, mg));
579 if (call_method("POP", G_SCALAR)) {
580 retval = newSVsv(*PL_stack_sp--);
582 retval = &PL_sv_undef;
590 retval = AvARRAY(av)[AvFILLp(av)];
591 AvARRAY(av)[AvFILLp(av)--] = &PL_sv_undef;
598 =for apidoc av_unshift
600 Unshift the given number of C<undef> values onto the beginning of the
601 array. The array will grow automatically to accommodate the addition. You
602 must then use C<av_store> to assign values to these new elements.
608 Perl_av_unshift(pTHX_ register AV *av, register I32 num)
619 Perl_croak(aTHX_ PL_no_modify);
621 if ((mg = SvTIED_mg((SV*)av, PERL_MAGIC_tied))) {
623 PUSHSTACKi(PERLSI_MAGIC);
626 PUSHs(SvTIED_obj((SV*)av, mg));
632 call_method("UNSHIFT", G_SCALAR|G_DISCARD);
640 if (!AvREAL(av) && AvREIFY(av))
642 i = AvARRAY(av) - AvALLOC(av);
650 SvPV_set(av, (char*)(AvARRAY(av) - i));
654 /* Create extra elements */
655 slide = i > 0 ? i : 0;
657 av_extend(av, i + num);
660 Move(ary, ary + num, i + 1, SV*);
662 ary[--num] = &PL_sv_undef;
664 /* Make extra elements into a buffer */
666 AvFILLp(av) -= slide;
667 SvPV_set(av, (char*)(AvARRAY(av) + slide));
674 Shifts an SV off the beginning of the array.
680 Perl_av_shift(pTHX_ register AV *av)
689 Perl_croak(aTHX_ PL_no_modify);
690 if ((mg = SvTIED_mg((SV*)av, PERL_MAGIC_tied))) {
692 PUSHSTACKi(PERLSI_MAGIC);
694 XPUSHs(SvTIED_obj((SV*)av, mg));
697 if (call_method("SHIFT", G_SCALAR)) {
698 retval = newSVsv(*PL_stack_sp--);
700 retval = &PL_sv_undef;
708 retval = *AvARRAY(av);
710 *AvARRAY(av) = &PL_sv_undef;
711 SvPV_set(av, (char*)(AvARRAY(av) + 1));
722 Returns the highest index in the array. Returns -1 if the array is
729 Perl_av_len(pTHX_ const register AV *av)
737 Ensure than an array has a given number of elements, equivalent to
738 Perl's C<$#array = $fill;>.
743 Perl_av_fill(pTHX_ register AV *av, I32 fill)
748 Perl_croak(aTHX_ "panic: null array");
751 if ((mg = SvTIED_mg((SV*)av, PERL_MAGIC_tied))) {
755 PUSHSTACKi(PERLSI_MAGIC);
758 PUSHs(SvTIED_obj((SV*)av, mg));
759 PUSHs(sv_2mortal(newSViv(fill+1)));
761 call_method("STORESIZE", G_SCALAR|G_DISCARD);
767 if (fill <= AvMAX(av)) {
768 I32 key = AvFILLp(av);
769 SV** ary = AvARRAY(av);
773 SvREFCNT_dec(ary[key]);
774 ary[key--] = &PL_sv_undef;
779 ary[++key] = &PL_sv_undef;
787 (void)av_store(av,fill,&PL_sv_undef);
791 =for apidoc av_delete
793 Deletes the element indexed by C<key> from the array. Returns the
794 deleted element. If C<flags> equals C<G_DISCARD>, the element is freed
795 and null is returned.
800 Perl_av_delete(pTHX_ AV *av, I32 key, I32 flags)
807 Perl_croak(aTHX_ PL_no_modify);
809 if (SvRMAGICAL(av)) {
810 const MAGIC * const tied_magic = mg_find((SV*)av, PERL_MAGIC_tied);
811 if ((tied_magic || mg_find((SV*)av, PERL_MAGIC_regdata))) {
812 /* Handle negative array indices 20020222 MJD */
815 unsigned adjust_index = 1;
817 SV **negative_indices_glob =
818 hv_fetch(SvSTASH(SvRV(SvTIED_obj((SV *)av,
820 NEGATIVE_INDICES_VAR, 16, 0);
821 if (negative_indices_glob
822 && SvTRUE(GvSV(*negative_indices_glob)))
826 key += AvFILL(av) + 1;
831 svp = av_fetch(av, key, TRUE);
835 if (mg_find(sv, PERL_MAGIC_tiedelem)) {
836 sv_unmagic(sv, PERL_MAGIC_tiedelem); /* No longer an element */
845 key += AvFILL(av) + 1;
850 if (key > AvFILLp(av))
853 if (!AvREAL(av) && AvREIFY(av))
855 sv = AvARRAY(av)[key];
856 if (key == AvFILLp(av)) {
857 AvARRAY(av)[key] = &PL_sv_undef;
860 } while (--key >= 0 && AvARRAY(av)[key] == &PL_sv_undef);
863 AvARRAY(av)[key] = &PL_sv_undef;
867 if (flags & G_DISCARD) {
877 =for apidoc av_exists
879 Returns true if the element indexed by C<key> has been initialized.
881 This relies on the fact that uninitialized array elements are set to
887 Perl_av_exists(pTHX_ AV *av, I32 key)
893 if (SvRMAGICAL(av)) {
894 const MAGIC * const tied_magic = mg_find((SV*)av, PERL_MAGIC_tied);
895 if (tied_magic || mg_find((SV*)av, PERL_MAGIC_regdata)) {
896 SV *sv = sv_newmortal();
898 /* Handle negative array indices 20020222 MJD */
900 unsigned adjust_index = 1;
902 SV **negative_indices_glob =
903 hv_fetch(SvSTASH(SvRV(SvTIED_obj((SV *)av,
905 NEGATIVE_INDICES_VAR, 16, 0);
906 if (negative_indices_glob
907 && SvTRUE(GvSV(*negative_indices_glob)))
911 key += AvFILL(av) + 1;
917 mg_copy((SV*)av, sv, 0, key);
918 mg = mg_find(sv, PERL_MAGIC_tiedelem);
920 magic_existspack(sv, mg);
921 return (bool)SvTRUE(sv);
928 key += AvFILL(av) + 1;
933 if (key <= AvFILLp(av) && AvARRAY(av)[key] != &PL_sv_undef