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