3 * Copyright (c) 1991-2001, Larry Wall
5 * You may distribute under the terms of either the GNU General Public
6 * License or the Artistic License, as specified in the README file.
11 * "...for the Entwives desired order, and plenty, and peace (by which they
12 * meant that things should remain where they had set them)." --Treebeard
20 Perl_av_reify(pTHX_ AV *av)
28 if (SvTIED_mg((SV*)av, PERL_MAGIC_tied) && ckWARN_d(WARN_DEBUGGING))
29 Perl_warner(aTHX_ WARN_DEBUGGING, "av_reify called on tied array");
32 while (key > AvFILLp(av) + 1)
33 AvARRAY(av)[--key] = &PL_sv_undef;
35 sv = AvARRAY(av)[--key];
37 if (sv != &PL_sv_undef)
38 (void)SvREFCNT_inc(sv);
40 key = AvARRAY(av) - AvALLOC(av);
42 AvALLOC(av)[--key] = &PL_sv_undef;
50 Pre-extend an array. The C<key> is the index to which the array should be
57 Perl_av_extend(pTHX_ AV *av, I32 key)
60 if ((mg = SvTIED_mg((SV*)av, PERL_MAGIC_tied))) {
64 PUSHSTACKi(PERLSI_MAGIC);
67 PUSHs(SvTIED_obj((SV*)av, mg));
68 PUSHs(sv_2mortal(newSViv(key+1)));
70 call_method("EXTEND", G_SCALAR|G_DISCARD);
76 if (key > AvMAX(av)) {
81 if (AvALLOC(av) != AvARRAY(av)) {
82 ary = AvALLOC(av) + AvFILLp(av) + 1;
83 tmp = AvARRAY(av) - AvALLOC(av);
84 Move(AvARRAY(av), AvALLOC(av), AvFILLp(av)+1, SV*);
86 SvPVX(av) = (char*)AvALLOC(av);
89 ary[--tmp] = &PL_sv_undef;
92 if (key > AvMAX(av) - 10) {
93 newmax = key + AvMAX(av);
99 #ifndef STRANGE_MALLOC
104 #if defined(MYMALLOC) && !defined(LEAKTEST)
105 newmax = malloced_size((void*)AvALLOC(av))/sizeof(SV*) - 1;
110 newmax = key + AvMAX(av) / 5;
112 #if defined(STRANGE_MALLOC) || defined(MYMALLOC)
113 Renew(AvALLOC(av),newmax+1, SV*);
115 bytes = (newmax + 1) * sizeof(SV*);
116 #define MALLOC_OVERHEAD 16
117 itmp = MALLOC_OVERHEAD;
118 while (itmp - MALLOC_OVERHEAD < bytes)
120 itmp -= MALLOC_OVERHEAD;
122 assert(itmp > newmax);
124 assert(newmax >= AvMAX(av));
125 New(2,ary, newmax+1, SV*);
126 Copy(AvALLOC(av), ary, AvMAX(av)+1, SV*);
128 offer_nice_chunk(AvALLOC(av), (AvMAX(av)+1) * sizeof(SV*));
130 Safefree(AvALLOC(av));
134 ary = AvALLOC(av) + AvMAX(av) + 1;
135 tmp = newmax - AvMAX(av);
136 if (av == PL_curstack) { /* Oops, grew stack (via av_store()?) */
137 PL_stack_sp = AvALLOC(av) + (PL_stack_sp - PL_stack_base);
138 PL_stack_base = AvALLOC(av);
139 PL_stack_max = PL_stack_base + newmax;
143 newmax = key < 3 ? 3 : key;
144 New(2,AvALLOC(av), newmax+1, SV*);
145 ary = AvALLOC(av) + 1;
147 AvALLOC(av)[0] = &PL_sv_undef; /* For the stacks */
151 ary[--tmp] = &PL_sv_undef;
154 SvPVX(av) = (char*)AvALLOC(av);
163 Returns the SV at the specified index in the array. The C<key> is the
164 index. If C<lval> is set then the fetch will be part of a store. Check
165 that the return value is non-null before dereferencing it to a C<SV*>.
167 See L<perlguts/"Understanding the Magic of Tied Hashes and Arrays"> for
168 more information on how to use this function on tied arrays.
174 Perl_av_fetch(pTHX_ register AV *av, I32 key, I32 lval)
182 key += AvFILL(av) + 1;
187 if (SvRMAGICAL(av)) {
188 if (mg_find((SV*)av, PERL_MAGIC_tied) ||
189 mg_find((SV*)av, PERL_MAGIC_regdata))
192 mg_copy((SV*)av, sv, 0, key);
194 return &PL_av_fetch_sv;
198 if (key > AvFILLp(av)) {
202 return av_store(av,key,sv);
204 if (AvARRAY(av)[key] == &PL_sv_undef) {
208 return av_store(av,key,sv);
213 && (!AvARRAY(av)[key] /* eg. @_ could have freed elts */
214 || SvTYPE(AvARRAY(av)[key]) == SVTYPEMASK)) {
215 AvARRAY(av)[key] = &PL_sv_undef; /* 1/2 reify */
218 return &AvARRAY(av)[key];
224 Stores an SV in an array. The array index is specified as C<key>. The
225 return value will be NULL if the operation failed or if the value did not
226 need to be actually stored within the array (as in the case of tied
227 arrays). Otherwise it can be dereferenced to get the original C<SV*>. Note
228 that the caller is responsible for suitably incrementing the reference
229 count of C<val> before the call, and decrementing it if the function
232 See L<perlguts/"Understanding the Magic of Tied Hashes and Arrays"> for
233 more information on how to use this function on tied arrays.
239 Perl_av_store(pTHX_ register AV *av, I32 key, SV *val)
249 key += AvFILL(av) + 1;
254 if (SvREADONLY(av) && key >= AvFILL(av))
255 Perl_croak(aTHX_ PL_no_modify);
257 if (SvRMAGICAL(av)) {
258 if (mg_find((SV*)av, PERL_MAGIC_tied)) {
259 if (val != &PL_sv_undef) {
260 mg_copy((SV*)av, val, 0, key);
266 if (!AvREAL(av) && AvREIFY(av))
271 if (AvFILLp(av) < key) {
273 if (av == PL_curstack && key > PL_stack_sp - PL_stack_base)
274 PL_stack_sp = PL_stack_base + key; /* XPUSH in disguise */
276 ary[++AvFILLp(av)] = &PL_sv_undef;
277 while (AvFILLp(av) < key);
282 SvREFCNT_dec(ary[key]);
284 if (SvSMAGICAL(av)) {
285 if (val != &PL_sv_undef) {
286 MAGIC* mg = SvMAGIC(av);
287 sv_magic(val, (SV*)av, toLOWER(mg->mg_type), 0, key);
297 Creates a new AV. The reference count is set to 1.
307 av = (AV*)NEWSV(3,0);
308 sv_upgrade((SV *)av, SVt_PVAV);
312 AvMAX(av) = AvFILLp(av) = -1;
319 Creates a new AV and populates it with a list of SVs. The SVs are copied
320 into the array, so they may be freed after the call to av_make. The new AV
321 will have a reference count of 1.
327 Perl_av_make(pTHX_ register I32 size, register SV **strp)
333 av = (AV*)NEWSV(8,0);
334 sv_upgrade((SV *) av,SVt_PVAV);
335 AvFLAGS(av) = AVf_REAL;
336 if (size) { /* `defined' was returning undef for size==0 anyway. */
339 SvPVX(av) = (char*)ary;
340 AvFILLp(av) = size - 1;
341 AvMAX(av) = size - 1;
342 for (i = 0; i < size; i++) {
345 sv_setsv(ary[i], *strp);
353 Perl_av_fake(pTHX_ register I32 size, register SV **strp)
358 av = (AV*)NEWSV(9,0);
359 sv_upgrade((SV *)av, SVt_PVAV);
360 New(4,ary,size+1,SV*);
362 Copy(strp,ary,size,SV*);
363 AvFLAGS(av) = AVf_REIFY;
364 SvPVX(av) = (char*)ary;
365 AvFILLp(av) = size - 1;
366 AvMAX(av) = size - 1;
378 Clears an array, making it empty. Does not free the memory used by the
385 Perl_av_clear(pTHX_ register AV *av)
391 if (SvREFCNT(av) == 0 && ckWARN_d(WARN_DEBUGGING)) {
392 Perl_warner(aTHX_ WARN_DEBUGGING, "Attempt to clear deleted array");
400 Perl_croak(aTHX_ PL_no_modify);
402 /* Give any tie a chance to cleanup first */
411 key = AvFILLp(av) + 1;
413 SvREFCNT_dec(ary[--key]);
414 ary[key] = &PL_sv_undef;
417 if ((key = AvARRAY(av) - AvALLOC(av))) {
419 SvPVX(av) = (char*)AvALLOC(av);
428 Undefines the array. Frees the memory used by the array itself.
434 Perl_av_undef(pTHX_ register AV *av)
442 /* Give any tie a chance to cleanup first */
443 if (SvTIED_mg((SV*)av, PERL_MAGIC_tied))
444 av_fill(av, -1); /* mg_clear() ? */
447 key = AvFILLp(av) + 1;
449 SvREFCNT_dec(AvARRAY(av)[--key]);
451 Safefree(AvALLOC(av));
454 AvMAX(av) = AvFILLp(av) = -1;
456 SvREFCNT_dec(AvARYLEN(av));
464 Pushes an SV onto the end of the array. The array will grow automatically
465 to accommodate the addition.
471 Perl_av_push(pTHX_ register AV *av, SV *val)
477 Perl_croak(aTHX_ PL_no_modify);
479 if ((mg = SvTIED_mg((SV*)av, PERL_MAGIC_tied))) {
481 PUSHSTACKi(PERLSI_MAGIC);
484 PUSHs(SvTIED_obj((SV*)av, mg));
488 call_method("PUSH", G_SCALAR|G_DISCARD);
493 av_store(av,AvFILLp(av)+1,val);
499 Pops an SV off the end of the array. Returns C<&PL_sv_undef> if the array
506 Perl_av_pop(pTHX_ register AV *av)
511 if (!av || AvFILL(av) < 0)
514 Perl_croak(aTHX_ PL_no_modify);
515 if ((mg = SvTIED_mg((SV*)av, PERL_MAGIC_tied))) {
517 PUSHSTACKi(PERLSI_MAGIC);
519 XPUSHs(SvTIED_obj((SV*)av, mg));
522 if (call_method("POP", G_SCALAR)) {
523 retval = newSVsv(*PL_stack_sp--);
525 retval = &PL_sv_undef;
531 retval = AvARRAY(av)[AvFILLp(av)];
532 AvARRAY(av)[AvFILLp(av)--] = &PL_sv_undef;
539 =for apidoc av_unshift
541 Unshift the given number of C<undef> values onto the beginning of the
542 array. The array will grow automatically to accommodate the addition. You
543 must then use C<av_store> to assign values to these new elements.
549 Perl_av_unshift(pTHX_ register AV *av, register I32 num)
559 Perl_croak(aTHX_ PL_no_modify);
561 if ((mg = SvTIED_mg((SV*)av, PERL_MAGIC_tied))) {
563 PUSHSTACKi(PERLSI_MAGIC);
566 PUSHs(SvTIED_obj((SV*)av, mg));
572 call_method("UNSHIFT", G_SCALAR|G_DISCARD);
578 if (!AvREAL(av) && AvREIFY(av))
580 i = AvARRAY(av) - AvALLOC(av);
588 SvPVX(av) = (char*)(AvARRAY(av) - i);
592 /* Create extra elements */
593 slide = i > 0 ? i : 0;
595 av_extend(av, i + num);
598 Move(ary, ary + num, i + 1, SV*);
600 ary[--num] = &PL_sv_undef;
602 /* Make extra elements into a buffer */
604 AvFILLp(av) -= slide;
605 SvPVX(av) = (char*)(AvARRAY(av) + slide);
612 Shifts an SV off the beginning of the array.
618 Perl_av_shift(pTHX_ register AV *av)
623 if (!av || AvFILL(av) < 0)
626 Perl_croak(aTHX_ PL_no_modify);
627 if ((mg = SvTIED_mg((SV*)av, PERL_MAGIC_tied))) {
629 PUSHSTACKi(PERLSI_MAGIC);
631 XPUSHs(SvTIED_obj((SV*)av, mg));
634 if (call_method("SHIFT", G_SCALAR)) {
635 retval = newSVsv(*PL_stack_sp--);
637 retval = &PL_sv_undef;
643 retval = *AvARRAY(av);
645 *AvARRAY(av) = &PL_sv_undef;
646 SvPVX(av) = (char*)(AvARRAY(av) + 1);
657 Returns the highest index in the array. Returns -1 if the array is
664 Perl_av_len(pTHX_ register AV *av)
672 Ensure than an array has a given number of elements, equivalent to
673 Perl's C<$#array = $fill;>.
678 Perl_av_fill(pTHX_ register AV *av, I32 fill)
682 Perl_croak(aTHX_ "panic: null array");
685 if ((mg = SvTIED_mg((SV*)av, PERL_MAGIC_tied))) {
689 PUSHSTACKi(PERLSI_MAGIC);
692 PUSHs(SvTIED_obj((SV*)av, mg));
693 PUSHs(sv_2mortal(newSViv(fill+1)));
695 call_method("STORESIZE", G_SCALAR|G_DISCARD);
701 if (fill <= AvMAX(av)) {
702 I32 key = AvFILLp(av);
703 SV** ary = AvARRAY(av);
707 SvREFCNT_dec(ary[key]);
708 ary[key--] = &PL_sv_undef;
713 ary[++key] = &PL_sv_undef;
721 (void)av_store(av,fill,&PL_sv_undef);
725 =for apidoc av_delete
727 Deletes the element indexed by C<key> from the array. Returns the
728 deleted element. C<flags> is currently ignored.
733 Perl_av_delete(pTHX_ AV *av, I32 key, I32 flags)
740 Perl_croak(aTHX_ PL_no_modify);
742 key += AvFILL(av) + 1;
746 if (SvRMAGICAL(av)) {
748 if ((mg_find((SV*)av, PERL_MAGIC_tied) ||
749 mg_find((SV*)av, PERL_MAGIC_regdata))
750 && (svp = av_fetch(av, key, TRUE)))
754 if (mg_find(sv, PERL_MAGIC_tiedelem)) {
755 sv_unmagic(sv, PERL_MAGIC_tiedelem); /* No longer an element */
758 return Nullsv; /* element cannot be deleted */
761 if (key > AvFILLp(av))
764 sv = AvARRAY(av)[key];
765 if (key == AvFILLp(av)) {
768 } while (--key >= 0 && AvARRAY(av)[key] == &PL_sv_undef);
771 AvARRAY(av)[key] = &PL_sv_undef;
775 if (flags & G_DISCARD) {
783 =for apidoc av_exists
785 Returns true if the element indexed by C<key> has been initialized.
787 This relies on the fact that uninitialized array elements are set to
793 Perl_av_exists(pTHX_ AV *av, I32 key)
798 key += AvFILL(av) + 1;
802 if (SvRMAGICAL(av)) {
803 if (mg_find((SV*)av, PERL_MAGIC_tied) ||
804 mg_find((SV*)av, PERL_MAGIC_regdata))
806 SV *sv = sv_newmortal();
809 mg_copy((SV*)av, sv, 0, key);
810 mg = mg_find(sv, PERL_MAGIC_tiedelem);
812 magic_existspack(sv, mg);
817 if (key <= AvFILLp(av) && AvARRAY(av)[key] != &PL_sv_undef
826 /* AVHV: Support for treating arrays as if they were hashes. The
827 * first element of the array should be a hash reference that maps
828 * hash keys to array indices.
832 S_avhv_index_sv(pTHX_ SV* sv)
834 I32 index = SvIV(sv);
836 Perl_croak(aTHX_ "Bad index while coercing array into hash");
841 S_avhv_index(pTHX_ AV *av, SV *keysv, U32 hash)
847 keys = avhv_keys(av);
848 he = hv_fetch_ent(keys, keysv, FALSE, hash);
850 Perl_croak(aTHX_ "No such pseudo-hash field \"%s\"", SvPV(keysv,n_a));
851 return avhv_index_sv(HeVAL(he));
855 Perl_avhv_keys(pTHX_ AV *av)
857 SV **keysp = av_fetch(av, 0, FALSE);
864 if (SvTYPE(sv) == SVt_PVHV)
868 Perl_croak(aTHX_ "Can't coerce array into hash");
873 Perl_avhv_store_ent(pTHX_ AV *av, SV *keysv, SV *val, U32 hash)
875 return av_store(av, avhv_index(av, keysv, hash), val);
879 Perl_avhv_fetch_ent(pTHX_ AV *av, SV *keysv, I32 lval, U32 hash)
881 return av_fetch(av, avhv_index(av, keysv, hash), lval);
885 Perl_avhv_delete_ent(pTHX_ AV *av, SV *keysv, I32 flags, U32 hash)
887 HV *keys = avhv_keys(av);
890 he = hv_fetch_ent(keys, keysv, FALSE, hash);
891 if (!he || !SvOK(HeVAL(he)))
894 return av_delete(av, avhv_index_sv(HeVAL(he)), flags);
897 /* Check for the existence of an element named by a given key.
901 Perl_avhv_exists_ent(pTHX_ AV *av, SV *keysv, U32 hash)
903 HV *keys = avhv_keys(av);
906 he = hv_fetch_ent(keys, keysv, FALSE, hash);
907 if (!he || !SvOK(HeVAL(he)))
910 return av_exists(av, avhv_index_sv(HeVAL(he)));
914 Perl_avhv_iternext(pTHX_ AV *av)
916 HV *keys = avhv_keys(av);
917 return hv_iternext(keys);
921 Perl_avhv_iterval(pTHX_ AV *av, register HE *entry)
923 SV *sv = hv_iterval(avhv_keys(av), entry);
924 return *av_fetch(av, avhv_index_sv(sv), TRUE);