1 /* av.c
2 *
3 * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
4 * 2000, 2001, 2002, 2003, by Larry Wall and others
5 *
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.
8 *
9 */
10
11 /*
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
14 */
15
16 /*
17 =head1 Array Manipulation Functions
18 */
19
20 #include "EXTERN.h"
21 #define PERL_IN_AV_C
22 #include "perl.h"
23
24 void
Perl_av_reify(pTHX_ AV * av)25 Perl_av_reify(pTHX_ AV *av)
26 {
27 I32 key;
28 SV* sv;
29
30 if (AvREAL(av))
31 return;
32 #ifdef DEBUGGING
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");
35 #endif
36 key = AvMAX(av) + 1;
37 while (key > AvFILLp(av) + 1)
38 AvARRAY(av)[--key] = &PL_sv_undef;
39 while (key) {
40 sv = AvARRAY(av)[--key];
41 assert(sv);
42 if (sv != &PL_sv_undef)
43 (void)SvREFCNT_inc(sv);
44 }
45 key = AvARRAY(av) - AvALLOC(av);
46 while (key)
47 AvALLOC(av)[--key] = &PL_sv_undef;
48 AvREIFY_off(av);
49 AvREAL_on(av);
50 }
51
52 /*
53 =for apidoc av_extend
54
55 Pre-extend an array. The C<key> is the index to which the array should be
56 extended.
57
58 =cut
59 */
60
61 void
Perl_av_extend(pTHX_ AV * av,I32 key)62 Perl_av_extend(pTHX_ AV *av, I32 key)
63 {
64 MAGIC *mg;
65 if ((mg = SvTIED_mg((SV*)av, PERL_MAGIC_tied))) {
66 dSP;
67 ENTER;
68 SAVETMPS;
69 PUSHSTACKi(PERLSI_MAGIC);
70 PUSHMARK(SP);
71 EXTEND(SP,2);
72 PUSHs(SvTIED_obj((SV*)av, mg));
73 PUSHs(sv_2mortal(newSViv(key+1)));
74 PUTBACK;
75 call_method("EXTEND", G_SCALAR|G_DISCARD);
76 POPSTACK;
77 FREETMPS;
78 LEAVE;
79 return;
80 }
81 if (key > AvMAX(av)) {
82 SV** ary;
83 I32 tmp;
84 I32 newmax;
85
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*);
90 AvMAX(av) += tmp;
91 SvPVX(av) = (char*)AvALLOC(av);
92 if (AvREAL(av)) {
93 while (tmp)
94 ary[--tmp] = &PL_sv_undef;
95 }
96
97 if (key > AvMAX(av) - 10) {
98 newmax = key + AvMAX(av);
99 goto resize;
100 }
101 }
102 else {
103 if (AvALLOC(av)) {
104 #if !defined(STRANGE_MALLOC) && !defined(MYMALLOC)
105 MEM_SIZE bytes;
106 IV itmp;
107 #endif
108
109 #ifdef MYMALLOC
110 newmax = malloced_size((void*)AvALLOC(av))/sizeof(SV*) - 1;
111
112 if (key <= newmax)
113 goto resized;
114 #endif
115 newmax = key + AvMAX(av) / 5;
116 resize:
117 MEM_WRAP_CHECK_1(newmax+1, SV*, "panic: array extend");
118 #if defined(STRANGE_MALLOC) || defined(MYMALLOC)
119 Renew(AvALLOC(av),newmax+1, SV*);
120 #else
121 bytes = (newmax + 1) * sizeof(SV*);
122 #define MALLOC_OVERHEAD 16
123 itmp = MALLOC_OVERHEAD;
124 while ((MEM_SIZE)(itmp - MALLOC_OVERHEAD) < bytes)
125 itmp += itmp;
126 itmp -= MALLOC_OVERHEAD;
127 itmp /= sizeof(SV*);
128 assert(itmp > newmax);
129 newmax = itmp - 1;
130 assert(newmax >= AvMAX(av));
131 New(2,ary, newmax+1, SV*);
132 Copy(AvALLOC(av), ary, AvMAX(av)+1, SV*);
133 if (AvMAX(av) > 64)
134 offer_nice_chunk(AvALLOC(av), (AvMAX(av)+1) * sizeof(SV*));
135 else
136 Safefree(AvALLOC(av));
137 AvALLOC(av) = ary;
138 #endif
139 #ifdef MYMALLOC
140 resized:
141 #endif
142 ary = AvALLOC(av) + AvMAX(av) + 1;
143 tmp = newmax - AvMAX(av);
144 if (av == PL_curstack) { /* Oops, grew stack (via av_store()?) */
145 PL_stack_sp = AvALLOC(av) + (PL_stack_sp - PL_stack_base);
146 PL_stack_base = AvALLOC(av);
147 PL_stack_max = PL_stack_base + newmax;
148 }
149 }
150 else {
151 newmax = key < 3 ? 3 : key;
152 MEM_WRAP_CHECK_1(newmax+1, SV*, "panic: array extend");
153 New(2,AvALLOC(av), newmax+1, SV*);
154 ary = AvALLOC(av) + 1;
155 tmp = newmax;
156 AvALLOC(av)[0] = &PL_sv_undef; /* For the stacks */
157 }
158 if (AvREAL(av)) {
159 while (tmp)
160 ary[--tmp] = &PL_sv_undef;
161 }
162
163 SvPVX(av) = (char*)AvALLOC(av);
164 AvMAX(av) = newmax;
165 }
166 }
167 }
168
169 /*
170 =for apidoc av_fetch
171
172 Returns the SV at the specified index in the array. The C<key> is the
173 index. If C<lval> is set then the fetch will be part of a store. Check
174 that the return value is non-null before dereferencing it to a C<SV*>.
175
176 See L<perlguts/"Understanding the Magic of Tied Hashes and Arrays"> for
177 more information on how to use this function on tied arrays.
178
179 =cut
180 */
181
182 SV**
Perl_av_fetch(pTHX_ register AV * av,I32 key,I32 lval)183 Perl_av_fetch(pTHX_ register AV *av, I32 key, I32 lval)
184 {
185 SV *sv;
186
187 if (!av)
188 return 0;
189
190 if (SvRMAGICAL(av)) {
191 MAGIC *tied_magic = mg_find((SV*)av, PERL_MAGIC_tied);
192 if (tied_magic || mg_find((SV*)av, PERL_MAGIC_regdata)) {
193 U32 adjust_index = 1;
194
195 if (tied_magic && key < 0) {
196 /* Handle negative array indices 20020222 MJD */
197 SV **negative_indices_glob =
198 hv_fetch(SvSTASH(SvRV(SvTIED_obj((SV *)av,
199 tied_magic))),
200 NEGATIVE_INDICES_VAR, 16, 0);
201
202 if (negative_indices_glob
203 && SvTRUE(GvSV(*negative_indices_glob)))
204 adjust_index = 0;
205 }
206
207 if (key < 0 && adjust_index) {
208 key += AvFILL(av) + 1;
209 if (key < 0)
210 return 0;
211 }
212
213 sv = sv_newmortal();
214 sv_upgrade(sv, SVt_PVLV);
215 mg_copy((SV*)av, sv, 0, key);
216 LvTYPE(sv) = 't';
217 LvTARG(sv) = sv; /* fake (SV**) */
218 return &(LvTARG(sv));
219 }
220 }
221
222 if (key < 0) {
223 key += AvFILL(av) + 1;
224 if (key < 0)
225 return 0;
226 }
227
228 if (key > AvFILLp(av)) {
229 if (!lval)
230 return 0;
231 sv = NEWSV(5,0);
232 return av_store(av,key,sv);
233 }
234 if (AvARRAY(av)[key] == &PL_sv_undef) {
235 emptyness:
236 if (lval) {
237 sv = NEWSV(6,0);
238 return av_store(av,key,sv);
239 }
240 return 0;
241 }
242 else if (AvREIFY(av)
243 && (!AvARRAY(av)[key] /* eg. @_ could have freed elts */
244 || SvTYPE(AvARRAY(av)[key]) == SVTYPEMASK)) {
245 AvARRAY(av)[key] = &PL_sv_undef; /* 1/2 reify */
246 goto emptyness;
247 }
248 return &AvARRAY(av)[key];
249 }
250
251 /*
252 =for apidoc av_store
253
254 Stores an SV in an array. The array index is specified as C<key>. The
255 return value will be NULL if the operation failed or if the value did not
256 need to be actually stored within the array (as in the case of tied
257 arrays). Otherwise it can be dereferenced to get the original C<SV*>. Note
258 that the caller is responsible for suitably incrementing the reference
259 count of C<val> before the call, and decrementing it if the function
260 returned NULL.
261
262 See L<perlguts/"Understanding the Magic of Tied Hashes and Arrays"> for
263 more information on how to use this function on tied arrays.
264
265 =cut
266 */
267
268 SV**
Perl_av_store(pTHX_ register AV * av,I32 key,SV * val)269 Perl_av_store(pTHX_ register AV *av, I32 key, SV *val)
270 {
271 SV** ary;
272
273 if (!av)
274 return 0;
275 if (!val)
276 val = &PL_sv_undef;
277
278 if (SvRMAGICAL(av)) {
279 MAGIC *tied_magic = mg_find((SV*)av, PERL_MAGIC_tied);
280 if (tied_magic) {
281 /* Handle negative array indices 20020222 MJD */
282 if (key < 0) {
283 unsigned adjust_index = 1;
284 SV **negative_indices_glob =
285 hv_fetch(SvSTASH(SvRV(SvTIED_obj((SV *)av,
286 tied_magic))),
287 NEGATIVE_INDICES_VAR, 16, 0);
288 if (negative_indices_glob
289 && SvTRUE(GvSV(*negative_indices_glob)))
290 adjust_index = 0;
291 if (adjust_index) {
292 key += AvFILL(av) + 1;
293 if (key < 0)
294 return 0;
295 }
296 }
297 if (val != &PL_sv_undef) {
298 mg_copy((SV*)av, val, 0, key);
299 }
300 return 0;
301 }
302 }
303
304
305 if (key < 0) {
306 key += AvFILL(av) + 1;
307 if (key < 0)
308 return 0;
309 }
310
311 if (SvREADONLY(av) && key >= AvFILL(av))
312 Perl_croak(aTHX_ PL_no_modify);
313
314 if (!AvREAL(av) && AvREIFY(av))
315 av_reify(av);
316 if (key > AvMAX(av))
317 av_extend(av,key);
318 ary = AvARRAY(av);
319 if (AvFILLp(av) < key) {
320 if (!AvREAL(av)) {
321 if (av == PL_curstack && key > PL_stack_sp - PL_stack_base)
322 PL_stack_sp = PL_stack_base + key; /* XPUSH in disguise */
323 do
324 ary[++AvFILLp(av)] = &PL_sv_undef;
325 while (AvFILLp(av) < key);
326 }
327 AvFILLp(av) = key;
328 }
329 else if (AvREAL(av))
330 SvREFCNT_dec(ary[key]);
331 ary[key] = val;
332 if (SvSMAGICAL(av)) {
333 if (val != &PL_sv_undef) {
334 MAGIC* mg = SvMAGIC(av);
335 sv_magic(val, (SV*)av, toLOWER(mg->mg_type), 0, key);
336 }
337 mg_set((SV*)av);
338 }
339 return &ary[key];
340 }
341
342 /*
343 =for apidoc newAV
344
345 Creates a new AV. The reference count is set to 1.
346
347 =cut
348 */
349
350 AV *
Perl_newAV(pTHX)351 Perl_newAV(pTHX)
352 {
353 register AV *av;
354
355 av = (AV*)NEWSV(3,0);
356 sv_upgrade((SV *)av, SVt_PVAV);
357 AvREAL_on(av);
358 AvALLOC(av) = 0;
359 SvPVX(av) = 0;
360 AvMAX(av) = AvFILLp(av) = -1;
361 return av;
362 }
363
364 /*
365 =for apidoc av_make
366
367 Creates a new AV and populates it with a list of SVs. The SVs are copied
368 into the array, so they may be freed after the call to av_make. The new AV
369 will have a reference count of 1.
370
371 =cut
372 */
373
374 AV *
Perl_av_make(pTHX_ register I32 size,register SV ** strp)375 Perl_av_make(pTHX_ register I32 size, register SV **strp)
376 {
377 register AV *av;
378 register I32 i;
379 register SV** ary;
380
381 av = (AV*)NEWSV(8,0);
382 sv_upgrade((SV *) av,SVt_PVAV);
383 AvFLAGS(av) = AVf_REAL;
384 if (size) { /* `defined' was returning undef for size==0 anyway. */
385 New(4,ary,size,SV*);
386 AvALLOC(av) = ary;
387 SvPVX(av) = (char*)ary;
388 AvFILLp(av) = size - 1;
389 AvMAX(av) = size - 1;
390 for (i = 0; i < size; i++) {
391 assert (*strp);
392 ary[i] = NEWSV(7,0);
393 sv_setsv(ary[i], *strp);
394 strp++;
395 }
396 }
397 return av;
398 }
399
400 AV *
Perl_av_fake(pTHX_ register I32 size,register SV ** strp)401 Perl_av_fake(pTHX_ register I32 size, register SV **strp)
402 {
403 register AV *av;
404 register SV** ary;
405
406 av = (AV*)NEWSV(9,0);
407 sv_upgrade((SV *)av, SVt_PVAV);
408 New(4,ary,size+1,SV*);
409 AvALLOC(av) = ary;
410 Copy(strp,ary,size,SV*);
411 AvFLAGS(av) = AVf_REIFY;
412 SvPVX(av) = (char*)ary;
413 AvFILLp(av) = size - 1;
414 AvMAX(av) = size - 1;
415 while (size--) {
416 assert (*strp);
417 SvTEMP_off(*strp);
418 strp++;
419 }
420 return av;
421 }
422
423 /*
424 =for apidoc av_clear
425
426 Clears an array, making it empty. Does not free the memory used by the
427 array itself.
428
429 =cut
430 */
431
432 void
Perl_av_clear(pTHX_ register AV * av)433 Perl_av_clear(pTHX_ register AV *av)
434 {
435 register I32 key;
436 SV** ary;
437
438 #ifdef DEBUGGING
439 if (SvREFCNT(av) == 0 && ckWARN_d(WARN_DEBUGGING)) {
440 Perl_warner(aTHX_ packWARN(WARN_DEBUGGING), "Attempt to clear deleted array");
441 }
442 #endif
443 if (!av)
444 return;
445 /*SUPPRESS 560*/
446
447 if (SvREADONLY(av))
448 Perl_croak(aTHX_ PL_no_modify);
449
450 /* Give any tie a chance to cleanup first */
451 if (SvRMAGICAL(av))
452 mg_clear((SV*)av);
453
454 if (AvMAX(av) < 0)
455 return;
456
457 if (AvREAL(av)) {
458 ary = AvARRAY(av);
459 key = AvFILLp(av) + 1;
460 while (key) {
461 SV * sv = ary[--key];
462 /* undef the slot before freeing the value, because a
463 * destructor might try to modify this arrray */
464 ary[key] = &PL_sv_undef;
465 SvREFCNT_dec(sv);
466 }
467 }
468 if ((key = AvARRAY(av) - AvALLOC(av))) {
469 AvMAX(av) += key;
470 SvPVX(av) = (char*)AvALLOC(av);
471 }
472 AvFILLp(av) = -1;
473
474 }
475
476 /*
477 =for apidoc av_undef
478
479 Undefines the array. Frees the memory used by the array itself.
480
481 =cut
482 */
483
484 void
Perl_av_undef(pTHX_ register AV * av)485 Perl_av_undef(pTHX_ register AV *av)
486 {
487 register I32 key;
488
489 if (!av)
490 return;
491 /*SUPPRESS 560*/
492
493 /* Give any tie a chance to cleanup first */
494 if (SvTIED_mg((SV*)av, PERL_MAGIC_tied))
495 av_fill(av, -1); /* mg_clear() ? */
496
497 if (AvREAL(av)) {
498 key = AvFILLp(av) + 1;
499 while (key)
500 SvREFCNT_dec(AvARRAY(av)[--key]);
501 }
502 Safefree(AvALLOC(av));
503 AvALLOC(av) = 0;
504 SvPVX(av) = 0;
505 AvMAX(av) = AvFILLp(av) = -1;
506 if (AvARYLEN(av)) {
507 SvREFCNT_dec(AvARYLEN(av));
508 AvARYLEN(av) = 0;
509 }
510 }
511
512 /*
513 =for apidoc av_push
514
515 Pushes an SV onto the end of the array. The array will grow automatically
516 to accommodate the addition.
517
518 =cut
519 */
520
521 void
Perl_av_push(pTHX_ register AV * av,SV * val)522 Perl_av_push(pTHX_ register AV *av, SV *val)
523 {
524 MAGIC *mg;
525 if (!av)
526 return;
527 if (SvREADONLY(av))
528 Perl_croak(aTHX_ PL_no_modify);
529
530 if ((mg = SvTIED_mg((SV*)av, PERL_MAGIC_tied))) {
531 dSP;
532 PUSHSTACKi(PERLSI_MAGIC);
533 PUSHMARK(SP);
534 EXTEND(SP,2);
535 PUSHs(SvTIED_obj((SV*)av, mg));
536 PUSHs(val);
537 PUTBACK;
538 ENTER;
539 call_method("PUSH", G_SCALAR|G_DISCARD);
540 LEAVE;
541 POPSTACK;
542 return;
543 }
544 av_store(av,AvFILLp(av)+1,val);
545 }
546
547 /*
548 =for apidoc av_pop
549
550 Pops an SV off the end of the array. Returns C<&PL_sv_undef> if the array
551 is empty.
552
553 =cut
554 */
555
556 SV *
Perl_av_pop(pTHX_ register AV * av)557 Perl_av_pop(pTHX_ register AV *av)
558 {
559 SV *retval;
560 MAGIC* mg;
561
562 if (!av)
563 return &PL_sv_undef;
564 if (SvREADONLY(av))
565 Perl_croak(aTHX_ PL_no_modify);
566 if ((mg = SvTIED_mg((SV*)av, PERL_MAGIC_tied))) {
567 dSP;
568 PUSHSTACKi(PERLSI_MAGIC);
569 PUSHMARK(SP);
570 XPUSHs(SvTIED_obj((SV*)av, mg));
571 PUTBACK;
572 ENTER;
573 if (call_method("POP", G_SCALAR)) {
574 retval = newSVsv(*PL_stack_sp--);
575 } else {
576 retval = &PL_sv_undef;
577 }
578 LEAVE;
579 POPSTACK;
580 return retval;
581 }
582 if (AvFILL(av) < 0)
583 return &PL_sv_undef;
584 retval = AvARRAY(av)[AvFILLp(av)];
585 AvARRAY(av)[AvFILLp(av)--] = &PL_sv_undef;
586 if (SvSMAGICAL(av))
587 mg_set((SV*)av);
588 return retval;
589 }
590
591 /*
592 =for apidoc av_unshift
593
594 Unshift the given number of C<undef> values onto the beginning of the
595 array. The array will grow automatically to accommodate the addition. You
596 must then use C<av_store> to assign values to these new elements.
597
598 =cut
599 */
600
601 void
Perl_av_unshift(pTHX_ register AV * av,register I32 num)602 Perl_av_unshift(pTHX_ register AV *av, register I32 num)
603 {
604 register I32 i;
605 register SV **ary;
606 MAGIC* mg;
607 I32 slide;
608
609 if (!av)
610 return;
611 if (SvREADONLY(av))
612 Perl_croak(aTHX_ PL_no_modify);
613
614 if ((mg = SvTIED_mg((SV*)av, PERL_MAGIC_tied))) {
615 dSP;
616 PUSHSTACKi(PERLSI_MAGIC);
617 PUSHMARK(SP);
618 EXTEND(SP,1+num);
619 PUSHs(SvTIED_obj((SV*)av, mg));
620 while (num-- > 0) {
621 PUSHs(&PL_sv_undef);
622 }
623 PUTBACK;
624 ENTER;
625 call_method("UNSHIFT", G_SCALAR|G_DISCARD);
626 LEAVE;
627 POPSTACK;
628 return;
629 }
630
631 if (num <= 0)
632 return;
633 if (!AvREAL(av) && AvREIFY(av))
634 av_reify(av);
635 i = AvARRAY(av) - AvALLOC(av);
636 if (i) {
637 if (i > num)
638 i = num;
639 num -= i;
640
641 AvMAX(av) += i;
642 AvFILLp(av) += i;
643 SvPVX(av) = (char*)(AvARRAY(av) - i);
644 }
645 if (num) {
646 i = AvFILLp(av);
647 /* Create extra elements */
648 slide = i > 0 ? i : 0;
649 num += slide;
650 av_extend(av, i + num);
651 AvFILLp(av) += num;
652 ary = AvARRAY(av);
653 Move(ary, ary + num, i + 1, SV*);
654 do {
655 ary[--num] = &PL_sv_undef;
656 } while (num);
657 /* Make extra elements into a buffer */
658 AvMAX(av) -= slide;
659 AvFILLp(av) -= slide;
660 SvPVX(av) = (char*)(AvARRAY(av) + slide);
661 }
662 }
663
664 /*
665 =for apidoc av_shift
666
667 Shifts an SV off the beginning of the array.
668
669 =cut
670 */
671
672 SV *
Perl_av_shift(pTHX_ register AV * av)673 Perl_av_shift(pTHX_ register AV *av)
674 {
675 SV *retval;
676 MAGIC* mg;
677
678 if (!av)
679 return &PL_sv_undef;
680 if (SvREADONLY(av))
681 Perl_croak(aTHX_ PL_no_modify);
682 if ((mg = SvTIED_mg((SV*)av, PERL_MAGIC_tied))) {
683 dSP;
684 PUSHSTACKi(PERLSI_MAGIC);
685 PUSHMARK(SP);
686 XPUSHs(SvTIED_obj((SV*)av, mg));
687 PUTBACK;
688 ENTER;
689 if (call_method("SHIFT", G_SCALAR)) {
690 retval = newSVsv(*PL_stack_sp--);
691 } else {
692 retval = &PL_sv_undef;
693 }
694 LEAVE;
695 POPSTACK;
696 return retval;
697 }
698 if (AvFILL(av) < 0)
699 return &PL_sv_undef;
700 retval = *AvARRAY(av);
701 if (AvREAL(av))
702 *AvARRAY(av) = &PL_sv_undef;
703 SvPVX(av) = (char*)(AvARRAY(av) + 1);
704 AvMAX(av)--;
705 AvFILLp(av)--;
706 if (SvSMAGICAL(av))
707 mg_set((SV*)av);
708 return retval;
709 }
710
711 /*
712 =for apidoc av_len
713
714 Returns the highest index in the array. Returns -1 if the array is
715 empty.
716
717 =cut
718 */
719
720 I32
Perl_av_len(pTHX_ register AV * av)721 Perl_av_len(pTHX_ register AV *av)
722 {
723 return AvFILL(av);
724 }
725
726 /*
727 =for apidoc av_fill
728
729 Ensure than an array has a given number of elements, equivalent to
730 Perl's C<$#array = $fill;>.
731
732 =cut
733 */
734 void
Perl_av_fill(pTHX_ register AV * av,I32 fill)735 Perl_av_fill(pTHX_ register AV *av, I32 fill)
736 {
737 MAGIC *mg;
738 if (!av)
739 Perl_croak(aTHX_ "panic: null array");
740 if (fill < 0)
741 fill = -1;
742 if ((mg = SvTIED_mg((SV*)av, PERL_MAGIC_tied))) {
743 dSP;
744 ENTER;
745 SAVETMPS;
746 PUSHSTACKi(PERLSI_MAGIC);
747 PUSHMARK(SP);
748 EXTEND(SP,2);
749 PUSHs(SvTIED_obj((SV*)av, mg));
750 PUSHs(sv_2mortal(newSViv(fill+1)));
751 PUTBACK;
752 call_method("STORESIZE", G_SCALAR|G_DISCARD);
753 POPSTACK;
754 FREETMPS;
755 LEAVE;
756 return;
757 }
758 if (fill <= AvMAX(av)) {
759 I32 key = AvFILLp(av);
760 SV** ary = AvARRAY(av);
761
762 if (AvREAL(av)) {
763 while (key > fill) {
764 SvREFCNT_dec(ary[key]);
765 ary[key--] = &PL_sv_undef;
766 }
767 }
768 else {
769 while (key < fill)
770 ary[++key] = &PL_sv_undef;
771 }
772
773 AvFILLp(av) = fill;
774 if (SvSMAGICAL(av))
775 mg_set((SV*)av);
776 }
777 else
778 (void)av_store(av,fill,&PL_sv_undef);
779 }
780
781 /*
782 =for apidoc av_delete
783
784 Deletes the element indexed by C<key> from the array. Returns the
785 deleted element. If C<flags> equals C<G_DISCARD>, the element is freed
786 and null is returned.
787
788 =cut
789 */
790 SV *
Perl_av_delete(pTHX_ AV * av,I32 key,I32 flags)791 Perl_av_delete(pTHX_ AV *av, I32 key, I32 flags)
792 {
793 SV *sv;
794
795 if (!av)
796 return Nullsv;
797 if (SvREADONLY(av))
798 Perl_croak(aTHX_ PL_no_modify);
799
800 if (SvRMAGICAL(av)) {
801 MAGIC *tied_magic = mg_find((SV*)av, PERL_MAGIC_tied);
802 SV **svp;
803 if ((tied_magic || mg_find((SV*)av, PERL_MAGIC_regdata))) {
804 /* Handle negative array indices 20020222 MJD */
805 if (key < 0) {
806 unsigned adjust_index = 1;
807 if (tied_magic) {
808 SV **negative_indices_glob =
809 hv_fetch(SvSTASH(SvRV(SvTIED_obj((SV *)av,
810 tied_magic))),
811 NEGATIVE_INDICES_VAR, 16, 0);
812 if (negative_indices_glob
813 && SvTRUE(GvSV(*negative_indices_glob)))
814 adjust_index = 0;
815 }
816 if (adjust_index) {
817 key += AvFILL(av) + 1;
818 if (key < 0)
819 return Nullsv;
820 }
821 }
822 svp = av_fetch(av, key, TRUE);
823 if (svp) {
824 sv = *svp;
825 mg_clear(sv);
826 if (mg_find(sv, PERL_MAGIC_tiedelem)) {
827 sv_unmagic(sv, PERL_MAGIC_tiedelem); /* No longer an element */
828 return sv;
829 }
830 return Nullsv;
831 }
832 }
833 }
834
835 if (key < 0) {
836 key += AvFILL(av) + 1;
837 if (key < 0)
838 return Nullsv;
839 }
840
841 if (key > AvFILLp(av))
842 return Nullsv;
843 else {
844 if (!AvREAL(av) && AvREIFY(av))
845 av_reify(av);
846 sv = AvARRAY(av)[key];
847 if (key == AvFILLp(av)) {
848 AvARRAY(av)[key] = &PL_sv_undef;
849 do {
850 AvFILLp(av)--;
851 } while (--key >= 0 && AvARRAY(av)[key] == &PL_sv_undef);
852 }
853 else
854 AvARRAY(av)[key] = &PL_sv_undef;
855 if (SvSMAGICAL(av))
856 mg_set((SV*)av);
857 }
858 if (flags & G_DISCARD) {
859 SvREFCNT_dec(sv);
860 sv = Nullsv;
861 }
862 return sv;
863 }
864
865 /*
866 =for apidoc av_exists
867
868 Returns true if the element indexed by C<key> has been initialized.
869
870 This relies on the fact that uninitialized array elements are set to
871 C<&PL_sv_undef>.
872
873 =cut
874 */
875 bool
Perl_av_exists(pTHX_ AV * av,I32 key)876 Perl_av_exists(pTHX_ AV *av, I32 key)
877 {
878 if (!av)
879 return FALSE;
880
881
882 if (SvRMAGICAL(av)) {
883 MAGIC *tied_magic = mg_find((SV*)av, PERL_MAGIC_tied);
884 if (tied_magic || mg_find((SV*)av, PERL_MAGIC_regdata)) {
885 SV *sv = sv_newmortal();
886 MAGIC *mg;
887 /* Handle negative array indices 20020222 MJD */
888 if (key < 0) {
889 unsigned adjust_index = 1;
890 if (tied_magic) {
891 SV **negative_indices_glob =
892 hv_fetch(SvSTASH(SvRV(SvTIED_obj((SV *)av,
893 tied_magic))),
894 NEGATIVE_INDICES_VAR, 16, 0);
895 if (negative_indices_glob
896 && SvTRUE(GvSV(*negative_indices_glob)))
897 adjust_index = 0;
898 }
899 if (adjust_index) {
900 key += AvFILL(av) + 1;
901 if (key < 0)
902 return FALSE;
903 }
904 }
905
906 mg_copy((SV*)av, sv, 0, key);
907 mg = mg_find(sv, PERL_MAGIC_tiedelem);
908 if (mg) {
909 magic_existspack(sv, mg);
910 return (bool)SvTRUE(sv);
911 }
912
913 }
914 }
915
916 if (key < 0) {
917 key += AvFILL(av) + 1;
918 if (key < 0)
919 return FALSE;
920 }
921
922 if (key <= AvFILLp(av) && AvARRAY(av)[key] != &PL_sv_undef
923 && AvARRAY(av)[key])
924 {
925 return TRUE;
926 }
927 else
928 return FALSE;
929 }
930
931 /* AVHV: Support for treating arrays as if they were hashes. The
932 * first element of the array should be a hash reference that maps
933 * hash keys to array indices.
934 */
935
936 STATIC I32
S_avhv_index_sv(pTHX_ SV * sv)937 S_avhv_index_sv(pTHX_ SV* sv)
938 {
939 I32 index = SvIV(sv);
940 if (index < 1)
941 Perl_croak(aTHX_ "Bad index while coercing array into hash");
942 return index;
943 }
944
945 STATIC I32
S_avhv_index(pTHX_ AV * av,SV * keysv,U32 hash)946 S_avhv_index(pTHX_ AV *av, SV *keysv, U32 hash)
947 {
948 HV *keys;
949 HE *he;
950 STRLEN n_a;
951
952 keys = avhv_keys(av);
953 he = hv_fetch_ent(keys, keysv, FALSE, hash);
954 if (!he)
955 Perl_croak(aTHX_ "No such pseudo-hash field \"%s\"", SvPV(keysv,n_a));
956 return avhv_index_sv(HeVAL(he));
957 }
958
959 HV*
Perl_avhv_keys(pTHX_ AV * av)960 Perl_avhv_keys(pTHX_ AV *av)
961 {
962 SV **keysp = av_fetch(av, 0, FALSE);
963 if (keysp) {
964 SV *sv = *keysp;
965 if (SvGMAGICAL(sv))
966 mg_get(sv);
967 if (SvROK(sv)) {
968 if (ckWARN(WARN_DEPRECATED) && !sv_isa(sv, "pseudohash"))
969 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
970 "Pseudo-hashes are deprecated");
971 sv = SvRV(sv);
972 if (SvTYPE(sv) == SVt_PVHV)
973 return (HV*)sv;
974 }
975 }
976 Perl_croak(aTHX_ "Can't coerce array into hash");
977 return Nullhv;
978 }
979
980 SV**
Perl_avhv_store_ent(pTHX_ AV * av,SV * keysv,SV * val,U32 hash)981 Perl_avhv_store_ent(pTHX_ AV *av, SV *keysv, SV *val, U32 hash)
982 {
983 return av_store(av, avhv_index(av, keysv, hash), val);
984 }
985
986 SV**
Perl_avhv_fetch_ent(pTHX_ AV * av,SV * keysv,I32 lval,U32 hash)987 Perl_avhv_fetch_ent(pTHX_ AV *av, SV *keysv, I32 lval, U32 hash)
988 {
989 return av_fetch(av, avhv_index(av, keysv, hash), lval);
990 }
991
992 SV *
Perl_avhv_delete_ent(pTHX_ AV * av,SV * keysv,I32 flags,U32 hash)993 Perl_avhv_delete_ent(pTHX_ AV *av, SV *keysv, I32 flags, U32 hash)
994 {
995 HV *keys = avhv_keys(av);
996 HE *he;
997
998 he = hv_fetch_ent(keys, keysv, FALSE, hash);
999 if (!he || !SvOK(HeVAL(he)))
1000 return Nullsv;
1001
1002 return av_delete(av, avhv_index_sv(HeVAL(he)), flags);
1003 }
1004
1005 /* Check for the existence of an element named by a given key.
1006 *
1007 */
1008 bool
Perl_avhv_exists_ent(pTHX_ AV * av,SV * keysv,U32 hash)1009 Perl_avhv_exists_ent(pTHX_ AV *av, SV *keysv, U32 hash)
1010 {
1011 HV *keys = avhv_keys(av);
1012 HE *he;
1013
1014 he = hv_fetch_ent(keys, keysv, FALSE, hash);
1015 if (!he || !SvOK(HeVAL(he)))
1016 return FALSE;
1017
1018 return av_exists(av, avhv_index_sv(HeVAL(he)));
1019 }
1020
1021 HE *
Perl_avhv_iternext(pTHX_ AV * av)1022 Perl_avhv_iternext(pTHX_ AV *av)
1023 {
1024 HV *keys = avhv_keys(av);
1025 return hv_iternext(keys);
1026 }
1027
1028 SV *
Perl_avhv_iterval(pTHX_ AV * av,register HE * entry)1029 Perl_avhv_iterval(pTHX_ AV *av, register HE *entry)
1030 {
1031 SV *sv = hv_iterval(avhv_keys(av), entry);
1032 return *av_fetch(av, avhv_index_sv(sv), TRUE);
1033 }
1034