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