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