3 * Copyright (c) 1991-2000, 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, 'P') && 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) {
39 (void)SvREFCNT_inc(sv);
42 key = AvARRAY(av) - AvALLOC(av);
44 AvALLOC(av)[--key] = &PL_sv_undef;
52 Pre-extend an array. The C<key> is the index to which the array should be
59 Perl_av_extend(pTHX_ AV *av, I32 key)
61 dTHR; /* only necessary if we have to extend stack */
63 if ((mg = SvTIED_mg((SV*)av, 'P'))) {
67 PUSHSTACKi(PERLSI_MAGIC);
70 PUSHs(SvTIED_obj((SV*)av, mg));
71 PUSHs(sv_2mortal(newSViv(key+1)));
73 call_method("EXTEND", G_SCALAR|G_DISCARD);
79 if (key > AvMAX(av)) {
84 if (AvALLOC(av) != AvARRAY(av)) {
85 ary = AvALLOC(av) + AvFILLp(av) + 1;
86 tmp = AvARRAY(av) - AvALLOC(av);
87 Move(AvARRAY(av), AvALLOC(av), AvFILLp(av)+1, SV*);
89 SvPVX(av) = (char*)AvALLOC(av);
92 ary[--tmp] = &PL_sv_undef;
95 if (key > AvMAX(av) - 10) {
96 newmax = key + AvMAX(av);
102 #ifndef STRANGE_MALLOC
107 #if defined(MYMALLOC) && !defined(LEAKTEST)
108 newmax = malloced_size((void*)AvALLOC(av))/sizeof(SV*) - 1;
113 newmax = key + AvMAX(av) / 5;
115 #if defined(STRANGE_MALLOC) || defined(MYMALLOC)
116 Renew(AvALLOC(av),newmax+1, SV*);
118 bytes = (newmax + 1) * sizeof(SV*);
119 #define MALLOC_OVERHEAD 16
120 itmp = MALLOC_OVERHEAD;
121 while (itmp - MALLOC_OVERHEAD < bytes)
123 itmp -= MALLOC_OVERHEAD;
125 assert(itmp > newmax);
127 assert(newmax >= AvMAX(av));
128 New(2,ary, newmax+1, SV*);
129 Copy(AvALLOC(av), ary, AvMAX(av)+1, SV*);
131 offer_nice_chunk(AvALLOC(av), (AvMAX(av)+1) * sizeof(SV*));
133 Safefree(AvALLOC(av));
137 ary = AvALLOC(av) + AvMAX(av) + 1;
138 tmp = newmax - AvMAX(av);
139 if (av == PL_curstack) { /* Oops, grew stack (via av_store()?) */
140 PL_stack_sp = AvALLOC(av) + (PL_stack_sp - PL_stack_base);
141 PL_stack_base = AvALLOC(av);
142 PL_stack_max = PL_stack_base + newmax;
146 newmax = key < 3 ? 3 : key;
147 New(2,AvALLOC(av), newmax+1, SV*);
148 ary = AvALLOC(av) + 1;
150 AvALLOC(av)[0] = &PL_sv_undef; /* For the stacks */
154 ary[--tmp] = &PL_sv_undef;
157 SvPVX(av) = (char*)AvALLOC(av);
166 Returns the SV at the specified index in the array. The C<key> is the
167 index. If C<lval> is set then the fetch will be part of a store. Check
168 that the return value is non-null before dereferencing it to a C<SV*>.
170 See L<perlguts/"Understanding the Magic of Tied Hashes and Arrays"> for
171 more information on how to use this function on tied arrays.
177 Perl_av_fetch(pTHX_ register AV *av, I32 key, I32 lval)
185 key += AvFILL(av) + 1;
190 if (SvRMAGICAL(av)) {
191 if (mg_find((SV*)av,'P') || mg_find((SV*)av,'D')) {
194 mg_copy((SV*)av, sv, 0, key);
196 return &PL_av_fetch_sv;
200 if (key > AvFILLp(av)) {
204 return av_store(av,key,sv);
206 if (AvARRAY(av)[key] == &PL_sv_undef) {
210 return av_store(av,key,sv);
215 && (!AvARRAY(av)[key] /* eg. @_ could have freed elts */
216 || SvTYPE(AvARRAY(av)[key]) == SVTYPEMASK)) {
217 AvARRAY(av)[key] = &PL_sv_undef; /* 1/2 reify */
220 return &AvARRAY(av)[key];
226 Stores an SV in an array. The array index is specified as C<key>. The
227 return value will be NULL if the operation failed or if the value did not
228 need to be actually stored within the array (as in the case of tied
229 arrays). Otherwise it can be dereferenced to get the original C<SV*>. Note
230 that the caller is responsible for suitably incrementing the reference
231 count of C<val> before the call, and decrementing it if the function
234 See L<perlguts/"Understanding the Magic of Tied Hashes and Arrays"> for
235 more information on how to use this function on tied arrays.
241 Perl_av_store(pTHX_ register AV *av, I32 key, SV *val)
251 key += AvFILL(av) + 1;
256 if (SvREADONLY(av) && key >= AvFILL(av))
257 Perl_croak(aTHX_ PL_no_modify);
259 if (SvRMAGICAL(av)) {
260 if (mg_find((SV*)av,'P')) {
261 if (val != &PL_sv_undef) {
262 mg_copy((SV*)av, val, 0, key);
268 if (!AvREAL(av) && AvREIFY(av))
273 if (AvFILLp(av) < key) {
276 if (av == PL_curstack && key > PL_stack_sp - PL_stack_base)
277 PL_stack_sp = PL_stack_base + key; /* XPUSH in disguise */
279 ary[++AvFILLp(av)] = &PL_sv_undef;
280 while (AvFILLp(av) < key);
285 SvREFCNT_dec(ary[key]);
287 if (SvSMAGICAL(av)) {
288 if (val != &PL_sv_undef) {
289 MAGIC* mg = SvMAGIC(av);
290 sv_magic(val, (SV*)av, toLOWER(mg->mg_type), 0, key);
300 Creates a new AV. The reference count is set to 1.
310 av = (AV*)NEWSV(3,0);
311 sv_upgrade((SV *)av, SVt_PVAV);
315 AvMAX(av) = AvFILLp(av) = -1;
322 Creates a new AV and populates it with a list of SVs. The SVs are copied
323 into the array, so they may be freed after the call to av_make. The new AV
324 will have a reference count of 1.
330 Perl_av_make(pTHX_ register I32 size, register SV **strp)
336 av = (AV*)NEWSV(8,0);
337 sv_upgrade((SV *) av,SVt_PVAV);
338 AvFLAGS(av) = AVf_REAL;
339 if (size) { /* `defined' was returning undef for size==0 anyway. */
342 SvPVX(av) = (char*)ary;
343 AvFILLp(av) = size - 1;
344 AvMAX(av) = size - 1;
345 for (i = 0; i < size; i++) {
348 sv_setsv(ary[i], *strp);
356 Perl_av_fake(pTHX_ register I32 size, register SV **strp)
361 av = (AV*)NEWSV(9,0);
362 sv_upgrade((SV *)av, SVt_PVAV);
363 New(4,ary,size+1,SV*);
365 Copy(strp,ary,size,SV*);
366 AvFLAGS(av) = AVf_REIFY;
367 SvPVX(av) = (char*)ary;
368 AvFILLp(av) = size - 1;
369 AvMAX(av) = size - 1;
381 Clears an array, making it empty. Does not free the memory used by the
388 Perl_av_clear(pTHX_ register AV *av)
394 if (SvREFCNT(av) == 0 && ckWARN_d(WARN_DEBUGGING)) {
395 Perl_warner(aTHX_ WARN_DEBUGGING, "Attempt to clear deleted array");
403 Perl_croak(aTHX_ PL_no_modify);
405 /* Give any tie a chance to cleanup first */
414 key = AvFILLp(av) + 1;
416 SvREFCNT_dec(ary[--key]);
417 ary[key] = &PL_sv_undef;
420 if ((key = AvARRAY(av) - AvALLOC(av))) {
422 SvPVX(av) = (char*)AvALLOC(av);
431 Undefines the array. Frees the memory used by the array itself.
437 Perl_av_undef(pTHX_ register AV *av)
445 /* Give any tie a chance to cleanup first */
446 if (SvTIED_mg((SV*)av, 'P'))
447 av_fill(av, -1); /* mg_clear() ? */
450 key = AvFILLp(av) + 1;
452 SvREFCNT_dec(AvARRAY(av)[--key]);
454 Safefree(AvALLOC(av));
457 AvMAX(av) = AvFILLp(av) = -1;
459 SvREFCNT_dec(AvARYLEN(av));
467 Pushes an SV onto the end of the array. The array will grow automatically
468 to accommodate the addition.
474 Perl_av_push(pTHX_ register AV *av, SV *val)
480 Perl_croak(aTHX_ PL_no_modify);
482 if ((mg = SvTIED_mg((SV*)av, 'P'))) {
484 PUSHSTACKi(PERLSI_MAGIC);
487 PUSHs(SvTIED_obj((SV*)av, mg));
491 call_method("PUSH", G_SCALAR|G_DISCARD);
496 av_store(av,AvFILLp(av)+1,val);
502 Pops an SV off the end of the array. Returns C<&PL_sv_undef> if the array
509 Perl_av_pop(pTHX_ register AV *av)
514 if (!av || AvFILL(av) < 0)
517 Perl_croak(aTHX_ PL_no_modify);
518 if ((mg = SvTIED_mg((SV*)av, 'P'))) {
520 PUSHSTACKi(PERLSI_MAGIC);
522 XPUSHs(SvTIED_obj((SV*)av, mg));
525 if (call_method("POP", G_SCALAR)) {
526 retval = newSVsv(*PL_stack_sp--);
528 retval = &PL_sv_undef;
534 retval = AvARRAY(av)[AvFILLp(av)];
535 AvARRAY(av)[AvFILLp(av)--] = &PL_sv_undef;
542 =for apidoc av_unshift
544 Unshift the given number of C<undef> values onto the beginning of the
545 array. The array will grow automatically to accommodate the addition. You
546 must then use C<av_store> to assign values to these new elements.
552 Perl_av_unshift(pTHX_ register AV *av, register I32 num)
562 Perl_croak(aTHX_ PL_no_modify);
564 if ((mg = SvTIED_mg((SV*)av, 'P'))) {
566 PUSHSTACKi(PERLSI_MAGIC);
569 PUSHs(SvTIED_obj((SV*)av, mg));
575 call_method("UNSHIFT", G_SCALAR|G_DISCARD);
581 if (!AvREAL(av) && AvREIFY(av))
583 i = AvARRAY(av) - AvALLOC(av);
591 SvPVX(av) = (char*)(AvARRAY(av) - i);
595 /* Create extra elements */
596 slide = i > 0 ? i : 0;
598 av_extend(av, i + num);
601 Move(ary, ary + num, i + 1, SV*);
603 ary[--num] = &PL_sv_undef;
605 /* Make extra elements into a buffer */
607 AvFILLp(av) -= slide;
608 SvPVX(av) = (char*)(AvARRAY(av) + slide);
615 Shifts an SV off the beginning of the array.
621 Perl_av_shift(pTHX_ register AV *av)
626 if (!av || AvFILL(av) < 0)
629 Perl_croak(aTHX_ PL_no_modify);
630 if ((mg = SvTIED_mg((SV*)av, 'P'))) {
632 PUSHSTACKi(PERLSI_MAGIC);
634 XPUSHs(SvTIED_obj((SV*)av, mg));
637 if (call_method("SHIFT", G_SCALAR)) {
638 retval = newSVsv(*PL_stack_sp--);
640 retval = &PL_sv_undef;
646 retval = *AvARRAY(av);
648 *AvARRAY(av) = &PL_sv_undef;
649 SvPVX(av) = (char*)(AvARRAY(av) + 1);
660 Returns the highest index in the array. Returns -1 if the array is
667 Perl_av_len(pTHX_ register AV *av)
675 Ensure than an array has a given number of elements, equivalent to
676 Perl's C<$#array = $fill;>.
681 Perl_av_fill(pTHX_ register AV *av, I32 fill)
685 Perl_croak(aTHX_ "panic: null array");
688 if ((mg = SvTIED_mg((SV*)av, 'P'))) {
692 PUSHSTACKi(PERLSI_MAGIC);
695 PUSHs(SvTIED_obj((SV*)av, mg));
696 PUSHs(sv_2mortal(newSViv(fill+1)));
698 call_method("STORESIZE", G_SCALAR|G_DISCARD);
704 if (fill <= AvMAX(av)) {
705 I32 key = AvFILLp(av);
706 SV** ary = AvARRAY(av);
710 SvREFCNT_dec(ary[key]);
711 ary[key--] = &PL_sv_undef;
716 ary[++key] = &PL_sv_undef;
724 (void)av_store(av,fill,&PL_sv_undef);
728 =for apidoc av_delete
730 Deletes the element indexed by C<key> from the array. Returns the
731 deleted element. C<flags> is currently ignored.
736 Perl_av_delete(pTHX_ AV *av, I32 key, I32 flags)
743 Perl_croak(aTHX_ PL_no_modify);
745 key += AvFILL(av) + 1;
749 if (SvRMAGICAL(av)) {
751 if ((mg_find((SV*)av,'P') || mg_find((SV*)av,'D'))
752 && (svp = av_fetch(av, key, TRUE)))
756 if (mg_find(sv, 'p')) {
757 sv_unmagic(sv, 'p'); /* No longer an element */
760 return Nullsv; /* element cannot be deleted */
763 if (key > AvFILLp(av))
766 sv = AvARRAY(av)[key];
767 if (key == AvFILLp(av)) {
770 } while (--key >= 0 && AvARRAY(av)[key] == &PL_sv_undef);
773 AvARRAY(av)[key] = &PL_sv_undef;
777 if (flags & G_DISCARD) {
785 =for apidoc av_exists
787 Returns true if the element indexed by C<key> has been initialized.
789 This relies on the fact that uninitialized array elements are set to
795 Perl_av_exists(pTHX_ AV *av, I32 key)
800 key += AvFILL(av) + 1;
804 if (SvRMAGICAL(av)) {
805 if (mg_find((SV*)av,'P') || mg_find((SV*)av,'D')) {
806 SV *sv = sv_newmortal();
809 mg_copy((SV*)av, sv, 0, key);
810 mg = mg_find(sv, 'p');
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);