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