This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
tiearray tweaks
[perl5.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     AvARRAY(av) = 0;
368     AvALLOC(av) = 0;
369     SvPVX(av) = 0;
370     AvMAX(av) = AvFILLp(av) = -1;
371     if (AvARYLEN(av)) {
372         SvREFCNT_dec(AvARYLEN(av));
373         AvARYLEN(av) = 0;
374     }
375 }
376
377 void
378 av_push(register AV *av, SV *val)
379 {             
380     MAGIC *mg;
381     if (!av)
382         return;
383     if (SvREADONLY(av))
384         croak(no_modify);
385
386     if (SvRMAGICAL(av) && (mg = mg_find((SV*)av,'P'))) {
387         dSP;
388         PUSHMARK(sp);
389         EXTEND(sp,2);
390         PUSHs(mg->mg_obj);
391         PUSHs(val);
392         PUTBACK;
393         perl_call_method("PUSH", G_SCALAR|G_DISCARD);
394         return;
395     }
396     av_store(av,AvFILLp(av)+1,val);
397 }
398
399 SV *
400 av_pop(register AV *av)
401 {
402     SV *retval;
403     MAGIC* mg;
404
405     if (!av || AvFILL(av) < 0)
406         return &sv_undef;
407     if (SvREADONLY(av))
408         croak(no_modify);
409     if (SvRMAGICAL(av) && (mg = mg_find((SV*)av,'P'))) {
410         dSP;    
411         PUSHMARK(sp);
412         XPUSHs(mg->mg_obj);
413         PUTBACK;
414         if (perl_call_method("POP", G_SCALAR)) {
415             retval = newSVsv(*stack_sp--);    
416         } else {    
417             retval = &sv_undef;
418         }
419         return retval;
420     }
421     retval = AvARRAY(av)[AvFILLp(av)];
422     AvARRAY(av)[AvFILLp(av)--] = &sv_undef;
423     if (SvSMAGICAL(av))
424         mg_set((SV*)av);
425     return retval;
426 }
427
428 void
429 av_unshift(register AV *av, register I32 num)
430 {
431     register I32 i;
432     register SV **sstr,**dstr;
433     MAGIC* mg;
434
435     if (!av || num <= 0)
436         return;
437     if (SvREADONLY(av))
438         croak(no_modify);
439
440     if (SvRMAGICAL(av) && (mg = mg_find((SV*)av,'P'))) {
441         dSP;
442         PUSHMARK(sp);
443         EXTEND(sp,1+num);
444         PUSHs(mg->mg_obj);
445         while (num-- > 0) {
446             PUSHs(&sv_undef);
447         }
448         PUTBACK;
449         perl_call_method("UNSHIFT", G_SCALAR|G_DISCARD);
450         return;
451     }
452
453     if (!AvREAL(av) && AvREIFY(av))
454         av_reify(av);
455     i = AvARRAY(av) - AvALLOC(av);
456     if (i) {
457         if (i > num)
458             i = num;
459         num -= i;
460     
461         AvMAX(av) += i;
462         AvFILLp(av) += i;
463         SvPVX(av) = (char*)(AvARRAY(av) - i);
464     }
465     if (num) {
466         av_extend(av,AvFILLp(av)+num);
467         AvFILLp(av) += num;
468         dstr = AvARRAY(av) + AvFILLp(av);
469         sstr = dstr - num;
470 #ifdef BUGGY_MSC5
471  # pragma loop_opt(off) /* don't loop-optimize the following code */
472 #endif /* BUGGY_MSC5 */
473         for (i = AvFILLp(av) - num; i >= 0; --i) {
474             *dstr-- = *sstr--;
475 #ifdef BUGGY_MSC5
476  # pragma loop_opt()    /* loop-optimization back to command-line setting */
477 #endif /* BUGGY_MSC5 */
478         }
479         while (num)
480             AvARRAY(av)[--num] = &sv_undef;
481     }
482 }
483
484 SV *
485 av_shift(register AV *av)
486 {
487     SV *retval;
488     MAGIC* mg;
489
490     if (!av || AvFILL(av) < 0)
491         return &sv_undef;
492     if (SvREADONLY(av))
493         croak(no_modify);
494     if (SvRMAGICAL(av) && (mg = mg_find((SV*)av,'P'))) {
495         dSP;
496         PUSHMARK(sp);
497         XPUSHs(mg->mg_obj);
498         PUTBACK;
499         if (perl_call_method("SHIFT", G_SCALAR)) {
500             retval = newSVsv(*stack_sp--);            
501         } else {    
502             retval = &sv_undef;
503         }
504         return retval;
505     }
506     retval = *AvARRAY(av);
507     if (AvREAL(av))
508         *AvARRAY(av) = &sv_undef;
509     SvPVX(av) = (char*)(AvARRAY(av) + 1);
510     AvMAX(av)--;
511     AvFILLp(av)--;
512     if (SvSMAGICAL(av))
513         mg_set((SV*)av);
514     return retval;
515 }
516
517 I32
518 av_len(register AV *av)
519 {
520     return AvFILL(av);
521 }
522
523 void
524 av_fill(register AV *av, I32 fill)
525 {
526     MAGIC *mg;
527     if (!av)
528         croak("panic: null array");
529     if (fill < 0)
530         fill = -1;
531     if (SvRMAGICAL(av) && (mg = mg_find((SV*)av,'P'))) {
532         dSP;            
533         ENTER;
534         SAVETMPS;
535         PUSHMARK(sp);
536         EXTEND(sp,2);
537         PUSHs(mg->mg_obj);
538         PUSHs(sv_2mortal(newSViv(fill)));
539         PUTBACK;
540         perl_call_method("STORESIZE", G_SCALAR|G_DISCARD);
541         FREETMPS;
542         LEAVE;
543         return;
544     }
545     if (fill <= AvMAX(av)) {
546         I32 key = AvFILLp(av);
547         SV** ary = AvARRAY(av);
548
549         if (AvREAL(av)) {
550             while (key > fill) {
551                 SvREFCNT_dec(ary[key]);
552                 ary[key--] = &sv_undef;
553             }
554         }
555         else {
556             while (key < fill)
557                 ary[++key] = &sv_undef;
558         }
559             
560         AvFILLp(av) = fill;
561         if (SvSMAGICAL(av))
562             mg_set((SV*)av);
563     }
564     else
565         (void)av_store(av,fill,&sv_undef);
566 }
567
568   
569 HV*
570 avhv_keys(AV *av)
571 {
572     SV **keysp;
573     HV *keys = Nullhv;
574
575     keysp = av_fetch(av, 0, FALSE);
576     if (keysp) {
577         SV *sv = *keysp;
578         if (SvGMAGICAL(sv))
579             mg_get(sv);
580         if (SvROK(sv)) {
581             sv = SvRV(sv);
582             if (SvTYPE(sv) == SVt_PVHV)
583                 keys = (HV*)sv;
584         }
585     }
586     if (!keys)
587         croak("Can't coerce array into hash");
588     return keys;
589 }
590
591 SV**
592 avhv_fetch(AV *av, char *key, U32 klen, I32 lval)
593 {
594     SV **indsvp;
595     HV *keys = avhv_keys(av);
596     I32 ind;
597     
598     indsvp = hv_fetch(keys, key, klen, FALSE);
599     if (indsvp) {
600         ind = SvIV(*indsvp);
601         if (ind < 1)
602             croak("Bad index while coercing array into hash");
603     } else {
604         if (!lval)
605             return 0;
606         
607         ind = AvFILL(av) + 1;
608         hv_store(keys, key, klen, newSViv(ind), 0);
609     }
610     return av_fetch(av, ind, lval);
611 }
612
613 SV**
614 avhv_fetch_ent(AV *av, SV *keysv, I32 lval, U32 hash)
615 {
616     SV **indsvp;
617     HV *keys = avhv_keys(av);
618     HE *he;
619     I32 ind;
620     
621     he = hv_fetch_ent(keys, keysv, FALSE, hash);
622     if (he) {
623         ind = SvIV(HeVAL(he));
624         if (ind < 1)
625             croak("Bad index while coercing array into hash");
626     } else {
627         if (!lval)
628             return 0;
629         
630         ind = AvFILL(av) + 1;
631         hv_store_ent(keys, keysv, newSViv(ind), 0);
632     }
633     return av_fetch(av, ind, lval);
634 }
635
636 SV**
637 avhv_store(AV *av, char *key, U32 klen, SV *val, U32 hash)
638 {
639     SV **indsvp;
640     HV *keys = avhv_keys(av);
641     I32 ind;
642     
643     indsvp = hv_fetch(keys, key, klen, FALSE);
644     if (indsvp) {
645         ind = SvIV(*indsvp);
646         if (ind < 1)
647             croak("Bad index while coercing array into hash");
648     } else {
649         ind = AvFILL(av) + 1;
650         hv_store(keys, key, klen, newSViv(ind), hash);
651     }
652     return av_store(av, ind, val);
653 }
654
655 SV**
656 avhv_store_ent(AV *av, SV *keysv, SV *val, U32 hash)
657 {
658     HV *keys = avhv_keys(av);
659     HE *he;
660     I32 ind;
661     
662     he = hv_fetch_ent(keys, keysv, FALSE, hash);
663     if (he) {
664         ind = SvIV(HeVAL(he));
665         if (ind < 1)
666             croak("Bad index while coercing array into hash");
667     } else {
668         ind = AvFILL(av) + 1;
669         hv_store_ent(keys, keysv, newSViv(ind), hash);
670     }
671     return av_store(av, ind, val);
672 }
673
674 bool
675 avhv_exists_ent(AV *av, SV *keysv, U32 hash)
676 {
677     HV *keys = avhv_keys(av);
678     return hv_exists_ent(keys, keysv, hash);
679 }
680
681 bool
682 avhv_exists(AV *av, char *key, U32 klen)
683 {
684     HV *keys = avhv_keys(av);
685     return hv_exists(keys, key, klen);
686 }
687
688 /* avhv_delete leaks. Caller can re-index and compress if so desired. */
689 SV *
690 avhv_delete(AV *av, char *key, U32 klen, I32 flags)
691 {
692     HV *keys = avhv_keys(av);
693     SV *sv;
694     SV **svp;
695     I32 ind;
696     
697     sv = hv_delete(keys, key, klen, 0);
698     if (!sv)
699         return Nullsv;
700     ind = SvIV(sv);
701     if (ind < 1)
702         croak("Bad index while coercing array into hash");
703     svp = av_fetch(av, ind, FALSE);
704     if (!svp)
705         return Nullsv;
706     if (flags & G_DISCARD) {
707         sv = Nullsv;
708         SvREFCNT_dec(*svp);
709     } else {
710         sv = sv_2mortal(*svp);
711     }
712     *svp = &sv_undef;
713     return sv;
714 }
715
716 /* avhv_delete_ent leaks. Caller can re-index and compress if so desired. */
717 SV *
718 avhv_delete_ent(AV *av, SV *keysv, I32 flags, U32 hash)
719 {
720     HV *keys = avhv_keys(av);
721     SV *sv;
722     SV **svp;
723     I32 ind;
724     
725     sv = hv_delete_ent(keys, keysv, 0, hash);
726     if (!sv)
727         return Nullsv;
728     ind = SvIV(sv);
729     if (ind < 1)
730         croak("Bad index while coercing array into hash");
731     svp = av_fetch(av, ind, FALSE);
732     if (!svp)
733         return Nullsv;
734     if (flags & G_DISCARD) {
735         sv = Nullsv;
736         SvREFCNT_dec(*svp);
737     } else {
738         sv = sv_2mortal(*svp);
739     }
740     *svp = &sv_undef;
741     return sv;
742 }
743
744 I32
745 avhv_iterinit(AV *av)
746 {
747     HV *keys = avhv_keys(av);
748     return hv_iterinit(keys);
749 }
750
751 HE *
752 avhv_iternext(AV *av)
753 {
754     HV *keys = avhv_keys(av);
755     return hv_iternext(keys);
756 }
757
758 SV *
759 avhv_iterval(AV *av, register HE *entry)
760 {
761     HV *keys = avhv_keys(av);
762     SV *sv;
763     I32 ind;
764     
765     sv = hv_iterval(keys, entry);
766     ind = SvIV(sv);
767     if (ind < 1)
768         croak("Bad index while coercing array into hash");
769     return *av_fetch(av, ind, TRUE);
770 }
771
772 SV *
773 avhv_iternextsv(AV *av, char **key, I32 *retlen)
774 {
775     HV *keys = avhv_keys(av);
776     HE *he;
777     SV *sv;
778     I32 ind;
779     
780     he = hv_iternext(keys);
781     if (!he)
782         return Nullsv;
783     *key = hv_iterkey(he, retlen);
784     sv = hv_iterval(keys, he);
785     ind = SvIV(sv);
786     if (ind < 1)
787         croak("Bad index while coercing array into hash");
788     return *av_fetch(av, ind, TRUE);
789 }