This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Adds support for hashes. Neither hashes nor arrays can contain references yet.
[perl5.git] / ext / threads / shared / shared.xs
1
2 #include "EXTERN.h"
3 #include "perl.h"
4 #include "XSUB.h"
5
6
7 void shared_sv_attach_sv (SV* sv, shared_sv* shared) {
8     HV* shared_hv = get_hv("threads::shared::shared", FALSE);
9     SV* id = newSViv((IV)shared);
10     STRLEN length = sv_len(id);
11     SV* tiedobject;
12     SV** tiedobject_ = hv_fetch(shared_hv, SvPV(id,length), length, 0);
13     if(tiedobject_) {
14         tiedobject = (*tiedobject_);
15         SvROK_on(sv);
16         SvRV(sv) = SvRV(tiedobject);
17
18     } else {
19         croak("die\n");
20     }
21 }
22
23
24 int shared_sv_fetch_mg (pTHX_ SV* sv, MAGIC *mg) {
25     shared_sv* shared = (shared_sv*) SvIV(mg->mg_obj);
26     SHAREDSvLOCK(shared);
27     if(mg->mg_private != shared->index) {
28         if(SvROK(SHAREDSvGET(shared))) {
29             shared_sv* target = (shared_sv*) SvIV(SvRV(SHAREDSvGET(shared)));
30             shared_sv_attach_sv(sv, target);
31         } else {
32             sv_setsv(sv, SHAREDSvGET(shared));
33         }
34         mg->mg_private = shared->index;
35     }
36     SHAREDSvUNLOCK(shared);
37
38     return 0;
39 }
40
41 int shared_sv_store_mg (pTHX_ SV* sv, MAGIC *mg) {
42     shared_sv* shared = (shared_sv*) SvIV(mg->mg_obj);
43     SHAREDSvLOCK(shared);
44     if(SvROK(SHAREDSvGET(shared)))
45         Perl_sharedsv_thrcnt_dec(aTHX_ (shared_sv*) SvIV(SvRV(SHAREDSvGET(shared))));
46     if(SvROK(sv)) {
47         shared_sv* target = Perl_sharedsv_find(aTHX_ SvRV(sv));
48         if(!target) {
49             SHAREDSvRELEASE(shared);
50             sv_setsv(sv,SHAREDSvGET(shared));
51             SHAREDSvUNLOCK(shared);            
52             Perl_croak(aTHX_ "You cannot assign a non shared reference to a shared scalar");
53         }
54         SHAREDSvEDIT(shared);
55         Perl_sv_free(PL_sharedsv_space,SHAREDSvGET(shared));
56         SHAREDSvGET(shared) = newRV_noinc(newSViv((IV)target));
57     } else {
58             SHAREDSvEDIT(shared);
59         sv_setsv(SHAREDSvGET(shared), sv);
60     }
61     shared->index++;
62     mg->mg_private = shared->index;
63     SHAREDSvRELEASE(shared);
64     if(SvROK(SHAREDSvGET(shared)))
65        Perl_sharedsv_thrcnt_inc(aTHX_ (shared_sv*) SvIV(SvRV(SHAREDSvGET(shared))));       
66     SHAREDSvUNLOCK(shared);
67     return 0;
68 }
69
70 int shared_sv_destroy_mg (pTHX_ SV* sv, MAGIC *mg) {
71     shared_sv* shared = (shared_sv*) SvIV(mg->mg_obj);
72     if(!shared) 
73         return 0;
74     Perl_sharedsv_thrcnt_dec(aTHX_ shared);
75 }
76
77 MGVTBL svtable = {MEMBER_TO_FPTR(shared_sv_fetch_mg),
78                   MEMBER_TO_FPTR(shared_sv_store_mg),
79                   0,
80                   0,
81                   MEMBER_TO_FPTR(shared_sv_destroy_mg)
82 };
83
84 MODULE = threads::shared                PACKAGE = threads::shared               
85
86
87 PROTOTYPES: DISABLE
88
89
90 SV*
91 ptr(ref)
92         SV* ref
93         CODE:
94         RETVAL = newSViv(SvIV(SvRV(ref)));
95         OUTPUT:
96         RETVAL
97
98
99 SV*
100 _thrcnt(ref)
101         SV* ref
102         CODE:
103         shared_sv* shared = Perl_sharedsv_find(aTHX, ref);
104         if(!shared)
105            croak("thrcnt can only be used on shared values");
106         SHAREDSvLOCK(shared);
107         RETVAL = newSViv(SvREFCNT(SHAREDSvGET(shared)));
108         SHAREDSvUNLOCK(shared);
109         OUTPUT:
110         RETVAL   
111
112
113 void
114 thrcnt_inc(ref)
115         SV* ref
116         CODE:
117         shared_sv* shared;
118         if(SvROK(ref)) 
119             ref = SvRV(ref);
120         shared = Perl_sharedsv_find(aTHX, ref);
121         if(!shared)
122            croak("thrcnt can only be used on shared values");
123         Perl_sharedsv_thrcnt_inc(aTHX_ shared);
124
125
126 MODULE = threads::shared                PACKAGE = threads::shared::sv           
127
128 SV*
129 new(class, value)
130         SV* class
131         SV* value
132         CODE:
133         shared_sv* shared = Perl_sharedsv_new(aTHX);
134         MAGIC* shared_magic;
135         SV* obj = newSViv((IV)shared);
136         SHAREDSvEDIT(shared);
137         SHAREDSvGET(shared) = newSVsv(value);
138         SHAREDSvRELEASE(shared);
139         sv_magic(value, 0, PERL_MAGIC_ext, "threads::shared", 16);
140         shared_magic = mg_find(value, PERL_MAGIC_ext);
141         shared_magic->mg_virtual = &svtable;
142         shared_magic->mg_obj = newSViv((IV)shared);
143         shared_magic->mg_flags |= MGf_REFCOUNTED;
144         shared_magic->mg_private = 0;
145         SvMAGICAL_on(value);
146         RETVAL = obj;
147         OUTPUT:         
148         RETVAL
149
150
151 MODULE = threads::shared                PACKAGE = threads::shared::av
152
153 SV* 
154 new(class, value)
155         SV* class
156         SV* value
157         CODE:
158         shared_sv* shared = Perl_sharedsv_new(aTHX);
159         SV* obj = newSViv((IV)shared);
160         SHAREDSvEDIT(shared);
161         SHAREDSvGET(shared) = (SV*) newAV();
162         SHAREDSvRELEASE(shared);
163         RETVAL = obj;
164         OUTPUT:
165         RETVAL
166
167 void
168 STORE(self, index, value)
169         SV* self
170         SV* index
171         SV* value
172         CODE:    
173         shared_sv* shared = (shared_sv*) SvIV(SvRV(self));
174         shared_sv* slot;
175         SV* aentry;
176         SV** aentry_;
177         SHAREDSvLOCK(shared);
178         aentry_ = av_fetch((AV*) SHAREDSvGET(shared), SvIV(index), 0);
179         if(aentry_ && SvIV((*aentry_))) {
180             aentry = (*aentry_);
181             slot = (shared_sv*) SvIV(aentry);
182             if(SvROK(SHAREDSvGET(slot)))
183                 Perl_sharedsv_thrcnt_dec(aTHX_ (shared_sv*) SvIV(SvRV(SHAREDSvGET(slot))));
184             SHAREDSvEDIT(slot);
185             sv_setsv(SHAREDSvGET(slot), value);
186             SHAREDSvRELEASE(slot);
187         } else {
188             slot = Perl_sharedsv_new(aTHX);
189             SHAREDSvEDIT(shared);
190             SHAREDSvGET(slot) = newSVsv(value);
191             aentry = newSViv((IV)slot);
192             av_store((AV*) SHAREDSvGET(shared), SvIV(index), aentry);
193             SHAREDSvRELEASE(shared);
194         }
195         SHAREDSvUNLOCK(shared);
196
197 SV*
198 FETCH(self, index)
199         SV* self
200         SV* index
201         CODE:
202         shared_sv* shared = (shared_sv*) SvIV(SvRV(self));
203         shared_sv* slot;
204         SV* aentry;
205         SV** aentry_;
206         SV* retval;
207         SHAREDSvLOCK(shared);
208         aentry_ = av_fetch((AV*) SHAREDSvGET(shared), SvIV(index),0);
209         if(aentry_) {
210             aentry = (*aentry_);
211             if(SvTYPE(aentry) == SVt_NULL) {
212                 retval = &PL_sv_undef;
213             } else {
214                 slot = (shared_sv*) SvIV(aentry);
215                 retval = newSVsv(SHAREDSvGET(slot));
216             }
217         } else {
218             retval = &PL_sv_undef;
219         }
220         SHAREDSvUNLOCK(shared); 
221         RETVAL = retval;
222         OUTPUT:
223         RETVAL
224
225 void
226 PUSH(self, ...)
227         SV* self
228         CODE:
229         shared_sv* shared = (shared_sv*) SvIV(SvRV(self));
230         int i;
231         SHAREDSvLOCK(shared);
232         for(i = 1; i < items; i++) {
233             shared_sv* slot = Perl_sharedsv_new(aTHX);
234             SV* tmp = ST(i);
235             SHAREDSvEDIT(slot);
236             SHAREDSvGET(slot) = newSVsv(tmp);
237             av_push((AV*) SHAREDSvGET(shared), newSViv((IV)slot));          
238             SHAREDSvRELEASE(slot);
239         }
240         SHAREDSvUNLOCK(shared);
241
242 void
243 UNSHIFT(self, ...)
244         SV* self
245         CODE:
246         shared_sv* shared = (shared_sv*) SvIV(SvRV(self));
247         int i;
248         SHAREDSvLOCK(shared);
249         SHAREDSvEDIT(shared);
250         av_unshift((AV*)SHAREDSvGET(shared), items - 1);
251         SHAREDSvRELEASE(shared);
252         for(i = 1; i < items; i++) {
253             shared_sv* slot = Perl_sharedsv_new(aTHX);
254             SV* tmp = ST(i);
255             SHAREDSvEDIT(slot);
256             SHAREDSvGET(slot) = newSVsv(tmp);
257             av_store((AV*) SHAREDSvGET(shared), i - 1, newSViv((IV)slot));
258             SHAREDSvRELEASE(slot);
259         }
260         SHAREDSvUNLOCK(shared);
261
262 SV*
263 POP(self)
264         SV* self
265         CODE:
266         shared_sv* shared = (shared_sv*) SvIV(SvRV(self));
267         shared_sv* slot;
268         SV* retval;
269         SHAREDSvLOCK(shared);
270         SHAREDSvEDIT(shared);
271         retval = av_pop((AV*)SHAREDSvGET(shared));
272         SHAREDSvRELEASE(shared);
273         if(retval && SvIV(retval)) {
274             slot = (shared_sv*) SvIV(retval);
275             retval = newSVsv(SHAREDSvGET(slot));
276             Perl_sharedsv_thrcnt_dec(aTHX_ slot);
277         } else {
278             retval = &PL_sv_undef;
279         }
280         SHAREDSvUNLOCK(shared);
281         RETVAL = retval;
282         OUTPUT:
283         RETVAL
284
285
286 SV*
287 SHIFT(self)
288         SV* self
289         CODE:
290         shared_sv* shared = (shared_sv*) SvIV(SvRV(self));
291         shared_sv* slot;
292         SV* retval;
293         SHAREDSvLOCK(shared);
294         SHAREDSvEDIT(shared);
295         retval = av_shift((AV*)SHAREDSvGET(shared));
296         SHAREDSvRELEASE(shared);
297         if(retval && SvIV(retval)) {
298             slot = (shared_sv*) SvIV(retval);
299             retval = newSVsv(SHAREDSvGET(slot));
300             Perl_sharedsv_thrcnt_dec(aTHX_ slot);
301         } else {
302             retval = &PL_sv_undef;
303         }
304         SHAREDSvUNLOCK(shared);
305         RETVAL = retval;
306         OUTPUT:
307         RETVAL
308
309 void
310 CLEAR(self)
311         SV* self
312         CODE:
313         shared_sv* shared = (shared_sv*) SvIV(SvRV(self));
314         shared_sv* slot;
315         SV** svp;
316         I32 i;
317         SHAREDSvLOCK(shared);
318         svp = AvARRAY((AV*)SHAREDSvGET(shared));
319         i   = AvFILLp((AV*)SHAREDSvGET(shared));
320         while ( i >= 0) {
321             if(SvIV(svp[i])) {
322                 Perl_sharedsv_thrcnt_dec(aTHX_ (shared_sv*) SvIV(svp[i]));
323             }
324             i--;
325         }
326         SHAREDSvEDIT(shared);
327         av_clear((AV*)SHAREDSvGET(shared));
328         SHAREDSvRELEASE(shared);
329         SHAREDSvUNLOCK(shared);
330         
331 void
332 EXTEND(self, count)
333         SV* self
334         SV* count
335         CODE:
336         shared_sv* shared = (shared_sv*) SvIV(SvRV(self));
337         SHAREDSvEDIT(shared);
338         av_extend((AV*)SHAREDSvGET(shared), (I32) SvIV(count));
339         SHAREDSvRELEASE(shared);
340
341
342
343
344 SV*
345 EXISTS(self, index)
346         SV* self
347         SV* index
348         CODE:
349         shared_sv* shared = (shared_sv*) SvIV(SvRV(self));
350         I32 exists;
351         SHAREDSvLOCK(shared);
352         exists = av_exists((AV*) SHAREDSvGET(shared), (I32) SvIV(index));
353         if(exists) {
354             RETVAL = &PL_sv_yes;
355         } else {
356             RETVAL = &PL_sv_no;
357         }
358         SHAREDSvUNLOCK(shared);
359
360 void
361 STORESIZE(self,count)
362         SV* self
363         SV* count
364         CODE:
365         shared_sv* shared = (shared_sv*) SvIV(SvRV(self));
366         SHAREDSvEDIT(shared);
367         av_fill((AV*) SHAREDSvGET(shared), (I32) SvIV(count));
368         SHAREDSvRELEASE(shared);
369
370 SV*
371 FETCHSIZE(self)
372         SV* self
373         CODE:
374         shared_sv* shared = (shared_sv*) SvIV(SvRV(self));
375         SHAREDSvLOCK(shared);
376         RETVAL = newSViv(av_len((AV*) SHAREDSvGET(shared)) + 1);
377         SHAREDSvUNLOCK(shared);
378         OUTPUT:
379         RETVAL
380
381 SV*
382 DELETE(self,index)
383         SV* self
384         SV* index
385         CODE:
386         shared_sv* shared = (shared_sv*) SvIV(SvRV(self));
387         shared_sv* slot;
388         SHAREDSvLOCK(shared);
389         if(av_exists((AV*) SHAREDSvGET(shared), (I32) SvIV(index))) {
390             SV* tmp;
391             SHAREDSvEDIT(shared);
392             tmp = av_delete((AV*)SHAREDSvGET(shared), (I32) SvIV(index),0);
393             SHAREDSvRELEASE(shared);
394             if(SvIV(tmp)) {
395                 slot = (shared_sv*) SvIV(tmp);
396                 RETVAL = newSVsv(SHAREDSvGET(slot));
397                 Perl_sharedsv_thrcnt_dec(aTHX_ slot);               
398             } else {
399                 RETVAL = &PL_sv_undef;
400             }       
401         } else {
402             RETVAL = &PL_sv_undef;
403         }       
404         SHAREDSvUNLOCK(shared);
405         OUTPUT:
406         RETVAL
407
408 AV*
409 SPLICE(self, offset, length, ...)
410         SV* self
411         SV* offset
412         SV* length
413         CODE:
414         croak("Splice is not implmented for shared arrays");
415         
416 MODULE = threads::shared                PACKAGE = threads::shared::hv
417
418 SV* 
419 new(class, value)
420         SV* class
421         SV* value
422         CODE:
423         shared_sv* shared = Perl_sharedsv_new(aTHX);
424         SV* obj = newSViv((IV)shared);
425         SHAREDSvEDIT(shared);
426         SHAREDSvGET(shared) = (SV*) newHV();
427         SHAREDSvRELEASE(shared);
428         RETVAL = obj;
429         OUTPUT:
430         RETVAL
431
432 void
433 STORE(self, key, value)
434         SV* self
435         SV* key
436         SV* value
437         CODE:
438         shared_sv* shared = (shared_sv*) SvIV(SvRV(self));
439         shared_sv* slot;
440         SV* hentry;
441         SV** hentry_;
442         STRLEN len;
443         char* ckey = SvPV(key, len);
444         SHAREDSvLOCK(shared);
445         hentry_ = hv_fetch((HV*) SHAREDSvGET(shared), ckey, len, 0);
446         if(hentry_ && SvIV((*hentry_))) {
447             hentry = (*hentry_);
448             slot = (shared_sv*) SvIV(hentry);
449             if(SvROK(SHAREDSvGET(slot)))
450                 Perl_sharedsv_thrcnt_dec(aTHX_ (shared_sv*) SvIV(SvRV(SHAREDSvGET(slot))));
451             SHAREDSvEDIT(slot);
452             sv_setsv(SHAREDSvGET(slot), value);
453             SHAREDSvRELEASE(slot);
454         } else {
455             slot = Perl_sharedsv_new(aTHX);
456             SHAREDSvEDIT(shared);
457             SHAREDSvGET(slot) = newSVsv(value);
458             hentry = newSViv((IV)slot);
459             hv_store((HV*) SHAREDSvGET(shared), ckey,len , hentry, 0);
460             SHAREDSvRELEASE(shared);
461         }
462         SHAREDSvUNLOCK(shared);
463
464
465 SV*
466 FETCH(self, key)
467         SV* self
468         SV* key
469         CODE:
470         shared_sv* shared = (shared_sv*) SvIV(SvRV(self));
471         shared_sv* slot;
472         SV* hentry;
473         SV** hentry_;
474         SV* retval;
475         STRLEN len;
476         char* ckey = SvPV(key, len);
477         SHAREDSvLOCK(shared);
478         hentry_ = hv_fetch((HV*) SHAREDSvGET(shared), ckey, len,0);
479         if(hentry_) {
480             hentry = (*hentry_);
481             if(SvTYPE(hentry) == SVt_NULL) {
482                 retval = &PL_sv_undef;
483             } else {
484                 slot = (shared_sv*) SvIV(hentry);
485                 retval = newSVsv(SHAREDSvGET(slot));
486             }
487         } else {
488             retval = &PL_sv_undef;
489         }
490         SHAREDSvUNLOCK(shared);
491         RETVAL = retval;
492         OUTPUT:
493         RETVAL
494
495 void
496 CLEAR(self)
497         SV* self
498         CODE:
499         shared_sv* shared = (shared_sv*) SvIV(SvRV(self));
500         shared_sv* slot;
501         HE* entry;
502         SHAREDSvLOCK(shared);
503         Perl_hv_iterinit(PL_sharedsv_space, (HV*) SHAREDSvGET(shared));
504         entry = Perl_hv_iternext(PL_sharedsv_space, (HV*) SHAREDSvGET(shared));
505         while(entry) {
506                 slot = (shared_sv*) SvIV(Perl_hv_iterval(PL_sharedsv_space, (HV*) SHAREDSvGET(shared), entry));
507                 Perl_sharedsv_thrcnt_dec(aTHX_ slot);
508                 entry = Perl_hv_iternext(PL_sharedsv_space,(HV*) SHAREDSvGET(shared));
509         }
510         SHAREDSvEDIT(shared);
511         hv_clear((HV*) SHAREDSvGET(shared));
512         SHAREDSvRELEASE(shared);
513         SHAREDSvUNLOCK(shared);
514
515 SV*
516 FIRSTKEY(self)
517         SV* self
518         CODE:
519         shared_sv* shared = (shared_sv*) SvIV(SvRV(self));
520         char* key = NULL;
521         I32 len;
522         HE* entry;
523         SHAREDSvLOCK(shared);
524         Perl_hv_iterinit(PL_sharedsv_space, (HV*) SHAREDSvGET(shared));
525         entry = Perl_hv_iternext(PL_sharedsv_space, (HV*) SHAREDSvGET(shared));
526         if(entry) {
527                 key = Perl_hv_iterkey(PL_sharedsv_space, entry,&len);
528                 RETVAL = newSVpv(key, len);
529         } else {
530              RETVAL = &PL_sv_undef;
531         }
532         SHAREDSvUNLOCK(shared);
533         OUTPUT:
534         RETVAL
535
536
537 SV*
538 NEXTKEY(self, oldkey)
539         SV* self
540         SV* oldkey
541         CODE:
542         shared_sv* shared = (shared_sv*) SvIV(SvRV(self));
543         char* key = NULL;
544         I32 len;
545         HE* entry;
546         SHAREDSvLOCK(shared);
547         entry = Perl_hv_iternext(PL_sharedsv_space, (HV*) SHAREDSvGET(shared));
548         if(entry) {
549                 key = Perl_hv_iterkey(PL_sharedsv_space, entry,&len);
550                 RETVAL = newSVpv(key, len);
551         } else {
552              RETVAL = &PL_sv_undef;
553         }
554         SHAREDSvUNLOCK(shared);
555         OUTPUT:
556         RETVAL
557
558
559 SV*
560 EXISTS(self, key)
561         SV* self
562         SV* key
563         CODE:
564         shared_sv* shared = (shared_sv*) SvIV(SvRV(self));
565         STRLEN len;
566         char* ckey = SvPV(key, len);
567         SHAREDSvLOCK(shared);
568         if(hv_exists((HV*)SHAREDSvGET(shared), ckey, len)) {
569                 RETVAL = &PL_sv_yes;
570         } else {
571                 RETVAL = &PL_sv_no;
572         }
573         SHAREDSvUNLOCK(shared);
574         OUTPUT:
575         RETVAL
576
577 SV*
578 DELETE(self, key)
579         SV* self
580         SV* key
581         CODE:
582         shared_sv* shared = (shared_sv*) SvIV(SvRV(self));
583         shared_sv* slot;
584         STRLEN len;
585         char* ckey = SvPV(key, len);
586         SV* tmp;
587         SHAREDSvLOCK(shared);
588         SHAREDSvEDIT(shared);
589         tmp = hv_delete((HV*) SHAREDSvGET(shared), ckey, len,0);
590         SHAREDSvRELEASE(shared);
591         if(tmp) {
592                 slot = SvIV(tmp);       
593                 RETVAL = newSVsv(SHAREDSvGET(slot));
594                 Perl_sharedsv_thrcnt_dec(aTHX_ slot);
595         } else {
596                 RETVAL = &PL_sv_undef;
597         }
598         SHAREDSvUNLOCK(shared);
599         OUTPUT:
600         RETVAL