line |
stmt |
bran |
cond |
sub |
time |
code |
1
|
|
|
|
|
|
/* |
2
|
|
|
|
|
|
* This file was generated automatically by ExtUtils::ParseXS version 3.22 from the |
3
|
|
|
|
|
|
* contents of shared.xs. Do not edit this file, edit shared.xs instead. |
4
|
|
|
|
|
|
* |
5
|
|
|
|
|
|
* ANY CHANGES MADE HERE WILL BE LOST! |
6
|
|
|
|
|
|
* |
7
|
|
|
|
|
|
*/ |
8
|
|
|
|
|
|
|
9
|
|
|
|
|
|
#line 1 "shared.xs" |
10
|
|
|
|
|
|
/* shared.xs |
11
|
|
|
|
|
|
* |
12
|
|
|
|
|
|
* Copyright (c) 2001-2002, 2006 Larry Wall |
13
|
|
|
|
|
|
* |
14
|
|
|
|
|
|
* You may distribute under the terms of either the GNU General Public |
15
|
|
|
|
|
|
* License or the Artistic License, as specified in the README file. |
16
|
|
|
|
|
|
* |
17
|
|
|
|
|
|
* "Hand any two wizards a piece of rope and they would instinctively pull in |
18
|
|
|
|
|
|
* opposite directions." |
19
|
|
|
|
|
|
* --Sourcery |
20
|
|
|
|
|
|
* |
21
|
|
|
|
|
|
* Contributed by Artur Bergman |
22
|
|
|
|
|
|
* Pulled in the (an)other direction by Nick Ing-Simmons |
23
|
|
|
|
|
|
* |
24
|
|
|
|
|
|
* CPAN version produced by Jerry D. Hedden |
25
|
|
|
|
|
|
*/ |
26
|
|
|
|
|
|
|
27
|
|
|
|
|
|
/* |
28
|
|
|
|
|
|
* Shared variables are implemented by a scheme similar to tieing. |
29
|
|
|
|
|
|
* Each thread has a proxy SV with attached magic -- "private SVs" -- |
30
|
|
|
|
|
|
* which all point to a single SV in a separate shared interpreter |
31
|
|
|
|
|
|
* (PL_sharedsv_space) -- "shared SVs". |
32
|
|
|
|
|
|
* |
33
|
|
|
|
|
|
* The shared SV holds the variable's true values, and its state is |
34
|
|
|
|
|
|
* copied between the shared and private SVs with the usual |
35
|
|
|
|
|
|
* mg_get()/mg_set() arrangement. |
36
|
|
|
|
|
|
* |
37
|
|
|
|
|
|
* Aggregates (AVs and HVs) are implemented using tie magic, except that |
38
|
|
|
|
|
|
* the vtable used is one defined in this file rather than the standard one. |
39
|
|
|
|
|
|
* This means that where a tie function like FETCH is normally invoked by |
40
|
|
|
|
|
|
* the tie magic's mg_get() function, we completely bypass the calling of a |
41
|
|
|
|
|
|
* perl-level function, and directly call C-level code to handle it. On |
42
|
|
|
|
|
|
* the other hand, calls to functions like PUSH are done directly by code |
43
|
|
|
|
|
|
* in av.c, etc., which we can't bypass. So the best we can do is to provide |
44
|
|
|
|
|
|
* XS versions of these functions. We also have to attach a tie object, |
45
|
|
|
|
|
|
* blessed into the class threads::shared::tie, to keep the method-calling |
46
|
|
|
|
|
|
* code happy. |
47
|
|
|
|
|
|
* |
48
|
|
|
|
|
|
* Access to aggregate elements is done the usual tied way by returning a |
49
|
|
|
|
|
|
* proxy PVLV element with attached element magic. |
50
|
|
|
|
|
|
* |
51
|
|
|
|
|
|
* Pointers to the shared SV are squirrelled away in the mg->mg_ptr field |
52
|
|
|
|
|
|
* of magic (with mg_len == 0), and in the IV2PTR(SvIV(sv)) field of tied |
53
|
|
|
|
|
|
* object SVs. These pointers have to be hidden like this because they |
54
|
|
|
|
|
|
* cross interpreter boundaries, and we don't want sv_clear() and friends |
55
|
|
|
|
|
|
* following them. |
56
|
|
|
|
|
|
* |
57
|
|
|
|
|
|
* The three basic shared types look like the following: |
58
|
|
|
|
|
|
* |
59
|
|
|
|
|
|
* ----------------- |
60
|
|
|
|
|
|
* |
61
|
|
|
|
|
|
* Shared scalar (my $s : shared): |
62
|
|
|
|
|
|
* |
63
|
|
|
|
|
|
* SV = PVMG(0x7ba238) at 0x7387a8 |
64
|
|
|
|
|
|
* FLAGS = (PADMY,GMG,SMG) |
65
|
|
|
|
|
|
* MAGIC = 0x824d88 |
66
|
|
|
|
|
|
* MG_TYPE = PERL_MAGIC_shared_scalar(n) |
67
|
|
|
|
|
|
* MG_PTR = 0x810358 <<<< pointer to the shared SV |
68
|
|
|
|
|
|
* |
69
|
|
|
|
|
|
* ----------------- |
70
|
|
|
|
|
|
* |
71
|
|
|
|
|
|
* Shared aggregate (my @a : shared; my %h : shared): |
72
|
|
|
|
|
|
* |
73
|
|
|
|
|
|
* SV = PVAV(0x7175d0) at 0x738708 |
74
|
|
|
|
|
|
* FLAGS = (PADMY,RMG) |
75
|
|
|
|
|
|
* MAGIC = 0x824e48 |
76
|
|
|
|
|
|
* MG_TYPE = PERL_MAGIC_tied(P) |
77
|
|
|
|
|
|
* MG_OBJ = 0x7136e0 <<<< ref to the tied object |
78
|
|
|
|
|
|
* SV = RV(0x7136f0) at 0x7136e0 |
79
|
|
|
|
|
|
* RV = 0x738640 |
80
|
|
|
|
|
|
* SV = PVMG(0x7ba238) at 0x738640 <<<< the tied object |
81
|
|
|
|
|
|
* FLAGS = (OBJECT,IOK,pIOK) |
82
|
|
|
|
|
|
* IV = 8455000 <<<< pointer to the shared AV |
83
|
|
|
|
|
|
* STASH = 0x80abf0 "threads::shared::tie" |
84
|
|
|
|
|
|
* MG_PTR = 0x810358 "" <<<< another pointer to the shared AV |
85
|
|
|
|
|
|
* ARRAY = 0x0 |
86
|
|
|
|
|
|
* |
87
|
|
|
|
|
|
* ----------------- |
88
|
|
|
|
|
|
* |
89
|
|
|
|
|
|
* Aggregate element (my @a : shared; $a[0]) |
90
|
|
|
|
|
|
* |
91
|
|
|
|
|
|
* SV = PVLV(0x77f628) at 0x713550 |
92
|
|
|
|
|
|
* FLAGS = (GMG,SMG,RMG,pIOK) |
93
|
|
|
|
|
|
* MAGIC = 0x72bd58 |
94
|
|
|
|
|
|
* MG_TYPE = PERL_MAGIC_shared_scalar(n) |
95
|
|
|
|
|
|
* MG_PTR = 0x8103c0 "" <<<< pointer to the shared element |
96
|
|
|
|
|
|
* MAGIC = 0x72bd18 |
97
|
|
|
|
|
|
* MG_TYPE = PERL_MAGIC_tiedelem(p) |
98
|
|
|
|
|
|
* MG_OBJ = 0x7136e0 <<<< ref to the tied object |
99
|
|
|
|
|
|
* SV = RV(0x7136f0) at 0x7136e0 |
100
|
|
|
|
|
|
* RV = 0x738660 |
101
|
|
|
|
|
|
* SV = PVMG(0x7ba278) at 0x738660 <<<< the tied object |
102
|
|
|
|
|
|
* FLAGS = (OBJECT,IOK,pIOK) |
103
|
|
|
|
|
|
* IV = 8455064 <<<< pointer to the shared AV |
104
|
|
|
|
|
|
* STASH = 0x80ac30 "threads::shared::tie" |
105
|
|
|
|
|
|
* TYPE = t |
106
|
|
|
|
|
|
* |
107
|
|
|
|
|
|
* Note that PERL_MAGIC_tiedelem(p) magic doesn't have a pointer to a |
108
|
|
|
|
|
|
* shared SV in mg_ptr; instead this is used to store the hash key, |
109
|
|
|
|
|
|
* if any, like normal tied elements. Note also that element SVs may have |
110
|
|
|
|
|
|
* pointers to both the shared aggregate and the shared element. |
111
|
|
|
|
|
|
* |
112
|
|
|
|
|
|
* |
113
|
|
|
|
|
|
* Userland locks: |
114
|
|
|
|
|
|
* |
115
|
|
|
|
|
|
* If a shared variable is used as a perl-level lock or condition |
116
|
|
|
|
|
|
* variable, then PERL_MAGIC_ext magic is attached to the associated |
117
|
|
|
|
|
|
* *shared* SV, whose mg_ptr field points to a malloc'ed structure |
118
|
|
|
|
|
|
* containing the necessary mutexes and condition variables. |
119
|
|
|
|
|
|
* |
120
|
|
|
|
|
|
* Nomenclature: |
121
|
|
|
|
|
|
* |
122
|
|
|
|
|
|
* In this file, any variable name prefixed with 's' (e.g., ssv, stmp or sobj) |
123
|
|
|
|
|
|
* usually represents a shared SV which corresponds to a private SV named |
124
|
|
|
|
|
|
* without the prefix (e.g., sv, tmp or obj). |
125
|
|
|
|
|
|
*/ |
126
|
|
|
|
|
|
|
127
|
|
|
|
|
|
#define PERL_NO_GET_CONTEXT |
128
|
|
|
|
|
|
#include "EXTERN.h" |
129
|
|
|
|
|
|
#include "perl.h" |
130
|
|
|
|
|
|
#include "XSUB.h" |
131
|
|
|
|
|
|
#ifdef HAS_PPPORT_H |
132
|
|
|
|
|
|
# define NEED_sv_2pv_flags |
133
|
|
|
|
|
|
# define NEED_vnewSVpvf |
134
|
|
|
|
|
|
# define NEED_warner |
135
|
|
|
|
|
|
# define NEED_newSVpvn_flags |
136
|
|
|
|
|
|
# include "ppport.h" |
137
|
|
|
|
|
|
# include "shared.h" |
138
|
|
|
|
|
|
#endif |
139
|
|
|
|
|
|
|
140
|
|
|
|
|
|
#ifdef USE_ITHREADS |
141
|
|
|
|
|
|
|
142
|
|
|
|
|
|
/* Magic signature(s) for mg_private to make PERL_MAGIC_ext magic safer */ |
143
|
|
|
|
|
|
#define UL_MAGIC_SIG 0x554C /* UL = user lock */ |
144
|
|
|
|
|
|
|
145
|
|
|
|
|
|
/* |
146
|
|
|
|
|
|
* The shared things need an interpreter to live in ... |
147
|
|
|
|
|
|
*/ |
148
|
|
|
|
|
|
PerlInterpreter *PL_sharedsv_space; /* The shared sv space */ |
149
|
|
|
|
|
|
/* To access shared space we fake aTHX in this scope and thread's context */ |
150
|
|
|
|
|
|
|
151
|
|
|
|
|
|
/* Bug #24255: We include ENTER+SAVETMPS/FREETMPS+LEAVE with |
152
|
|
|
|
|
|
* SHARED_CONTEXT/CALLER_CONTEXT macros, so that any mortals, etc. created |
153
|
|
|
|
|
|
* while in the shared interpreter context don't languish */ |
154
|
|
|
|
|
|
|
155
|
|
|
|
|
|
#define SHARED_CONTEXT \ |
156
|
|
|
|
|
|
STMT_START { \ |
157
|
|
|
|
|
|
PERL_SET_CONTEXT((aTHX = PL_sharedsv_space)); \ |
158
|
|
|
|
|
|
ENTER; \ |
159
|
|
|
|
|
|
SAVETMPS; \ |
160
|
|
|
|
|
|
} STMT_END |
161
|
|
|
|
|
|
|
162
|
|
|
|
|
|
/* So we need a way to switch back to the caller's context... */ |
163
|
|
|
|
|
|
/* So we declare _another_ copy of the aTHX variable ... */ |
164
|
|
|
|
|
|
#define dTHXc PerlInterpreter *caller_perl = aTHX |
165
|
|
|
|
|
|
|
166
|
|
|
|
|
|
/* ... and use it to switch back */ |
167
|
|
|
|
|
|
#define CALLER_CONTEXT \ |
168
|
|
|
|
|
|
STMT_START { \ |
169
|
|
|
|
|
|
FREETMPS; \ |
170
|
|
|
|
|
|
LEAVE; \ |
171
|
|
|
|
|
|
PERL_SET_CONTEXT((aTHX = caller_perl)); \ |
172
|
|
|
|
|
|
} STMT_END |
173
|
|
|
|
|
|
|
174
|
|
|
|
|
|
/* |
175
|
|
|
|
|
|
* Only one thread at a time is allowed to mess with shared space. |
176
|
|
|
|
|
|
*/ |
177
|
|
|
|
|
|
|
178
|
|
|
|
|
|
typedef struct { |
179
|
|
|
|
|
|
perl_mutex mutex; |
180
|
|
|
|
|
|
PerlInterpreter *owner; |
181
|
|
|
|
|
|
I32 locks; |
182
|
|
|
|
|
|
perl_cond cond; |
183
|
|
|
|
|
|
#ifdef DEBUG_LOCKS |
184
|
|
|
|
|
|
char * file; |
185
|
|
|
|
|
|
int line; |
186
|
|
|
|
|
|
#endif |
187
|
|
|
|
|
|
} recursive_lock_t; |
188
|
|
|
|
|
|
|
189
|
|
|
|
|
|
recursive_lock_t PL_sharedsv_lock; /* Mutex protecting the shared sv space */ |
190
|
|
|
|
|
|
|
191
|
|
|
|
|
|
void |
192
|
|
|
|
|
|
recursive_lock_init(pTHX_ recursive_lock_t *lock) |
193
|
|
|
|
|
|
{ |
194
|
|
|
|
|
|
Zero(lock,1,recursive_lock_t); |
195
|
|
|
|
|
|
MUTEX_INIT(&lock->mutex); |
196
|
|
|
|
|
|
COND_INIT(&lock->cond); |
197
|
|
|
|
|
|
} |
198
|
|
|
|
|
|
|
199
|
|
|
|
|
|
void |
200
|
|
|
|
|
|
recursive_lock_destroy(pTHX_ recursive_lock_t *lock) |
201
|
|
|
|
|
|
{ |
202
|
|
|
|
|
|
MUTEX_DESTROY(&lock->mutex); |
203
|
|
|
|
|
|
COND_DESTROY(&lock->cond); |
204
|
|
|
|
|
|
} |
205
|
|
|
|
|
|
|
206
|
|
|
|
|
|
void |
207
|
|
|
|
|
|
recursive_lock_release(pTHX_ recursive_lock_t *lock) |
208
|
|
|
|
|
|
{ |
209
|
|
|
|
|
|
MUTEX_LOCK(&lock->mutex); |
210
|
|
|
|
|
|
if (lock->owner == aTHX) { |
211
|
|
|
|
|
|
if (--lock->locks == 0) { |
212
|
|
|
|
|
|
lock->owner = NULL; |
213
|
|
|
|
|
|
COND_SIGNAL(&lock->cond); |
214
|
|
|
|
|
|
} |
215
|
|
|
|
|
|
} |
216
|
|
|
|
|
|
MUTEX_UNLOCK(&lock->mutex); |
217
|
|
|
|
|
|
} |
218
|
|
|
|
|
|
|
219
|
|
|
|
|
|
void |
220
|
|
|
|
|
|
recursive_lock_acquire(pTHX_ recursive_lock_t *lock, char *file, int line) |
221
|
|
|
|
|
|
{ |
222
|
|
|
|
|
|
PERL_UNUSED_ARG(file); |
223
|
|
|
|
|
|
PERL_UNUSED_ARG(line); |
224
|
|
|
|
|
|
assert(aTHX); |
225
|
|
|
|
|
|
MUTEX_LOCK(&lock->mutex); |
226
|
|
|
|
|
|
if (lock->owner == aTHX) { |
227
|
|
|
|
|
|
lock->locks++; |
228
|
|
|
|
|
|
} else { |
229
|
|
|
|
|
|
while (lock->owner) { |
230
|
|
|
|
|
|
#ifdef DEBUG_LOCKS |
231
|
|
|
|
|
|
Perl_warn(aTHX_ " %p waiting - owned by %p %s:%d\n", |
232
|
|
|
|
|
|
aTHX, lock->owner, lock->file, lock->line); |
233
|
|
|
|
|
|
#endif |
234
|
|
|
|
|
|
COND_WAIT(&lock->cond,&lock->mutex); |
235
|
|
|
|
|
|
} |
236
|
|
|
|
|
|
lock->locks = 1; |
237
|
|
|
|
|
|
lock->owner = aTHX; |
238
|
|
|
|
|
|
#ifdef DEBUG_LOCKS |
239
|
|
|
|
|
|
lock->file = file; |
240
|
|
|
|
|
|
lock->line = line; |
241
|
|
|
|
|
|
#endif |
242
|
|
|
|
|
|
} |
243
|
|
|
|
|
|
MUTEX_UNLOCK(&lock->mutex); |
244
|
|
|
|
|
|
SAVEDESTRUCTOR_X(recursive_lock_release,lock); |
245
|
|
|
|
|
|
} |
246
|
|
|
|
|
|
|
247
|
|
|
|
|
|
#define ENTER_LOCK \ |
248
|
|
|
|
|
|
STMT_START { \ |
249
|
|
|
|
|
|
ENTER; \ |
250
|
|
|
|
|
|
recursive_lock_acquire(aTHX_ &PL_sharedsv_lock, __FILE__, __LINE__);\ |
251
|
|
|
|
|
|
} STMT_END |
252
|
|
|
|
|
|
|
253
|
|
|
|
|
|
/* The unlocking is done automatically at scope exit */ |
254
|
|
|
|
|
|
#define LEAVE_LOCK LEAVE |
255
|
|
|
|
|
|
|
256
|
|
|
|
|
|
|
257
|
|
|
|
|
|
/* A common idiom is to acquire access and switch in ... */ |
258
|
|
|
|
|
|
#define SHARED_EDIT \ |
259
|
|
|
|
|
|
STMT_START { \ |
260
|
|
|
|
|
|
ENTER_LOCK; \ |
261
|
|
|
|
|
|
SHARED_CONTEXT; \ |
262
|
|
|
|
|
|
} STMT_END |
263
|
|
|
|
|
|
|
264
|
|
|
|
|
|
/* ... then switch out and release access. */ |
265
|
|
|
|
|
|
#define SHARED_RELEASE \ |
266
|
|
|
|
|
|
STMT_START { \ |
267
|
|
|
|
|
|
CALLER_CONTEXT; \ |
268
|
|
|
|
|
|
LEAVE_LOCK; \ |
269
|
|
|
|
|
|
} STMT_END |
270
|
|
|
|
|
|
|
271
|
|
|
|
|
|
|
272
|
|
|
|
|
|
/* User-level locks: |
273
|
|
|
|
|
|
This structure is attached (using ext magic) to any shared SV that |
274
|
|
|
|
|
|
is used by user-level locking or condition code |
275
|
|
|
|
|
|
*/ |
276
|
|
|
|
|
|
|
277
|
|
|
|
|
|
typedef struct { |
278
|
|
|
|
|
|
recursive_lock_t lock; /* For user-levl locks */ |
279
|
|
|
|
|
|
perl_cond user_cond; /* For user-level conditions */ |
280
|
|
|
|
|
|
} user_lock; |
281
|
|
|
|
|
|
|
282
|
|
|
|
|
|
/* Magic used for attaching user_lock structs to shared SVs |
283
|
|
|
|
|
|
|
284
|
|
|
|
|
|
The vtable used has just one entry - when the SV goes away |
285
|
|
|
|
|
|
we free the memory for the above. |
286
|
|
|
|
|
|
*/ |
287
|
|
|
|
|
|
|
288
|
|
|
|
|
|
int |
289
|
|
|
|
|
|
sharedsv_userlock_free(pTHX_ SV *sv, MAGIC *mg) |
290
|
|
|
|
|
|
{ |
291
|
|
|
|
|
|
user_lock *ul = (user_lock *) mg->mg_ptr; |
292
|
|
|
|
|
|
PERL_UNUSED_ARG(sv); |
293
|
|
|
|
|
|
assert(aTHX == PL_sharedsv_space); |
294
|
|
|
|
|
|
if (ul) { |
295
|
|
|
|
|
|
recursive_lock_destroy(aTHX_ &ul->lock); |
296
|
|
|
|
|
|
COND_DESTROY(&ul->user_cond); |
297
|
|
|
|
|
|
PerlMemShared_free(ul); |
298
|
|
|
|
|
|
mg->mg_ptr = NULL; |
299
|
|
|
|
|
|
} |
300
|
|
|
|
|
|
return (0); |
301
|
|
|
|
|
|
} |
302
|
|
|
|
|
|
|
303
|
|
|
|
|
|
MGVTBL sharedsv_userlock_vtbl = { |
304
|
|
|
|
|
|
0, /* get */ |
305
|
|
|
|
|
|
0, /* set */ |
306
|
|
|
|
|
|
0, /* len */ |
307
|
|
|
|
|
|
0, /* clear */ |
308
|
|
|
|
|
|
sharedsv_userlock_free, /* free */ |
309
|
|
|
|
|
|
0, /* copy */ |
310
|
|
|
|
|
|
0, /* dup */ |
311
|
|
|
|
|
|
#ifdef MGf_LOCAL |
312
|
|
|
|
|
|
0, /* local */ |
313
|
|
|
|
|
|
#endif |
314
|
|
|
|
|
|
}; |
315
|
|
|
|
|
|
|
316
|
|
|
|
|
|
|
317
|
|
|
|
|
|
/* Support for dual-valued variables */ |
318
|
|
|
|
|
|
#ifdef SVf_IVisUV |
319
|
|
|
|
|
|
# define DUALVAR_FLAGS(sv) \ |
320
|
|
|
|
|
|
((SvPOK(sv)) \ |
321
|
|
|
|
|
|
? ((SvNOK(sv) || SvNOKp(sv)) ? SVf_NOK \ |
322
|
|
|
|
|
|
: ((SvIsUV(sv)) ? (SVf_IOK | SVf_IVisUV) \ |
323
|
|
|
|
|
|
: ((SvIOK(sv) || SvIOKp(sv)) ? SVf_IOK : 0))) \ |
324
|
|
|
|
|
|
: 0) |
325
|
|
|
|
|
|
#else |
326
|
|
|
|
|
|
# define DUALVAR_FLAGS(sv) \ |
327
|
|
|
|
|
|
((SvPOK(sv)) \ |
328
|
|
|
|
|
|
? ((SvNOK(sv) || SvNOKp(sv)) ? SVf_NOK \ |
329
|
|
|
|
|
|
: ((SvIOK(sv) || SvIOKp(sv)) ? SVf_IOK : 0)) \ |
330
|
|
|
|
|
|
: 0) |
331
|
|
|
|
|
|
#endif |
332
|
|
|
|
|
|
|
333
|
|
|
|
|
|
|
334
|
|
|
|
|
|
/* |
335
|
|
|
|
|
|
* Access to shared things is heavily based on MAGIC |
336
|
|
|
|
|
|
* - in mg.h/mg.c/sv.c sense |
337
|
|
|
|
|
|
*/ |
338
|
|
|
|
|
|
|
339
|
|
|
|
|
|
/* In any thread that has access to a shared thing there is a "proxy" |
340
|
|
|
|
|
|
for it in its own space which has 'MAGIC' associated which accesses |
341
|
|
|
|
|
|
the shared thing. |
342
|
|
|
|
|
|
*/ |
343
|
|
|
|
|
|
|
344
|
|
|
|
|
|
extern MGVTBL sharedsv_scalar_vtbl; /* Scalars have this vtable */ |
345
|
|
|
|
|
|
extern MGVTBL sharedsv_array_vtbl; /* Hashes and arrays have this |
346
|
|
|
|
|
|
- like 'tie' */ |
347
|
|
|
|
|
|
extern MGVTBL sharedsv_elem_vtbl; /* Elements of hashes and arrays have |
348
|
|
|
|
|
|
this _AS WELL AS_ the scalar magic: |
349
|
|
|
|
|
|
The sharedsv_elem_vtbl associates the element with the array/hash and |
350
|
|
|
|
|
|
the sharedsv_scalar_vtbl associates it with the value |
351
|
|
|
|
|
|
*/ |
352
|
|
|
|
|
|
|
353
|
|
|
|
|
|
|
354
|
|
|
|
|
|
/* Get shared aggregate SV pointed to by threads::shared::tie magic object */ |
355
|
|
|
|
|
|
|
356
|
|
|
|
|
|
#define SHAREDSV_FROM_OBJ(sv) ((SvROK(sv)) ? INT2PTR(SV *, SvIV(SvRV(sv))) : NULL) |
357
|
|
|
|
|
|
|
358
|
|
|
|
|
|
|
359
|
|
|
|
|
|
/* Return the user_lock structure (if any) associated with a shared SV. |
360
|
|
|
|
|
|
* If create is true, create one if it doesn't exist |
361
|
|
|
|
|
|
*/ |
362
|
|
|
|
|
|
STATIC user_lock * |
363
|
|
|
|
|
|
S_get_userlock(pTHX_ SV* ssv, bool create) |
364
|
|
|
|
|
|
{ |
365
|
|
|
|
|
|
MAGIC *mg; |
366
|
|
|
|
|
|
user_lock *ul = NULL; |
367
|
|
|
|
|
|
|
368
|
|
|
|
|
|
assert(ssv); |
369
|
|
|
|
|
|
/* XXX Redesign the storage of user locks so we don't need a global |
370
|
|
|
|
|
|
* lock to access them ???? DAPM */ |
371
|
|
|
|
|
|
ENTER_LOCK; |
372
|
|
|
|
|
|
|
373
|
|
|
|
|
|
/* Version of mg_find that also checks the private signature */ |
374
|
|
|
|
|
|
for (mg = SvMAGIC(ssv); mg; mg = mg->mg_moremagic) { |
375
|
|
|
|
|
|
if ((mg->mg_type == PERL_MAGIC_ext) && |
376
|
|
|
|
|
|
(mg->mg_private == UL_MAGIC_SIG)) |
377
|
|
|
|
|
|
{ |
378
|
|
|
|
|
|
break; |
379
|
|
|
|
|
|
} |
380
|
|
|
|
|
|
} |
381
|
|
|
|
|
|
|
382
|
|
|
|
|
|
if (mg) { |
383
|
|
|
|
|
|
ul = (user_lock*)(mg->mg_ptr); |
384
|
|
|
|
|
|
} else if (create) { |
385
|
|
|
|
|
|
dTHXc; |
386
|
|
|
|
|
|
SHARED_CONTEXT; |
387
|
|
|
|
|
|
ul = (user_lock *) PerlMemShared_malloc(sizeof(user_lock)); |
388
|
|
|
|
|
|
Zero(ul, 1, user_lock); |
389
|
|
|
|
|
|
/* Attach to shared SV using ext magic */ |
390
|
|
|
|
|
|
mg = sv_magicext(ssv, NULL, PERL_MAGIC_ext, &sharedsv_userlock_vtbl, |
391
|
|
|
|
|
|
(char *)ul, 0); |
392
|
|
|
|
|
|
mg->mg_private = UL_MAGIC_SIG; /* Set private signature */ |
393
|
|
|
|
|
|
recursive_lock_init(aTHX_ &ul->lock); |
394
|
|
|
|
|
|
COND_INIT(&ul->user_cond); |
395
|
|
|
|
|
|
CALLER_CONTEXT; |
396
|
|
|
|
|
|
} |
397
|
|
|
|
|
|
LEAVE_LOCK; |
398
|
|
|
|
|
|
return (ul); |
399
|
|
|
|
|
|
} |
400
|
|
|
|
|
|
|
401
|
|
|
|
|
|
|
402
|
|
|
|
|
|
/* Given a private side SV tries to find if the SV has a shared backend, |
403
|
|
|
|
|
|
* by looking for the magic. |
404
|
|
|
|
|
|
*/ |
405
|
|
|
|
|
|
SV * |
406
|
|
|
|
|
|
Perl_sharedsv_find(pTHX_ SV *sv) |
407
|
|
|
|
|
|
{ |
408
|
|
|
|
|
|
MAGIC *mg; |
409
|
|
|
|
|
|
if (SvTYPE(sv) >= SVt_PVMG) { |
410
|
|
|
|
|
|
switch(SvTYPE(sv)) { |
411
|
|
|
|
|
|
case SVt_PVAV: |
412
|
|
|
|
|
|
case SVt_PVHV: |
413
|
|
|
|
|
|
if ((mg = mg_find(sv, PERL_MAGIC_tied)) |
414
|
|
|
|
|
|
&& mg->mg_virtual == &sharedsv_array_vtbl) { |
415
|
|
|
|
|
|
return ((SV *)mg->mg_ptr); |
416
|
|
|
|
|
|
} |
417
|
|
|
|
|
|
break; |
418
|
|
|
|
|
|
default: |
419
|
|
|
|
|
|
/* This should work for elements as well as they |
420
|
|
|
|
|
|
* have scalar magic as well as their element magic |
421
|
|
|
|
|
|
*/ |
422
|
|
|
|
|
|
if ((mg = mg_find(sv, PERL_MAGIC_shared_scalar)) |
423
|
|
|
|
|
|
&& mg->mg_virtual == &sharedsv_scalar_vtbl) { |
424
|
|
|
|
|
|
return ((SV *)mg->mg_ptr); |
425
|
|
|
|
|
|
} |
426
|
|
|
|
|
|
break; |
427
|
|
|
|
|
|
} |
428
|
|
|
|
|
|
} |
429
|
|
|
|
|
|
/* Just for tidyness of API also handle tie objects */ |
430
|
|
|
|
|
|
if (SvROK(sv) && sv_derived_from(sv, "threads::shared::tie")) { |
431
|
|
|
|
|
|
return (SHAREDSV_FROM_OBJ(sv)); |
432
|
|
|
|
|
|
} |
433
|
|
|
|
|
|
return (NULL); |
434
|
|
|
|
|
|
} |
435
|
|
|
|
|
|
|
436
|
|
|
|
|
|
|
437
|
|
|
|
|
|
/* Associate a private SV with a shared SV by pointing the appropriate |
438
|
|
|
|
|
|
* magics at it. |
439
|
|
|
|
|
|
* Assumes lock is held. |
440
|
|
|
|
|
|
*/ |
441
|
|
|
|
|
|
void |
442
|
|
|
|
|
|
Perl_sharedsv_associate(pTHX_ SV *sv, SV *ssv) |
443
|
|
|
|
|
|
{ |
444
|
|
|
|
|
|
MAGIC *mg = 0; |
445
|
|
|
|
|
|
|
446
|
|
|
|
|
|
/* If we are asked for any private ops we need a thread */ |
447
|
|
|
|
|
|
assert ( aTHX != PL_sharedsv_space ); |
448
|
|
|
|
|
|
|
449
|
|
|
|
|
|
/* To avoid need for recursive locks require caller to hold lock */ |
450
|
|
|
|
|
|
assert ( PL_sharedsv_lock.owner == aTHX ); |
451
|
|
|
|
|
|
|
452
|
|
|
|
|
|
switch(SvTYPE(sv)) { |
453
|
|
|
|
|
|
case SVt_PVAV: |
454
|
|
|
|
|
|
case SVt_PVHV: |
455
|
|
|
|
|
|
if (!(mg = mg_find(sv, PERL_MAGIC_tied)) |
456
|
|
|
|
|
|
|| mg->mg_virtual != &sharedsv_array_vtbl |
457
|
|
|
|
|
|
|| (SV*) mg->mg_ptr != ssv) |
458
|
|
|
|
|
|
{ |
459
|
|
|
|
|
|
SV *obj = newSV(0); |
460
|
|
|
|
|
|
sv_setref_iv(obj, "threads::shared::tie", PTR2IV(ssv)); |
461
|
|
|
|
|
|
if (mg) { |
462
|
|
|
|
|
|
sv_unmagic(sv, PERL_MAGIC_tied); |
463
|
|
|
|
|
|
} |
464
|
|
|
|
|
|
mg = sv_magicext(sv, obj, PERL_MAGIC_tied, &sharedsv_array_vtbl, |
465
|
|
|
|
|
|
(char *)ssv, 0); |
466
|
|
|
|
|
|
mg->mg_flags |= (MGf_COPY|MGf_DUP); |
467
|
|
|
|
|
|
SvREFCNT_inc_void(ssv); |
468
|
|
|
|
|
|
SvREFCNT_dec(obj); |
469
|
|
|
|
|
|
} |
470
|
|
|
|
|
|
break; |
471
|
|
|
|
|
|
|
472
|
|
|
|
|
|
default: |
473
|
|
|
|
|
|
if ((SvTYPE(sv) < SVt_PVMG) |
474
|
|
|
|
|
|
|| !(mg = mg_find(sv, PERL_MAGIC_shared_scalar)) |
475
|
|
|
|
|
|
|| mg->mg_virtual != &sharedsv_scalar_vtbl |
476
|
|
|
|
|
|
|| (SV*) mg->mg_ptr != ssv) |
477
|
|
|
|
|
|
{ |
478
|
|
|
|
|
|
if (mg) { |
479
|
|
|
|
|
|
sv_unmagic(sv, PERL_MAGIC_shared_scalar); |
480
|
|
|
|
|
|
} |
481
|
|
|
|
|
|
mg = sv_magicext(sv, Nullsv, PERL_MAGIC_shared_scalar, |
482
|
|
|
|
|
|
&sharedsv_scalar_vtbl, (char *)ssv, 0); |
483
|
|
|
|
|
|
mg->mg_flags |= (MGf_DUP |
484
|
|
|
|
|
|
#ifdef MGf_LOCAL |
485
|
|
|
|
|
|
|MGf_LOCAL |
486
|
|
|
|
|
|
#endif |
487
|
|
|
|
|
|
); |
488
|
|
|
|
|
|
SvREFCNT_inc_void(ssv); |
489
|
|
|
|
|
|
} |
490
|
|
|
|
|
|
break; |
491
|
|
|
|
|
|
} |
492
|
|
|
|
|
|
|
493
|
|
|
|
|
|
assert ( Perl_sharedsv_find(aTHX_ sv) == ssv ); |
494
|
|
|
|
|
|
} |
495
|
|
|
|
|
|
|
496
|
|
|
|
|
|
|
497
|
|
|
|
|
|
/* Given a private SV, create and return an associated shared SV. |
498
|
|
|
|
|
|
* Assumes lock is held. |
499
|
|
|
|
|
|
*/ |
500
|
|
|
|
|
|
STATIC SV * |
501
|
|
|
|
|
|
S_sharedsv_new_shared(pTHX_ SV *sv) |
502
|
|
|
|
|
|
{ |
503
|
|
|
|
|
|
dTHXc; |
504
|
|
|
|
|
|
SV *ssv; |
505
|
|
|
|
|
|
|
506
|
|
|
|
|
|
assert(PL_sharedsv_lock.owner == aTHX); |
507
|
|
|
|
|
|
assert(aTHX != PL_sharedsv_space); |
508
|
|
|
|
|
|
|
509
|
|
|
|
|
|
SHARED_CONTEXT; |
510
|
|
|
|
|
|
ssv = newSV(0); |
511
|
|
|
|
|
|
SvREFCNT(ssv) = 0; /* Will be upped to 1 by Perl_sharedsv_associate */ |
512
|
|
|
|
|
|
sv_upgrade(ssv, SvTYPE(sv)); |
513
|
|
|
|
|
|
CALLER_CONTEXT; |
514
|
|
|
|
|
|
Perl_sharedsv_associate(aTHX_ sv, ssv); |
515
|
|
|
|
|
|
return (ssv); |
516
|
|
|
|
|
|
} |
517
|
|
|
|
|
|
|
518
|
|
|
|
|
|
|
519
|
|
|
|
|
|
/* Given a shared SV, create and return an associated private SV. |
520
|
|
|
|
|
|
* Assumes lock is held. |
521
|
|
|
|
|
|
*/ |
522
|
|
|
|
|
|
STATIC SV * |
523
|
|
|
|
|
|
S_sharedsv_new_private(pTHX_ SV *ssv) |
524
|
|
|
|
|
|
{ |
525
|
|
|
|
|
|
SV *sv; |
526
|
|
|
|
|
|
|
527
|
|
|
|
|
|
assert(PL_sharedsv_lock.owner == aTHX); |
528
|
|
|
|
|
|
assert(aTHX != PL_sharedsv_space); |
529
|
|
|
|
|
|
|
530
|
|
|
|
|
|
sv = newSV(0); |
531
|
|
|
|
|
|
sv_upgrade(sv, SvTYPE(ssv)); |
532
|
|
|
|
|
|
Perl_sharedsv_associate(aTHX_ sv, ssv); |
533
|
|
|
|
|
|
return (sv); |
534
|
|
|
|
|
|
} |
535
|
|
|
|
|
|
|
536
|
|
|
|
|
|
|
537
|
|
|
|
|
|
/* A threadsafe version of SvREFCNT_dec(ssv) */ |
538
|
|
|
|
|
|
|
539
|
|
|
|
|
|
STATIC void |
540
|
|
|
|
|
|
S_sharedsv_dec(pTHX_ SV* ssv) |
541
|
|
|
|
|
|
{ |
542
|
|
|
|
|
|
if (! ssv) |
543
|
|
|
|
|
|
return; |
544
|
|
|
|
|
|
ENTER_LOCK; |
545
|
|
|
|
|
|
if (SvREFCNT(ssv) > 1) { |
546
|
|
|
|
|
|
/* No side effects, so can do it lightweight */ |
547
|
|
|
|
|
|
SvREFCNT_dec(ssv); |
548
|
|
|
|
|
|
} else { |
549
|
|
|
|
|
|
dTHXc; |
550
|
|
|
|
|
|
SHARED_CONTEXT; |
551
|
|
|
|
|
|
SvREFCNT_dec(ssv); |
552
|
|
|
|
|
|
CALLER_CONTEXT; |
553
|
|
|
|
|
|
} |
554
|
|
|
|
|
|
LEAVE_LOCK; |
555
|
|
|
|
|
|
} |
556
|
|
|
|
|
|
|
557
|
|
|
|
|
|
|
558
|
|
|
|
|
|
/* Implements Perl-level share() and :shared */ |
559
|
|
|
|
|
|
|
560
|
|
|
|
|
|
void |
561
|
|
|
|
|
|
Perl_sharedsv_share(pTHX_ SV *sv) |
562
|
|
|
|
|
|
{ |
563
|
|
|
|
|
|
switch(SvTYPE(sv)) { |
564
|
|
|
|
|
|
case SVt_PVGV: |
565
|
|
|
|
|
|
Perl_croak(aTHX_ "Cannot share globs yet"); |
566
|
|
|
|
|
|
break; |
567
|
|
|
|
|
|
|
568
|
|
|
|
|
|
case SVt_PVCV: |
569
|
|
|
|
|
|
Perl_croak(aTHX_ "Cannot share subs yet"); |
570
|
|
|
|
|
|
break; |
571
|
|
|
|
|
|
|
572
|
|
|
|
|
|
default: |
573
|
|
|
|
|
|
ENTER_LOCK; |
574
|
|
|
|
|
|
(void) S_sharedsv_new_shared(aTHX_ sv); |
575
|
|
|
|
|
|
LEAVE_LOCK; |
576
|
|
|
|
|
|
SvSETMAGIC(sv); |
577
|
|
|
|
|
|
break; |
578
|
|
|
|
|
|
} |
579
|
|
|
|
|
|
} |
580
|
|
|
|
|
|
|
581
|
|
|
|
|
|
|
582
|
|
|
|
|
|
#ifdef WIN32 |
583
|
|
|
|
|
|
/* Number of milliseconds from 1/1/1601 to 1/1/1970 */ |
584
|
|
|
|
|
|
#define EPOCH_BIAS 11644473600000. |
585
|
|
|
|
|
|
|
586
|
|
|
|
|
|
/* Returns relative time in milliseconds. (Adapted from Time::HiRes.) */ |
587
|
|
|
|
|
|
STATIC DWORD |
588
|
|
|
|
|
|
S_abs_2_rel_milli(double abs) |
589
|
|
|
|
|
|
{ |
590
|
|
|
|
|
|
double rel; |
591
|
|
|
|
|
|
|
592
|
|
|
|
|
|
/* Get current time (in units of 100 nanoseconds since 1/1/1601) */ |
593
|
|
|
|
|
|
union { |
594
|
|
|
|
|
|
FILETIME ft; |
595
|
|
|
|
|
|
__int64 i64; /* 'signed' to keep compilers happy */ |
596
|
|
|
|
|
|
} now; |
597
|
|
|
|
|
|
|
598
|
|
|
|
|
|
GetSystemTimeAsFileTime(&now.ft); |
599
|
|
|
|
|
|
|
600
|
|
|
|
|
|
/* Relative time in milliseconds */ |
601
|
|
|
|
|
|
rel = (abs * 1000.) - (((double)now.i64 / 10000.) - EPOCH_BIAS); |
602
|
|
|
|
|
|
if (rel <= 0.0) { |
603
|
|
|
|
|
|
return (0); |
604
|
|
|
|
|
|
} |
605
|
|
|
|
|
|
return (DWORD)rel; |
606
|
|
|
|
|
|
} |
607
|
|
|
|
|
|
|
608
|
|
|
|
|
|
#else |
609
|
|
|
|
|
|
# if defined(OS2) |
610
|
|
|
|
|
|
# define ABS2RELMILLI(abs) \ |
611
|
|
|
|
|
|
do { \ |
612
|
|
|
|
|
|
abs -= (double)time(NULL); \ |
613
|
|
|
|
|
|
if (abs > 0) { abs *= 1000; } \ |
614
|
|
|
|
|
|
else { abs = 0; } \ |
615
|
|
|
|
|
|
} while (0) |
616
|
|
|
|
|
|
# endif /* OS2 */ |
617
|
|
|
|
|
|
#endif /* WIN32 */ |
618
|
|
|
|
|
|
|
619
|
|
|
|
|
|
/* Do OS-specific condition timed wait */ |
620
|
|
|
|
|
|
|
621
|
|
|
|
|
|
bool |
622
|
|
|
|
|
|
Perl_sharedsv_cond_timedwait(perl_cond *cond, perl_mutex *mut, double abs) |
623
|
|
|
|
|
|
{ |
624
|
|
|
|
|
|
#if defined(NETWARE) || defined(I_MACH_CTHREADS) |
625
|
|
|
|
|
|
Perl_croak_nocontext("cond_timedwait not supported on this platform"); |
626
|
|
|
|
|
|
#else |
627
|
|
|
|
|
|
# ifdef WIN32 |
628
|
|
|
|
|
|
int got_it = 0; |
629
|
|
|
|
|
|
|
630
|
|
|
|
|
|
cond->waiters++; |
631
|
|
|
|
|
|
MUTEX_UNLOCK(mut); |
632
|
|
|
|
|
|
/* See comments in win32/win32thread.h COND_WAIT vis-a-vis race */ |
633
|
|
|
|
|
|
switch (WaitForSingleObject(cond->sem, S_abs_2_rel_milli(abs))) { |
634
|
|
|
|
|
|
case WAIT_OBJECT_0: got_it = 1; break; |
635
|
|
|
|
|
|
case WAIT_TIMEOUT: break; |
636
|
|
|
|
|
|
default: |
637
|
|
|
|
|
|
/* WAIT_FAILED? WAIT_ABANDONED? others? */ |
638
|
|
|
|
|
|
Perl_croak_nocontext("panic: cond_timedwait (%ld)",GetLastError()); |
639
|
|
|
|
|
|
break; |
640
|
|
|
|
|
|
} |
641
|
|
|
|
|
|
MUTEX_LOCK(mut); |
642
|
|
|
|
|
|
cond->waiters--; |
643
|
|
|
|
|
|
return (got_it); |
644
|
|
|
|
|
|
# else |
645
|
|
|
|
|
|
# ifdef OS2 |
646
|
|
|
|
|
|
int rc, got_it = 0; |
647
|
|
|
|
|
|
STRLEN n_a; |
648
|
|
|
|
|
|
|
649
|
|
|
|
|
|
ABS2RELMILLI(abs); |
650
|
|
|
|
|
|
|
651
|
|
|
|
|
|
if ((rc = DosResetEventSem(*cond,&n_a)) && (rc != ERROR_ALREADY_RESET)) |
652
|
|
|
|
|
|
Perl_rc = rc, croak_with_os2error("panic: cond_timedwait-reset"); |
653
|
|
|
|
|
|
MUTEX_UNLOCK(mut); |
654
|
|
|
|
|
|
if (CheckOSError(DosWaitEventSem(*cond,abs)) |
655
|
|
|
|
|
|
&& (rc != ERROR_INTERRUPT)) |
656
|
|
|
|
|
|
croak_with_os2error("panic: cond_timedwait"); |
657
|
|
|
|
|
|
if (rc == ERROR_INTERRUPT) errno = EINTR; |
658
|
|
|
|
|
|
MUTEX_LOCK(mut); |
659
|
|
|
|
|
|
return (got_it); |
660
|
|
|
|
|
|
# else /* Hope you're I_PTHREAD! */ |
661
|
|
|
|
|
|
struct timespec ts; |
662
|
|
|
|
|
|
int got_it = 0; |
663
|
|
|
|
|
|
|
664
|
|
|
|
|
|
ts.tv_sec = (long)abs; |
665
|
|
|
|
|
|
abs -= (NV)ts.tv_sec; |
666
|
|
|
|
|
|
ts.tv_nsec = (long)(abs * 1000000000.0); |
667
|
|
|
|
|
|
|
668
|
|
|
|
|
|
switch (pthread_cond_timedwait(cond, mut, &ts)) { |
669
|
|
|
|
|
|
case 0: got_it = 1; break; |
670
|
|
|
|
|
|
case ETIMEDOUT: break; |
671
|
|
|
|
|
|
#ifdef OEMVS |
672
|
|
|
|
|
|
case -1: |
673
|
|
|
|
|
|
if (errno == ETIMEDOUT || errno == EAGAIN) |
674
|
|
|
|
|
|
break; |
675
|
|
|
|
|
|
#endif |
676
|
|
|
|
|
|
default: |
677
|
|
|
|
|
|
Perl_croak_nocontext("panic: cond_timedwait"); |
678
|
|
|
|
|
|
break; |
679
|
|
|
|
|
|
} |
680
|
|
|
|
|
|
return (got_it); |
681
|
|
|
|
|
|
# endif /* OS2 */ |
682
|
|
|
|
|
|
# endif /* WIN32 */ |
683
|
|
|
|
|
|
#endif /* NETWARE || I_MACH_CTHREADS */ |
684
|
|
|
|
|
|
} |
685
|
|
|
|
|
|
|
686
|
|
|
|
|
|
|
687
|
|
|
|
|
|
/* Given a thingy referenced by a shared RV, copy it's value to a private |
688
|
|
|
|
|
|
* RV, also copying the object status of the referent. |
689
|
|
|
|
|
|
* If the private side is already an appropriate RV->SV combination, keep |
690
|
|
|
|
|
|
* it if possible. |
691
|
|
|
|
|
|
*/ |
692
|
|
|
|
|
|
STATIC void |
693
|
|
|
|
|
|
S_get_RV(pTHX_ SV *sv, SV *sobj) { |
694
|
|
|
|
|
|
SV *obj; |
695
|
|
|
|
|
|
if (! (SvROK(sv) && |
696
|
|
|
|
|
|
((obj = SvRV(sv))) && |
697
|
|
|
|
|
|
(Perl_sharedsv_find(aTHX_ obj) == sobj) && |
698
|
|
|
|
|
|
(SvTYPE(obj) == SvTYPE(sobj)))) |
699
|
|
|
|
|
|
{ |
700
|
|
|
|
|
|
/* Can't reuse obj */ |
701
|
|
|
|
|
|
if (SvROK(sv)) { |
702
|
|
|
|
|
|
SvREFCNT_dec(SvRV(sv)); |
703
|
|
|
|
|
|
} else { |
704
|
|
|
|
|
|
assert(SvTYPE(sv) >= SVt_RV); |
705
|
|
|
|
|
|
sv_setsv_nomg(sv, &PL_sv_undef); |
706
|
|
|
|
|
|
SvROK_on(sv); |
707
|
|
|
|
|
|
} |
708
|
|
|
|
|
|
obj = S_sharedsv_new_private(aTHX_ sobj); |
709
|
|
|
|
|
|
SvRV_set(sv, obj); |
710
|
|
|
|
|
|
} |
711
|
|
|
|
|
|
|
712
|
|
|
|
|
|
if (SvOBJECT(obj)) { |
713
|
|
|
|
|
|
/* Remove any old blessing */ |
714
|
|
|
|
|
|
SvREFCNT_dec(SvSTASH(obj)); |
715
|
|
|
|
|
|
SvOBJECT_off(obj); |
716
|
|
|
|
|
|
} |
717
|
|
|
|
|
|
if (SvOBJECT(sobj)) { |
718
|
|
|
|
|
|
/* Add any new old blessing */ |
719
|
|
|
|
|
|
STRLEN len; |
720
|
|
|
|
|
|
char* stash_ptr = SvPV((SV*) SvSTASH(sobj), len); |
721
|
|
|
|
|
|
HV* stash = gv_stashpvn(stash_ptr, len, TRUE); |
722
|
|
|
|
|
|
SvOBJECT_on(obj); |
723
|
|
|
|
|
|
SvSTASH_set(obj, (HV*)SvREFCNT_inc(stash)); |
724
|
|
|
|
|
|
} |
725
|
|
|
|
|
|
} |
726
|
|
|
|
|
|
|
727
|
|
|
|
|
|
/* Every caller of S_get_RV needs this incantation (which cannot go inside |
728
|
|
|
|
|
|
S_get_RV itself, as we do not want recursion beyond one level): */ |
729
|
|
|
|
|
|
#define get_RV(sv, sobj) \ |
730
|
|
|
|
|
|
S_get_RV(aTHX_ sv, sobj); \ |
731
|
|
|
|
|
|
/* Look ahead for refs of refs */ \ |
732
|
|
|
|
|
|
if (SvROK(sobj)) { \ |
733
|
|
|
|
|
|
SvROK_on(SvRV(sv)); \ |
734
|
|
|
|
|
|
S_get_RV(aTHX_ SvRV(sv), SvRV(sobj)); \ |
735
|
|
|
|
|
|
} |
736
|
|
|
|
|
|
|
737
|
|
|
|
|
|
|
738
|
|
|
|
|
|
/* ------------ PERL_MAGIC_shared_scalar(n) functions -------------- */ |
739
|
|
|
|
|
|
|
740
|
|
|
|
|
|
/* Get magic for PERL_MAGIC_shared_scalar(n) */ |
741
|
|
|
|
|
|
|
742
|
|
|
|
|
|
int |
743
|
|
|
|
|
|
sharedsv_scalar_mg_get(pTHX_ SV *sv, MAGIC *mg) |
744
|
|
|
|
|
|
{ |
745
|
|
|
|
|
|
SV *ssv = (SV *) mg->mg_ptr; |
746
|
|
|
|
|
|
assert(ssv); |
747
|
|
|
|
|
|
|
748
|
|
|
|
|
|
ENTER_LOCK; |
749
|
|
|
|
|
|
if (SvROK(ssv)) { |
750
|
|
|
|
|
|
get_RV(sv, SvRV(ssv)); |
751
|
|
|
|
|
|
} else { |
752
|
|
|
|
|
|
sv_setsv_nomg(sv, ssv); |
753
|
|
|
|
|
|
} |
754
|
|
|
|
|
|
LEAVE_LOCK; |
755
|
|
|
|
|
|
return (0); |
756
|
|
|
|
|
|
} |
757
|
|
|
|
|
|
|
758
|
|
|
|
|
|
/* Copy the contents of a private SV to a shared SV. |
759
|
|
|
|
|
|
* Used by various mg_set()-type functions. |
760
|
|
|
|
|
|
* Assumes lock is held. |
761
|
|
|
|
|
|
*/ |
762
|
|
|
|
|
|
void |
763
|
|
|
|
|
|
sharedsv_scalar_store(pTHX_ SV *sv, SV *ssv) |
764
|
|
|
|
|
|
{ |
765
|
|
|
|
|
|
dTHXc; |
766
|
|
|
|
|
|
bool allowed = TRUE; |
767
|
|
|
|
|
|
|
768
|
|
|
|
|
|
assert(PL_sharedsv_lock.owner == aTHX); |
769
|
|
|
|
|
|
if (!PL_dirty && SvROK(ssv) && SvREFCNT(SvRV(ssv)) == 1) { |
770
|
|
|
|
|
|
SV *sv = sv_newmortal(); |
771
|
|
|
|
|
|
sv_upgrade(sv, SVt_RV); |
772
|
|
|
|
|
|
get_RV(sv, SvRV(ssv)); |
773
|
|
|
|
|
|
} |
774
|
|
|
|
|
|
if (SvROK(sv)) { |
775
|
|
|
|
|
|
SV *obj = SvRV(sv); |
776
|
|
|
|
|
|
SV *sobj = Perl_sharedsv_find(aTHX_ obj); |
777
|
|
|
|
|
|
if (sobj) { |
778
|
|
|
|
|
|
SHARED_CONTEXT; |
779
|
|
|
|
|
|
(void)SvUPGRADE(ssv, SVt_RV); |
780
|
|
|
|
|
|
sv_setsv_nomg(ssv, &PL_sv_undef); |
781
|
|
|
|
|
|
|
782
|
|
|
|
|
|
SvRV_set(ssv, SvREFCNT_inc(sobj)); |
783
|
|
|
|
|
|
SvROK_on(ssv); |
784
|
|
|
|
|
|
if (SvOBJECT(sobj)) { |
785
|
|
|
|
|
|
/* Remove any old blessing */ |
786
|
|
|
|
|
|
SvREFCNT_dec(SvSTASH(sobj)); |
787
|
|
|
|
|
|
SvOBJECT_off(sobj); |
788
|
|
|
|
|
|
} |
789
|
|
|
|
|
|
if (SvOBJECT(obj)) { |
790
|
|
|
|
|
|
SV* fake_stash = newSVpv(HvNAME_get(SvSTASH(obj)),0); |
791
|
|
|
|
|
|
SvOBJECT_on(sobj); |
792
|
|
|
|
|
|
SvSTASH_set(sobj, (HV*)fake_stash); |
793
|
|
|
|
|
|
} |
794
|
|
|
|
|
|
CALLER_CONTEXT; |
795
|
|
|
|
|
|
} else { |
796
|
|
|
|
|
|
allowed = FALSE; |
797
|
|
|
|
|
|
} |
798
|
|
|
|
|
|
} else { |
799
|
|
|
|
|
|
SvTEMP_off(sv); |
800
|
|
|
|
|
|
SHARED_CONTEXT; |
801
|
|
|
|
|
|
sv_setsv_nomg(ssv, sv); |
802
|
|
|
|
|
|
if (SvOBJECT(ssv)) { |
803
|
|
|
|
|
|
/* Remove any old blessing */ |
804
|
|
|
|
|
|
SvREFCNT_dec(SvSTASH(ssv)); |
805
|
|
|
|
|
|
SvOBJECT_off(ssv); |
806
|
|
|
|
|
|
} |
807
|
|
|
|
|
|
if (SvOBJECT(sv)) { |
808
|
|
|
|
|
|
SV* fake_stash = newSVpv(HvNAME_get(SvSTASH(sv)),0); |
809
|
|
|
|
|
|
SvOBJECT_on(ssv); |
810
|
|
|
|
|
|
SvSTASH_set(ssv, (HV*)fake_stash); |
811
|
|
|
|
|
|
} |
812
|
|
|
|
|
|
CALLER_CONTEXT; |
813
|
|
|
|
|
|
} |
814
|
|
|
|
|
|
if (!allowed) { |
815
|
|
|
|
|
|
Perl_croak(aTHX_ "Invalid value for shared scalar"); |
816
|
|
|
|
|
|
} |
817
|
|
|
|
|
|
} |
818
|
|
|
|
|
|
|
819
|
|
|
|
|
|
/* Set magic for PERL_MAGIC_shared_scalar(n) */ |
820
|
|
|
|
|
|
|
821
|
|
|
|
|
|
int |
822
|
|
|
|
|
|
sharedsv_scalar_mg_set(pTHX_ SV *sv, MAGIC *mg) |
823
|
|
|
|
|
|
{ |
824
|
|
|
|
|
|
SV *ssv = (SV*)(mg->mg_ptr); |
825
|
|
|
|
|
|
assert(ssv); |
826
|
|
|
|
|
|
ENTER_LOCK; |
827
|
|
|
|
|
|
if (SvTYPE(ssv) < SvTYPE(sv)) { |
828
|
|
|
|
|
|
dTHXc; |
829
|
|
|
|
|
|
SHARED_CONTEXT; |
830
|
|
|
|
|
|
sv_upgrade(ssv, SvTYPE(sv)); |
831
|
|
|
|
|
|
CALLER_CONTEXT; |
832
|
|
|
|
|
|
} |
833
|
|
|
|
|
|
sharedsv_scalar_store(aTHX_ sv, ssv); |
834
|
|
|
|
|
|
LEAVE_LOCK; |
835
|
|
|
|
|
|
return (0); |
836
|
|
|
|
|
|
} |
837
|
|
|
|
|
|
|
838
|
|
|
|
|
|
/* Free magic for PERL_MAGIC_shared_scalar(n) */ |
839
|
|
|
|
|
|
|
840
|
|
|
|
|
|
int |
841
|
|
|
|
|
|
sharedsv_scalar_mg_free(pTHX_ SV *sv, MAGIC *mg) |
842
|
|
|
|
|
|
{ |
843
|
|
|
|
|
|
PERL_UNUSED_ARG(sv); |
844
|
|
|
|
|
|
ENTER_LOCK; |
845
|
|
|
|
|
|
if (!PL_dirty |
846
|
|
|
|
|
|
&& SvROK((SV *)mg->mg_ptr) && SvREFCNT(SvRV((SV *)mg->mg_ptr)) == 1) { |
847
|
|
|
|
|
|
SV *sv = sv_newmortal(); |
848
|
|
|
|
|
|
sv_upgrade(sv, SVt_RV); |
849
|
|
|
|
|
|
get_RV(sv, SvRV((SV *)mg->mg_ptr)); |
850
|
|
|
|
|
|
} |
851
|
|
|
|
|
|
S_sharedsv_dec(aTHX_ (SV*)mg->mg_ptr); |
852
|
|
|
|
|
|
LEAVE_LOCK; |
853
|
|
|
|
|
|
return (0); |
854
|
|
|
|
|
|
} |
855
|
|
|
|
|
|
|
856
|
|
|
|
|
|
/* |
857
|
|
|
|
|
|
* Called during cloning of PERL_MAGIC_shared_scalar(n) magic in new thread |
858
|
|
|
|
|
|
*/ |
859
|
|
|
|
|
|
int |
860
|
|
|
|
|
|
sharedsv_scalar_mg_dup(pTHX_ MAGIC *mg, CLONE_PARAMS *param) |
861
|
|
|
|
|
|
{ |
862
|
|
|
|
|
|
PERL_UNUSED_ARG(param); |
863
|
|
|
|
|
|
SvREFCNT_inc_void(mg->mg_ptr); |
864
|
|
|
|
|
|
return (0); |
865
|
|
|
|
|
|
} |
866
|
|
|
|
|
|
|
867
|
|
|
|
|
|
#ifdef MGf_LOCAL |
868
|
|
|
|
|
|
/* |
869
|
|
|
|
|
|
* Called during local $shared |
870
|
|
|
|
|
|
*/ |
871
|
|
|
|
|
|
int |
872
|
|
|
|
|
|
sharedsv_scalar_mg_local(pTHX_ SV* nsv, MAGIC *mg) |
873
|
|
|
|
|
|
{ |
874
|
|
|
|
|
|
MAGIC *nmg; |
875
|
|
|
|
|
|
SV *ssv = (SV *) mg->mg_ptr; |
876
|
|
|
|
|
|
if (ssv) { |
877
|
|
|
|
|
|
ENTER_LOCK; |
878
|
|
|
|
|
|
SvREFCNT_inc_void(ssv); |
879
|
|
|
|
|
|
LEAVE_LOCK; |
880
|
|
|
|
|
|
} |
881
|
|
|
|
|
|
nmg = sv_magicext(nsv, mg->mg_obj, mg->mg_type, mg->mg_virtual, |
882
|
|
|
|
|
|
mg->mg_ptr, mg->mg_len); |
883
|
|
|
|
|
|
nmg->mg_flags = mg->mg_flags; |
884
|
|
|
|
|
|
nmg->mg_private = mg->mg_private; |
885
|
|
|
|
|
|
|
886
|
|
|
|
|
|
return (0); |
887
|
|
|
|
|
|
} |
888
|
|
|
|
|
|
#endif |
889
|
|
|
|
|
|
|
890
|
|
|
|
|
|
MGVTBL sharedsv_scalar_vtbl = { |
891
|
|
|
|
|
|
sharedsv_scalar_mg_get, /* get */ |
892
|
|
|
|
|
|
sharedsv_scalar_mg_set, /* set */ |
893
|
|
|
|
|
|
0, /* len */ |
894
|
|
|
|
|
|
0, /* clear */ |
895
|
|
|
|
|
|
sharedsv_scalar_mg_free, /* free */ |
896
|
|
|
|
|
|
0, /* copy */ |
897
|
|
|
|
|
|
sharedsv_scalar_mg_dup, /* dup */ |
898
|
|
|
|
|
|
#ifdef MGf_LOCAL |
899
|
|
|
|
|
|
sharedsv_scalar_mg_local, /* local */ |
900
|
|
|
|
|
|
#endif |
901
|
|
|
|
|
|
}; |
902
|
|
|
|
|
|
|
903
|
|
|
|
|
|
/* ------------ PERL_MAGIC_tiedelem(p) functions -------------- */ |
904
|
|
|
|
|
|
|
905
|
|
|
|
|
|
/* Get magic for PERL_MAGIC_tiedelem(p) */ |
906
|
|
|
|
|
|
|
907
|
|
|
|
|
|
int |
908
|
|
|
|
|
|
sharedsv_elem_mg_FETCH(pTHX_ SV *sv, MAGIC *mg) |
909
|
|
|
|
|
|
{ |
910
|
|
|
|
|
|
dTHXc; |
911
|
|
|
|
|
|
SV *saggregate = SHAREDSV_FROM_OBJ(mg->mg_obj); |
912
|
|
|
|
|
|
SV** svp = NULL; |
913
|
|
|
|
|
|
|
914
|
|
|
|
|
|
ENTER_LOCK; |
915
|
|
|
|
|
|
if (saggregate) { /* During global destruction, underlying |
916
|
|
|
|
|
|
aggregate may no longer exist */ |
917
|
|
|
|
|
|
if (SvTYPE(saggregate) == SVt_PVAV) { |
918
|
|
|
|
|
|
assert ( mg->mg_ptr == 0 ); |
919
|
|
|
|
|
|
SHARED_CONTEXT; |
920
|
|
|
|
|
|
svp = av_fetch((AV*) saggregate, mg->mg_len, 0); |
921
|
|
|
|
|
|
} else { |
922
|
|
|
|
|
|
char *key = mg->mg_ptr; |
923
|
|
|
|
|
|
I32 len = mg->mg_len; |
924
|
|
|
|
|
|
assert ( mg->mg_ptr != 0 ); |
925
|
|
|
|
|
|
if (mg->mg_len == HEf_SVKEY) { |
926
|
|
|
|
|
|
STRLEN slen; |
927
|
|
|
|
|
|
key = SvPV((SV *)mg->mg_ptr, slen); |
928
|
|
|
|
|
|
len = slen; |
929
|
|
|
|
|
|
if (SvUTF8((SV *)mg->mg_ptr)) { |
930
|
|
|
|
|
|
len = -len; |
931
|
|
|
|
|
|
} |
932
|
|
|
|
|
|
} |
933
|
|
|
|
|
|
SHARED_CONTEXT; |
934
|
|
|
|
|
|
svp = hv_fetch((HV*) saggregate, key, len, 0); |
935
|
|
|
|
|
|
} |
936
|
|
|
|
|
|
CALLER_CONTEXT; |
937
|
|
|
|
|
|
} |
938
|
|
|
|
|
|
if (svp) { |
939
|
|
|
|
|
|
/* Exists in the array */ |
940
|
|
|
|
|
|
if (SvROK(*svp)) { |
941
|
|
|
|
|
|
get_RV(sv, SvRV(*svp)); |
942
|
|
|
|
|
|
} else { |
943
|
|
|
|
|
|
/* $ary->[elem] or $ary->{elem} is a scalar */ |
944
|
|
|
|
|
|
Perl_sharedsv_associate(aTHX_ sv, *svp); |
945
|
|
|
|
|
|
sv_setsv(sv, *svp); |
946
|
|
|
|
|
|
} |
947
|
|
|
|
|
|
} else { |
948
|
|
|
|
|
|
/* Not in the array */ |
949
|
|
|
|
|
|
sv_setsv(sv, &PL_sv_undef); |
950
|
|
|
|
|
|
} |
951
|
|
|
|
|
|
LEAVE_LOCK; |
952
|
|
|
|
|
|
return (0); |
953
|
|
|
|
|
|
} |
954
|
|
|
|
|
|
|
955
|
|
|
|
|
|
/* Set magic for PERL_MAGIC_tiedelem(p) */ |
956
|
|
|
|
|
|
|
957
|
|
|
|
|
|
int |
958
|
|
|
|
|
|
sharedsv_elem_mg_STORE(pTHX_ SV *sv, MAGIC *mg) |
959
|
|
|
|
|
|
{ |
960
|
|
|
|
|
|
dTHXc; |
961
|
|
|
|
|
|
SV *saggregate = SHAREDSV_FROM_OBJ(mg->mg_obj); |
962
|
|
|
|
|
|
SV **svp; |
963
|
|
|
|
|
|
U32 dualvar_flags = DUALVAR_FLAGS(sv); |
964
|
|
|
|
|
|
|
965
|
|
|
|
|
|
/* Theory - SV itself is magically shared - and we have ordered the |
966
|
|
|
|
|
|
magic such that by the time we get here it has been stored |
967
|
|
|
|
|
|
to its shared counterpart |
968
|
|
|
|
|
|
*/ |
969
|
|
|
|
|
|
ENTER_LOCK; |
970
|
|
|
|
|
|
assert(saggregate); |
971
|
|
|
|
|
|
if (SvTYPE(saggregate) == SVt_PVAV) { |
972
|
|
|
|
|
|
assert ( mg->mg_ptr == 0 ); |
973
|
|
|
|
|
|
SHARED_CONTEXT; |
974
|
|
|
|
|
|
svp = av_fetch((AV*) saggregate, mg->mg_len, 1); |
975
|
|
|
|
|
|
} else { |
976
|
|
|
|
|
|
char *key = mg->mg_ptr; |
977
|
|
|
|
|
|
I32 len = mg->mg_len; |
978
|
|
|
|
|
|
assert ( mg->mg_ptr != 0 ); |
979
|
|
|
|
|
|
if (mg->mg_len == HEf_SVKEY) { |
980
|
|
|
|
|
|
STRLEN slen; |
981
|
|
|
|
|
|
key = SvPV((SV *)mg->mg_ptr, slen); |
982
|
|
|
|
|
|
len = slen; |
983
|
|
|
|
|
|
if (SvUTF8((SV *)mg->mg_ptr)) { |
984
|
|
|
|
|
|
len = -len; |
985
|
|
|
|
|
|
} |
986
|
|
|
|
|
|
} |
987
|
|
|
|
|
|
SHARED_CONTEXT; |
988
|
|
|
|
|
|
svp = hv_fetch((HV*) saggregate, key, len, 1); |
989
|
|
|
|
|
|
} |
990
|
|
|
|
|
|
CALLER_CONTEXT; |
991
|
|
|
|
|
|
Perl_sharedsv_associate(aTHX_ sv, *svp); |
992
|
|
|
|
|
|
sharedsv_scalar_store(aTHX_ sv, *svp); |
993
|
|
|
|
|
|
SvFLAGS(*svp) |= dualvar_flags; |
994
|
|
|
|
|
|
LEAVE_LOCK; |
995
|
|
|
|
|
|
return (0); |
996
|
|
|
|
|
|
} |
997
|
|
|
|
|
|
|
998
|
|
|
|
|
|
/* Clear magic for PERL_MAGIC_tiedelem(p) */ |
999
|
|
|
|
|
|
|
1000
|
|
|
|
|
|
int |
1001
|
|
|
|
|
|
sharedsv_elem_mg_DELETE(pTHX_ SV *sv, MAGIC *mg) |
1002
|
|
|
|
|
|
{ |
1003
|
|
|
|
|
|
dTHXc; |
1004
|
|
|
|
|
|
MAGIC *shmg; |
1005
|
|
|
|
|
|
SV *saggregate = SHAREDSV_FROM_OBJ(mg->mg_obj); |
1006
|
|
|
|
|
|
|
1007
|
|
|
|
|
|
/* Object may not exist during global destruction */ |
1008
|
|
|
|
|
|
if (! saggregate) { |
1009
|
|
|
|
|
|
return (0); |
1010
|
|
|
|
|
|
} |
1011
|
|
|
|
|
|
|
1012
|
|
|
|
|
|
ENTER_LOCK; |
1013
|
|
|
|
|
|
sharedsv_elem_mg_FETCH(aTHX_ sv, mg); |
1014
|
|
|
|
|
|
if ((shmg = mg_find(sv, PERL_MAGIC_shared_scalar))) |
1015
|
|
|
|
|
|
sharedsv_scalar_mg_get(aTHX_ sv, shmg); |
1016
|
|
|
|
|
|
if (SvTYPE(saggregate) == SVt_PVAV) { |
1017
|
|
|
|
|
|
SHARED_CONTEXT; |
1018
|
|
|
|
|
|
av_delete((AV*) saggregate, mg->mg_len, G_DISCARD); |
1019
|
|
|
|
|
|
} else { |
1020
|
|
|
|
|
|
char *key = mg->mg_ptr; |
1021
|
|
|
|
|
|
I32 len = mg->mg_len; |
1022
|
|
|
|
|
|
assert ( mg->mg_ptr != 0 ); |
1023
|
|
|
|
|
|
if (mg->mg_len == HEf_SVKEY) { |
1024
|
|
|
|
|
|
STRLEN slen; |
1025
|
|
|
|
|
|
key = SvPV((SV *)mg->mg_ptr, slen); |
1026
|
|
|
|
|
|
len = slen; |
1027
|
|
|
|
|
|
if (SvUTF8((SV *)mg->mg_ptr)) { |
1028
|
|
|
|
|
|
len = -len; |
1029
|
|
|
|
|
|
} |
1030
|
|
|
|
|
|
} |
1031
|
|
|
|
|
|
SHARED_CONTEXT; |
1032
|
|
|
|
|
|
(void) hv_delete((HV*) saggregate, key, len, G_DISCARD); |
1033
|
|
|
|
|
|
} |
1034
|
|
|
|
|
|
CALLER_CONTEXT; |
1035
|
|
|
|
|
|
LEAVE_LOCK; |
1036
|
|
|
|
|
|
return (0); |
1037
|
|
|
|
|
|
} |
1038
|
|
|
|
|
|
|
1039
|
|
|
|
|
|
/* Called during cloning of PERL_MAGIC_tiedelem(p) magic in new |
1040
|
|
|
|
|
|
* thread */ |
1041
|
|
|
|
|
|
|
1042
|
|
|
|
|
|
int |
1043
|
|
|
|
|
|
sharedsv_elem_mg_dup(pTHX_ MAGIC *mg, CLONE_PARAMS *param) |
1044
|
|
|
|
|
|
{ |
1045
|
|
|
|
|
|
PERL_UNUSED_ARG(param); |
1046
|
|
|
|
|
|
SvREFCNT_inc_void(SHAREDSV_FROM_OBJ(mg->mg_obj)); |
1047
|
|
|
|
|
|
assert(mg->mg_flags & MGf_DUP); |
1048
|
|
|
|
|
|
return (0); |
1049
|
|
|
|
|
|
} |
1050
|
|
|
|
|
|
|
1051
|
|
|
|
|
|
MGVTBL sharedsv_elem_vtbl = { |
1052
|
|
|
|
|
|
sharedsv_elem_mg_FETCH, /* get */ |
1053
|
|
|
|
|
|
sharedsv_elem_mg_STORE, /* set */ |
1054
|
|
|
|
|
|
0, /* len */ |
1055
|
|
|
|
|
|
sharedsv_elem_mg_DELETE, /* clear */ |
1056
|
|
|
|
|
|
0, /* free */ |
1057
|
|
|
|
|
|
0, /* copy */ |
1058
|
|
|
|
|
|
sharedsv_elem_mg_dup, /* dup */ |
1059
|
|
|
|
|
|
#ifdef MGf_LOCAL |
1060
|
|
|
|
|
|
0, /* local */ |
1061
|
|
|
|
|
|
#endif |
1062
|
|
|
|
|
|
}; |
1063
|
|
|
|
|
|
|
1064
|
|
|
|
|
|
/* ------------ PERL_MAGIC_tied(P) functions -------------- */ |
1065
|
|
|
|
|
|
|
1066
|
|
|
|
|
|
/* Len magic for PERL_MAGIC_tied(P) */ |
1067
|
|
|
|
|
|
|
1068
|
|
|
|
|
|
U32 |
1069
|
|
|
|
|
|
sharedsv_array_mg_FETCHSIZE(pTHX_ SV *sv, MAGIC *mg) |
1070
|
|
|
|
|
|
{ |
1071
|
|
|
|
|
|
dTHXc; |
1072
|
|
|
|
|
|
SV *ssv = (SV *) mg->mg_ptr; |
1073
|
|
|
|
|
|
U32 val; |
1074
|
|
|
|
|
|
PERL_UNUSED_ARG(sv); |
1075
|
|
|
|
|
|
SHARED_EDIT; |
1076
|
|
|
|
|
|
if (SvTYPE(ssv) == SVt_PVAV) { |
1077
|
|
|
|
|
|
val = av_len((AV*) ssv); |
1078
|
|
|
|
|
|
} else { |
1079
|
|
|
|
|
|
/* Not actually defined by tie API but ... */ |
1080
|
|
|
|
|
|
val = HvUSEDKEYS((HV*) ssv); |
1081
|
|
|
|
|
|
} |
1082
|
|
|
|
|
|
SHARED_RELEASE; |
1083
|
|
|
|
|
|
return (val); |
1084
|
|
|
|
|
|
} |
1085
|
|
|
|
|
|
|
1086
|
|
|
|
|
|
/* Clear magic for PERL_MAGIC_tied(P) */ |
1087
|
|
|
|
|
|
|
1088
|
|
|
|
|
|
int |
1089
|
|
|
|
|
|
sharedsv_array_mg_CLEAR(pTHX_ SV *sv, MAGIC *mg) |
1090
|
|
|
|
|
|
{ |
1091
|
|
|
|
|
|
dTHXc; |
1092
|
|
|
|
|
|
SV *ssv = (SV *) mg->mg_ptr; |
1093
|
|
|
|
|
|
const bool isav = SvTYPE(ssv) == SVt_PVAV; |
1094
|
|
|
|
|
|
PERL_UNUSED_ARG(sv); |
1095
|
|
|
|
|
|
SHARED_EDIT; |
1096
|
|
|
|
|
|
if (!PL_dirty) { |
1097
|
|
|
|
|
|
SV **svp = isav ? AvARRAY((AV *)ssv) : NULL; |
1098
|
|
|
|
|
|
I32 items = isav ? AvFILLp((AV *)ssv) + 1 : 0; |
1099
|
|
|
|
|
|
HE *iter; |
1100
|
|
|
|
|
|
if (!isav) hv_iterinit((HV *)ssv); |
1101
|
|
|
|
|
|
while (isav ? items-- : !!(iter = hv_iternext((HV *)ssv))) { |
1102
|
|
|
|
|
|
SV *sv = isav ? *svp++ : HeVAL(iter); |
1103
|
|
|
|
|
|
if (!sv) continue; |
1104
|
|
|
|
|
|
if ( (SvOBJECT(sv) || (SvROK(sv) && (sv = SvRV(sv)))) |
1105
|
|
|
|
|
|
&& SvREFCNT(sv) == 1 ) { |
1106
|
|
|
|
|
|
SV *tmp = Perl_sv_newmortal(caller_perl); |
1107
|
|
|
|
|
|
PERL_SET_CONTEXT((aTHX = caller_perl)); |
1108
|
|
|
|
|
|
sv_upgrade(tmp, SVt_RV); |
1109
|
|
|
|
|
|
get_RV(tmp, sv); |
1110
|
|
|
|
|
|
PERL_SET_CONTEXT((aTHX = PL_sharedsv_space)); |
1111
|
|
|
|
|
|
} |
1112
|
|
|
|
|
|
} |
1113
|
|
|
|
|
|
} |
1114
|
|
|
|
|
|
if (isav) av_clear((AV*) ssv); |
1115
|
|
|
|
|
|
else hv_clear((HV*) ssv); |
1116
|
|
|
|
|
|
SHARED_RELEASE; |
1117
|
|
|
|
|
|
return (0); |
1118
|
|
|
|
|
|
} |
1119
|
|
|
|
|
|
|
1120
|
|
|
|
|
|
/* Free magic for PERL_MAGIC_tied(P) */ |
1121
|
|
|
|
|
|
|
1122
|
|
|
|
|
|
int |
1123
|
|
|
|
|
|
sharedsv_array_mg_free(pTHX_ SV *sv, MAGIC *mg) |
1124
|
|
|
|
|
|
{ |
1125
|
|
|
|
|
|
PERL_UNUSED_ARG(sv); |
1126
|
|
|
|
|
|
S_sharedsv_dec(aTHX_ (SV*)mg->mg_ptr); |
1127
|
|
|
|
|
|
return (0); |
1128
|
|
|
|
|
|
} |
1129
|
|
|
|
|
|
|
1130
|
|
|
|
|
|
/* |
1131
|
|
|
|
|
|
* Copy magic for PERL_MAGIC_tied(P) |
1132
|
|
|
|
|
|
* This is called when perl is about to access an element of |
1133
|
|
|
|
|
|
* the array - |
1134
|
|
|
|
|
|
*/ |
1135
|
|
|
|
|
|
#if PERL_VERSION >= 11 |
1136
|
|
|
|
|
|
int |
1137
|
|
|
|
|
|
sharedsv_array_mg_copy(pTHX_ SV *sv, MAGIC* mg, |
1138
|
|
|
|
|
|
SV *nsv, const char *name, I32 namlen) |
1139
|
|
|
|
|
|
#else |
1140
|
|
|
|
|
|
int |
1141
|
|
|
|
|
|
sharedsv_array_mg_copy(pTHX_ SV *sv, MAGIC* mg, |
1142
|
|
|
|
|
|
SV *nsv, const char *name, int namlen) |
1143
|
|
|
|
|
|
#endif |
1144
|
|
|
|
|
|
{ |
1145
|
|
|
|
|
|
MAGIC *nmg = sv_magicext(nsv,mg->mg_obj, |
1146
|
|
|
|
|
|
toLOWER(mg->mg_type),&sharedsv_elem_vtbl, |
1147
|
|
|
|
|
|
name, namlen); |
1148
|
|
|
|
|
|
PERL_UNUSED_ARG(sv); |
1149
|
|
|
|
|
|
nmg->mg_flags |= MGf_DUP; |
1150
|
|
|
|
|
|
return (1); |
1151
|
|
|
|
|
|
} |
1152
|
|
|
|
|
|
|
1153
|
|
|
|
|
|
/* Called during cloning of PERL_MAGIC_tied(P) magic in new thread */ |
1154
|
|
|
|
|
|
|
1155
|
|
|
|
|
|
int |
1156
|
|
|
|
|
|
sharedsv_array_mg_dup(pTHX_ MAGIC *mg, CLONE_PARAMS *param) |
1157
|
|
|
|
|
|
{ |
1158
|
|
|
|
|
|
PERL_UNUSED_ARG(param); |
1159
|
|
|
|
|
|
SvREFCNT_inc_void((SV*)mg->mg_ptr); |
1160
|
|
|
|
|
|
assert(mg->mg_flags & MGf_DUP); |
1161
|
|
|
|
|
|
return (0); |
1162
|
|
|
|
|
|
} |
1163
|
|
|
|
|
|
|
1164
|
|
|
|
|
|
MGVTBL sharedsv_array_vtbl = { |
1165
|
|
|
|
|
|
0, /* get */ |
1166
|
|
|
|
|
|
0, /* set */ |
1167
|
|
|
|
|
|
sharedsv_array_mg_FETCHSIZE,/* len */ |
1168
|
|
|
|
|
|
sharedsv_array_mg_CLEAR, /* clear */ |
1169
|
|
|
|
|
|
sharedsv_array_mg_free, /* free */ |
1170
|
|
|
|
|
|
sharedsv_array_mg_copy, /* copy */ |
1171
|
|
|
|
|
|
sharedsv_array_mg_dup, /* dup */ |
1172
|
|
|
|
|
|
#ifdef MGf_LOCAL |
1173
|
|
|
|
|
|
0, /* local */ |
1174
|
|
|
|
|
|
#endif |
1175
|
|
|
|
|
|
}; |
1176
|
|
|
|
|
|
|
1177
|
|
|
|
|
|
|
1178
|
|
|
|
|
|
/* Recursively unlocks a shared sv. */ |
1179
|
|
|
|
|
|
|
1180
|
|
|
|
|
|
void |
1181
|
|
|
|
|
|
Perl_sharedsv_unlock(pTHX_ SV *ssv) |
1182
|
|
|
|
|
|
{ |
1183
|
|
|
|
|
|
user_lock *ul = S_get_userlock(aTHX_ ssv, 0); |
1184
|
|
|
|
|
|
assert(ul); |
1185
|
|
|
|
|
|
recursive_lock_release(aTHX_ &ul->lock); |
1186
|
|
|
|
|
|
} |
1187
|
|
|
|
|
|
|
1188
|
|
|
|
|
|
|
1189
|
|
|
|
|
|
/* Recursive locks on a sharedsv. |
1190
|
|
|
|
|
|
* Locks are dynamically scoped at the level of the first lock. |
1191
|
|
|
|
|
|
*/ |
1192
|
|
|
|
|
|
void |
1193
|
|
|
|
|
|
Perl_sharedsv_lock(pTHX_ SV *ssv) |
1194
|
|
|
|
|
|
{ |
1195
|
|
|
|
|
|
user_lock *ul; |
1196
|
|
|
|
|
|
if (! ssv) |
1197
|
|
|
|
|
|
return; |
1198
|
|
|
|
|
|
ul = S_get_userlock(aTHX_ ssv, 1); |
1199
|
|
|
|
|
|
recursive_lock_acquire(aTHX_ &ul->lock, __FILE__, __LINE__); |
1200
|
|
|
|
|
|
} |
1201
|
|
|
|
|
|
|
1202
|
|
|
|
|
|
/* Handles calls from lock() builtin via PL_lockhook */ |
1203
|
|
|
|
|
|
|
1204
|
|
|
|
|
|
void |
1205
|
|
|
|
|
|
Perl_sharedsv_locksv(pTHX_ SV *sv) |
1206
|
|
|
|
|
|
{ |
1207
|
|
|
|
|
|
SV *ssv; |
1208
|
|
|
|
|
|
|
1209
|
|
|
|
|
|
if (SvROK(sv)) |
1210
|
|
|
|
|
|
sv = SvRV(sv); |
1211
|
|
|
|
|
|
ssv = Perl_sharedsv_find(aTHX_ sv); |
1212
|
|
|
|
|
|
if (!ssv) |
1213
|
|
|
|
|
|
croak("lock can only be used on shared values"); |
1214
|
|
|
|
|
|
Perl_sharedsv_lock(aTHX_ ssv); |
1215
|
|
|
|
|
|
} |
1216
|
|
|
|
|
|
|
1217
|
|
|
|
|
|
|
1218
|
|
|
|
|
|
/* Can a shared object be destroyed? |
1219
|
|
|
|
|
|
* True if not a shared, |
1220
|
|
|
|
|
|
* or if destroying last proxy on a shared object |
1221
|
|
|
|
|
|
*/ |
1222
|
|
|
|
|
|
#ifdef PL_destroyhook |
1223
|
|
|
|
|
|
bool |
1224
|
|
|
|
|
|
Perl_shared_object_destroy(pTHX_ SV *sv) |
1225
|
|
|
|
|
|
{ |
1226
|
|
|
|
|
|
SV *ssv; |
1227
|
|
|
|
|
|
|
1228
|
|
|
|
|
|
if (SvROK(sv)) |
1229
|
|
|
|
|
|
sv = SvRV(sv); |
1230
|
|
|
|
|
|
ssv = Perl_sharedsv_find(aTHX_ sv); |
1231
|
|
|
|
|
|
return (!ssv || (SvREFCNT(ssv) <= 1)); |
1232
|
|
|
|
|
|
} |
1233
|
|
|
|
|
|
#endif |
1234
|
|
|
|
|
|
|
1235
|
|
|
|
|
|
/* veto signal dispatch if we have the lock */ |
1236
|
|
|
|
|
|
|
1237
|
|
|
|
|
|
#ifdef PL_signalhook |
1238
|
|
|
|
|
|
|
1239
|
|
|
|
|
|
STATIC despatch_signals_proc_t prev_signal_hook = NULL; |
1240
|
|
|
|
|
|
|
1241
|
|
|
|
|
|
STATIC void |
1242
|
|
|
|
|
|
S_shared_signal_hook(pTHX) { |
1243
|
|
|
|
|
|
int us; |
1244
|
|
|
|
|
|
MUTEX_LOCK(&PL_sharedsv_lock.mutex); |
1245
|
|
|
|
|
|
us = (PL_sharedsv_lock.owner == aTHX); |
1246
|
|
|
|
|
|
MUTEX_UNLOCK(&PL_sharedsv_lock.mutex); |
1247
|
|
|
|
|
|
if (us) |
1248
|
|
|
|
|
|
return; /* try again later */ |
1249
|
|
|
|
|
|
prev_signal_hook(aTHX); |
1250
|
|
|
|
|
|
} |
1251
|
|
|
|
|
|
#endif |
1252
|
|
|
|
|
|
|
1253
|
|
|
|
|
|
/* Saves a space for keeping SVs wider than an interpreter. */ |
1254
|
|
|
|
|
|
|
1255
|
|
|
|
|
|
void |
1256
|
|
|
|
|
|
Perl_sharedsv_init(pTHX) |
1257
|
|
|
|
|
|
{ |
1258
|
|
|
|
|
|
dTHXc; |
1259
|
|
|
|
|
|
/* This pair leaves us in shared context ... */ |
1260
|
|
|
|
|
|
PL_sharedsv_space = perl_alloc(); |
1261
|
|
|
|
|
|
perl_construct(PL_sharedsv_space); |
1262
|
|
|
|
|
|
LEAVE; /* This balances the ENTER at the end of perl_construct. */ |
1263
|
|
|
|
|
|
PERL_SET_CONTEXT((aTHX = caller_perl)); |
1264
|
|
|
|
|
|
recursive_lock_init(aTHX_ &PL_sharedsv_lock); |
1265
|
|
|
|
|
|
PL_lockhook = &Perl_sharedsv_locksv; |
1266
|
|
|
|
|
|
PL_sharehook = &Perl_sharedsv_share; |
1267
|
|
|
|
|
|
#ifdef PL_destroyhook |
1268
|
|
|
|
|
|
PL_destroyhook = &Perl_shared_object_destroy; |
1269
|
|
|
|
|
|
#endif |
1270
|
|
|
|
|
|
#ifdef PL_signalhook |
1271
|
|
|
|
|
|
if (!prev_signal_hook) { |
1272
|
|
|
|
|
|
prev_signal_hook = PL_signalhook; |
1273
|
|
|
|
|
|
PL_signalhook = &S_shared_signal_hook; |
1274
|
|
|
|
|
|
} |
1275
|
|
|
|
|
|
#endif |
1276
|
|
|
|
|
|
} |
1277
|
|
|
|
|
|
|
1278
|
|
|
|
|
|
#endif /* USE_ITHREADS */ |
1279
|
|
|
|
|
|
|
1280
|
|
|
|
|
|
#line 1281 "shared.c" |
1281
|
|
|
|
|
|
#ifndef PERL_UNUSED_VAR |
1282
|
|
|
|
|
|
# define PERL_UNUSED_VAR(var) if (0) var = var |
1283
|
|
|
|
|
|
#endif |
1284
|
|
|
|
|
|
|
1285
|
|
|
|
|
|
#ifndef dVAR |
1286
|
|
|
|
|
|
# define dVAR dNOOP |
1287
|
|
|
|
|
|
#endif |
1288
|
|
|
|
|
|
|
1289
|
|
|
|
|
|
|
1290
|
|
|
|
|
|
/* This stuff is not part of the API! You have been warned. */ |
1291
|
|
|
|
|
|
#ifndef PERL_VERSION_DECIMAL |
1292
|
|
|
|
|
|
# define PERL_VERSION_DECIMAL(r,v,s) (r*1000000 + v*1000 + s) |
1293
|
|
|
|
|
|
#endif |
1294
|
|
|
|
|
|
#ifndef PERL_DECIMAL_VERSION |
1295
|
|
|
|
|
|
# define PERL_DECIMAL_VERSION \ |
1296
|
|
|
|
|
|
PERL_VERSION_DECIMAL(PERL_REVISION,PERL_VERSION,PERL_SUBVERSION) |
1297
|
|
|
|
|
|
#endif |
1298
|
|
|
|
|
|
#ifndef PERL_VERSION_GE |
1299
|
|
|
|
|
|
# define PERL_VERSION_GE(r,v,s) \ |
1300
|
|
|
|
|
|
(PERL_DECIMAL_VERSION >= PERL_VERSION_DECIMAL(r,v,s)) |
1301
|
|
|
|
|
|
#endif |
1302
|
|
|
|
|
|
#ifndef PERL_VERSION_LE |
1303
|
|
|
|
|
|
# define PERL_VERSION_LE(r,v,s) \ |
1304
|
|
|
|
|
|
(PERL_DECIMAL_VERSION <= PERL_VERSION_DECIMAL(r,v,s)) |
1305
|
|
|
|
|
|
#endif |
1306
|
|
|
|
|
|
|
1307
|
|
|
|
|
|
/* XS_INTERNAL is the explicit static-linkage variant of the default |
1308
|
|
|
|
|
|
* XS macro. |
1309
|
|
|
|
|
|
* |
1310
|
|
|
|
|
|
* XS_EXTERNAL is the same as XS_INTERNAL except it does not include |
1311
|
|
|
|
|
|
* "STATIC", ie. it exports XSUB symbols. You probably don't want that |
1312
|
|
|
|
|
|
* for anything but the BOOT XSUB. |
1313
|
|
|
|
|
|
* |
1314
|
|
|
|
|
|
* See XSUB.h in core! |
1315
|
|
|
|
|
|
*/ |
1316
|
|
|
|
|
|
|
1317
|
|
|
|
|
|
|
1318
|
|
|
|
|
|
/* TODO: This might be compatible further back than 5.10.0. */ |
1319
|
|
|
|
|
|
#if PERL_VERSION_GE(5, 10, 0) && PERL_VERSION_LE(5, 15, 1) |
1320
|
|
|
|
|
|
# undef XS_EXTERNAL |
1321
|
|
|
|
|
|
# undef XS_INTERNAL |
1322
|
|
|
|
|
|
# if defined(__CYGWIN__) && defined(USE_DYNAMIC_LOADING) |
1323
|
|
|
|
|
|
# define XS_EXTERNAL(name) __declspec(dllexport) XSPROTO(name) |
1324
|
|
|
|
|
|
# define XS_INTERNAL(name) STATIC XSPROTO(name) |
1325
|
|
|
|
|
|
# endif |
1326
|
|
|
|
|
|
# if defined(__SYMBIAN32__) |
1327
|
|
|
|
|
|
# define XS_EXTERNAL(name) EXPORT_C XSPROTO(name) |
1328
|
|
|
|
|
|
# define XS_INTERNAL(name) EXPORT_C STATIC XSPROTO(name) |
1329
|
|
|
|
|
|
# endif |
1330
|
|
|
|
|
|
# ifndef XS_EXTERNAL |
1331
|
|
|
|
|
|
# if defined(HASATTRIBUTE_UNUSED) && !defined(__cplusplus) |
1332
|
|
|
|
|
|
# define XS_EXTERNAL(name) void name(pTHX_ CV* cv __attribute__unused__) |
1333
|
|
|
|
|
|
# define XS_INTERNAL(name) STATIC void name(pTHX_ CV* cv __attribute__unused__) |
1334
|
|
|
|
|
|
# else |
1335
|
|
|
|
|
|
# ifdef __cplusplus |
1336
|
|
|
|
|
|
# define XS_EXTERNAL(name) extern "C" XSPROTO(name) |
1337
|
|
|
|
|
|
# define XS_INTERNAL(name) static XSPROTO(name) |
1338
|
|
|
|
|
|
# else |
1339
|
|
|
|
|
|
# define XS_EXTERNAL(name) XSPROTO(name) |
1340
|
|
|
|
|
|
# define XS_INTERNAL(name) STATIC XSPROTO(name) |
1341
|
|
|
|
|
|
# endif |
1342
|
|
|
|
|
|
# endif |
1343
|
|
|
|
|
|
# endif |
1344
|
|
|
|
|
|
#endif |
1345
|
|
|
|
|
|
|
1346
|
|
|
|
|
|
/* perl >= 5.10.0 && perl <= 5.15.1 */ |
1347
|
|
|
|
|
|
|
1348
|
|
|
|
|
|
|
1349
|
|
|
|
|
|
/* The XS_EXTERNAL macro is used for functions that must not be static |
1350
|
|
|
|
|
|
* like the boot XSUB of a module. If perl didn't have an XS_EXTERNAL |
1351
|
|
|
|
|
|
* macro defined, the best we can do is assume XS is the same. |
1352
|
|
|
|
|
|
* Dito for XS_INTERNAL. |
1353
|
|
|
|
|
|
*/ |
1354
|
|
|
|
|
|
#ifndef XS_EXTERNAL |
1355
|
|
|
|
|
|
# define XS_EXTERNAL(name) XS(name) |
1356
|
|
|
|
|
|
#endif |
1357
|
|
|
|
|
|
#ifndef XS_INTERNAL |
1358
|
|
|
|
|
|
# define XS_INTERNAL(name) XS(name) |
1359
|
|
|
|
|
|
#endif |
1360
|
|
|
|
|
|
|
1361
|
|
|
|
|
|
/* Now, finally, after all this mess, we want an ExtUtils::ParseXS |
1362
|
|
|
|
|
|
* internal macro that we're free to redefine for varying linkage due |
1363
|
|
|
|
|
|
* to the EXPORT_XSUB_SYMBOLS XS keyword. This is internal, use |
1364
|
|
|
|
|
|
* XS_EXTERNAL(name) or XS_INTERNAL(name) in your code if you need to! |
1365
|
|
|
|
|
|
*/ |
1366
|
|
|
|
|
|
|
1367
|
|
|
|
|
|
#undef XS_EUPXS |
1368
|
|
|
|
|
|
#if defined(PERL_EUPXS_ALWAYS_EXPORT) |
1369
|
|
|
|
|
|
# define XS_EUPXS(name) XS_EXTERNAL(name) |
1370
|
|
|
|
|
|
#else |
1371
|
|
|
|
|
|
/* default to internal */ |
1372
|
|
|
|
|
|
# define XS_EUPXS(name) XS_INTERNAL(name) |
1373
|
|
|
|
|
|
#endif |
1374
|
|
|
|
|
|
|
1375
|
|
|
|
|
|
#ifndef PERL_ARGS_ASSERT_CROAK_XS_USAGE |
1376
|
|
|
|
|
|
#define PERL_ARGS_ASSERT_CROAK_XS_USAGE assert(cv); assert(params) |
1377
|
|
|
|
|
|
|
1378
|
|
|
|
|
|
/* prototype to pass -Wmissing-prototypes */ |
1379
|
|
|
|
|
|
STATIC void |
1380
|
|
|
|
|
|
S_croak_xs_usage(pTHX_ const CV *const cv, const char *const params); |
1381
|
|
|
|
|
|
|
1382
|
|
|
|
|
|
STATIC void |
1383
|
|
|
|
|
|
S_croak_xs_usage(pTHX_ const CV *const cv, const char *const params) |
1384
|
|
|
|
|
|
{ |
1385
|
|
|
|
|
|
const GV *const gv = CvGV(cv); |
1386
|
|
|
|
|
|
|
1387
|
|
|
|
|
|
PERL_ARGS_ASSERT_CROAK_XS_USAGE; |
1388
|
|
|
|
|
|
|
1389
|
|
|
|
|
|
if (gv) { |
1390
|
|
|
|
|
|
const char *const gvname = GvNAME(gv); |
1391
|
|
|
|
|
|
const HV *const stash = GvSTASH(gv); |
1392
|
|
|
|
|
|
const char *const hvname = stash ? HvNAME(stash) : NULL; |
1393
|
|
|
|
|
|
|
1394
|
|
|
|
|
|
if (hvname) |
1395
|
|
|
|
|
|
Perl_croak(aTHX_ "Usage: %s::%s(%s)", hvname, gvname, params); |
1396
|
|
|
|
|
|
else |
1397
|
|
|
|
|
|
Perl_croak(aTHX_ "Usage: %s(%s)", gvname, params); |
1398
|
|
|
|
|
|
} else { |
1399
|
|
|
|
|
|
/* Pants. I don't think that it should be possible to get here. */ |
1400
|
|
|
|
|
|
Perl_croak(aTHX_ "Usage: CODE(0x%"UVxf")(%s)", PTR2UV(cv), params); |
1401
|
|
|
|
|
|
} |
1402
|
|
|
|
|
|
} |
1403
|
|
|
|
|
|
#undef PERL_ARGS_ASSERT_CROAK_XS_USAGE |
1404
|
|
|
|
|
|
|
1405
|
|
|
|
|
|
#ifdef PERL_IMPLICIT_CONTEXT |
1406
|
|
|
|
|
|
#define croak_xs_usage(a,b) S_croak_xs_usage(aTHX_ a,b) |
1407
|
|
|
|
|
|
#else |
1408
|
|
|
|
|
|
#define croak_xs_usage S_croak_xs_usage |
1409
|
|
|
|
|
|
#endif |
1410
|
|
|
|
|
|
|
1411
|
|
|
|
|
|
#endif |
1412
|
|
|
|
|
|
|
1413
|
|
|
|
|
|
/* NOTE: the prototype of newXSproto() is different in versions of perls, |
1414
|
|
|
|
|
|
* so we define a portable version of newXSproto() |
1415
|
|
|
|
|
|
*/ |
1416
|
|
|
|
|
|
#ifdef newXS_flags |
1417
|
|
|
|
|
|
#define newXSproto_portable(name, c_impl, file, proto) newXS_flags(name, c_impl, file, proto, 0) |
1418
|
|
|
|
|
|
#else |
1419
|
|
|
|
|
|
#define newXSproto_portable(name, c_impl, file, proto) (PL_Sv=(SV*)newXS(name, c_impl, file), sv_setpv(PL_Sv, proto), (CV*)PL_Sv) |
1420
|
|
|
|
|
|
#endif /* !defined(newXS_flags) */ |
1421
|
|
|
|
|
|
|
1422
|
|
|
|
|
|
#line 1423 "shared.c" |
1423
|
|
|
|
|
|
#ifdef USE_ITHREADS |
1424
|
|
|
|
|
|
#define XSubPPtmpAAAA 1 |
1425
|
|
|
|
|
|
|
1426
|
|
|
|
|
|
|
1427
|
|
|
|
|
|
XS_EUPXS(XS_threads__shared__tie_PUSH); /* prototype to pass -Wmissing-prototypes */ |
1428
|
|
|
|
|
|
XS_EUPXS(XS_threads__shared__tie_PUSH) |
1429
|
|
|
|
|
|
{ |
1430
|
|
|
|
|
|
dVAR; dXSARGS; |
1431
|
|
|
|
|
|
if (items < 1) |
1432
|
|
|
|
|
|
croak_xs_usage(cv, "obj, ..."); |
1433
|
|
|
|
|
|
{ |
1434
|
|
|
|
|
|
SV * obj = ST(0) |
1435
|
|
|
|
|
|
; |
1436
|
|
|
|
|
|
#line 1280 "shared.xs" |
1437
|
|
|
|
|
|
dTHXc; |
1438
|
|
|
|
|
|
SV *sobj = SHAREDSV_FROM_OBJ(obj); |
1439
|
|
|
|
|
|
int ii; |
1440
|
|
|
|
|
|
for (ii = 1; ii < items; ii++) { |
1441
|
|
|
|
|
|
SV* tmp = newSVsv(ST(ii)); |
1442
|
|
|
|
|
|
SV *stmp; |
1443
|
|
|
|
|
|
U32 dualvar_flags = DUALVAR_FLAGS(tmp); |
1444
|
|
|
|
|
|
ENTER_LOCK; |
1445
|
|
|
|
|
|
stmp = S_sharedsv_new_shared(aTHX_ tmp); |
1446
|
|
|
|
|
|
sharedsv_scalar_store(aTHX_ tmp, stmp); |
1447
|
|
|
|
|
|
SvFLAGS(stmp) |= dualvar_flags; |
1448
|
|
|
|
|
|
SHARED_CONTEXT; |
1449
|
|
|
|
|
|
av_push((AV*) sobj, stmp); |
1450
|
|
|
|
|
|
SvREFCNT_inc_void(stmp); |
1451
|
|
|
|
|
|
SHARED_RELEASE; |
1452
|
|
|
|
|
|
SvREFCNT_dec(tmp); |
1453
|
|
|
|
|
|
} |
1454
|
|
|
|
|
|
#line 1455 "shared.c" |
1455
|
|
|
|
|
|
} |
1456
|
|
|
|
|
|
XSRETURN_EMPTY; |
1457
|
|
|
|
|
|
} |
1458
|
|
|
|
|
|
|
1459
|
|
|
|
|
|
|
1460
|
|
|
|
|
|
XS_EUPXS(XS_threads__shared__tie_UNSHIFT); /* prototype to pass -Wmissing-prototypes */ |
1461
|
|
|
|
|
|
XS_EUPXS(XS_threads__shared__tie_UNSHIFT) |
1462
|
|
|
|
|
|
{ |
1463
|
|
|
|
|
|
dVAR; dXSARGS; |
1464
|
|
|
|
|
|
if (items < 1) |
1465
|
|
|
|
|
|
croak_xs_usage(cv, "obj, ..."); |
1466
|
|
|
|
|
|
{ |
1467
|
|
|
|
|
|
SV * obj = ST(0) |
1468
|
|
|
|
|
|
; |
1469
|
|
|
|
|
|
#line 1302 "shared.xs" |
1470
|
|
|
|
|
|
dTHXc; |
1471
|
|
|
|
|
|
SV *sobj = SHAREDSV_FROM_OBJ(obj); |
1472
|
|
|
|
|
|
int ii; |
1473
|
|
|
|
|
|
ENTER_LOCK; |
1474
|
|
|
|
|
|
SHARED_CONTEXT; |
1475
|
|
|
|
|
|
av_unshift((AV*)sobj, items - 1); |
1476
|
|
|
|
|
|
CALLER_CONTEXT; |
1477
|
|
|
|
|
|
for (ii = 1; ii < items; ii++) { |
1478
|
|
|
|
|
|
SV *tmp = newSVsv(ST(ii)); |
1479
|
|
|
|
|
|
U32 dualvar_flags = DUALVAR_FLAGS(tmp); |
1480
|
|
|
|
|
|
SV *stmp = S_sharedsv_new_shared(aTHX_ tmp); |
1481
|
|
|
|
|
|
sharedsv_scalar_store(aTHX_ tmp, stmp); |
1482
|
|
|
|
|
|
SHARED_CONTEXT; |
1483
|
|
|
|
|
|
SvFLAGS(stmp) |= dualvar_flags; |
1484
|
|
|
|
|
|
av_store((AV*) sobj, ii - 1, stmp); |
1485
|
|
|
|
|
|
SvREFCNT_inc_void(stmp); |
1486
|
|
|
|
|
|
CALLER_CONTEXT; |
1487
|
|
|
|
|
|
SvREFCNT_dec(tmp); |
1488
|
|
|
|
|
|
} |
1489
|
|
|
|
|
|
LEAVE_LOCK; |
1490
|
|
|
|
|
|
#line 1491 "shared.c" |
1491
|
|
|
|
|
|
} |
1492
|
|
|
|
|
|
XSRETURN_EMPTY; |
1493
|
|
|
|
|
|
} |
1494
|
|
|
|
|
|
|
1495
|
|
|
|
|
|
|
1496
|
|
|
|
|
|
XS_EUPXS(XS_threads__shared__tie_POP); /* prototype to pass -Wmissing-prototypes */ |
1497
|
|
|
|
|
|
XS_EUPXS(XS_threads__shared__tie_POP) |
1498
|
|
|
|
|
|
{ |
1499
|
|
|
|
|
|
dVAR; dXSARGS; |
1500
|
|
|
|
|
|
if (items != 1) |
1501
|
|
|
|
|
|
croak_xs_usage(cv, "obj"); |
1502
|
|
|
|
|
|
{ |
1503
|
|
|
|
|
|
SV * obj = ST(0) |
1504
|
|
|
|
|
|
; |
1505
|
|
|
|
|
|
#line 1327 "shared.xs" |
1506
|
|
|
|
|
|
dTHXc; |
1507
|
|
|
|
|
|
SV *sobj = SHAREDSV_FROM_OBJ(obj); |
1508
|
|
|
|
|
|
SV* ssv; |
1509
|
|
|
|
|
|
ENTER_LOCK; |
1510
|
|
|
|
|
|
SHARED_CONTEXT; |
1511
|
|
|
|
|
|
ssv = av_pop((AV*)sobj); |
1512
|
|
|
|
|
|
CALLER_CONTEXT; |
1513
|
|
|
|
|
|
ST(0) = sv_newmortal(); |
1514
|
|
|
|
|
|
Perl_sharedsv_associate(aTHX_ ST(0), ssv); |
1515
|
|
|
|
|
|
SvREFCNT_dec(ssv); |
1516
|
|
|
|
|
|
LEAVE_LOCK; |
1517
|
|
|
|
|
|
/* XSRETURN(1); - implied */ |
1518
|
|
|
|
|
|
#line 1519 "shared.c" |
1519
|
|
|
|
|
|
} |
1520
|
|
|
|
|
|
XSRETURN(1); |
1521
|
|
|
|
|
|
} |
1522
|
|
|
|
|
|
|
1523
|
|
|
|
|
|
|
1524
|
|
|
|
|
|
XS_EUPXS(XS_threads__shared__tie_SHIFT); /* prototype to pass -Wmissing-prototypes */ |
1525
|
|
|
|
|
|
XS_EUPXS(XS_threads__shared__tie_SHIFT) |
1526
|
|
|
|
|
|
{ |
1527
|
|
|
|
|
|
dVAR; dXSARGS; |
1528
|
|
|
|
|
|
if (items != 1) |
1529
|
|
|
|
|
|
croak_xs_usage(cv, "obj"); |
1530
|
|
|
|
|
|
{ |
1531
|
|
|
|
|
|
SV * obj = ST(0) |
1532
|
|
|
|
|
|
; |
1533
|
|
|
|
|
|
#line 1344 "shared.xs" |
1534
|
|
|
|
|
|
dTHXc; |
1535
|
|
|
|
|
|
SV *sobj = SHAREDSV_FROM_OBJ(obj); |
1536
|
|
|
|
|
|
SV* ssv; |
1537
|
|
|
|
|
|
ENTER_LOCK; |
1538
|
|
|
|
|
|
SHARED_CONTEXT; |
1539
|
|
|
|
|
|
ssv = av_shift((AV*)sobj); |
1540
|
|
|
|
|
|
CALLER_CONTEXT; |
1541
|
|
|
|
|
|
ST(0) = sv_newmortal(); |
1542
|
|
|
|
|
|
Perl_sharedsv_associate(aTHX_ ST(0), ssv); |
1543
|
|
|
|
|
|
SvREFCNT_dec(ssv); |
1544
|
|
|
|
|
|
LEAVE_LOCK; |
1545
|
|
|
|
|
|
/* XSRETURN(1); - implied */ |
1546
|
|
|
|
|
|
#line 1547 "shared.c" |
1547
|
|
|
|
|
|
} |
1548
|
|
|
|
|
|
XSRETURN(1); |
1549
|
|
|
|
|
|
} |
1550
|
|
|
|
|
|
|
1551
|
|
|
|
|
|
|
1552
|
|
|
|
|
|
XS_EUPXS(XS_threads__shared__tie_EXTEND); /* prototype to pass -Wmissing-prototypes */ |
1553
|
|
|
|
|
|
XS_EUPXS(XS_threads__shared__tie_EXTEND) |
1554
|
|
|
|
|
|
{ |
1555
|
|
|
|
|
|
dVAR; dXSARGS; |
1556
|
|
|
|
|
|
if (items != 2) |
1557
|
|
|
|
|
|
croak_xs_usage(cv, "obj, count"); |
1558
|
|
|
|
|
|
{ |
1559
|
|
|
|
|
|
SV * obj = ST(0) |
1560
|
|
|
|
|
|
; |
1561
|
|
|
|
|
|
IV count = (IV)SvIV(ST(1)) |
1562
|
|
|
|
|
|
; |
1563
|
|
|
|
|
|
#line 1361 "shared.xs" |
1564
|
|
|
|
|
|
dTHXc; |
1565
|
|
|
|
|
|
SV *sobj = SHAREDSV_FROM_OBJ(obj); |
1566
|
|
|
|
|
|
SHARED_EDIT; |
1567
|
|
|
|
|
|
av_extend((AV*)sobj, count); |
1568
|
|
|
|
|
|
SHARED_RELEASE; |
1569
|
|
|
|
|
|
#line 1570 "shared.c" |
1570
|
|
|
|
|
|
} |
1571
|
|
|
|
|
|
XSRETURN_EMPTY; |
1572
|
|
|
|
|
|
} |
1573
|
|
|
|
|
|
|
1574
|
|
|
|
|
|
|
1575
|
|
|
|
|
|
XS_EUPXS(XS_threads__shared__tie_STORESIZE); /* prototype to pass -Wmissing-prototypes */ |
1576
|
|
|
|
|
|
XS_EUPXS(XS_threads__shared__tie_STORESIZE) |
1577
|
|
|
|
|
|
{ |
1578
|
|
|
|
|
|
dVAR; dXSARGS; |
1579
|
|
|
|
|
|
if (items != 2) |
1580
|
|
|
|
|
|
croak_xs_usage(cv, "obj, count"); |
1581
|
|
|
|
|
|
{ |
1582
|
|
|
|
|
|
SV * obj = ST(0) |
1583
|
|
|
|
|
|
; |
1584
|
|
|
|
|
|
IV count = (IV)SvIV(ST(1)) |
1585
|
|
|
|
|
|
; |
1586
|
|
|
|
|
|
#line 1371 "shared.xs" |
1587
|
|
|
|
|
|
dTHXc; |
1588
|
|
|
|
|
|
SV *sobj = SHAREDSV_FROM_OBJ(obj); |
1589
|
|
|
|
|
|
SHARED_EDIT; |
1590
|
|
|
|
|
|
av_fill((AV*) sobj, count); |
1591
|
|
|
|
|
|
SHARED_RELEASE; |
1592
|
|
|
|
|
|
#line 1593 "shared.c" |
1593
|
|
|
|
|
|
} |
1594
|
|
|
|
|
|
XSRETURN_EMPTY; |
1595
|
|
|
|
|
|
} |
1596
|
|
|
|
|
|
|
1597
|
|
|
|
|
|
|
1598
|
|
|
|
|
|
XS_EUPXS(XS_threads__shared__tie_EXISTS); /* prototype to pass -Wmissing-prototypes */ |
1599
|
|
|
|
|
|
XS_EUPXS(XS_threads__shared__tie_EXISTS) |
1600
|
|
|
|
|
|
{ |
1601
|
|
|
|
|
|
dVAR; dXSARGS; |
1602
|
|
|
|
|
|
if (items != 2) |
1603
|
|
|
|
|
|
croak_xs_usage(cv, "obj, index"); |
1604
|
|
|
|
|
|
{ |
1605
|
|
|
|
|
|
SV * obj = ST(0) |
1606
|
|
|
|
|
|
; |
1607
|
|
|
|
|
|
SV * index = ST(1) |
1608
|
|
|
|
|
|
; |
1609
|
|
|
|
|
|
#line 1381 "shared.xs" |
1610
|
|
|
|
|
|
dTHXc; |
1611
|
|
|
|
|
|
SV *sobj = SHAREDSV_FROM_OBJ(obj); |
1612
|
|
|
|
|
|
bool exists; |
1613
|
|
|
|
|
|
if (SvTYPE(sobj) == SVt_PVAV) { |
1614
|
|
|
|
|
|
SHARED_EDIT; |
1615
|
|
|
|
|
|
exists = av_exists((AV*) sobj, SvIV(index)); |
1616
|
|
|
|
|
|
} else { |
1617
|
|
|
|
|
|
I32 len; |
1618
|
|
|
|
|
|
STRLEN slen; |
1619
|
|
|
|
|
|
char *key = SvPVutf8(index, slen); |
1620
|
|
|
|
|
|
len = slen; |
1621
|
|
|
|
|
|
if (SvUTF8(index)) { |
1622
|
|
|
|
|
|
len = -len; |
1623
|
|
|
|
|
|
} |
1624
|
|
|
|
|
|
SHARED_EDIT; |
1625
|
|
|
|
|
|
exists = hv_exists((HV*) sobj, key, len); |
1626
|
|
|
|
|
|
} |
1627
|
|
|
|
|
|
SHARED_RELEASE; |
1628
|
|
|
|
|
|
ST(0) = (exists) ? &PL_sv_yes : &PL_sv_no; |
1629
|
|
|
|
|
|
/* XSRETURN(1); - implied */ |
1630
|
|
|
|
|
|
#line 1631 "shared.c" |
1631
|
|
|
|
|
|
} |
1632
|
|
|
|
|
|
XSRETURN(1); |
1633
|
|
|
|
|
|
} |
1634
|
|
|
|
|
|
|
1635
|
|
|
|
|
|
|
1636
|
|
|
|
|
|
XS_EUPXS(XS_threads__shared__tie_FIRSTKEY); /* prototype to pass -Wmissing-prototypes */ |
1637
|
|
|
|
|
|
XS_EUPXS(XS_threads__shared__tie_FIRSTKEY) |
1638
|
|
|
|
|
|
{ |
1639
|
|
|
|
|
|
dVAR; dXSARGS; |
1640
|
|
|
|
|
|
if (items != 1) |
1641
|
|
|
|
|
|
croak_xs_usage(cv, "obj"); |
1642
|
|
|
|
|
|
{ |
1643
|
|
|
|
|
|
SV * obj = ST(0) |
1644
|
|
|
|
|
|
; |
1645
|
|
|
|
|
|
#line 1406 "shared.xs" |
1646
|
|
|
|
|
|
dTHXc; |
1647
|
|
|
|
|
|
SV *sobj = SHAREDSV_FROM_OBJ(obj); |
1648
|
|
|
|
|
|
char* key = NULL; |
1649
|
|
|
|
|
|
I32 len = 0; |
1650
|
|
|
|
|
|
HE* entry; |
1651
|
|
|
|
|
|
ENTER_LOCK; |
1652
|
|
|
|
|
|
SHARED_CONTEXT; |
1653
|
|
|
|
|
|
hv_iterinit((HV*) sobj); |
1654
|
|
|
|
|
|
entry = hv_iternext((HV*) sobj); |
1655
|
|
|
|
|
|
if (entry) { |
1656
|
|
|
|
|
|
I32 utf8 = HeKUTF8(entry); |
1657
|
|
|
|
|
|
key = hv_iterkey(entry,&len); |
1658
|
|
|
|
|
|
CALLER_CONTEXT; |
1659
|
|
|
|
|
|
ST(0) = newSVpvn_flags(key, len, SVs_TEMP | (utf8 ? SVf_UTF8 : 0)); |
1660
|
|
|
|
|
|
} else { |
1661
|
|
|
|
|
|
CALLER_CONTEXT; |
1662
|
|
|
|
|
|
ST(0) = &PL_sv_undef; |
1663
|
|
|
|
|
|
} |
1664
|
|
|
|
|
|
LEAVE_LOCK; |
1665
|
|
|
|
|
|
/* XSRETURN(1); - implied */ |
1666
|
|
|
|
|
|
#line 1667 "shared.c" |
1667
|
|
|
|
|
|
} |
1668
|
|
|
|
|
|
XSRETURN(1); |
1669
|
|
|
|
|
|
} |
1670
|
|
|
|
|
|
|
1671
|
|
|
|
|
|
|
1672
|
|
|
|
|
|
XS_EUPXS(XS_threads__shared__tie_NEXTKEY); /* prototype to pass -Wmissing-prototypes */ |
1673
|
|
|
|
|
|
XS_EUPXS(XS_threads__shared__tie_NEXTKEY) |
1674
|
|
|
|
|
|
{ |
1675
|
|
|
|
|
|
dVAR; dXSARGS; |
1676
|
|
|
|
|
|
if (items != 2) |
1677
|
|
|
|
|
|
croak_xs_usage(cv, "obj, oldkey"); |
1678
|
|
|
|
|
|
{ |
1679
|
|
|
|
|
|
SV * obj = ST(0) |
1680
|
|
|
|
|
|
; |
1681
|
|
|
|
|
|
SV * oldkey = ST(1) |
1682
|
|
|
|
|
|
; |
1683
|
|
|
|
|
|
#line 1431 "shared.xs" |
1684
|
|
|
|
|
|
dTHXc; |
1685
|
|
|
|
|
|
SV *sobj = SHAREDSV_FROM_OBJ(obj); |
1686
|
|
|
|
|
|
char* key = NULL; |
1687
|
|
|
|
|
|
I32 len = 0; |
1688
|
|
|
|
|
|
HE* entry; |
1689
|
|
|
|
|
|
|
1690
|
|
|
|
|
|
PERL_UNUSED_VAR(oldkey); |
1691
|
|
|
|
|
|
|
1692
|
|
|
|
|
|
ENTER_LOCK; |
1693
|
|
|
|
|
|
SHARED_CONTEXT; |
1694
|
|
|
|
|
|
entry = hv_iternext((HV*) sobj); |
1695
|
|
|
|
|
|
if (entry) { |
1696
|
|
|
|
|
|
I32 utf8 = HeKUTF8(entry); |
1697
|
|
|
|
|
|
key = hv_iterkey(entry,&len); |
1698
|
|
|
|
|
|
CALLER_CONTEXT; |
1699
|
|
|
|
|
|
ST(0) = newSVpvn_flags(key, len, SVs_TEMP | (utf8 ? SVf_UTF8 : 0)); |
1700
|
|
|
|
|
|
} else { |
1701
|
|
|
|
|
|
CALLER_CONTEXT; |
1702
|
|
|
|
|
|
ST(0) = &PL_sv_undef; |
1703
|
|
|
|
|
|
} |
1704
|
|
|
|
|
|
LEAVE_LOCK; |
1705
|
|
|
|
|
|
/* XSRETURN(1); - implied */ |
1706
|
|
|
|
|
|
#line 1707 "shared.c" |
1707
|
|
|
|
|
|
} |
1708
|
|
|
|
|
|
XSRETURN(1); |
1709
|
|
|
|
|
|
} |
1710
|
|
|
|
|
|
|
1711
|
|
|
|
|
|
|
1712
|
|
|
|
|
|
XS_EUPXS(XS_threads__shared__id); /* prototype to pass -Wmissing-prototypes */ |
1713
|
|
|
|
|
|
XS_EUPXS(XS_threads__shared__id) |
1714
|
|
|
|
|
|
{ |
1715
|
|
|
|
|
|
dVAR; dXSARGS; |
1716
|
|
|
|
|
|
if (items != 1) |
1717
|
|
|
|
|
|
croak_xs_usage(cv, "myref"); |
1718
|
|
|
|
|
|
{ |
1719
|
|
|
|
|
|
#line 1463 "shared.xs" |
1720
|
|
|
|
|
|
SV *ssv; |
1721
|
|
|
|
|
|
#line 1722 "shared.c" |
1722
|
|
|
|
|
|
SV * myref = ST(0) |
1723
|
|
|
|
|
|
; |
1724
|
|
|
|
|
|
#line 1465 "shared.xs" |
1725
|
|
|
|
|
|
myref = SvRV(myref); |
1726
|
|
|
|
|
|
if (SvMAGICAL(myref)) |
1727
|
|
|
|
|
|
mg_get(myref); |
1728
|
|
|
|
|
|
if (SvROK(myref)) |
1729
|
|
|
|
|
|
myref = SvRV(myref); |
1730
|
|
|
|
|
|
ssv = Perl_sharedsv_find(aTHX_ myref); |
1731
|
|
|
|
|
|
if (! ssv) |
1732
|
|
|
|
|
|
XSRETURN_UNDEF; |
1733
|
|
|
|
|
|
ST(0) = sv_2mortal(newSVuv(PTR2UV(ssv))); |
1734
|
|
|
|
|
|
/* XSRETURN(1); - implied */ |
1735
|
|
|
|
|
|
#line 1736 "shared.c" |
1736
|
|
|
|
|
|
} |
1737
|
|
|
|
|
|
XSRETURN(1); |
1738
|
|
|
|
|
|
} |
1739
|
|
|
|
|
|
|
1740
|
|
|
|
|
|
|
1741
|
|
|
|
|
|
XS_EUPXS(XS_threads__shared__refcnt); /* prototype to pass -Wmissing-prototypes */ |
1742
|
|
|
|
|
|
XS_EUPXS(XS_threads__shared__refcnt) |
1743
|
|
|
|
|
|
{ |
1744
|
|
|
|
|
|
dVAR; dXSARGS; |
1745
|
|
|
|
|
|
if (items != 1) |
1746
|
|
|
|
|
|
croak_xs_usage(cv, "myref"); |
1747
|
|
|
|
|
|
{ |
1748
|
|
|
|
|
|
#line 1481 "shared.xs" |
1749
|
|
|
|
|
|
SV *ssv; |
1750
|
|
|
|
|
|
#line 1751 "shared.c" |
1751
|
|
|
|
|
|
SV * myref = ST(0) |
1752
|
|
|
|
|
|
; |
1753
|
|
|
|
|
|
#line 1483 "shared.xs" |
1754
|
|
|
|
|
|
myref = SvRV(myref); |
1755
|
|
|
|
|
|
if (SvROK(myref)) |
1756
|
|
|
|
|
|
myref = SvRV(myref); |
1757
|
|
|
|
|
|
ssv = Perl_sharedsv_find(aTHX_ myref); |
1758
|
|
|
|
|
|
if (! ssv) { |
1759
|
|
|
|
|
|
if (ckWARN(WARN_THREADS)) { |
1760
|
|
|
|
|
|
Perl_warner(aTHX_ packWARN(WARN_THREADS), |
1761
|
|
|
|
|
|
"%" SVf " is not shared", ST(0)); |
1762
|
|
|
|
|
|
} |
1763
|
|
|
|
|
|
XSRETURN_UNDEF; |
1764
|
|
|
|
|
|
} |
1765
|
|
|
|
|
|
ST(0) = sv_2mortal(newSViv(SvREFCNT(ssv))); |
1766
|
|
|
|
|
|
/* XSRETURN(1); - implied */ |
1767
|
|
|
|
|
|
#line 1768 "shared.c" |
1768
|
|
|
|
|
|
} |
1769
|
|
|
|
|
|
XSRETURN(1); |
1770
|
|
|
|
|
|
} |
1771
|
|
|
|
|
|
|
1772
|
|
|
|
|
|
|
1773
|
|
|
|
|
|
XS_EUPXS(XS_threads__shared_share); /* prototype to pass -Wmissing-prototypes */ |
1774
|
|
|
|
|
|
XS_EUPXS(XS_threads__shared_share) |
1775
|
|
|
|
|
|
{ |
1776
|
|
|
|
|
|
dVAR; dXSARGS; |
1777
|
|
|
|
|
|
if (items != 1) |
1778
|
|
|
|
|
|
croak_xs_usage(cv, "myref"); |
1779
|
|
|
|
|
|
{ |
1780
|
|
|
|
|
|
SV * myref = ST(0) |
1781
|
|
|
|
|
|
; |
1782
|
|
|
|
|
|
#line 1502 "shared.xs" |
1783
|
|
|
|
|
|
if (! SvROK(myref)) |
1784
|
|
|
|
|
|
Perl_croak(aTHX_ "Argument to share needs to be passed as ref"); |
1785
|
|
|
|
|
|
myref = SvRV(myref); |
1786
|
|
|
|
|
|
if (SvROK(myref)) |
1787
|
|
|
|
|
|
myref = SvRV(myref); |
1788
|
|
|
|
|
|
Perl_sharedsv_share(aTHX_ myref); |
1789
|
|
|
|
|
|
ST(0) = sv_2mortal(newRV_inc(myref)); |
1790
|
|
|
|
|
|
/* XSRETURN(1); - implied */ |
1791
|
|
|
|
|
|
#line 1792 "shared.c" |
1792
|
|
|
|
|
|
} |
1793
|
|
|
|
|
|
XSRETURN(1); |
1794
|
|
|
|
|
|
} |
1795
|
|
|
|
|
|
|
1796
|
|
|
|
|
|
|
1797
|
|
|
|
|
|
XS_EUPXS(XS_threads__shared_cond_wait); /* prototype to pass -Wmissing-prototypes */ |
1798
|
|
|
|
|
|
XS_EUPXS(XS_threads__shared_cond_wait) |
1799
|
|
|
|
|
|
{ |
1800
|
|
|
|
|
|
dVAR; dXSARGS; |
1801
|
|
|
|
|
|
if (items < 1 || items > 2) |
1802
|
|
|
|
|
|
croak_xs_usage(cv, "ref_cond, ref_lock= 0"); |
1803
|
|
|
|
|
|
{ |
1804
|
|
|
|
|
|
#line 1516 "shared.xs" |
1805
|
|
|
|
|
|
SV *ssv; |
1806
|
|
|
|
|
|
perl_cond* user_condition; |
1807
|
|
|
|
|
|
int locks; |
1808
|
|
|
|
|
|
user_lock *ul; |
1809
|
|
|
|
|
|
#line 1810 "shared.c" |
1810
|
|
|
|
|
|
SV * ref_cond = ST(0) |
1811
|
|
|
|
|
|
; |
1812
|
|
|
|
|
|
SV * ref_lock; |
1813
|
|
|
|
|
|
|
1814
|
|
|
|
|
|
if (items < 2) |
1815
|
|
|
|
|
|
ref_lock = 0; |
1816
|
|
|
|
|
|
else { |
1817
|
|
|
|
|
|
ref_lock = ST(1) |
1818
|
|
|
|
|
|
; |
1819
|
|
|
|
|
|
} |
1820
|
|
|
|
|
|
#line 1521 "shared.xs" |
1821
|
|
|
|
|
|
if (!SvROK(ref_cond)) |
1822
|
|
|
|
|
|
Perl_croak(aTHX_ "Argument to cond_wait needs to be passed as ref"); |
1823
|
|
|
|
|
|
ref_cond = SvRV(ref_cond); |
1824
|
|
|
|
|
|
if (SvROK(ref_cond)) |
1825
|
|
|
|
|
|
ref_cond = SvRV(ref_cond); |
1826
|
|
|
|
|
|
ssv = Perl_sharedsv_find(aTHX_ ref_cond); |
1827
|
|
|
|
|
|
if (! ssv) |
1828
|
|
|
|
|
|
Perl_croak(aTHX_ "cond_wait can only be used on shared values"); |
1829
|
|
|
|
|
|
ul = S_get_userlock(aTHX_ ssv, 1); |
1830
|
|
|
|
|
|
|
1831
|
|
|
|
|
|
user_condition = &ul->user_cond; |
1832
|
|
|
|
|
|
if (ref_lock && (ref_cond != ref_lock)) { |
1833
|
|
|
|
|
|
if (!SvROK(ref_lock)) |
1834
|
|
|
|
|
|
Perl_croak(aTHX_ "cond_wait lock needs to be passed as ref"); |
1835
|
|
|
|
|
|
ref_lock = SvRV(ref_lock); |
1836
|
|
|
|
|
|
if (SvROK(ref_lock)) ref_lock = SvRV(ref_lock); |
1837
|
|
|
|
|
|
ssv = Perl_sharedsv_find(aTHX_ ref_lock); |
1838
|
|
|
|
|
|
if (! ssv) |
1839
|
|
|
|
|
|
Perl_croak(aTHX_ "cond_wait lock must be a shared value"); |
1840
|
|
|
|
|
|
ul = S_get_userlock(aTHX_ ssv, 1); |
1841
|
|
|
|
|
|
} |
1842
|
|
|
|
|
|
if (ul->lock.owner != aTHX) |
1843
|
|
|
|
|
|
croak("You need a lock before you can cond_wait"); |
1844
|
|
|
|
|
|
|
1845
|
|
|
|
|
|
/* Stealing the members of the lock object worries me - NI-S */ |
1846
|
|
|
|
|
|
MUTEX_LOCK(&ul->lock.mutex); |
1847
|
|
|
|
|
|
ul->lock.owner = NULL; |
1848
|
|
|
|
|
|
locks = ul->lock.locks; |
1849
|
|
|
|
|
|
ul->lock.locks = 0; |
1850
|
|
|
|
|
|
|
1851
|
|
|
|
|
|
/* Since we are releasing the lock here, we need to tell other |
1852
|
|
|
|
|
|
* people that it is ok to go ahead and use it */ |
1853
|
|
|
|
|
|
COND_SIGNAL(&ul->lock.cond); |
1854
|
|
|
|
|
|
COND_WAIT(user_condition, &ul->lock.mutex); |
1855
|
|
|
|
|
|
while (ul->lock.owner != NULL) { |
1856
|
|
|
|
|
|
/* OK -- must reacquire the lock */ |
1857
|
|
|
|
|
|
COND_WAIT(&ul->lock.cond, &ul->lock.mutex); |
1858
|
|
|
|
|
|
} |
1859
|
|
|
|
|
|
ul->lock.owner = aTHX; |
1860
|
|
|
|
|
|
ul->lock.locks = locks; |
1861
|
|
|
|
|
|
MUTEX_UNLOCK(&ul->lock.mutex); |
1862
|
|
|
|
|
|
#line 1863 "shared.c" |
1863
|
|
|
|
|
|
} |
1864
|
|
|
|
|
|
XSRETURN_EMPTY; |
1865
|
|
|
|
|
|
} |
1866
|
|
|
|
|
|
|
1867
|
|
|
|
|
|
|
1868
|
|
|
|
|
|
XS_EUPXS(XS_threads__shared_cond_timedwait); /* prototype to pass -Wmissing-prototypes */ |
1869
|
|
|
|
|
|
XS_EUPXS(XS_threads__shared_cond_timedwait) |
1870
|
|
|
|
|
|
{ |
1871
|
|
|
|
|
|
dVAR; dXSARGS; |
1872
|
|
|
|
|
|
if (items < 2 || items > 3) |
1873
|
|
|
|
|
|
croak_xs_usage(cv, "ref_cond, abs, ref_lock= 0"); |
1874
|
|
|
|
|
|
{ |
1875
|
|
|
|
|
|
#line 1568 "shared.xs" |
1876
|
|
|
|
|
|
SV *ssv; |
1877
|
|
|
|
|
|
perl_cond* user_condition; |
1878
|
|
|
|
|
|
int locks; |
1879
|
|
|
|
|
|
user_lock *ul; |
1880
|
|
|
|
|
|
#line 1881 "shared.c" |
1881
|
|
|
|
|
|
int RETVAL; |
1882
|
|
|
|
|
|
dXSTARG; |
1883
|
|
|
|
|
|
SV * ref_cond = ST(0) |
1884
|
|
|
|
|
|
; |
1885
|
|
|
|
|
|
double abs = (double)SvNV(ST(1)) |
1886
|
|
|
|
|
|
; |
1887
|
|
|
|
|
|
SV * ref_lock; |
1888
|
|
|
|
|
|
|
1889
|
|
|
|
|
|
if (items < 3) |
1890
|
|
|
|
|
|
ref_lock = 0; |
1891
|
|
|
|
|
|
else { |
1892
|
|
|
|
|
|
ref_lock = ST(2) |
1893
|
|
|
|
|
|
; |
1894
|
|
|
|
|
|
} |
1895
|
|
|
|
|
|
#line 1573 "shared.xs" |
1896
|
|
|
|
|
|
if (! SvROK(ref_cond)) |
1897
|
|
|
|
|
|
Perl_croak(aTHX_ "Argument to cond_timedwait needs to be passed as ref"); |
1898
|
|
|
|
|
|
ref_cond = SvRV(ref_cond); |
1899
|
|
|
|
|
|
if (SvROK(ref_cond)) |
1900
|
|
|
|
|
|
ref_cond = SvRV(ref_cond); |
1901
|
|
|
|
|
|
ssv = Perl_sharedsv_find(aTHX_ ref_cond); |
1902
|
|
|
|
|
|
if (! ssv) |
1903
|
|
|
|
|
|
Perl_croak(aTHX_ "cond_timedwait can only be used on shared values"); |
1904
|
|
|
|
|
|
ul = S_get_userlock(aTHX_ ssv, 1); |
1905
|
|
|
|
|
|
|
1906
|
|
|
|
|
|
user_condition = &ul->user_cond; |
1907
|
|
|
|
|
|
if (ref_lock && (ref_cond != ref_lock)) { |
1908
|
|
|
|
|
|
if (! SvROK(ref_lock)) |
1909
|
|
|
|
|
|
Perl_croak(aTHX_ "cond_timedwait lock needs to be passed as ref"); |
1910
|
|
|
|
|
|
ref_lock = SvRV(ref_lock); |
1911
|
|
|
|
|
|
if (SvROK(ref_lock)) ref_lock = SvRV(ref_lock); |
1912
|
|
|
|
|
|
ssv = Perl_sharedsv_find(aTHX_ ref_lock); |
1913
|
|
|
|
|
|
if (! ssv) |
1914
|
|
|
|
|
|
Perl_croak(aTHX_ "cond_timedwait lock must be a shared value"); |
1915
|
|
|
|
|
|
ul = S_get_userlock(aTHX_ ssv, 1); |
1916
|
|
|
|
|
|
} |
1917
|
|
|
|
|
|
if (ul->lock.owner != aTHX) |
1918
|
|
|
|
|
|
Perl_croak(aTHX_ "You need a lock before you can cond_wait"); |
1919
|
|
|
|
|
|
|
1920
|
|
|
|
|
|
MUTEX_LOCK(&ul->lock.mutex); |
1921
|
|
|
|
|
|
ul->lock.owner = NULL; |
1922
|
|
|
|
|
|
locks = ul->lock.locks; |
1923
|
|
|
|
|
|
ul->lock.locks = 0; |
1924
|
|
|
|
|
|
/* Since we are releasing the lock here, we need to tell other |
1925
|
|
|
|
|
|
* people that it is ok to go ahead and use it */ |
1926
|
|
|
|
|
|
COND_SIGNAL(&ul->lock.cond); |
1927
|
|
|
|
|
|
RETVAL = Perl_sharedsv_cond_timedwait(user_condition, &ul->lock.mutex, abs); |
1928
|
|
|
|
|
|
while (ul->lock.owner != NULL) { |
1929
|
|
|
|
|
|
/* OK -- must reacquire the lock... */ |
1930
|
|
|
|
|
|
COND_WAIT(&ul->lock.cond, &ul->lock.mutex); |
1931
|
|
|
|
|
|
} |
1932
|
|
|
|
|
|
ul->lock.owner = aTHX; |
1933
|
|
|
|
|
|
ul->lock.locks = locks; |
1934
|
|
|
|
|
|
MUTEX_UNLOCK(&ul->lock.mutex); |
1935
|
|
|
|
|
|
|
1936
|
|
|
|
|
|
if (RETVAL == 0) |
1937
|
|
|
|
|
|
XSRETURN_UNDEF; |
1938
|
|
|
|
|
|
#line 1939 "shared.c" |
1939
|
|
|
|
|
|
XSprePUSH; PUSHi((IV)RETVAL); |
1940
|
|
|
|
|
|
} |
1941
|
|
|
|
|
|
XSRETURN(1); |
1942
|
|
|
|
|
|
} |
1943
|
|
|
|
|
|
|
1944
|
|
|
|
|
|
|
1945
|
|
|
|
|
|
XS_EUPXS(XS_threads__shared_cond_signal); /* prototype to pass -Wmissing-prototypes */ |
1946
|
|
|
|
|
|
XS_EUPXS(XS_threads__shared_cond_signal) |
1947
|
|
|
|
|
|
{ |
1948
|
|
|
|
|
|
dVAR; dXSARGS; |
1949
|
|
|
|
|
|
if (items != 1) |
1950
|
|
|
|
|
|
croak_xs_usage(cv, "myref"); |
1951
|
|
|
|
|
|
{ |
1952
|
|
|
|
|
|
#line 1623 "shared.xs" |
1953
|
|
|
|
|
|
SV *ssv; |
1954
|
|
|
|
|
|
user_lock *ul; |
1955
|
|
|
|
|
|
#line 1956 "shared.c" |
1956
|
|
|
|
|
|
SV * myref = ST(0) |
1957
|
|
|
|
|
|
; |
1958
|
|
|
|
|
|
#line 1626 "shared.xs" |
1959
|
|
|
|
|
|
if (! SvROK(myref)) |
1960
|
|
|
|
|
|
Perl_croak(aTHX_ "Argument to cond_signal needs to be passed as ref"); |
1961
|
|
|
|
|
|
myref = SvRV(myref); |
1962
|
|
|
|
|
|
if (SvROK(myref)) |
1963
|
|
|
|
|
|
myref = SvRV(myref); |
1964
|
|
|
|
|
|
ssv = Perl_sharedsv_find(aTHX_ myref); |
1965
|
|
|
|
|
|
if (! ssv) |
1966
|
|
|
|
|
|
Perl_croak(aTHX_ "cond_signal can only be used on shared values"); |
1967
|
|
|
|
|
|
ul = S_get_userlock(aTHX_ ssv, 1); |
1968
|
|
|
|
|
|
if (ckWARN(WARN_THREADS) && ul->lock.owner != aTHX) { |
1969
|
|
|
|
|
|
Perl_warner(aTHX_ packWARN(WARN_THREADS), |
1970
|
|
|
|
|
|
"cond_signal() called on unlocked variable"); |
1971
|
|
|
|
|
|
} |
1972
|
|
|
|
|
|
COND_SIGNAL(&ul->user_cond); |
1973
|
|
|
|
|
|
#line 1974 "shared.c" |
1974
|
|
|
|
|
|
} |
1975
|
|
|
|
|
|
XSRETURN_EMPTY; |
1976
|
|
|
|
|
|
} |
1977
|
|
|
|
|
|
|
1978
|
|
|
|
|
|
|
1979
|
|
|
|
|
|
XS_EUPXS(XS_threads__shared_cond_broadcast); /* prototype to pass -Wmissing-prototypes */ |
1980
|
|
|
|
|
|
XS_EUPXS(XS_threads__shared_cond_broadcast) |
1981
|
|
|
|
|
|
{ |
1982
|
|
|
|
|
|
dVAR; dXSARGS; |
1983
|
|
|
|
|
|
if (items != 1) |
1984
|
|
|
|
|
|
croak_xs_usage(cv, "myref"); |
1985
|
|
|
|
|
|
{ |
1986
|
|
|
|
|
|
#line 1646 "shared.xs" |
1987
|
|
|
|
|
|
SV *ssv; |
1988
|
|
|
|
|
|
user_lock *ul; |
1989
|
|
|
|
|
|
#line 1990 "shared.c" |
1990
|
|
|
|
|
|
SV * myref = ST(0) |
1991
|
|
|
|
|
|
; |
1992
|
|
|
|
|
|
#line 1649 "shared.xs" |
1993
|
|
|
|
|
|
if (! SvROK(myref)) |
1994
|
|
|
|
|
|
Perl_croak(aTHX_ "Argument to cond_broadcast needs to be passed as ref"); |
1995
|
|
|
|
|
|
myref = SvRV(myref); |
1996
|
|
|
|
|
|
if (SvROK(myref)) |
1997
|
|
|
|
|
|
myref = SvRV(myref); |
1998
|
|
|
|
|
|
ssv = Perl_sharedsv_find(aTHX_ myref); |
1999
|
|
|
|
|
|
if (! ssv) |
2000
|
|
|
|
|
|
Perl_croak(aTHX_ "cond_broadcast can only be used on shared values"); |
2001
|
|
|
|
|
|
ul = S_get_userlock(aTHX_ ssv, 1); |
2002
|
|
|
|
|
|
if (ckWARN(WARN_THREADS) && ul->lock.owner != aTHX) { |
2003
|
|
|
|
|
|
Perl_warner(aTHX_ packWARN(WARN_THREADS), |
2004
|
|
|
|
|
|
"cond_broadcast() called on unlocked variable"); |
2005
|
|
|
|
|
|
} |
2006
|
|
|
|
|
|
COND_BROADCAST(&ul->user_cond); |
2007
|
|
|
|
|
|
#line 2008 "shared.c" |
2008
|
|
|
|
|
|
} |
2009
|
|
|
|
|
|
XSRETURN_EMPTY; |
2010
|
|
|
|
|
|
} |
2011
|
|
|
|
|
|
|
2012
|
|
|
|
|
|
|
2013
|
|
|
|
|
|
XS_EUPXS(XS_threads__shared_bless); /* prototype to pass -Wmissing-prototypes */ |
2014
|
|
|
|
|
|
XS_EUPXS(XS_threads__shared_bless) |
2015
|
|
|
|
|
|
{ |
2016
|
|
|
|
|
|
dVAR; dXSARGS; |
2017
|
|
|
|
|
|
if (items < 1) |
2018
|
|
|
|
|
|
croak_xs_usage(cv, "myref, ..."); |
2019
|
|
|
|
|
|
{ |
2020
|
|
|
|
|
|
#line 1669 "shared.xs" |
2021
|
|
|
|
|
|
HV* stash; |
2022
|
|
|
|
|
|
SV *ssv; |
2023
|
|
|
|
|
|
#line 2024 "shared.c" |
2024
|
|
|
|
|
|
SV* myref = ST(0) |
2025
|
|
|
|
|
|
; |
2026
|
|
|
|
|
|
#line 1672 "shared.xs" |
2027
|
|
|
|
|
|
if (items == 1) { |
2028
|
|
|
|
|
|
stash = CopSTASH(PL_curcop); |
2029
|
|
|
|
|
|
} else { |
2030
|
|
|
|
|
|
SV* classname = ST(1); |
2031
|
|
|
|
|
|
STRLEN len; |
2032
|
|
|
|
|
|
char *ptr; |
2033
|
|
|
|
|
|
|
2034
|
|
|
|
|
|
if (classname && |
2035
|
|
|
|
|
|
! SvGMAGICAL(classname) && |
2036
|
|
|
|
|
|
! SvAMAGIC(classname) && |
2037
|
|
|
|
|
|
SvROK(classname)) |
2038
|
|
|
|
|
|
{ |
2039
|
|
|
|
|
|
Perl_croak(aTHX_ "Attempt to bless into a reference"); |
2040
|
|
|
|
|
|
} |
2041
|
|
|
|
|
|
ptr = SvPV(classname, len); |
2042
|
|
|
|
|
|
if (ckWARN(WARN_MISC) && len == 0) { |
2043
|
|
|
|
|
|
Perl_warner(aTHX_ packWARN(WARN_MISC), |
2044
|
|
|
|
|
|
"Explicit blessing to '' (assuming package main)"); |
2045
|
|
|
|
|
|
} |
2046
|
|
|
|
|
|
stash = gv_stashpvn(ptr, len, TRUE); |
2047
|
|
|
|
|
|
} |
2048
|
|
|
|
|
|
SvREFCNT_inc_void(myref); |
2049
|
|
|
|
|
|
(void)sv_bless(myref, stash); |
2050
|
|
|
|
|
|
ST(0) = sv_2mortal(myref); |
2051
|
|
|
|
|
|
ssv = Perl_sharedsv_find(aTHX_ myref); |
2052
|
|
|
|
|
|
if (ssv) { |
2053
|
|
|
|
|
|
dTHXc; |
2054
|
|
|
|
|
|
ENTER_LOCK; |
2055
|
|
|
|
|
|
SHARED_CONTEXT; |
2056
|
|
|
|
|
|
{ |
2057
|
|
|
|
|
|
SV* fake_stash = newSVpv(HvNAME_get(stash), 0); |
2058
|
|
|
|
|
|
(void)sv_bless(ssv, (HV*)fake_stash); |
2059
|
|
|
|
|
|
} |
2060
|
|
|
|
|
|
CALLER_CONTEXT; |
2061
|
|
|
|
|
|
LEAVE_LOCK; |
2062
|
|
|
|
|
|
} |
2063
|
|
|
|
|
|
/* XSRETURN(1); - implied */ |
2064
|
|
|
|
|
|
#line 2065 "shared.c" |
2065
|
|
|
|
|
|
} |
2066
|
|
|
|
|
|
XSRETURN(1); |
2067
|
|
|
|
|
|
} |
2068
|
|
|
|
|
|
|
2069
|
|
|
|
|
|
#endif /* USE_ITHREADS */ |
2070
|
|
|
|
|
|
#ifdef __cplusplus |
2071
|
|
|
|
|
|
extern "C" |
2072
|
|
|
|
|
|
#endif |
2073
|
|
|
|
|
|
XS_EXTERNAL(boot_threads__shared); /* prototype to pass -Wmissing-prototypes */ |
2074
|
0
|
|
|
|
|
XS_EXTERNAL(boot_threads__shared) |
2075
|
|
|
|
|
|
{ |
2076
|
0
|
|
|
|
|
dVAR; dXSARGS; |
2077
|
|
|
|
|
|
#if (PERL_REVISION == 5 && PERL_VERSION < 9) |
2078
|
|
|
|
|
|
char* file = __FILE__; |
2079
|
|
|
|
|
|
#else |
2080
|
|
|
|
|
|
const char* file = __FILE__; |
2081
|
|
|
|
|
|
#endif |
2082
|
|
|
|
|
|
|
2083
|
|
|
|
|
|
PERL_UNUSED_VAR(cv); /* -W */ |
2084
|
|
|
|
|
|
PERL_UNUSED_VAR(items); /* -W */ |
2085
|
|
|
|
|
|
#ifdef XS_APIVERSION_BOOTCHECK |
2086
|
0
|
|
|
|
|
XS_APIVERSION_BOOTCHECK; |
2087
|
|
|
|
|
|
#endif |
2088
|
0
|
|
|
|
|
XS_VERSION_BOOTCHECK; |
2089
|
|
|
|
|
|
|
2090
|
|
|
|
|
|
#if XSubPPtmpAAAA |
2091
|
|
|
|
|
|
newXS("threads::shared::tie::PUSH", XS_threads__shared__tie_PUSH, file); |
2092
|
|
|
|
|
|
newXS("threads::shared::tie::UNSHIFT", XS_threads__shared__tie_UNSHIFT, file); |
2093
|
|
|
|
|
|
newXS("threads::shared::tie::POP", XS_threads__shared__tie_POP, file); |
2094
|
|
|
|
|
|
newXS("threads::shared::tie::SHIFT", XS_threads__shared__tie_SHIFT, file); |
2095
|
|
|
|
|
|
newXS("threads::shared::tie::EXTEND", XS_threads__shared__tie_EXTEND, file); |
2096
|
|
|
|
|
|
newXS("threads::shared::tie::STORESIZE", XS_threads__shared__tie_STORESIZE, file); |
2097
|
|
|
|
|
|
newXS("threads::shared::tie::EXISTS", XS_threads__shared__tie_EXISTS, file); |
2098
|
|
|
|
|
|
newXS("threads::shared::tie::FIRSTKEY", XS_threads__shared__tie_FIRSTKEY, file); |
2099
|
|
|
|
|
|
newXS("threads::shared::tie::NEXTKEY", XS_threads__shared__tie_NEXTKEY, file); |
2100
|
|
|
|
|
|
(void)newXSproto_portable("threads::shared::_id", XS_threads__shared__id, file, "\\[$@%]"); |
2101
|
|
|
|
|
|
(void)newXSproto_portable("threads::shared::_refcnt", XS_threads__shared__refcnt, file, "\\[$@%]"); |
2102
|
|
|
|
|
|
(void)newXSproto_portable("threads::shared::share", XS_threads__shared_share, file, "\\[$@%]"); |
2103
|
|
|
|
|
|
(void)newXSproto_portable("threads::shared::cond_wait", XS_threads__shared_cond_wait, file, "\\[$@%];\\[$@%]"); |
2104
|
|
|
|
|
|
(void)newXSproto_portable("threads::shared::cond_timedwait", XS_threads__shared_cond_timedwait, file, "\\[$@%]$;\\[$@%]"); |
2105
|
|
|
|
|
|
(void)newXSproto_portable("threads::shared::cond_signal", XS_threads__shared_cond_signal, file, "\\[$@%]"); |
2106
|
|
|
|
|
|
(void)newXSproto_portable("threads::shared::cond_broadcast", XS_threads__shared_cond_broadcast, file, "\\[$@%]"); |
2107
|
|
|
|
|
|
(void)newXSproto_portable("threads::shared::bless", XS_threads__shared_bless, file, "$;$"); |
2108
|
|
|
|
|
|
#endif |
2109
|
|
|
|
|
|
|
2110
|
|
|
|
|
|
/* Initialisation Section */ |
2111
|
|
|
|
|
|
|
2112
|
|
|
|
|
|
#if XSubPPtmpAAAA |
2113
|
|
|
|
|
|
#endif |
2114
|
|
|
|
|
|
#line 1713 "shared.xs" |
2115
|
|
|
|
|
|
{ |
2116
|
|
|
|
|
|
#ifdef USE_ITHREADS |
2117
|
|
|
|
|
|
Perl_sharedsv_init(aTHX); |
2118
|
|
|
|
|
|
#endif /* USE_ITHREADS */ |
2119
|
|
|
|
|
|
} |
2120
|
|
|
|
|
|
|
2121
|
|
|
|
|
|
#line 2122 "shared.c" |
2122
|
|
|
|
|
|
|
2123
|
|
|
|
|
|
/* End of Initialisation Section */ |
2124
|
|
|
|
|
|
|
2125
|
|
|
|
|
|
#if (PERL_REVISION == 5 && PERL_VERSION >= 9) |
2126
|
0
|
|
|
|
|
if (PL_unitcheckav) |
2127
|
0
|
|
|
|
|
call_list(PL_scopestack_ix, PL_unitcheckav); |
2128
|
|
|
|
|
|
#endif |
2129
|
0
|
|
|
|
|
XSRETURN_YES; |
2130
|
|
|
|
|
|
} |
2131
|
|
|
|
|
|
|