File Coverage

dist/threads-shared/shared.c
Criterion Covered Total %
statement 0 7 0.0
branch n/a
condition n/a
subroutine n/a
total 0 7 0.0


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