This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Dump Unicode better for re 'debug'. The regprop()
[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))));
46 SHAREDSvEDIT(shared);
47 if(SvROK(sv)) {
48 shared_sv* target = Perl_sharedsv_find(aTHX_ SvRV(sv));
49 if(!target) {
50 SHAREDSvRELEASE(shared);
51 sv_setsv(sv,SHAREDSvGET(shared));
52 SHAREDSvUNLOCK(shared);
53 Perl_croak(aTHX_ "You cannot assign a non shared reference to a shared scalar");
54 }
55 Perl_sv_free(PL_sharedsv_space,SHAREDSvGET(shared));
56 SHAREDSvGET(shared) = newRV_noinc(newSViv((IV)target));
b050c948
AB
57 } else {
58 sv_setsv(SHAREDSvGET(shared), sv);
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:
102 shared_sv* shared = Perl_sharedsv_find(aTHX, ref);
103 if(!shared)
104 croak("thrcnt can only be used on shared values");
105 SHAREDSvLOCK(shared);
106 RETVAL = newSViv(SvREFCNT(SHAREDSvGET(shared)));
107 SHAREDSvUNLOCK(shared);
108 OUTPUT:
109 RETVAL
110
111
112void
113thrcnt_inc(ref)
114 SV* ref
115 CODE:
116 shared_sv* shared;
117 if(SvROK(ref))
118 ref = SvRV(ref);
119 shared = Perl_sharedsv_find(aTHX, ref);
120 if(!shared)
121 croak("thrcnt can only be used on shared values");
122 Perl_sharedsv_thrcnt_inc(aTHX_ shared);
123
124
125MODULE = threads::shared PACKAGE = threads::shared::sv
126
127SV*
128new(class, value)
129 SV* class
130 SV* value
131 CODE:
132 shared_sv* shared = Perl_sharedsv_new(aTHX);
133 MAGIC* shared_magic;
134 SV* obj = newSViv((IV)shared);
135 SHAREDSvEDIT(shared);
136 SHAREDSvGET(shared) = newSVsv(value);
137 SHAREDSvRELEASE(shared);
138 sv_magic(value, 0, PERL_MAGIC_ext, "threads::shared", 16);
139 shared_magic = mg_find(value, PERL_MAGIC_ext);
140 shared_magic->mg_virtual = &svtable;
141 shared_magic->mg_obj = newSViv((IV)shared);
142 shared_magic->mg_flags |= MGf_REFCOUNTED;
55fc11ad 143 shared_magic->mg_private = 0;
b050c948
AB
144 SvMAGICAL_on(value);
145 RETVAL = obj;
146 OUTPUT:
147 RETVAL
148
149