Update IPC SysV test from blead (hopefully is more graceful under duress)
[perl.git] / av.c
1 /*    av.c
2  *
3  *    Copyright (c) 1991-1999, 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 (SvTIED_mg((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] = &PL_sv_undef;
33     while (key) {
34         sv = AvARRAY(av)[--key];
35         assert(sv);
36         if (sv != &PL_sv_undef) {
37             dTHR;
38             (void)SvREFCNT_inc(sv);
39         }
40     }
41     key = AvARRAY(av) - AvALLOC(av);
42     while (key)
43         AvALLOC(av)[--key] = &PL_sv_undef;
44     AvREIFY_off(av);
45     AvREAL_on(av);
46 }
47
48 void
49 av_extend(AV *av, I32 key)
50 {
51     dTHR;                       /* only necessary if we have to extend stack */
52     MAGIC *mg;
53     if (mg = SvTIED_mg((SV*)av, 'P')) {
54         dSP;
55         ENTER;
56         SAVETMPS;
57         PUSHSTACKi(PERLSI_MAGIC);
58         PUSHMARK(SP);
59         EXTEND(SP,2);
60         PUSHs(SvTIED_obj((SV*)av, mg));
61         PUSHs(sv_2mortal(newSViv(key+1)));
62         PUTBACK;
63         perl_call_method("EXTEND", G_SCALAR|G_DISCARD);
64         POPSTACK;
65         FREETMPS;
66         LEAVE;
67         return;
68     }
69     if (key > AvMAX(av)) {
70         SV** ary;
71         I32 tmp;
72         I32 newmax;
73
74         if (AvALLOC(av) != AvARRAY(av)) {
75             ary = AvALLOC(av) + AvFILLp(av) + 1;
76             tmp = AvARRAY(av) - AvALLOC(av);
77             Move(AvARRAY(av), AvALLOC(av), AvFILLp(av)+1, SV*);
78             AvMAX(av) += tmp;
79             SvPVX(av) = (char*)AvALLOC(av);
80             if (AvREAL(av)) {
81                 while (tmp)
82                     ary[--tmp] = &PL_sv_undef;
83             }
84             
85             if (key > AvMAX(av) - 10) {
86                 newmax = key + AvMAX(av);
87                 goto resize;
88             }
89         }
90         else {
91             if (AvALLOC(av)) {
92 #ifndef STRANGE_MALLOC
93                 U32 bytes;
94 #endif
95
96 #if defined(MYMALLOC) && !defined(PURIFY) && !defined(LEAKTEST)
97                 newmax = malloced_size((void*)AvALLOC(av))/sizeof(SV*) - 1;
98
99                 if (key <= newmax) 
100                     goto resized;
101 #endif 
102                 newmax = key + AvMAX(av) / 5;
103               resize:
104 #if defined(STRANGE_MALLOC) || defined(MYMALLOC)
105                 Renew(AvALLOC(av),newmax+1, SV*);
106 #else
107                 bytes = (newmax + 1) * sizeof(SV*);
108 #define MALLOC_OVERHEAD 16
109                 tmp = MALLOC_OVERHEAD;
110                 while (tmp - MALLOC_OVERHEAD < bytes)
111                     tmp += tmp;
112                 tmp -= MALLOC_OVERHEAD;
113                 tmp /= sizeof(SV*);
114                 assert(tmp > newmax);
115                 newmax = tmp - 1;
116                 New(2,ary, newmax+1, SV*);
117                 Copy(AvALLOC(av), ary, AvMAX(av)+1, SV*);
118                 if (AvMAX(av) > 64)
119                     offer_nice_chunk(AvALLOC(av), (AvMAX(av)+1) * sizeof(SV*));
120                 else
121                     Safefree(AvALLOC(av));
122                 AvALLOC(av) = ary;
123 #endif
124               resized:
125                 ary = AvALLOC(av) + AvMAX(av) + 1;
126                 tmp = newmax - AvMAX(av);
127                 if (av == PL_curstack) {        /* Oops, grew stack (via av_store()?) */
128                     PL_stack_sp = AvALLOC(av) + (PL_stack_sp - PL_stack_base);
129                     PL_stack_base = AvALLOC(av);
130                     PL_stack_max = PL_stack_base + newmax;
131                 }
132             }
133             else {
134                 newmax = key < 3 ? 3 : key;
135                 New(2,AvALLOC(av), newmax+1, SV*);
136                 ary = AvALLOC(av) + 1;
137                 tmp = newmax;
138                 AvALLOC(av)[0] = &PL_sv_undef;  /* For the stacks */
139             }
140             if (AvREAL(av)) {
141                 while (tmp)
142                     ary[--tmp] = &PL_sv_undef;
143             }
144             
145             SvPVX(av) = (char*)AvALLOC(av);
146             AvMAX(av) = newmax;
147         }
148     }
149 }
150
151 SV**
152 av_fetch(register AV *av, I32 key, I32 lval)
153 {
154     SV *sv;
155
156     if (!av)
157         return 0;
158
159     if (key < 0) {
160         key += AvFILL(av) + 1;
161         if (key < 0)
162             return 0;
163     }
164
165     if (SvRMAGICAL(av)) {
166         if (mg_find((SV*)av,'P')) {
167             dTHR;
168             sv = sv_newmortal();
169             mg_copy((SV*)av, sv, 0, key);
170             PL_av_fetch_sv = sv;
171             return &PL_av_fetch_sv;
172         }
173     }
174
175     if (key > AvFILLp(av)) {
176         if (!lval)
177             return 0;
178         sv = NEWSV(5,0);
179         return av_store(av,key,sv);
180     }
181     if (AvARRAY(av)[key] == &PL_sv_undef) {
182     emptyness:
183         if (lval) {
184             sv = NEWSV(6,0);
185             return av_store(av,key,sv);
186         }
187         return 0;
188     }
189     else if (AvREIFY(av)
190              && (!AvARRAY(av)[key]      /* eg. @_ could have freed elts */
191                  || SvTYPE(AvARRAY(av)[key]) == SVTYPEMASK)) {
192         AvARRAY(av)[key] = &PL_sv_undef;        /* 1/2 reify */
193         goto emptyness;
194     }
195     return &AvARRAY(av)[key];
196 }
197
198 SV**
199 av_store(register AV *av, I32 key, SV *val)
200 {
201     SV** ary;
202     U32  fill;
203
204
205     if (!av)
206         return 0;
207     if (!val)
208         val = &PL_sv_undef;
209
210     if (key < 0) {
211         key += AvFILL(av) + 1;
212         if (key < 0)
213             return 0;
214     }
215
216     if (SvREADONLY(av) && key >= AvFILL(av))
217         croak(no_modify);
218
219     if (SvRMAGICAL(av)) {
220         if (mg_find((SV*)av,'P')) {
221             if (val != &PL_sv_undef) {
222                 mg_copy((SV*)av, val, 0, key);
223             }
224             return 0;
225         }
226     }
227
228     if (!AvREAL(av) && AvREIFY(av))
229         av_reify(av);
230     if (key > AvMAX(av))
231         av_extend(av,key);
232     ary = AvARRAY(av);
233     if (AvFILLp(av) < key) {
234         if (!AvREAL(av)) {
235             dTHR;
236             if (av == PL_curstack && key > PL_stack_sp - PL_stack_base)
237                 PL_stack_sp = PL_stack_base + key;      /* XPUSH in disguise */
238             do
239                 ary[++AvFILLp(av)] = &PL_sv_undef;
240             while (AvFILLp(av) < key);
241         }
242         AvFILLp(av) = key;
243     }
244     else if (AvREAL(av))
245         SvREFCNT_dec(ary[key]);
246     ary[key] = val;
247     if (SvSMAGICAL(av)) {
248         if (val != &PL_sv_undef) {
249             MAGIC* mg = SvMAGIC(av);
250             sv_magic(val, (SV*)av, toLOWER(mg->mg_type), 0, key);
251         }
252         mg_set((SV*)av);
253     }
254     return &ary[key];
255 }
256
257 AV *
258 newAV(void)
259 {
260     register AV *av;
261
262     av = (AV*)NEWSV(3,0);
263     sv_upgrade((SV *)av, SVt_PVAV);
264     AvREAL_on(av);
265     AvALLOC(av) = 0;
266     SvPVX(av) = 0;
267     AvMAX(av) = AvFILLp(av) = -1;
268     return av;
269 }
270
271 AV *
272 av_make(register I32 size, register SV **strp)
273 {
274     register AV *av;
275     register I32 i;
276     register SV** ary;
277
278     av = (AV*)NEWSV(8,0);
279     sv_upgrade((SV *) av,SVt_PVAV);
280     AvFLAGS(av) = AVf_REAL;
281     if (size) {         /* `defined' was returning undef for size==0 anyway. */
282         New(4,ary,size,SV*);
283         AvALLOC(av) = ary;
284         SvPVX(av) = (char*)ary;
285         AvFILLp(av) = size - 1;
286         AvMAX(av) = size - 1;
287         for (i = 0; i < size; i++) {
288             assert (*strp);
289             ary[i] = NEWSV(7,0);
290             sv_setsv(ary[i], *strp);
291             strp++;
292         }
293     }
294     return av;
295 }
296
297 AV *
298 av_fake(register I32 size, register SV **strp)
299 {
300     register AV *av;
301     register SV** ary;
302
303     av = (AV*)NEWSV(9,0);
304     sv_upgrade((SV *)av, SVt_PVAV);
305     New(4,ary,size+1,SV*);
306     AvALLOC(av) = ary;
307     Copy(strp,ary,size,SV*);
308     AvFLAGS(av) = AVf_REIFY;
309     SvPVX(av) = (char*)ary;
310     AvFILLp(av) = size - 1;
311     AvMAX(av) = size - 1;
312     while (size--) {
313         assert (*strp);
314         SvTEMP_off(*strp);
315         strp++;
316     }
317     return av;
318 }
319
320 void
321 av_clear(register AV *av)
322 {
323     register I32 key;
324     SV** ary;
325
326 #ifdef DEBUGGING
327     if (SvREFCNT(av) <= 0) {
328         warn("Attempt to clear deleted array");
329     }
330 #endif
331     if (!av)
332         return;
333     /*SUPPRESS 560*/
334
335     if (SvREADONLY(av))
336         croak(no_modify);
337
338     /* Give any tie a chance to cleanup first */
339     if (SvRMAGICAL(av))
340         mg_clear((SV*)av); 
341
342     if (AvMAX(av) < 0)
343         return;
344
345     if (AvREAL(av)) {
346         ary = AvARRAY(av);
347         key = AvFILLp(av) + 1;
348         while (key) {
349             SvREFCNT_dec(ary[--key]);
350             ary[key] = &PL_sv_undef;
351         }
352     }
353     if (key = AvARRAY(av) - AvALLOC(av)) {
354         AvMAX(av) += key;
355         SvPVX(av) = (char*)AvALLOC(av);
356     }
357     AvFILLp(av) = -1;
358
359 }
360
361 void
362 av_undef(register AV *av)
363 {
364     register I32 key;
365
366     if (!av)
367         return;
368     /*SUPPRESS 560*/
369
370     /* Give any tie a chance to cleanup first */
371     if (SvTIED_mg((SV*)av, 'P')) 
372         av_fill(av, -1);   /* mg_clear() ? */
373
374     if (AvREAL(av)) {
375         key = AvFILLp(av) + 1;
376         while (key)
377             SvREFCNT_dec(AvARRAY(av)[--key]);
378     }
379     Safefree(AvALLOC(av));
380     AvALLOC(av) = 0;
381     SvPVX(av) = 0;
382     AvMAX(av) = AvFILLp(av) = -1;
383     if (AvARYLEN(av)) {
384         SvREFCNT_dec(AvARYLEN(av));
385         AvARYLEN(av) = 0;
386     }
387 }
388
389 void
390 av_push(register AV *av, SV *val)
391 {             
392     MAGIC *mg;
393     if (!av)
394         return;
395     if (SvREADONLY(av))
396         croak(no_modify);
397
398     if (mg = SvTIED_mg((SV*)av, 'P')) {
399         dSP;
400         PUSHSTACKi(PERLSI_MAGIC);
401         PUSHMARK(SP);
402         EXTEND(SP,2);
403         PUSHs(SvTIED_obj((SV*)av, mg));
404         PUSHs(val);
405         PUTBACK;
406         ENTER;
407         perl_call_method("PUSH", G_SCALAR|G_DISCARD);
408         LEAVE;
409         POPSTACK;
410         return;
411     }
412     av_store(av,AvFILLp(av)+1,val);
413 }
414
415 SV *
416 av_pop(register AV *av)
417 {
418     SV *retval;
419     MAGIC* mg;
420
421     if (!av || AvFILL(av) < 0)
422         return &PL_sv_undef;
423     if (SvREADONLY(av))
424         croak(no_modify);
425     if (mg = SvTIED_mg((SV*)av, 'P')) {
426         dSP;    
427         PUSHSTACKi(PERLSI_MAGIC);
428         PUSHMARK(SP);
429         XPUSHs(SvTIED_obj((SV*)av, mg));
430         PUTBACK;
431         ENTER;
432         if (perl_call_method("POP", G_SCALAR)) {
433             retval = newSVsv(*PL_stack_sp--);    
434         } else {    
435             retval = &PL_sv_undef;
436         }
437         LEAVE;
438         POPSTACK;
439         return retval;
440     }
441     retval = AvARRAY(av)[AvFILLp(av)];
442     AvARRAY(av)[AvFILLp(av)--] = &PL_sv_undef;
443     if (SvSMAGICAL(av))
444         mg_set((SV*)av);
445     return retval;
446 }
447
448 void
449 av_unshift(register AV *av, register I32 num)
450 {
451     register I32 i;
452     register SV **ary;
453     MAGIC* mg;
454
455     if (!av || num <= 0)
456         return;
457     if (SvREADONLY(av))
458         croak(no_modify);
459
460     if (mg = SvTIED_mg((SV*)av, 'P')) {
461         dSP;
462         PUSHSTACKi(PERLSI_MAGIC);
463         PUSHMARK(SP);
464         EXTEND(SP,1+num);
465         PUSHs(SvTIED_obj((SV*)av, mg));
466         while (num-- > 0) {
467             PUSHs(&PL_sv_undef);
468         }
469         PUTBACK;
470         ENTER;
471         perl_call_method("UNSHIFT", G_SCALAR|G_DISCARD);
472         LEAVE;
473         POPSTACK;
474         return;
475     }
476
477     if (!AvREAL(av) && AvREIFY(av))
478         av_reify(av);
479     i = AvARRAY(av) - AvALLOC(av);
480     if (i) {
481         if (i > num)
482             i = num;
483         num -= i;
484     
485         AvMAX(av) += i;
486         AvFILLp(av) += i;
487         SvPVX(av) = (char*)(AvARRAY(av) - i);
488     }
489     if (num) {
490         i = AvFILLp(av);
491         av_extend(av, i + num);
492         AvFILLp(av) += num;
493         ary = AvARRAY(av);
494         Move(ary, ary + num, i + 1, SV*);
495         do {
496             ary[--num] = &PL_sv_undef;
497         } while (num);
498     }
499 }
500
501 SV *
502 av_shift(register AV *av)
503 {
504     SV *retval;
505     MAGIC* mg;
506
507     if (!av || AvFILL(av) < 0)
508         return &PL_sv_undef;
509     if (SvREADONLY(av))
510         croak(no_modify);
511     if (mg = SvTIED_mg((SV*)av, 'P')) {
512         dSP;
513         PUSHSTACKi(PERLSI_MAGIC);
514         PUSHMARK(SP);
515         XPUSHs(SvTIED_obj((SV*)av, mg));
516         PUTBACK;
517         ENTER;
518         if (perl_call_method("SHIFT", G_SCALAR)) {
519             retval = newSVsv(*PL_stack_sp--);            
520         } else {    
521             retval = &PL_sv_undef;
522         }     
523         LEAVE;
524         POPSTACK;
525         return retval;
526     }
527     retval = *AvARRAY(av);
528     if (AvREAL(av))
529         *AvARRAY(av) = &PL_sv_undef;
530     SvPVX(av) = (char*)(AvARRAY(av) + 1);
531     AvMAX(av)--;
532     AvFILLp(av)--;
533     if (SvSMAGICAL(av))
534         mg_set((SV*)av);
535     return retval;
536 }
537
538 I32
539 av_len(register AV *av)
540 {
541     return AvFILL(av);
542 }
543
544 void
545 av_fill(register AV *av, I32 fill)
546 {
547     MAGIC *mg;
548     if (!av)
549         croak("panic: null array");
550     if (fill < 0)
551         fill = -1;
552     if (mg = SvTIED_mg((SV*)av, 'P')) {
553         dSP;            
554         ENTER;
555         SAVETMPS;
556         PUSHSTACKi(PERLSI_MAGIC);
557         PUSHMARK(SP);
558         EXTEND(SP,2);
559         PUSHs(SvTIED_obj((SV*)av, mg));
560         PUSHs(sv_2mortal(newSViv(fill+1)));
561         PUTBACK;
562         perl_call_method("STORESIZE", G_SCALAR|G_DISCARD);
563         POPSTACK;
564         FREETMPS;
565         LEAVE;
566         return;
567     }
568     if (fill <= AvMAX(av)) {
569         I32 key = AvFILLp(av);
570         SV** ary = AvARRAY(av);
571
572         if (AvREAL(av)) {
573             while (key > fill) {
574                 SvREFCNT_dec(ary[key]);
575                 ary[key--] = &PL_sv_undef;
576             }
577         }
578         else {
579             while (key < fill)
580                 ary[++key] = &PL_sv_undef;
581         }
582             
583         AvFILLp(av) = fill;
584         if (SvSMAGICAL(av))
585             mg_set((SV*)av);
586     }
587     else
588         (void)av_store(av,fill,&PL_sv_undef);
589 }
590
591
592 /* AVHV: Support for treating arrays as if they were hashes.  The
593  * first element of the array should be a hash reference that maps
594  * hash keys to array indices.
595  */
596
597 STATIC I32
598 avhv_index_sv(SV* sv)
599 {
600     I32 index = SvIV(sv);
601     if (index < 1)
602         croak("Bad index while coercing array into hash");
603     return index;    
604 }
605
606 HV*
607 avhv_keys(AV *av)
608 {
609     SV **keysp = av_fetch(av, 0, FALSE);
610     if (keysp) {
611         SV *sv = *keysp;
612         if (SvGMAGICAL(sv))
613             mg_get(sv);
614         if (SvROK(sv)) {
615             sv = SvRV(sv);
616             if (SvTYPE(sv) == SVt_PVHV)
617                 return (HV*)sv;
618         }
619     }
620     croak("Can't coerce array into hash");
621     return Nullhv;
622 }
623
624 SV**
625 avhv_fetch_ent(AV *av, SV *keysv, I32 lval, U32 hash)
626 {
627     SV **indsvp;
628     HV *keys = avhv_keys(av);
629     HE *he;
630     
631     he = hv_fetch_ent(keys, keysv, FALSE, hash);
632     if (!he)
633         croak("No such array field");
634     return av_fetch(av, avhv_index_sv(HeVAL(he)), lval);
635 }
636
637 bool
638 avhv_exists_ent(AV *av, SV *keysv, U32 hash)
639 {
640     HV *keys = avhv_keys(av);
641     return hv_exists_ent(keys, keysv, hash);
642 }
643
644 HE *
645 avhv_iternext(AV *av)
646 {
647     HV *keys = avhv_keys(av);
648     return hv_iternext(keys);
649 }
650
651 SV *
652 avhv_iterval(AV *av, register HE *entry)
653 {
654     SV *sv = hv_iterval(avhv_keys(av), entry);
655     return *av_fetch(av, avhv_index_sv(sv), TRUE);
656 }