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