3 * Copyright (c) 1991-1999, 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'))
29 Perl_warn(aTHX_ "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;
50 Perl_av_extend(pTHX_ AV *av, I32 key)
52 dTHR; /* only necessary if we have to extend stack */
54 if (mg = SvTIED_mg((SV*)av, 'P')) {
58 PUSHSTACKi(PERLSI_MAGIC);
61 PUSHs(SvTIED_obj((SV*)av, mg));
62 PUSHs(sv_2mortal(newSViv(key+1)));
64 call_method("EXTEND", G_SCALAR|G_DISCARD);
70 if (key > AvMAX(av)) {
75 if (AvALLOC(av) != AvARRAY(av)) {
76 ary = AvALLOC(av) + AvFILLp(av) + 1;
77 tmp = AvARRAY(av) - AvALLOC(av);
78 Move(AvARRAY(av), AvALLOC(av), AvFILLp(av)+1, SV*);
80 SvPVX(av) = (char*)AvALLOC(av);
83 ary[--tmp] = &PL_sv_undef;
86 if (key > AvMAX(av) - 10) {
87 newmax = key + AvMAX(av);
93 #ifndef STRANGE_MALLOC
97 #if defined(MYMALLOC) && !defined(PURIFY) && !defined(LEAKTEST)
98 newmax = malloced_size((void*)AvALLOC(av))/sizeof(SV*) - 1;
103 newmax = key + AvMAX(av) / 5;
105 #if defined(STRANGE_MALLOC) || defined(MYMALLOC)
106 Renew(AvALLOC(av),newmax+1, SV*);
108 bytes = (newmax + 1) * sizeof(SV*);
109 #define MALLOC_OVERHEAD 16
110 tmp = MALLOC_OVERHEAD;
111 while (tmp - MALLOC_OVERHEAD < bytes)
113 tmp -= MALLOC_OVERHEAD;
115 assert(tmp > newmax);
117 New(2,ary, newmax+1, SV*);
118 Copy(AvALLOC(av), ary, AvMAX(av)+1, SV*);
120 offer_nice_chunk(AvALLOC(av), (AvMAX(av)+1) * sizeof(SV*));
122 Safefree(AvALLOC(av));
126 ary = AvALLOC(av) + AvMAX(av) + 1;
127 tmp = newmax - AvMAX(av);
128 if (av == PL_curstack) { /* Oops, grew stack (via av_store()?) */
129 PL_stack_sp = AvALLOC(av) + (PL_stack_sp - PL_stack_base);
130 PL_stack_base = AvALLOC(av);
131 PL_stack_max = PL_stack_base + newmax;
135 newmax = key < 3 ? 3 : key;
136 New(2,AvALLOC(av), newmax+1, SV*);
137 ary = AvALLOC(av) + 1;
139 AvALLOC(av)[0] = &PL_sv_undef; /* For the stacks */
143 ary[--tmp] = &PL_sv_undef;
146 SvPVX(av) = (char*)AvALLOC(av);
153 Perl_av_fetch(pTHX_ register AV *av, I32 key, I32 lval)
161 key += AvFILL(av) + 1;
166 if (SvRMAGICAL(av)) {
167 if (mg_find((SV*)av,'P') || mg_find((SV*)av,'D')) {
170 mg_copy((SV*)av, sv, 0, key);
172 return &PL_av_fetch_sv;
176 if (key > AvFILLp(av)) {
180 return av_store(av,key,sv);
182 if (AvARRAY(av)[key] == &PL_sv_undef) {
186 return av_store(av,key,sv);
191 && (!AvARRAY(av)[key] /* eg. @_ could have freed elts */
192 || SvTYPE(AvARRAY(av)[key]) == SVTYPEMASK)) {
193 AvARRAY(av)[key] = &PL_sv_undef; /* 1/2 reify */
196 return &AvARRAY(av)[key];
200 Perl_av_store(pTHX_ register AV *av, I32 key, SV *val)
212 key += AvFILL(av) + 1;
217 if (SvREADONLY(av) && key >= AvFILL(av))
218 Perl_croak(aTHX_ PL_no_modify);
220 if (SvRMAGICAL(av)) {
221 if (mg_find((SV*)av,'P')) {
222 if (val != &PL_sv_undef) {
223 mg_copy((SV*)av, val, 0, key);
229 if (!AvREAL(av) && AvREIFY(av))
234 if (AvFILLp(av) < key) {
237 if (av == PL_curstack && key > PL_stack_sp - PL_stack_base)
238 PL_stack_sp = PL_stack_base + key; /* XPUSH in disguise */
240 ary[++AvFILLp(av)] = &PL_sv_undef;
241 while (AvFILLp(av) < key);
246 SvREFCNT_dec(ary[key]);
248 if (SvSMAGICAL(av)) {
249 if (val != &PL_sv_undef) {
250 MAGIC* mg = SvMAGIC(av);
251 sv_magic(val, (SV*)av, toLOWER(mg->mg_type), 0, key);
263 av = (AV*)NEWSV(3,0);
264 sv_upgrade((SV *)av, SVt_PVAV);
268 AvMAX(av) = AvFILLp(av) = -1;
273 Perl_av_make(pTHX_ register I32 size, register SV **strp)
279 av = (AV*)NEWSV(8,0);
280 sv_upgrade((SV *) av,SVt_PVAV);
281 AvFLAGS(av) = AVf_REAL;
282 if (size) { /* `defined' was returning undef for size==0 anyway. */
285 SvPVX(av) = (char*)ary;
286 AvFILLp(av) = size - 1;
287 AvMAX(av) = size - 1;
288 for (i = 0; i < size; i++) {
291 sv_setsv(ary[i], *strp);
299 Perl_av_fake(pTHX_ register I32 size, register SV **strp)
304 av = (AV*)NEWSV(9,0);
305 sv_upgrade((SV *)av, SVt_PVAV);
306 New(4,ary,size+1,SV*);
308 Copy(strp,ary,size,SV*);
309 AvFLAGS(av) = AVf_REIFY;
310 SvPVX(av) = (char*)ary;
311 AvFILLp(av) = size - 1;
312 AvMAX(av) = size - 1;
322 Perl_av_clear(pTHX_ register AV *av)
328 if (SvREFCNT(av) <= 0) {
329 Perl_warn(aTHX_ "Attempt to clear deleted array");
337 Perl_croak(aTHX_ PL_no_modify);
339 /* Give any tie a chance to cleanup first */
348 key = AvFILLp(av) + 1;
350 SvREFCNT_dec(ary[--key]);
351 ary[key] = &PL_sv_undef;
354 if (key = AvARRAY(av) - AvALLOC(av)) {
356 SvPVX(av) = (char*)AvALLOC(av);
363 Perl_av_undef(pTHX_ register AV *av)
371 /* Give any tie a chance to cleanup first */
372 if (SvTIED_mg((SV*)av, 'P'))
373 av_fill(av, -1); /* mg_clear() ? */
376 key = AvFILLp(av) + 1;
378 SvREFCNT_dec(AvARRAY(av)[--key]);
380 Safefree(AvALLOC(av));
383 AvMAX(av) = AvFILLp(av) = -1;
385 SvREFCNT_dec(AvARYLEN(av));
391 Perl_av_push(pTHX_ register AV *av, SV *val)
397 Perl_croak(aTHX_ PL_no_modify);
399 if (mg = SvTIED_mg((SV*)av, 'P')) {
401 PUSHSTACKi(PERLSI_MAGIC);
404 PUSHs(SvTIED_obj((SV*)av, mg));
408 call_method("PUSH", G_SCALAR|G_DISCARD);
413 av_store(av,AvFILLp(av)+1,val);
417 Perl_av_pop(pTHX_ register AV *av)
422 if (!av || AvFILL(av) < 0)
425 Perl_croak(aTHX_ PL_no_modify);
426 if (mg = SvTIED_mg((SV*)av, 'P')) {
428 PUSHSTACKi(PERLSI_MAGIC);
430 XPUSHs(SvTIED_obj((SV*)av, mg));
433 if (call_method("POP", G_SCALAR)) {
434 retval = newSVsv(*PL_stack_sp--);
436 retval = &PL_sv_undef;
442 retval = AvARRAY(av)[AvFILLp(av)];
443 AvARRAY(av)[AvFILLp(av)--] = &PL_sv_undef;
450 Perl_av_unshift(pTHX_ register AV *av, register I32 num)
459 Perl_croak(aTHX_ PL_no_modify);
461 if (mg = SvTIED_mg((SV*)av, 'P')) {
463 PUSHSTACKi(PERLSI_MAGIC);
466 PUSHs(SvTIED_obj((SV*)av, mg));
472 call_method("UNSHIFT", G_SCALAR|G_DISCARD);
478 if (!AvREAL(av) && AvREIFY(av))
480 i = AvARRAY(av) - AvALLOC(av);
488 SvPVX(av) = (char*)(AvARRAY(av) - i);
492 av_extend(av, i + num);
495 Move(ary, ary + num, i + 1, SV*);
497 ary[--num] = &PL_sv_undef;
503 Perl_av_shift(pTHX_ register AV *av)
508 if (!av || AvFILL(av) < 0)
511 Perl_croak(aTHX_ PL_no_modify);
512 if (mg = SvTIED_mg((SV*)av, 'P')) {
514 PUSHSTACKi(PERLSI_MAGIC);
516 XPUSHs(SvTIED_obj((SV*)av, mg));
519 if (call_method("SHIFT", G_SCALAR)) {
520 retval = newSVsv(*PL_stack_sp--);
522 retval = &PL_sv_undef;
528 retval = *AvARRAY(av);
530 *AvARRAY(av) = &PL_sv_undef;
531 SvPVX(av) = (char*)(AvARRAY(av) + 1);
540 Perl_av_len(pTHX_ register AV *av)
546 Perl_av_fill(pTHX_ register AV *av, I32 fill)
550 Perl_croak(aTHX_ "panic: null array");
553 if (mg = SvTIED_mg((SV*)av, 'P')) {
557 PUSHSTACKi(PERLSI_MAGIC);
560 PUSHs(SvTIED_obj((SV*)av, mg));
561 PUSHs(sv_2mortal(newSViv(fill+1)));
563 call_method("STORESIZE", G_SCALAR|G_DISCARD);
569 if (fill <= AvMAX(av)) {
570 I32 key = AvFILLp(av);
571 SV** ary = AvARRAY(av);
575 SvREFCNT_dec(ary[key]);
576 ary[key--] = &PL_sv_undef;
581 ary[++key] = &PL_sv_undef;
589 (void)av_store(av,fill,&PL_sv_undef);
593 /* AVHV: Support for treating arrays as if they were hashes. The
594 * first element of the array should be a hash reference that maps
595 * hash keys to array indices.
599 S_avhv_index_sv(pTHX_ SV* sv)
601 I32 index = SvIV(sv);
603 Perl_croak(aTHX_ "Bad index while coercing array into hash");
608 Perl_avhv_keys(pTHX_ AV *av)
610 SV **keysp = av_fetch(av, 0, FALSE);
617 if (SvTYPE(sv) == SVt_PVHV)
621 Perl_croak(aTHX_ "Can't coerce array into hash");
626 Perl_avhv_fetch_ent(pTHX_ AV *av, SV *keysv, I32 lval, U32 hash)
629 HV *keys = avhv_keys(av);
632 he = hv_fetch_ent(keys, keysv, FALSE, hash);
634 Perl_croak(aTHX_ "No such array field");
635 return av_fetch(av, avhv_index_sv(HeVAL(he)), lval);
639 Perl_avhv_exists_ent(pTHX_ AV *av, SV *keysv, U32 hash)
641 HV *keys = avhv_keys(av);
642 return hv_exists_ent(keys, keysv, hash);
646 Perl_avhv_iternext(pTHX_ AV *av)
648 HV *keys = avhv_keys(av);
649 return hv_iternext(keys);
653 Perl_avhv_iterval(pTHX_ AV *av, register HE *entry)
655 SV *sv = hv_iterval(avhv_keys(av), entry);
656 return *av_fetch(av, avhv_index_sv(sv), TRUE);