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