This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Add tests for references in hashes.
[perl5.git] / ext / threads / shared / shared.xs
CommitLineData
b050c948
AB
1
2#include "EXTERN.h"
3#include "perl.h"
4#include "XSUB.h"
5
6
0d76d117 7SV* shared_sv_attach_sv (SV* sv, shared_sv* shared) {
b050c948
AB
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_);
0d76d117
AB
15 if(sv) {
16 SvROK_on(sv);
17 SvRV(sv) = SvRV(tiedobject);
18 } else {
19 sv = newRV(SvRV(tiedobject));
20 }
b050c948
AB
21 } else {
22 croak("die\n");
23 }
0d76d117 24 return sv;
b050c948
AB
25}
26
27
28int shared_sv_fetch_mg (pTHX_ SV* sv, MAGIC *mg) {
29 shared_sv* shared = (shared_sv*) SvIV(mg->mg_obj);
30 SHAREDSvLOCK(shared);
55fc11ad
AB
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;
b050c948
AB
39 }
40 SHAREDSvUNLOCK(shared);
41
42 return 0;
43}
44
45int 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))));
b050c948
AB
50 if(SvROK(sv)) {
51 shared_sv* target = Perl_sharedsv_find(aTHX_ SvRV(sv));
52 if(!target) {
b050c948
AB
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 }
f70d29d4 57 SHAREDSvEDIT(shared);
b050c948
AB
58 Perl_sv_free(PL_sharedsv_space,SHAREDSvGET(shared));
59 SHAREDSvGET(shared) = newRV_noinc(newSViv((IV)target));
b050c948 60 } else {
f70d29d4
AB
61 SHAREDSvEDIT(shared);
62 sv_setsv(SHAREDSvGET(shared), sv);
b050c948 63 }
55fc11ad
AB
64 shared->index++;
65 mg->mg_private = shared->index;
b050c948
AB
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
73int 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
80MGVTBL 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
87MODULE = threads::shared PACKAGE = threads::shared
88
89
90PROTOTYPES: DISABLE
91
92
93SV*
94ptr(ref)
95 SV* ref
96 CODE:
97 RETVAL = newSViv(SvIV(SvRV(ref)));
98 OUTPUT:
99 RETVAL
100
101
102SV*
103_thrcnt(ref)
104 SV* ref
105 CODE:
866fba46
AB
106 shared_sv* shared;
107 if(SvROK(ref))
108 ref = SvRV(ref);
109 shared = Perl_sharedsv_find(aTHX, ref);
b050c948
AB
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
119void
120thrcnt_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
866fba46
AB
131void
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
b050c948
AB
140
141MODULE = threads::shared PACKAGE = threads::shared::sv
142
143SV*
144new(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;
55fc11ad 159 shared_magic->mg_private = 0;
b050c948
AB
160 SvMAGICAL_on(value);
161 RETVAL = obj;
162 OUTPUT:
163 RETVAL
164
165
aaf3876d
AB
166MODULE = threads::shared PACKAGE = threads::shared::av
167
168SV*
169new(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
182void
183STORE(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
212SV*
213FETCH(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
240void
241PUSH(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
257void
258UNSHIFT(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
277SV*
278POP(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
301SV*
302SHIFT(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
324void
325CLEAR(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
346void
347EXTEND(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
359SV*
360EXISTS(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
375void
376STORESIZE(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
385SV*
386FETCHSIZE(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
396SV*
397DELETE(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
423AV*
424SPLICE(self, offset, length, ...)
425 SV* self
426 SV* offset
427 SV* length
428 CODE:
429 croak("Splice is not implmented for shared arrays");
430
8669ce85 431MODULE = threads::shared PACKAGE = threads::shared::hv
aaf3876d 432
8669ce85
AB
433SV*
434new(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
447void
448STORE(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);
0d76d117
AB
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 }
8669ce85
AB
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 }
0d76d117
AB
484 if(SvROK(SHAREDSvGET(slot)))
485 Perl_sharedsv_thrcnt_inc(aTHX_ (shared_sv*) SvIV(SvRV(SHAREDSvGET(slot))));
8669ce85
AB
486 SHAREDSvUNLOCK(shared);
487
488
489SV*
490FETCH(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);
0d76d117
AB
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 }
8669ce85
AB
515 }
516 } else {
517 retval = &PL_sv_undef;
518 }
519 SHAREDSvUNLOCK(shared);
520 RETVAL = retval;
521 OUTPUT:
522 RETVAL
523
524void
525CLEAR(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
544SV*
545FIRSTKEY(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
566SV*
567NEXTKEY(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
588SV*
589EXISTS(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
606SV*
607DELETE(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) {
b48e3745 621 slot = (shared_sv*) SvIV(tmp);
0d76d117
AB
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 }
8669ce85
AB
628 Perl_sharedsv_thrcnt_dec(aTHX_ slot);
629 } else {
630 RETVAL = &PL_sv_undef;
631 }
632 SHAREDSvUNLOCK(shared);
633 OUTPUT:
634 RETVAL