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