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