source: trunk/third/perl/av.c @ 17035

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