threads::shared 1.13

[p5sagit/p5-mst-13.2.git] / ext / threads / shared / shared.xs

diff --git a/ext/threads/shared/shared.xs b/ext/threads/shared/shared.xs
index dcc2c97..4115bf1 100644 (file)
--- a/ext/threads/shared/shared.xs
+++ b/ext/threads/shared/shared.xs
@@ -115,31 +115,22 @@
  * without the prefix (e.g., sv, tmp or obj).
  */
 
-/* Patch status:
- *
- * Perl 5.8.8 contains threads::shared patches up to 26626 (equivalent to
- * blead patches 26350+26351).
- *
- * The CPAN version of threads::shared contains the following blead patches:
- *      26569 (applicable to 5.9.3 only)
- *      26684
- *      26693
- *      26695
- */
-
 #define PERL_NO_GET_CONTEXT
 #include "EXTERN.h"
 #include "perl.h"
 #include "XSUB.h"
 #ifdef HAS_PPPORT_H
-#define NEED_vnewSVpvf
-#define NEED_warner
+#  define NEED_vnewSVpvf
+#  define NEED_warner
 #  include "ppport.h"
 #  include "shared.h"
 #endif
 
 #ifdef USE_ITHREADS
 
+/* Magic signature(s) for mg_private to make PERL_MAGIC_ext magic safer */
+#define UL_MAGIC_SIG 0x554C  /* UL = user lock */
+
 /*
  * The shared things need an intepreter to live in ...
  */
@@ -350,7 +341,16 @@ S_get_userlock(pTHX_ SV* ssv, bool create)
     /* XXX Redesign the storage of user locks so we don't need a global
      * lock to access them ???? DAPM */
     ENTER_LOCK;
-    mg = mg_find(ssv, PERL_MAGIC_ext);
+
+    /* Version of mg_find that also checks the private signature */
+    for (mg = SvMAGIC(ssv); mg; mg = mg->mg_moremagic) {
+        if ((mg->mg_type == PERL_MAGIC_ext) &&
+            (mg->mg_private == UL_MAGIC_SIG))
+        {
+            break;
+        }
+    }
+
     if (mg) {
         ul = (user_lock*)(mg->mg_ptr);
     } else if (create) {
@@ -359,8 +359,9 @@ S_get_userlock(pTHX_ SV* ssv, bool create)
         ul = (user_lock *) PerlMemShared_malloc(sizeof(user_lock));
         Zero(ul, 1, user_lock);
         /* Attach to shared SV using ext magic */
-        sv_magicext(ssv, NULL, PERL_MAGIC_ext, &sharedsv_userlock_vtbl,
-               (char *)ul, 0);
+        mg = sv_magicext(ssv, NULL, PERL_MAGIC_ext, &sharedsv_userlock_vtbl,
+                            (char *)ul, 0);
+        mg->mg_private = UL_MAGIC_SIG;  /* Set private signature */
         recursive_lock_init(aTHX_ &ul->lock);
         COND_INIT(&ul->user_cond);
         CALLER_CONTEXT;
@@ -412,7 +413,6 @@ Perl_sharedsv_find(pTHX_ SV *sv)
 void
 Perl_sharedsv_associate(pTHX_ SV *sv, SV *ssv)
 {
-    dTHXc;
     MAGIC *mg = 0;
 
     /* If we are asked for any private ops we need a thread */
@@ -551,14 +551,42 @@ Perl_sharedsv_share(pTHX_ SV *sv)
 }
 
 
-#if defined(WIN32) || defined(OS2)
+#ifdef WIN32
+/* Number of milliseconds from 1/1/1601 to 1/1/1970 */
+#define EPOCH_BIAS      11644473600000.
+
+/* Returns relative time in milliseconds.  (Adapted from Time::HiRes.) */
+STATIC DWORD
+S_abs_2_rel_milli(double abs)
+{
+    double rel;
+
+    /* Get current time (in units of 100 nanoseconds since 1/1/1601) */
+    union {
+        FILETIME ft;
+        __int64  i64;   /* 'signed' to keep compilers happy */
+    } now;
+
+    GetSystemTimeAsFileTime(&now.ft);
+
+    /* Relative time in milliseconds */
+    rel = (abs * 1000.) - (((double)now.i64 / 10000.) - EPOCH_BIAS);
+    if (rel <= 0.0) {
+        return (0);
+    }
+    return (DWORD)rel;
+}
+
+#else
+# if defined(OS2)
 #  define ABS2RELMILLI(abs)             \
     do {                                \
         abs -= (double)time(NULL);      \
         if (abs > 0) { abs *= 1000; }   \
         else         { abs  = 0;    }   \
     } while (0)
-#endif /* WIN32 || OS2 */
+# endif /* OS2 */
+#endif /* WIN32 */
 
 /* Do OS-specific condition timed wait */
 
@@ -571,12 +599,10 @@ Perl_sharedsv_cond_timedwait(perl_cond *cond, perl_mutex *mut, double abs)
 #  ifdef WIN32
     int got_it = 0;
 
-    ABS2RELMILLI(abs);
-
     cond->waiters++;
     MUTEX_UNLOCK(mut);
     /* See comments in win32/win32thread.h COND_WAIT vis-a-vis race */
-    switch (WaitForSingleObject(cond->sem, (DWORD)abs)) {
+    switch (WaitForSingleObject(cond->sem, S_abs_2_rel_milli(abs))) {
         case WAIT_OBJECT_0:   got_it = 1; break;
         case WAIT_TIMEOUT:                break;
         default:
@@ -708,7 +734,7 @@ sharedsv_scalar_store(pTHX_ SV *sv, SV *ssv)
         SV *sobj = Perl_sharedsv_find(aTHX_ obj);
         if (sobj) {
             SHARED_CONTEXT;
-            SvUPGRADE(ssv, SVt_RV);
+            (void)SvUPGRADE(ssv, SVt_RV);
             sv_setsv_nomg(ssv, &PL_sv_undef);
 
             SvRV_set(ssv, SvREFCNT_inc(sobj));
@@ -1253,6 +1279,9 @@ NEXTKEY(SV *obj, SV *oldkey)
         char* key = NULL;
         I32 len = 0;
         HE* entry;
+
+        PERL_UNUSED_VAR(oldkey);
+
         ENTER_LOCK;
         SHARED_CONTEXT;
         entry = hv_iternext((HV*) sobj);
@@ -1299,7 +1328,10 @@ _refcnt(SV *ref)
             ref = SvRV(ref);
         ssv = Perl_sharedsv_find(aTHX_ ref);
         if (! ssv) {
-            Perl_warn(aTHX_ "%" SVf " is not shared", ST(0));
+            if (ckWARN(WARN_THREADS)) {
+                Perl_warner(aTHX_ packWARN(WARN_THREADS),
+                                "%" SVf " is not shared", ST(0));
+            }
             XSRETURN_UNDEF;
         }
         ST(0) = sv_2mortal(newSViv(SvREFCNT(ssv)));