a tweaked version of:
[p5sagit/p5-mst-13.2.git] / av.c
1 /*    av.c
2  *
3  *    Copyright (c) 1991-1997, 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 #include "perl.h"
17
18 void
19 av_reify(AV *av)
20 {
21     I32 key;
22     SV* sv;
23
24     if (AvREAL(av))
25         return;
26 #ifdef DEBUGGING
27     if (SvRMAGICAL(av) && mg_find((SV*)av,'P'))
28         warn("av_reify called on tied array");
29 #endif
30     key = AvMAX(av) + 1;
31     while (key > AvFILLp(av) + 1)
32         AvARRAY(av)[--key] = &sv_undef;
33     while (key) {
34         sv = AvARRAY(av)[--key];
35         assert(sv);
36         if (sv != &sv_undef) {
37             dTHR;
38             (void)SvREFCNT_inc(sv);
39         }
40     }
41     key = AvARRAY(av) - AvALLOC(av);
42     while (key)
43         AvALLOC(av)[--key] = &sv_undef;
44     AvREAL_on(av);
45 }
46
47 void
48 av_extend(AV *av, I32 key)
49 {
50     dTHR;                       /* only necessary if we have to extend stack */
51     MAGIC *mg;
52     if (SvRMAGICAL(av) && (mg = mg_find((SV*)av,'P'))) {
53         dSP;
54         ENTER;
55         SAVETMPS;
56         PUSHSTACK(SI_MAGIC);
57         PUSHMARK(SP);
58         EXTEND(SP,2);
59         PUSHs(mg->mg_obj);
60         PUSHs(sv_2mortal(newSViv(key+1)));
61         PUTBACK;
62         perl_call_method("EXTEND", G_SCALAR|G_DISCARD);
63         POPSTACK();
64         FREETMPS;
65         LEAVE;
66         return;
67     }
68     if (key > AvMAX(av)) {
69         SV** ary;
70         I32 tmp;
71         I32 newmax;
72
73         if (AvALLOC(av) != AvARRAY(av)) {
74             ary = AvALLOC(av) + AvFILLp(av) + 1;
75             tmp = AvARRAY(av) - AvALLOC(av);
76             Move(AvARRAY(av), AvALLOC(av), AvFILLp(av)+1, SV*);
77             AvMAX(av) += tmp;
78             SvPVX(av) = (char*)AvALLOC(av);
79             if (AvREAL(av)) {
80                 while (tmp)
81                     ary[--tmp] = &sv_undef;
82             }
83             
84             if (key > AvMAX(av) - 10) {
85                 newmax = key + AvMAX(av);
86                 goto resize;
87             }
88         }
89         else {
90             if (AvALLOC(av)) {
91 #ifndef STRANGE_MALLOC
92                 U32 bytes;
93 #endif
94
95                 newmax = key + AvMAX(av) / 5;
96               resize:
97 #ifdef STRANGE_MALLOC
98                 Renew(AvALLOC(av),newmax+1, SV*);
99 #else
100                 bytes = (newmax + 1) * sizeof(SV*);
101 #define MALLOC_OVERHEAD 16
102                 tmp = MALLOC_OVERHEAD;
103                 while (tmp - MALLOC_OVERHEAD < bytes)
104                     tmp += tmp;
105                 tmp -= MALLOC_OVERHEAD;
106                 tmp /= sizeof(SV*);
107                 assert(tmp > newmax);
108                 newmax = tmp - 1;
109                 New(2,ary, newmax+1, SV*);
110                 Copy(AvALLOC(av), ary, AvMAX(av)+1, SV*);
111                 if (AvMAX(av) > 64)
112                     offer_nice_chunk(AvALLOC(av), (AvMAX(av)+1) * sizeof(SV*));
113                 else
114                     Safefree(AvALLOC(av));
115                 AvALLOC(av) = ary;
116 #endif
117                 ary = AvALLOC(av) + AvMAX(av) + 1;
118                 tmp = newmax - AvMAX(av);
119                 if (av == curstack) {   /* Oops, grew stack (via av_store()?) */
120                     stack_sp = AvALLOC(av) + (stack_sp - stack_base);
121                     stack_base = AvALLOC(av);
122                     stack_max = stack_base + newmax;
123                 }
124             }
125             else {
126                 newmax = key < 4 ? 4 : key;
127                 New(2,AvALLOC(av), newmax+1, SV*);
128                 ary = AvALLOC(av) + 1;
129                 tmp = newmax;
130                 AvALLOC(av)[0] = &sv_undef;     /* For the stacks */
131             }
132             if (AvREAL(av)) {
133                 while (tmp)
134                     ary[--tmp] = &sv_undef;
135             }
136             
137             SvPVX(av) = (char*)AvALLOC(av);
138             AvMAX(av) = newmax;
139         }
140     }
141 }
142
143 SV**
144 av_fetch(register AV *av, I32 key, I32 lval)
145 {
146     SV *sv;
147
148     if (!av)
149         return 0;
150
151     if (key < 0) {
152         key += AvFILL(av) + 1;
153         if (key < 0)
154             return 0;
155     }
156
157     if (SvRMAGICAL(av)) {
158         if (mg_find((SV*)av,'P')) {
159             dTHR;
160             sv = sv_newmortal();
161             mg_copy((SV*)av, sv, 0, key);
162             av_fetch_sv = sv;
163             return &av_fetch_sv;
164         }
165     }
166
167     if (key > AvFILLp(av)) {
168         if (!lval)
169             return 0;
170         if (AvREALISH(av))
171             sv = NEWSV(5,0);
172         else
173             sv = sv_newmortal();
174         return av_store(av,key,sv);
175     }
176     if (AvARRAY(av)[key] == &sv_undef) {
177     emptyness:
178         if (lval) {
179             sv = NEWSV(6,0);
180             return av_store(av,key,sv);
181         }
182         return 0;
183     }
184     else if (AvREIFY(av)
185              && (!AvARRAY(av)[key]      /* eg. @_ could have freed elts */
186                  || SvTYPE(AvARRAY(av)[key]) == SVTYPEMASK)) {
187         AvARRAY(av)[key] = &sv_undef;   /* 1/2 reify */
188         goto emptyness;
189     }
190     return &AvARRAY(av)[key];
191 }
192
193 SV**
194 av_store(register AV *av, I32 key, SV *val)
195 {
196     SV** ary;
197     U32  fill;
198
199
200     if (!av)
201         return 0;
202     if (!val)
203         val = &sv_undef;
204
205     if (key < 0) {
206         key += AvFILL(av) + 1;
207         if (key < 0)
208             return 0;
209     }
210
211     if (SvREADONLY(av) && key >= AvFILL(av))
212         croak(no_modify);
213
214     if (SvRMAGICAL(av)) {
215         if (mg_find((SV*)av,'P')) {
216             if (val != &sv_undef) {
217                 mg_copy((SV*)av, val, 0, key);
218             }
219             return 0;
220         }
221     }
222
223     if (!AvREAL(av) && AvREIFY(av))
224         av_reify(av);
225     if (key > AvMAX(av))
226         av_extend(av,key);
227     ary = AvARRAY(av);
228     if (AvFILLp(av) < key) {
229         if (!AvREAL(av)) {
230             dTHR;
231             if (av == curstack && key > stack_sp - stack_base)
232                 stack_sp = stack_base + key;    /* XPUSH in disguise */
233             do
234                 ary[++AvFILLp(av)] = &sv_undef;
235             while (AvFILLp(av) < key);
236         }
237         AvFILLp(av) = key;
238     }
239     else if (AvREAL(av))
240         SvREFCNT_dec(ary[key]);
241     ary[key] = val;
242     if (SvSMAGICAL(av)) {
243         if (val != &sv_undef) {
244             MAGIC* mg = SvMAGIC(av);
245             sv_magic(val, (SV*)av, toLOWER(mg->mg_type), 0, key);
246         }
247         mg_set((SV*)av);
248     }
249     return &ary[key];
250 }
251
252 AV *
253 newAV(void)
254 {
255     register AV *av;
256
257     av = (AV*)NEWSV(3,0);
258     sv_upgrade((SV *)av, SVt_PVAV);
259     AvREAL_on(av);
260     AvALLOC(av) = 0;
261     SvPVX(av) = 0;
262     AvMAX(av) = AvFILLp(av) = -1;
263     return av;
264 }
265
266 AV *
267 av_make(register I32 size, register SV **strp)
268 {
269     register AV *av;
270     register I32 i;
271     register SV** ary;
272
273     av = (AV*)NEWSV(8,0);
274     sv_upgrade((SV *) av,SVt_PVAV);
275     AvFLAGS(av) = AVf_REAL;
276     if (size) {         /* `defined' was returning undef for size==0 anyway. */
277         New(4,ary,size,SV*);
278         AvALLOC(av) = ary;
279         SvPVX(av) = (char*)ary;
280         AvFILLp(av) = size - 1;
281         AvMAX(av) = size - 1;
282         for (i = 0; i < size; i++) {
283             assert (*strp);
284             ary[i] = NEWSV(7,0);
285             sv_setsv(ary[i], *strp);
286             strp++;
287         }
288     }
289     return av;
290 }
291
292 AV *
293 av_fake(register I32 size, register SV **strp)
294 {
295     register AV *av;
296     register SV** ary;
297
298     av = (AV*)NEWSV(9,0);
299     sv_upgrade((SV *)av, SVt_PVAV);
300     New(4,ary,size+1,SV*);
301     AvALLOC(av) = ary;
302     Copy(strp,ary,size,SV*);
303     AvFLAGS(av) = AVf_REIFY;
304     SvPVX(av) = (char*)ary;
305     AvFILLp(av) = size - 1;
306     AvMAX(av) = size - 1;
307     while (size--) {
308         assert (*strp);
309         SvTEMP_off(*strp);
310         strp++;
311     }
312     return av;
313 }
314
315 void
316 av_clear(register AV *av)
317 {
318     register I32 key;
319     SV** ary;
320
321 #ifdef DEBUGGING
322     if (SvREFCNT(av) <= 0) {
323         warn("Attempt to clear deleted array");
324     }
325 #endif
326     if (!av)
327         return;
328     /*SUPPRESS 560*/
329
330     /* Give any tie a chance to cleanup first */
331     if (SvRMAGICAL(av))
332         mg_clear((SV*)av); 
333
334     if (AvMAX(av) < 0)
335         return;
336
337     if (AvREAL(av)) {
338         ary = AvARRAY(av);
339         key = AvFILLp(av) + 1;
340         while (key) {
341             SvREFCNT_dec(ary[--key]);
342             ary[key] = &sv_undef;
343         }
344     }
345     if (key = AvARRAY(av) - AvALLOC(av)) {
346         AvMAX(av) += key;
347         SvPVX(av) = (char*)AvALLOC(av);
348     }
349     AvFILLp(av) = -1;
350
351 }
352
353 void
354 av_undef(register AV *av)
355 {
356     register I32 key;
357
358     if (!av)
359         return;
360     /*SUPPRESS 560*/
361
362     /* Give any tie a chance to cleanup first */
363     if (SvRMAGICAL(av) && mg_find((SV*)av,'P')) 
364         av_fill(av, -1);   /* mg_clear() ? */
365
366     if (AvREAL(av)) {
367         key = AvFILLp(av) + 1;
368         while (key)
369             SvREFCNT_dec(AvARRAY(av)[--key]);
370     }
371     Safefree(AvALLOC(av));
372     AvALLOC(av) = 0;
373     SvPVX(av) = 0;
374     AvMAX(av) = AvFILLp(av) = -1;
375     if (AvARYLEN(av)) {
376         SvREFCNT_dec(AvARYLEN(av));
377         AvARYLEN(av) = 0;
378     }
379 }
380
381 void
382 av_push(register AV *av, SV *val)
383 {             
384     MAGIC *mg;
385     if (!av)
386         return;
387     if (SvREADONLY(av))
388         croak(no_modify);
389
390     if (SvRMAGICAL(av) && (mg = mg_find((SV*)av,'P'))) {
391         dSP;
392         PUSHSTACK(SI_MAGIC);
393         PUSHMARK(SP);
394         EXTEND(SP,2);
395         PUSHs(mg->mg_obj);
396         PUSHs(val);
397         PUTBACK;
398         ENTER;
399         perl_call_method("PUSH", G_SCALAR|G_DISCARD);
400         LEAVE;
401         POPSTACK();
402         return;
403     }
404     av_store(av,AvFILLp(av)+1,val);
405 }
406
407 SV *
408 av_pop(register AV *av)
409 {
410     SV *retval;
411     MAGIC* mg;
412
413     if (!av || AvFILL(av) < 0)
414         return &sv_undef;
415     if (SvREADONLY(av))
416         croak(no_modify);
417     if (SvRMAGICAL(av) && (mg = mg_find((SV*)av,'P'))) {
418         dSP;    
419         PUSHSTACK(SI_MAGIC);
420         PUSHMARK(SP);
421         XPUSHs(mg->mg_obj);
422         PUTBACK;
423         ENTER;
424         if (perl_call_method("POP", G_SCALAR)) {
425             retval = newSVsv(*stack_sp--);    
426         } else {    
427             retval = &sv_undef;
428         }
429         LEAVE;
430         POPSTACK();
431         return retval;
432     }
433     retval = AvARRAY(av)[AvFILLp(av)];
434     AvARRAY(av)[AvFILLp(av)--] = &sv_undef;
435     if (SvSMAGICAL(av))
436         mg_set((SV*)av);
437     return retval;
438 }
439
440 void
441 av_unshift(register AV *av, register I32 num)
442 {
443     register I32 i;
444     register SV **ary;
445     MAGIC* mg;
446
447     if (!av || num <= 0)
448         return;
449     if (SvREADONLY(av))
450         croak(no_modify);
451
452     if (SvRMAGICAL(av) && (mg = mg_find((SV*)av,'P'))) {
453         dSP;
454         PUSHSTACK(SI_MAGIC);
455         PUSHMARK(SP);
456         EXTEND(SP,1+num);
457         PUSHs(mg->mg_obj);
458         while (num-- > 0) {
459             PUSHs(&sv_undef);
460         }
461         PUTBACK;
462         ENTER;
463         perl_call_method("UNSHIFT", G_SCALAR|G_DISCARD);
464         LEAVE;
465         POPSTACK();
466         return;
467     }
468
469     if (!AvREAL(av) && AvREIFY(av))
470         av_reify(av);
471     i = AvARRAY(av) - AvALLOC(av);
472     if (i) {
473         if (i > num)
474             i = num;
475         num -= i;
476     
477         AvMAX(av) += i;
478         AvFILLp(av) += i;
479         SvPVX(av) = (char*)(AvARRAY(av) - i);
480     }
481     if (num) {
482         i = AvFILLp(av);
483         av_extend(av, i + num);
484         AvFILLp(av) += num;
485         ary = AvARRAY(av);
486         Move(ary, ary + num, i + 1, SV*);
487         do {
488             ary[--num] = &sv_undef;
489         } while (num);
490     }
491 }
492
493 SV *
494 av_shift(register AV *av)
495 {
496     SV *retval;
497     MAGIC* mg;
498
499     if (!av || AvFILL(av) < 0)
500         return &sv_undef;
501     if (SvREADONLY(av))
502         croak(no_modify);
503     if (SvRMAGICAL(av) && (mg = mg_find((SV*)av,'P'))) {
504         dSP;
505         PUSHSTACK(SI_MAGIC);
506         PUSHMARK(SP);
507         XPUSHs(mg->mg_obj);
508         PUTBACK;
509         ENTER;
510         if (perl_call_method("SHIFT", G_SCALAR)) {
511             retval = newSVsv(*stack_sp--);            
512         } else {    
513             retval = &sv_undef;
514         }     
515         LEAVE;
516         POPSTACK();
517         return retval;
518     }
519     retval = *AvARRAY(av);
520     if (AvREAL(av))
521         *AvARRAY(av) = &sv_undef;
522     SvPVX(av) = (char*)(AvARRAY(av) + 1);
523     AvMAX(av)--;
524     AvFILLp(av)--;
525     if (SvSMAGICAL(av))
526         mg_set((SV*)av);
527     return retval;
528 }
529
530 I32
531 av_len(register AV *av)
532 {
533     return AvFILL(av);
534 }
535
536 void
537 av_fill(register AV *av, I32 fill)
538 {
539     MAGIC *mg;
540     if (!av)
541         croak("panic: null array");
542     if (fill < 0)
543         fill = -1;
544     if (SvRMAGICAL(av) && (mg = mg_find((SV*)av,'P'))) {
545         dSP;            
546         ENTER;
547         SAVETMPS;
548         PUSHSTACK(SI_MAGIC);
549         PUSHMARK(SP);
550         EXTEND(SP,2);
551         PUSHs(mg->mg_obj);
552         PUSHs(sv_2mortal(newSViv(fill+1)));
553         PUTBACK;
554         perl_call_method("STORESIZE", G_SCALAR|G_DISCARD);
555         POPSTACK();
556         FREETMPS;
557         LEAVE;
558         return;
559     }
560     if (fill <= AvMAX(av)) {
561         I32 key = AvFILLp(av);
562         SV** ary = AvARRAY(av);
563
564         if (AvREAL(av)) {
565             while (key > fill) {
566                 SvREFCNT_dec(ary[key]);
567                 ary[key--] = &sv_undef;
568             }
569         }
570         else {
571             while (key < fill)
572                 ary[++key] = &sv_undef;
573         }
574             
575         AvFILLp(av) = fill;
576         if (SvSMAGICAL(av))
577             mg_set((SV*)av);
578     }
579     else
580         (void)av_store(av,fill,&sv_undef);
581 }
582
583   
584 HV*
585 avhv_keys(AV *av)
586 {
587     SV **keysp;
588     HV *keys = Nullhv;
589
590     keysp = av_fetch(av, 0, FALSE);
591     if (keysp) {
592         SV *sv = *keysp;
593         if (SvGMAGICAL(sv))
594             mg_get(sv);
595         if (SvROK(sv)) {
596             sv = SvRV(sv);
597             if (SvTYPE(sv) == SVt_PVHV)
598                 keys = (HV*)sv;
599         }
600     }
601     if (!keys)
602         croak("Can't coerce array into hash");
603     return keys;
604 }
605
606 SV**
607 avhv_fetch(AV *av, char *key, U32 klen, I32 lval)
608 {
609     SV **indsvp;
610     HV *keys = avhv_keys(av);
611     I32 ind;
612     
613     indsvp = hv_fetch(keys, key, klen, FALSE);
614     if (indsvp) {
615         ind = SvIV(*indsvp);
616         if (ind < 1)
617             croak("Bad index while coercing array into hash");
618     } else {
619         if (!lval)
620             return 0;
621         
622         ind = AvFILL(av) + 1;
623         hv_store(keys, key, klen, newSViv(ind), 0);
624     }
625     return av_fetch(av, ind, lval);
626 }
627
628 SV**
629 avhv_fetch_ent(AV *av, SV *keysv, I32 lval, U32 hash)
630 {
631     SV **indsvp;
632     HV *keys = avhv_keys(av);
633     HE *he;
634     I32 ind;
635     
636     he = hv_fetch_ent(keys, keysv, FALSE, hash);
637     if (he) {
638         ind = SvIV(HeVAL(he));
639         if (ind < 1)
640             croak("Bad index while coercing array into hash");
641     } else {
642         if (!lval)
643             return 0;
644         
645         ind = AvFILL(av) + 1;
646         hv_store_ent(keys, keysv, newSViv(ind), 0);
647     }
648     return av_fetch(av, ind, lval);
649 }
650
651 SV**
652 avhv_store(AV *av, char *key, U32 klen, SV *val, U32 hash)
653 {
654     SV **indsvp;
655     HV *keys = avhv_keys(av);
656     I32 ind;
657     
658     indsvp = hv_fetch(keys, key, klen, FALSE);
659     if (indsvp) {
660         ind = SvIV(*indsvp);
661         if (ind < 1)
662             croak("Bad index while coercing array into hash");
663     } else {
664         ind = AvFILL(av) + 1;
665         hv_store(keys, key, klen, newSViv(ind), hash);
666     }
667     return av_store(av, ind, val);
668 }
669
670 SV**
671 avhv_store_ent(AV *av, SV *keysv, SV *val, U32 hash)
672 {
673     HV *keys = avhv_keys(av);
674     HE *he;
675     I32 ind;
676     
677     he = hv_fetch_ent(keys, keysv, FALSE, hash);
678     if (he) {
679         ind = SvIV(HeVAL(he));
680         if (ind < 1)
681             croak("Bad index while coercing array into hash");
682     } else {
683         ind = AvFILL(av) + 1;
684         hv_store_ent(keys, keysv, newSViv(ind), hash);
685     }
686     return av_store(av, ind, val);
687 }
688
689 bool
690 avhv_exists_ent(AV *av, SV *keysv, U32 hash)
691 {
692     HV *keys = avhv_keys(av);
693     return hv_exists_ent(keys, keysv, hash);
694 }
695
696 bool
697 avhv_exists(AV *av, char *key, U32 klen)
698 {
699     HV *keys = avhv_keys(av);
700     return hv_exists(keys, key, klen);
701 }
702
703 /* avhv_delete leaks. Caller can re-index and compress if so desired. */
704 SV *
705 avhv_delete(AV *av, char *key, U32 klen, I32 flags)
706 {
707     HV *keys = avhv_keys(av);
708     SV *sv;
709     SV **svp;
710     I32 ind;
711     
712     sv = hv_delete(keys, key, klen, 0);
713     if (!sv)
714         return Nullsv;
715     ind = SvIV(sv);
716     if (ind < 1)
717         croak("Bad index while coercing array into hash");
718     svp = av_fetch(av, ind, FALSE);
719     if (!svp)
720         return Nullsv;
721     if (flags & G_DISCARD) {
722         sv = Nullsv;
723         SvREFCNT_dec(*svp);
724     } else {
725         sv = sv_2mortal(*svp);
726     }
727     *svp = &sv_undef;
728     return sv;
729 }
730
731 /* avhv_delete_ent leaks. Caller can re-index and compress if so desired. */
732 SV *
733 avhv_delete_ent(AV *av, SV *keysv, I32 flags, U32 hash)
734 {
735     HV *keys = avhv_keys(av);
736     SV *sv;
737     SV **svp;
738     I32 ind;
739     
740     sv = hv_delete_ent(keys, keysv, 0, hash);
741     if (!sv)
742         return Nullsv;
743     ind = SvIV(sv);
744     if (ind < 1)
745         croak("Bad index while coercing array into hash");
746     svp = av_fetch(av, ind, FALSE);
747     if (!svp)
748         return Nullsv;
749     if (flags & G_DISCARD) {
750         sv = Nullsv;
751         SvREFCNT_dec(*svp);
752     } else {
753         sv = sv_2mortal(*svp);
754     }
755     *svp = &sv_undef;
756     return sv;
757 }
758
759 I32
760 avhv_iterinit(AV *av)
761 {
762     HV *keys = avhv_keys(av);
763     return hv_iterinit(keys);
764 }
765
766 HE *
767 avhv_iternext(AV *av)
768 {
769     HV *keys = avhv_keys(av);
770     return hv_iternext(keys);
771 }
772
773 SV *
774 avhv_iterval(AV *av, register HE *entry)
775 {
776     HV *keys = avhv_keys(av);
777     SV *sv;
778     I32 ind;
779     
780     sv = hv_iterval(keys, entry);
781     ind = SvIV(sv);
782     if (ind < 1)
783         croak("Bad index while coercing array into hash");
784     return *av_fetch(av, ind, TRUE);
785 }
786
787 SV *
788 avhv_iternextsv(AV *av, char **key, I32 *retlen)
789 {
790     HV *keys = avhv_keys(av);
791     HE *he;
792     SV *sv;
793     I32 ind;
794     
795     he = hv_iternext(keys);
796     if (!he)
797         return Nullsv;
798     *key = hv_iterkey(he, retlen);
799     sv = hv_iterval(keys, he);
800     ind = SvIV(sv);
801     if (ind < 1)
802         croak("Bad index while coercing array into hash");
803     return *av_fetch(av, ind, TRUE);
804 }