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