This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Upgrade to Locale::Codes 2.02.
[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_ packWARN(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_ packWARN(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)
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 if (AvFILL(av) < 0)
538 return &PL_sv_undef;
539 retval = AvARRAY(av)[AvFILLp(av)];
540 AvARRAY(av)[AvFILLp(av)--] = &PL_sv_undef;
541 if (SvSMAGICAL(av))
542 mg_set((SV*)av);
543 return retval;
544}
545
546/*
547=for apidoc av_unshift
548
549Unshift the given number of C<undef> values onto the beginning of the
550array. The array will grow automatically to accommodate the addition. You
551must then use C<av_store> to assign values to these new elements.
552
553=cut
554*/
555
556void
557Perl_av_unshift(pTHX_ register AV *av, register I32 num)
558{
559 register I32 i;
560 register SV **ary;
561 MAGIC* mg;
562 I32 slide;
563
564 if (!av)
565 return;
566 if (SvREADONLY(av))
567 Perl_croak(aTHX_ PL_no_modify);
568
569 if ((mg = SvTIED_mg((SV*)av, PERL_MAGIC_tied))) {
570 dSP;
571 PUSHSTACKi(PERLSI_MAGIC);
572 PUSHMARK(SP);
573 EXTEND(SP,1+num);
574 PUSHs(SvTIED_obj((SV*)av, mg));
575 while (num-- > 0) {
576 PUSHs(&PL_sv_undef);
577 }
578 PUTBACK;
579 ENTER;
580 call_method("UNSHIFT", G_SCALAR|G_DISCARD);
581 LEAVE;
582 POPSTACK;
583 return;
584 }
585
586 if (num <= 0)
587 return;
588 if (!AvREAL(av) && AvREIFY(av))
589 av_reify(av);
590 i = AvARRAY(av) - AvALLOC(av);
591 if (i) {
592 if (i > num)
593 i = num;
594 num -= i;
595
596 AvMAX(av) += i;
597 AvFILLp(av) += i;
598 SvPVX(av) = (char*)(AvARRAY(av) - i);
599 }
600 if (num) {
601 i = AvFILLp(av);
602 /* Create extra elements */
603 slide = i > 0 ? i : 0;
604 num += slide;
605 av_extend(av, i + num);
606 AvFILLp(av) += num;
607 ary = AvARRAY(av);
608 Move(ary, ary + num, i + 1, SV*);
609 do {
610 ary[--num] = &PL_sv_undef;
611 } while (num);
612 /* Make extra elements into a buffer */
613 AvMAX(av) -= slide;
614 AvFILLp(av) -= slide;
615 SvPVX(av) = (char*)(AvARRAY(av) + slide);
616 }
617}
618
619/*
620=for apidoc av_shift
621
622Shifts an SV off the beginning of the array.
623
624=cut
625*/
626
627SV *
628Perl_av_shift(pTHX_ register AV *av)
629{
630 SV *retval;
631 MAGIC* mg;
632
633 if (!av)
634 return &PL_sv_undef;
635 if (SvREADONLY(av))
636 Perl_croak(aTHX_ PL_no_modify);
637 if ((mg = SvTIED_mg((SV*)av, PERL_MAGIC_tied))) {
638 dSP;
639 PUSHSTACKi(PERLSI_MAGIC);
640 PUSHMARK(SP);
641 XPUSHs(SvTIED_obj((SV*)av, mg));
642 PUTBACK;
643 ENTER;
644 if (call_method("SHIFT", G_SCALAR)) {
645 retval = newSVsv(*PL_stack_sp--);
646 } else {
647 retval = &PL_sv_undef;
648 }
649 LEAVE;
650 POPSTACK;
651 return retval;
652 }
653 if (AvFILL(av) < 0)
654 return &PL_sv_undef;
655 retval = *AvARRAY(av);
656 if (AvREAL(av))
657 *AvARRAY(av) = &PL_sv_undef;
658 SvPVX(av) = (char*)(AvARRAY(av) + 1);
659 AvMAX(av)--;
660 AvFILLp(av)--;
661 if (SvSMAGICAL(av))
662 mg_set((SV*)av);
663 return retval;
664}
665
666/*
667=for apidoc av_len
668
669Returns the highest index in the array. Returns -1 if the array is
670empty.
671
672=cut
673*/
674
675I32
676Perl_av_len(pTHX_ register AV *av)
677{
678 return AvFILL(av);
679}
680
681/*
682=for apidoc av_fill
683
684Ensure than an array has a given number of elements, equivalent to
685Perl's C<$#array = $fill;>.
686
687=cut
688*/
689void
690Perl_av_fill(pTHX_ register AV *av, I32 fill)
691{
692 MAGIC *mg;
693 if (!av)
694 Perl_croak(aTHX_ "panic: null array");
695 if (fill < 0)
696 fill = -1;
697 if ((mg = SvTIED_mg((SV*)av, PERL_MAGIC_tied))) {
698 dSP;
699 ENTER;
700 SAVETMPS;
701 PUSHSTACKi(PERLSI_MAGIC);
702 PUSHMARK(SP);
703 EXTEND(SP,2);
704 PUSHs(SvTIED_obj((SV*)av, mg));
705 PUSHs(sv_2mortal(newSViv(fill+1)));
706 PUTBACK;
707 call_method("STORESIZE", G_SCALAR|G_DISCARD);
708 POPSTACK;
709 FREETMPS;
710 LEAVE;
711 return;
712 }
713 if (fill <= AvMAX(av)) {
714 I32 key = AvFILLp(av);
715 SV** ary = AvARRAY(av);
716
717 if (AvREAL(av)) {
718 while (key > fill) {
719 SvREFCNT_dec(ary[key]);
720 ary[key--] = &PL_sv_undef;
721 }
722 }
723 else {
724 while (key < fill)
725 ary[++key] = &PL_sv_undef;
726 }
727
728 AvFILLp(av) = fill;
729 if (SvSMAGICAL(av))
730 mg_set((SV*)av);
731 }
732 else
733 (void)av_store(av,fill,&PL_sv_undef);
734}
735
736/*
737=for apidoc av_delete
738
739Deletes the element indexed by C<key> from the array. Returns the
740deleted element. C<flags> is currently ignored.
741
742=cut
743*/
744SV *
745Perl_av_delete(pTHX_ AV *av, I32 key, I32 flags)
746{
747 SV *sv;
748
749 if (!av)
750 return Nullsv;
751 if (SvREADONLY(av))
752 Perl_croak(aTHX_ PL_no_modify);
753 if (key < 0) {
754 key += AvFILL(av) + 1;
755 if (key < 0)
756 return Nullsv;
757 }
758 if (SvRMAGICAL(av)) {
759 SV **svp;
760 if ((mg_find((SV*)av, PERL_MAGIC_tied) ||
761 mg_find((SV*)av, PERL_MAGIC_regdata))
762 && (svp = av_fetch(av, key, TRUE)))
763 {
764 sv = *svp;
765 mg_clear(sv);
766 if (mg_find(sv, PERL_MAGIC_tiedelem)) {
767 sv_unmagic(sv, PERL_MAGIC_tiedelem); /* No longer an element */
768 return sv;
769 }
770 return Nullsv; /* element cannot be deleted */
771 }
772 }
773 if (key > AvFILLp(av))
774 return Nullsv;
775 else {
776 sv = AvARRAY(av)[key];
777 if (key == AvFILLp(av)) {
778 AvARRAY(av)[key] = &PL_sv_undef;
779 do {
780 AvFILLp(av)--;
781 } while (--key >= 0 && AvARRAY(av)[key] == &PL_sv_undef);
782 }
783 else
784 AvARRAY(av)[key] = &PL_sv_undef;
785 if (SvSMAGICAL(av))
786 mg_set((SV*)av);
787 }
788 if (flags & G_DISCARD) {
789 SvREFCNT_dec(sv);
790 sv = Nullsv;
791 }
792 return sv;
793}
794
795/*
796=for apidoc av_exists
797
798Returns true if the element indexed by C<key> has been initialized.
799
800This relies on the fact that uninitialized array elements are set to
801C<&PL_sv_undef>.
802
803=cut
804*/
805bool
806Perl_av_exists(pTHX_ AV *av, I32 key)
807{
808 if (!av)
809 return FALSE;
810 if (key < 0) {
811 key += AvFILL(av) + 1;
812 if (key < 0)
813 return FALSE;
814 }
815 if (SvRMAGICAL(av)) {
816 if (mg_find((SV*)av, PERL_MAGIC_tied) ||
817 mg_find((SV*)av, PERL_MAGIC_regdata))
818 {
819 SV *sv = sv_newmortal();
820 MAGIC *mg;
821
822 mg_copy((SV*)av, sv, 0, key);
823 mg = mg_find(sv, PERL_MAGIC_tiedelem);
824 if (mg) {
825 magic_existspack(sv, mg);
826 return SvTRUE(sv);
827 }
828 }
829 }
830 if (key <= AvFILLp(av) && AvARRAY(av)[key] != &PL_sv_undef
831 && AvARRAY(av)[key])
832 {
833 return TRUE;
834 }
835 else
836 return FALSE;
837}
838
839/* AVHV: Support for treating arrays as if they were hashes. The
840 * first element of the array should be a hash reference that maps
841 * hash keys to array indices.
842 */
843
844STATIC I32
845S_avhv_index_sv(pTHX_ SV* sv)
846{
847 I32 index = SvIV(sv);
848 if (index < 1)
849 Perl_croak(aTHX_ "Bad index while coercing array into hash");
850 return index;
851}
852
853STATIC I32
854S_avhv_index(pTHX_ AV *av, SV *keysv, U32 hash)
855{
856 HV *keys;
857 HE *he;
858 STRLEN n_a;
859
860 keys = avhv_keys(av);
861 he = hv_fetch_ent(keys, keysv, FALSE, hash);
862 if (!he)
863 Perl_croak(aTHX_ "No such pseudo-hash field \"%s\"", SvPV(keysv,n_a));
864 return avhv_index_sv(HeVAL(he));
865}
866
867HV*
868Perl_avhv_keys(pTHX_ AV *av)
869{
870 SV **keysp = av_fetch(av, 0, FALSE);
871 if (keysp) {
872 SV *sv = *keysp;
873 if (SvGMAGICAL(sv))
874 mg_get(sv);
875 if (SvROK(sv)) {
876 sv = SvRV(sv);
877 if (SvTYPE(sv) == SVt_PVHV)
878 return (HV*)sv;
879 }
880 }
881 Perl_croak(aTHX_ "Can't coerce array into hash");
882 return Nullhv;
883}
884
885SV**
886Perl_avhv_store_ent(pTHX_ AV *av, SV *keysv, SV *val, U32 hash)
887{
888 return av_store(av, avhv_index(av, keysv, hash), val);
889}
890
891SV**
892Perl_avhv_fetch_ent(pTHX_ AV *av, SV *keysv, I32 lval, U32 hash)
893{
894 return av_fetch(av, avhv_index(av, keysv, hash), lval);
895}
896
897SV *
898Perl_avhv_delete_ent(pTHX_ AV *av, SV *keysv, I32 flags, U32 hash)
899{
900 HV *keys = avhv_keys(av);
901 HE *he;
902
903 he = hv_fetch_ent(keys, keysv, FALSE, hash);
904 if (!he || !SvOK(HeVAL(he)))
905 return Nullsv;
906
907 return av_delete(av, avhv_index_sv(HeVAL(he)), flags);
908}
909
910/* Check for the existence of an element named by a given key.
911 *
912 */
913bool
914Perl_avhv_exists_ent(pTHX_ AV *av, SV *keysv, U32 hash)
915{
916 HV *keys = avhv_keys(av);
917 HE *he;
918
919 he = hv_fetch_ent(keys, keysv, FALSE, hash);
920 if (!he || !SvOK(HeVAL(he)))
921 return FALSE;
922
923 return av_exists(av, avhv_index_sv(HeVAL(he)));
924}
925
926HE *
927Perl_avhv_iternext(pTHX_ AV *av)
928{
929 HV *keys = avhv_keys(av);
930 return hv_iternext(keys);
931}
932
933SV *
934Perl_avhv_iterval(pTHX_ AV *av, register HE *entry)
935{
936 SV *sv = hv_iterval(avhv_keys(av), entry);
937 return *av_fetch(av, avhv_index_sv(sv), TRUE);
938}