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)
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 SvREFCNT_inc_void_NN(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)
65 mg = SvTIED_mg((SV*)av, PERL_MAGIC_tied);
70 PUSHSTACKi(PERLSI_MAGIC);
73 PUSHs(SvTIED_obj((SV*)av, mg));
74 PUSHs(sv_2mortal(newSViv(key+1)));
76 call_method("EXTEND", G_SCALAR|G_DISCARD);
82 if (key > AvMAX(av)) {
87 if (AvALLOC(av) != AvARRAY(av)) {
88 ary = AvALLOC(av) + AvFILLp(av) + 1;
89 tmp = AvARRAY(av) - AvALLOC(av);
90 Move(AvARRAY(av), AvALLOC(av), AvFILLp(av)+1, SV*);
92 SvPV_set(av, (char*)AvALLOC(av));
95 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 Newx(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 Newx(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 * const * const 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 || SvIS_FREED(AvARRAY(av)[key]))) {
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 * const * const 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 const MAGIC* const 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.
358 register AV * const av = (AV*)NEWSV(3,0);
360 sv_upgrade((SV *)av, SVt_PVAV);
361 /* sv_upgrade does AvREAL_only() */
363 SvPV_set(av, (char*)0);
364 AvMAX(av) = AvFILLp(av) = -1;
371 Creates a new AV and populates it with a list of SVs. The SVs are copied
372 into the array, so they may be freed after the call to av_make. The new AV
373 will have a reference count of 1.
379 Perl_av_make(pTHX_ register I32 size, register SV **strp)
381 register AV * const av = (AV*)NEWSV(8,0);
383 sv_upgrade((SV *) av,SVt_PVAV);
384 /* sv_upgrade does AvREAL_only() */
385 if (size) { /* "defined" was returning undef for size==0 anyway. */
390 SvPV_set(av, (char*)ary);
391 AvFILLp(av) = size - 1;
392 AvMAX(av) = size - 1;
393 for (i = 0; i < size; i++) {
396 sv_setsv(ary[i], *strp);
406 Clears an array, making it empty. Does not free the memory used by the
413 Perl_av_clear(pTHX_ register AV *av)
417 /* XXX Should av_clear really be NN? */
419 if (SvREFCNT(av) == 0 && ckWARN_d(WARN_DEBUGGING)) {
420 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 */
437 SV** const ary = AvARRAY(av);
438 key = AvFILLp(av) + 1;
440 SV * const sv = ary[--key];
441 /* undef the slot before freeing the value, because a
442 * destructor might try to modify this arrray */
443 ary[key] = &PL_sv_undef;
447 if ((key = AvARRAY(av) - AvALLOC(av))) {
449 SvPV_set(av, (char*)AvALLOC(av));
458 Undefines the array. Frees the memory used by the array itself.
464 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;
482 /* Need to check SvMAGICAL, as during global destruction it may be that
483 AvARYLEN(av) has been freed before av, and hence the SvANY() pointer
484 is now part of the linked list of SV heads, rather than pointing to
485 the original body. */
486 /* FIXME - audit the code for other bugs like this one. */
487 if (AvARYLEN(av) && SvMAGICAL(AvARYLEN(av))) {
488 MAGIC *mg = mg_find (AvARYLEN(av), PERL_MAGIC_arylen);
491 /* arylen scalar holds a pointer back to the array, but doesn't
492 own a reference. Hence the we (the array) are about to go away
493 with it still pointing at us. Clear its pointer, else it would
494 be pointing at free memory. See the comment in sv_magic about
495 reference loops, and why it can't own a reference to us. */
499 SvREFCNT_dec(AvARYLEN(av));
507 Pushes an SV onto the end of the array. The array will grow automatically
508 to accommodate the addition.
514 Perl_av_push(pTHX_ register AV *av, SV *val)
520 Perl_croak(aTHX_ PL_no_modify);
522 if ((mg = SvTIED_mg((SV*)av, PERL_MAGIC_tied))) {
524 PUSHSTACKi(PERLSI_MAGIC);
527 PUSHs(SvTIED_obj((SV*)av, mg));
531 call_method("PUSH", G_SCALAR|G_DISCARD);
536 av_store(av,AvFILLp(av)+1,val);
542 Pops an SV off the end of the array. Returns C<&PL_sv_undef> if the array
549 Perl_av_pop(pTHX_ register AV *av)
557 Perl_croak(aTHX_ PL_no_modify);
558 if ((mg = SvTIED_mg((SV*)av, PERL_MAGIC_tied))) {
560 PUSHSTACKi(PERLSI_MAGIC);
562 XPUSHs(SvTIED_obj((SV*)av, mg));
565 if (call_method("POP", G_SCALAR)) {
566 retval = newSVsv(*PL_stack_sp--);
568 retval = &PL_sv_undef;
576 retval = AvARRAY(av)[AvFILLp(av)];
577 AvARRAY(av)[AvFILLp(av)--] = &PL_sv_undef;
584 =for apidoc av_unshift
586 Unshift the given number of C<undef> values onto the beginning of the
587 array. The array will grow automatically to accommodate the addition. You
588 must then use C<av_store> to assign values to these new elements.
594 Perl_av_unshift(pTHX_ register AV *av, register I32 num)
602 Perl_croak(aTHX_ PL_no_modify);
604 if ((mg = SvTIED_mg((SV*)av, PERL_MAGIC_tied))) {
606 PUSHSTACKi(PERLSI_MAGIC);
609 PUSHs(SvTIED_obj((SV*)av, mg));
615 call_method("UNSHIFT", G_SCALAR|G_DISCARD);
623 if (!AvREAL(av) && AvREIFY(av))
625 i = AvARRAY(av) - AvALLOC(av);
633 SvPV_set(av, (char*)(AvARRAY(av) - i));
639 /* Create extra elements */
640 slide = i > 0 ? i : 0;
642 av_extend(av, i + num);
645 Move(ary, ary + num, i + 1, SV*);
647 ary[--num] = &PL_sv_undef;
649 /* Make extra elements into a buffer */
651 AvFILLp(av) -= slide;
652 SvPV_set(av, (char*)(AvARRAY(av) + slide));
659 Shifts an SV off the beginning of the array.
665 Perl_av_shift(pTHX_ register AV *av)
673 Perl_croak(aTHX_ PL_no_modify);
674 if ((mg = SvTIED_mg((SV*)av, PERL_MAGIC_tied))) {
676 PUSHSTACKi(PERLSI_MAGIC);
678 XPUSHs(SvTIED_obj((SV*)av, mg));
681 if (call_method("SHIFT", G_SCALAR)) {
682 retval = newSVsv(*PL_stack_sp--);
684 retval = &PL_sv_undef;
692 retval = *AvARRAY(av);
694 *AvARRAY(av) = &PL_sv_undef;
695 SvPV_set(av, (char*)(AvARRAY(av) + 1));
706 Returns the highest index in the array. Returns -1 if the array is
713 Perl_av_len(pTHX_ register AV *av)
721 Ensure than an array has a given number of elements, equivalent to
722 Perl's C<$#array = $fill;>.
727 Perl_av_fill(pTHX_ register AV *av, I32 fill)
731 Perl_croak(aTHX_ "panic: null array");
734 if ((mg = SvTIED_mg((SV*)av, PERL_MAGIC_tied))) {
738 PUSHSTACKi(PERLSI_MAGIC);
741 PUSHs(SvTIED_obj((SV*)av, mg));
742 PUSHs(sv_2mortal(newSViv(fill+1)));
744 call_method("STORESIZE", G_SCALAR|G_DISCARD);
750 if (fill <= AvMAX(av)) {
751 I32 key = AvFILLp(av);
752 SV** const ary = AvARRAY(av);
756 SvREFCNT_dec(ary[key]);
757 ary[key--] = &PL_sv_undef;
762 ary[++key] = &PL_sv_undef;
770 (void)av_store(av,fill,&PL_sv_undef);
774 =for apidoc av_delete
776 Deletes the element indexed by C<key> from the array. Returns the
777 deleted element. If C<flags> equals C<G_DISCARD>, the element is freed
778 and null is returned.
783 Perl_av_delete(pTHX_ AV *av, I32 key, I32 flags)
790 Perl_croak(aTHX_ PL_no_modify);
792 if (SvRMAGICAL(av)) {
793 const MAGIC * const tied_magic = mg_find((SV*)av, PERL_MAGIC_tied);
794 if ((tied_magic || mg_find((SV*)av, PERL_MAGIC_regdata))) {
795 /* Handle negative array indices 20020222 MJD */
798 unsigned adjust_index = 1;
800 SV * const * const negative_indices_glob =
801 hv_fetch(SvSTASH(SvRV(SvTIED_obj((SV *)av,
803 NEGATIVE_INDICES_VAR, 16, 0);
804 if (negative_indices_glob
805 && SvTRUE(GvSV(*negative_indices_glob)))
809 key += AvFILL(av) + 1;
814 svp = av_fetch(av, key, TRUE);
818 if (mg_find(sv, PERL_MAGIC_tiedelem)) {
819 sv_unmagic(sv, PERL_MAGIC_tiedelem); /* No longer an element */
828 key += AvFILL(av) + 1;
833 if (key > AvFILLp(av))
836 if (!AvREAL(av) && AvREIFY(av))
838 sv = AvARRAY(av)[key];
839 if (key == AvFILLp(av)) {
840 AvARRAY(av)[key] = &PL_sv_undef;
843 } while (--key >= 0 && AvARRAY(av)[key] == &PL_sv_undef);
846 AvARRAY(av)[key] = &PL_sv_undef;
850 if (flags & G_DISCARD) {
860 =for apidoc av_exists
862 Returns true if the element indexed by C<key> has been initialized.
864 This relies on the fact that uninitialized array elements are set to
870 Perl_av_exists(pTHX_ AV *av, I32 key)
876 if (SvRMAGICAL(av)) {
877 const MAGIC * const tied_magic = mg_find((SV*)av, PERL_MAGIC_tied);
878 if (tied_magic || mg_find((SV*)av, PERL_MAGIC_regdata)) {
879 SV * const sv = sv_newmortal();
881 /* Handle negative array indices 20020222 MJD */
883 unsigned adjust_index = 1;
885 SV * const * const negative_indices_glob =
886 hv_fetch(SvSTASH(SvRV(SvTIED_obj((SV *)av,
888 NEGATIVE_INDICES_VAR, 16, 0);
889 if (negative_indices_glob
890 && SvTRUE(GvSV(*negative_indices_glob)))
894 key += AvFILL(av) + 1;
900 mg_copy((SV*)av, sv, 0, key);
901 mg = mg_find(sv, PERL_MAGIC_tiedelem);
903 magic_existspack(sv, mg);
904 return (bool)SvTRUE(sv);
911 key += AvFILL(av) + 1;
916 if (key <= AvFILLp(av) && AvARRAY(av)[key] != &PL_sv_undef
925 /* AVHV: Support for treating arrays as if they were hashes. The
926 * first element of the array should be a hash reference that maps
927 * hash keys to array indices.
931 S_avhv_index_sv(pTHX_ SV* sv)
933 I32 index = SvIV(sv);
935 Perl_croak(aTHX_ "Bad index while coercing array into hash");
940 S_avhv_index(pTHX_ AV *av, SV *keysv, U32 hash)
946 keys = avhv_keys(av);
947 he = hv_fetch_ent(keys, keysv, FALSE, hash);
949 Perl_croak(aTHX_ "No such pseudo-hash field \"%s\"", SvPV(keysv,n_a));
950 return avhv_index_sv(HeVAL(he));
954 Perl_avhv_keys(pTHX_ AV *av)
956 SV **keysp = av_fetch(av, 0, FALSE);
962 if (ckWARN(WARN_DEPRECATED) && !sv_isa(sv, "pseudohash"))
963 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
964 "Pseudo-hashes are deprecated");
966 if (SvTYPE(sv) == SVt_PVHV)
970 Perl_croak(aTHX_ "Can't coerce array into hash");
975 Perl_avhv_store_ent(pTHX_ AV *av, SV *keysv, SV *val, U32 hash)
977 return av_store(av, avhv_index(av, keysv, hash), val);
981 Perl_avhv_fetch_ent(pTHX_ AV *av, SV *keysv, I32 lval, U32 hash)
983 return av_fetch(av, avhv_index(av, keysv, hash), lval);
987 Perl_avhv_delete_ent(pTHX_ AV *av, SV *keysv, I32 flags, U32 hash)
989 HV *keys = avhv_keys(av);
992 he = hv_fetch_ent(keys, keysv, FALSE, hash);
993 if (!he || !SvOK(HeVAL(he)))
996 return av_delete(av, avhv_index_sv(HeVAL(he)), flags);
999 /* Check for the existence of an element named by a given key.
1003 Perl_avhv_exists_ent(pTHX_ AV *av, SV *keysv, U32 hash)
1005 HV *keys = avhv_keys(av);
1008 he = hv_fetch_ent(keys, keysv, FALSE, hash);
1009 if (!he || !SvOK(HeVAL(he)))
1012 return av_exists(av, avhv_index_sv(HeVAL(he)));
1016 Perl_avhv_iternext(pTHX_ AV *av)
1018 HV *keys = avhv_keys(av);
1019 return hv_iternext(keys);
1023 Perl_avhv_iterval(pTHX_ AV *av, register HE *entry)
1025 SV *sv = hv_iterval(avhv_keys(av), entry);
1026 return *av_fetch(av, avhv_index_sv(sv), TRUE);
1031 * c-indentation-style: bsd
1033 * indent-tabs-mode: t
1036 * ex: set ts=8 sts=4 sw=4 noet: