ext/threads/shared/shared.xs

   1 /*    shared.xs
   2  *
   3  *    Copyright (c) 2001-2002, Larry Wall
   4  *
   5  *    You may distribute under the terms of either the GNU General Public
   6  *    License or the Artistic License, as specified in the README file.
   7  *
   8  * "Hand any two wizards a piece of rope and they would instinctively pull in
   9  * opposite directions."
  10  *                         --Sourcery
  11  *
  12  * Contributed by Arthur Bergman arthur@contiller.se
  13  * pulled in the (an)other direction by Nick Ing-Simmons nick@ing-simmons.net
  14  */
  15
  16 #define PERL_NO_GET_CONTEXT
  17 #include "EXTERN.h"
  18 #include "perl.h"
  19 #include "XSUB.h"
  20
  21 #ifdef USE_ITHREADS
  22
  23 #define SHAREDSvPTR(a)      ((a)->sv)
  24
  25 /*
  26  * The shared things need an intepreter to live in ...
  27  */
  28 PerlInterpreter *PL_sharedsv_space;             /* The shared sv space */
  29 /* To access shared space we fake aTHX in this scope and thread's context */
  30
  31 /* bug #24255: we include ENTER+SAVETMPS/FREETMPS+LEAVE with
  32  * SHARED_CONTEXT/CALLER_CONTEXT macros, so that any mortals etc created
  33  * while in the shared interpreter context don't languish */
  34
  35 #define SHARED_CONTEXT \
  36     STMT_START {                                        \
  37         PERL_SET_CONTEXT((aTHX = PL_sharedsv_space));   \
  38         ENTER;                                          \
  39         SAVETMPS;                                       \
  40     } STMT_END
  41
  42 /* So we need a way to switch back to the caller's context... */
  43 /* So we declare _another_ copy of the aTHX variable ... */
  44 #define dTHXc PerlInterpreter *caller_perl = aTHX
  45
  46 /* and use it to switch back */
  47 #define CALLER_CONTEXT                                  \
  48     STMT_START {                                        \
  49         FREETMPS;                                       \
  50         LEAVE;                                          \
  51         PERL_SET_CONTEXT((aTHX = caller_perl));         \
  52     } STMT_END
  53
  54 /*
  55  * Only one thread at a time is allowed to mess with shared space.
  56  */
  57
  58 typedef struct
  59 {
  60  perl_mutex              mutex;
  61  PerlInterpreter        *owner;
  62  I32                     locks;
  63  perl_cond               cond;
  64 #ifdef DEBUG_LOCKS
  65  char *                  file;
  66  int                     line;
  67 #endif
  68 } recursive_lock_t;
  69
  70 recursive_lock_t PL_sharedsv_lock;       /* Mutex protecting the shared sv space */
  71
  72 void
  73 recursive_lock_init(pTHX_ recursive_lock_t *lock)
  74 {
  75     Zero(lock,1,recursive_lock_t);
  76     MUTEX_INIT(&lock->mutex);
  77     COND_INIT(&lock->cond);
  78 }
  79
  80 void
  81 recursive_lock_destroy(pTHX_ recursive_lock_t *lock)
  82 {
  83     MUTEX_DESTROY(&lock->mutex);
  84     COND_DESTROY(&lock->cond);
  85 }
  86
  87 void
  88 recursive_lock_release(pTHX_ recursive_lock_t *lock)
  89 {
  90     MUTEX_LOCK(&lock->mutex);
  91     if (lock->owner != aTHX) {
  92         MUTEX_UNLOCK(&lock->mutex);
  93     }
  94     else {
  95         if (--lock->locks == 0) {
  96             lock->owner = NULL;
  97             COND_SIGNAL(&lock->cond);
  98         }
  99     }
 100     MUTEX_UNLOCK(&lock->mutex);
 101 }
 102
 103 void
 104 recursive_lock_acquire(pTHX_ recursive_lock_t *lock,char *file,int line)
 105 {
 106     assert(aTHX);
 107     MUTEX_LOCK(&lock->mutex);
 108     if (lock->owner == aTHX) {
 109         lock->locks++;
 110     }
 111     else {
 112         while (lock->owner) {
 113 #ifdef DEBUG_LOCKS
 114             Perl_warn(aTHX_ " %p waiting - owned by %p %s:%d\n",
 115                       aTHX, lock->owner, lock->file, lock->line);
 116 #endif
 117             COND_WAIT(&lock->cond,&lock->mutex);
 118         }
 119         lock->locks = 1;
 120         lock->owner = aTHX;
 121 #ifdef DEBUG_LOCKS
 122         lock->file  = file;
 123         lock->line  = line;
 124 #endif
 125     }
 126     MUTEX_UNLOCK(&lock->mutex);
 127     SAVEDESTRUCTOR_X(recursive_lock_release,lock);
 128 }
 129
 130 #define ENTER_LOCK         STMT_START { \
 131                               ENTER; \
 132                               recursive_lock_acquire(aTHX_ &PL_sharedsv_lock, __FILE__, __LINE__);   \
 133                             } STMT_END
 134
 135 #define LEAVE_LOCK       LEAVE
 136
 137
 138 /* A common idiom is to acquire access and switch in ... */
 139 #define SHARED_EDIT         STMT_START {        \
 140                                 ENTER_LOCK;     \
 141                                 SHARED_CONTEXT; \
 142                             } STMT_END
 143
 144 /* then switch out and release access. */
 145 #define SHARED_RELEASE     STMT_START { \
 146                                 CALLER_CONTEXT; \
 147                                 LEAVE_LOCK;     \
 148                             } STMT_END
 149
 150
 151 /*
 152
 153   Shared SV
 154
 155   Shared SV is a structure for keeping the backend storage
 156   of shared svs.
 157
 158   Shared-ness really only needs the SV * - the rest is for locks.
 159   (Which suggests further space optimization ... )
 160
 161 */
 162
 163 typedef struct {
 164     SV                 *sv;             /* The actual SV - in shared space */
 165     recursive_lock_t    lock;
 166     perl_cond           user_cond;      /* For user-level conditions */
 167 } shared_sv;
 168
 169 /* The SV in shared-space has a back-pointer to the shared_sv
 170    struct associated with it PERL_MAGIC_ext.
 171
 172    The vtable used has just one entry - when the SV goes away
 173    we free the memory for the above.
 174
 175  */
 176
 177 int
 178 sharedsv_shared_mg_free(pTHX_ SV *sv, MAGIC *mg)
 179 {
 180     shared_sv *shared = (shared_sv *) mg->mg_ptr;
 181     assert( aTHX == PL_sharedsv_space );
 182     if (shared) {
 183         recursive_lock_destroy(aTHX_ &shared->lock);
 184         COND_DESTROY(&shared->user_cond);
 185         PerlMemShared_free(shared);
 186         mg->mg_ptr = NULL;
 187     }
 188     return 0;
 189 }
 190
 191 MGVTBL sharedsv_shared_vtbl = {
 192  0,                             /* get */
 193  0,                             /* set */
 194  0,                             /* len */
 195  0,                             /* clear */
 196  sharedsv_shared_mg_free,       /* free */
 197  0,                             /* copy */
 198  0,                             /* dup */
 199 };
 200
 201 /* Access to shared things is heavily based on MAGIC - in mg.h/mg.c/sv.c sense */
 202
 203 /* In any thread that has access to a shared thing there is a "proxy"
 204    for it in its own space which has 'MAGIC' associated which accesses
 205    the shared thing.
 206  */
 207
 208 MGVTBL sharedsv_scalar_vtbl;    /* scalars have this vtable */
 209 MGVTBL sharedsv_array_vtbl;     /* hashes and arrays have this - like 'tie' */
 210 MGVTBL sharedsv_elem_vtbl;      /* elements of hashes and arrays have this
 211                                    _AS WELL AS_ the scalar magic */
 212
 213 /* The sharedsv_elem_vtbl associates the element with the array/hash and
 214    the sharedsv_scalar_vtbl associates it with the value
 215  */
 216
 217
 218 /* Accessor to convert threads::shared::tie objects back shared_sv * */
 219 shared_sv *
 220 SV_to_sharedsv(pTHX_ SV *sv)
 221 {
 222     shared_sv *shared = 0;
 223     if (SvROK(sv))
 224      {
 225       shared = INT2PTR(shared_sv *, SvIV(SvRV(sv)));
 226      }
 227     return shared;
 228 }
 229
 230 =for apidoc sharedsv_find
 231
 232 Given a private side SV tries to find if the SV has a shared backend,
 233 by looking for the magic.
 234
 235 =cut
 236
 237 shared_sv *
 238 Perl_sharedsv_find(pTHX_ SV *sv)
 239 {
 240     MAGIC *mg;
 241     if (SvTYPE(sv) >= SVt_PVMG) {
 242         switch(SvTYPE(sv)) {
 243         case SVt_PVAV:
 244         case SVt_PVHV:
 245             if ((mg = mg_find(sv, PERL_MAGIC_tied))
 246                 && mg->mg_virtual == &sharedsv_array_vtbl) {
 247                 return (shared_sv *) mg->mg_ptr;
 248             }
 249             break;
 250         default:
 251             /* This should work for elements as well as they
 252              * have scalar magic as well as their element magic
 253              */
 254             if ((mg = mg_find(sv, PERL_MAGIC_shared_scalar))
 255                 && mg->mg_virtual == &sharedsv_scalar_vtbl) {
 256                 return (shared_sv *) mg->mg_ptr;
 257             }
 258             break;
 259         }
 260     }
 261     /* Just for tidyness of API also handle tie objects */
 262     if (SvROK(sv) && sv_derived_from(sv, "threads::shared::tie")) {
 263         return SV_to_sharedsv(aTHX_ sv);
 264     }
 265     return NULL;
 266 }
 267
 268 /*
 269  *  Almost all the pain is in this routine.
 270  *
 271  */
 272
 273 shared_sv *
 274 Perl_sharedsv_associate(pTHX_ SV **psv, SV *ssv, shared_sv *data)
 275 {
 276     dTHXc;
 277     MAGIC *mg = 0;
 278     SV *sv    = (psv) ? *psv : Nullsv;
 279
 280     /* If we are asked for an private ops we need a thread */
 281     assert ( aTHX !=  PL_sharedsv_space );
 282
 283     /* To avoid need for recursive locks require caller to hold lock */
 284     assert ( PL_sharedsv_lock.owner == aTHX );
 285
 286     /* First try and get existing global data structure */
 287
 288     /* Try shared SV as 1st choice */
 289     if (!data && ssv && SvTYPE(ssv) >= SVt_PVMG) {
 290         if( (mg = mg_find(ssv, PERL_MAGIC_ext)) ){
 291             data = (shared_sv *) mg->mg_ptr;
 292         }
 293     }
 294
 295     /* Next see if private SV is associated with something */
 296     if (!data && sv) {
 297         data = Perl_sharedsv_find(aTHX_ sv);
 298     }
 299
 300     /* If neither of those then create a new one */
 301     if (!data) {
 302             SHARED_CONTEXT;
 303             if (!ssv) {
 304                 ssv = newSV(0);
 305                 SvREFCNT(ssv) = 0;
 306             }
 307             data = (shared_sv *) PerlMemShared_malloc(sizeof(shared_sv));
 308             Zero(data,1,shared_sv);
 309             SHAREDSvPTR(data) = ssv;
 310             /* Tag shared side SV with data pointer */
 311             sv_magicext(ssv, ssv, PERL_MAGIC_ext, &sharedsv_shared_vtbl,
 312                    (char *)data, 0);
 313             recursive_lock_init(aTHX_ &data->lock);
 314             COND_INIT(&data->user_cond);
 315             CALLER_CONTEXT;
 316     }
 317
 318     if (!ssv)
 319         ssv = SHAREDSvPTR(data);
 320     if (!SHAREDSvPTR(data))
 321         SHAREDSvPTR(data) = ssv;
 322
 323     /* If we know type upgrade shared side SV */
 324     if (sv && SvTYPE(ssv) < SvTYPE(sv)) {
 325         SHARED_CONTEXT;
 326         sv_upgrade(ssv, SvTYPE(*psv));
 327         if (SvTYPE(ssv) == SVt_PVAV)    /* #24061 */
 328             AvREAL_on(ssv);
 329         CALLER_CONTEXT;
 330     }
 331
 332     /* Now if requested allocate private SV */
 333     if (psv && !sv) {
 334         *psv = sv = newSV(0);
 335     }
 336
 337     /* Finally if private SV exists check and add magic */
 338     if (sv) {
 339         MAGIC *mg = 0;
 340         if (SvTYPE(sv) < SvTYPE(ssv)) {
 341             sv_upgrade(sv, SvTYPE(ssv));
 342         }
 343         switch(SvTYPE(sv)) {
 344         case SVt_PVAV:
 345         case SVt_PVHV:
 346             if (!(mg = mg_find(sv, PERL_MAGIC_tied))
 347                 || mg->mg_virtual != &sharedsv_array_vtbl
 348                 || (shared_sv *) mg->mg_ptr != data) {
 349                 SV *obj = newSV(0);
 350                 sv_setref_iv(obj, "threads::shared::tie",PTR2IV(data));
 351                 if (mg) {
 352                     sv_unmagic(sv, PERL_MAGIC_tied);
 353                 }
 354                 mg = sv_magicext(sv, obj, PERL_MAGIC_tied, &sharedsv_array_vtbl,
 355                                 (char *) data, 0);
 356                 mg->mg_flags |= (MGf_COPY|MGf_DUP);
 357                 SvREFCNT_inc(ssv);
 358                 SvREFCNT_dec(obj);
 359                 if(SvOBJECT(ssv)) {
 360                   STRLEN len;
 361                   char* stash_ptr = SvPV((SV*) SvSTASH(ssv), len);
 362                   HV* stash = gv_stashpvn(stash_ptr, len, TRUE);
 363                   SvOBJECT_on(sv);
 364                   SvSTASH_set(sv, (HV*)SvREFCNT_inc(stash));
 365                 }
 366             }
 367             break;
 368
 369         default:
 370             if ((SvTYPE(sv) < SVt_PVMG)
 371                 || !(mg = mg_find(sv, PERL_MAGIC_shared_scalar))
 372                 || mg->mg_virtual != &sharedsv_scalar_vtbl
 373                 || (shared_sv *) mg->mg_ptr != data) {
 374                 if (mg) {
 375                     sv_unmagic(sv, PERL_MAGIC_shared_scalar);
 376                 }
 377                 mg = sv_magicext(sv, Nullsv, PERL_MAGIC_shared_scalar,
 378                                 &sharedsv_scalar_vtbl, (char *)data, 0);
 379                 mg->mg_flags |= (MGf_COPY|MGf_DUP);
 380                 SvREFCNT_inc(ssv);
 381                 if(SvOBJECT(ssv)) {
 382                   STRLEN len;
 383                   char* stash_ptr = SvPV((SV*) SvSTASH(ssv), len);
 384                   HV* stash = gv_stashpvn(stash_ptr, len, TRUE);
 385                   SvOBJECT_on(sv);
 386                   SvSTASH_set(sv, (HV*)SvREFCNT_inc(stash));
 387                 }
 388             }
 389             break;
 390         }
 391         assert ( Perl_sharedsv_find(aTHX_ *psv) == data );
 392     }
 393     return data;
 394 }
 395
 396 void
 397 Perl_sharedsv_free(pTHX_ shared_sv *shared)
 398 {
 399     if (shared) {
 400         dTHXc;
 401         SHARED_EDIT;
 402         SvREFCNT_dec(SHAREDSvPTR(shared));
 403         SHARED_RELEASE;
 404     }
 405 }
 406
 407 void
 408 Perl_sharedsv_share(pTHX_ SV *sv)
 409 {
 410     switch(SvTYPE(sv)) {
 411     case SVt_PVGV:
 412         Perl_croak(aTHX_ "Cannot share globs yet");
 413         break;
 414
 415     case SVt_PVCV:
 416         Perl_croak(aTHX_ "Cannot share subs yet");
 417         break;
 418
 419     default:
 420         ENTER_LOCK;
 421         Perl_sharedsv_associate(aTHX_ &sv, 0, 0);
 422         LEAVE_LOCK;
 423         SvSETMAGIC(sv);
 424         break;
 425     }
 426 }
 427
 428 #if defined(WIN32) || defined(OS2)
 429 #  define ABS2RELMILLI(abs)        \
 430     do {                                \
 431         abs -= (double)time(NULL);      \
 432         if (abs > 0) { abs *= 1000; }   \
 433         else         { abs  = 0;    }   \
 434     } while (0)
 435 #endif /* WIN32 || OS2 */
 436
 437 bool
 438 Perl_sharedsv_cond_timedwait(perl_cond *cond, perl_mutex *mut, double abs)
 439 {
 440 #if defined(NETWARE) || defined(FAKE_THREADS) || defined(I_MACH_CTHREADS)
 441     Perl_croak_nocontext("cond_timedwait not supported on this platform");
 442 #else
 443 #  ifdef WIN32
 444     int got_it = 0;
 445
 446     ABS2RELMILLI(abs);
 447
 448     cond->waiters++;
 449     MUTEX_UNLOCK(mut);
 450     /* See comments in win32/win32thread.h COND_WAIT vis-a-vis race */
 451     switch (WaitForSingleObject(cond->sem, (DWORD)abs)) {
 452         case WAIT_OBJECT_0:   got_it = 1; break;
 453         case WAIT_TIMEOUT:                break;
 454         default:
 455             /* WAIT_FAILED? WAIT_ABANDONED? others? */
 456             Perl_croak_nocontext("panic: cond_timedwait (%ld)",GetLastError());
 457             break;
 458     }
 459     MUTEX_LOCK(mut);
 460     cond->waiters--;
 461     return got_it;
 462 #  else
 463 #    ifdef OS2
 464     int rc, got_it = 0;
 465     STRLEN n_a;
 466
 467     ABS2RELMILLI(abs);
 468
 469     if ((rc = DosResetEventSem(*cond,&n_a)) && (rc != ERROR_ALREADY_RESET))
 470         Perl_rc = rc, croak_with_os2error("panic: cond_timedwait-reset");
 471     MUTEX_UNLOCK(mut);
 472     if (CheckOSError(DosWaitEventSem(*cond,abs))
 473         && (rc != ERROR_INTERRUPT))
 474         croak_with_os2error("panic: cond_timedwait");
 475     if (rc == ERROR_INTERRUPT) errno = EINTR;
 476     MUTEX_LOCK(mut);
 477     return got_it;
 478 #    else         /* hope you're I_PTHREAD! */
 479     struct timespec ts;
 480     int got_it = 0;
 481
 482     ts.tv_sec = (long)abs;
 483     abs -= (NV)ts.tv_sec;
 484     ts.tv_nsec = (long)(abs * 1000000000.0);
 485
 486     switch (pthread_cond_timedwait(cond, mut, &ts)) {
 487         case 0:         got_it = 1; break;
 488         case ETIMEDOUT:             break;
 489         default:
 490             Perl_croak_nocontext("panic: cond_timedwait");
 491             break;
 492     }
 493     return got_it;
 494 #    endif /* OS2 */
 495 #  endif /* WIN32 */
 496 #endif /* NETWARE || FAKE_THREADS || I_MACH_CTHREADS */
 497 }
 498
 499 /* MAGIC (in mg.h sense) hooks */
 500
 501 int
 502 sharedsv_scalar_mg_get(pTHX_ SV *sv, MAGIC *mg)
 503 {
 504     shared_sv *shared = (shared_sv *) mg->mg_ptr;
 505     assert(shared);
 506
 507     ENTER_LOCK;
 508     if (SHAREDSvPTR(shared)) {
 509         if (SvROK(SHAREDSvPTR(shared))) {
 510             SV *obj = Nullsv;
 511             Perl_sharedsv_associate(aTHX_ &obj, SvRV(SHAREDSvPTR(shared)), NULL);
 512             sv_setsv_nomg(sv, &PL_sv_undef);
 513             SvRV_set(sv, obj);
 514             SvROK_on(sv);
 515
 516         }
 517         else {
 518             sv_setsv_nomg(sv, SHAREDSvPTR(shared));
 519         }
 520     }
 521     LEAVE_LOCK;
 522     return 0;
 523 }
 524
 525 void
 526 sharedsv_scalar_store(pTHX_ SV *sv, shared_sv *shared)
 527 {
 528     dTHXc;
 529     bool allowed = TRUE;
 530     if (SvROK(sv)) {
 531         shared_sv* target = Perl_sharedsv_find(aTHX_ SvRV(sv));
 532         if (target) {
 533             SV *tmp;
 534             SHARED_CONTEXT;
 535             tmp = newRV(SHAREDSvPTR(target));
 536             sv_setsv_nomg(SHAREDSvPTR(shared), tmp);
 537             SvREFCNT_dec(tmp);
 538             if(SvOBJECT(SvRV(sv))) {
 539               SV* fake_stash = newSVpv(HvNAME_get(SvSTASH(SvRV(sv))),0);
 540               SvOBJECT_on(SHAREDSvPTR(target));
 541               SvSTASH_set(SHAREDSvPTR(target), (HV*)fake_stash);
 542             }
 543             CALLER_CONTEXT;
 544         }
 545         else {
 546             allowed = FALSE;
 547         }
 548     }
 549     else {
 550         SvTEMP_off(sv);
 551         SHARED_CONTEXT;
 552         sv_setsv_nomg(SHAREDSvPTR(shared), sv);
 553         if(SvOBJECT(sv)) {
 554           SV* fake_stash = newSVpv(HvNAME_get(SvSTASH(sv)),0);
 555           SvOBJECT_on(SHAREDSvPTR(shared));
 556           SvSTASH_set(SHAREDSvPTR(shared), (HV*)fake_stash);
 557         }
 558         CALLER_CONTEXT;
 559     }
 560     if (!allowed) {
 561         Perl_croak(aTHX_ "Invalid value for shared scalar");
 562     }
 563 }
 564
 565 int
 566 sharedsv_scalar_mg_set(pTHX_ SV *sv, MAGIC *mg)
 567 {
 568     shared_sv *shared;
 569     ENTER_LOCK;
 570     /* We call associate to potentially upgrade shared side SV */
 571     shared = Perl_sharedsv_associate(aTHX_ &sv, Nullsv, (shared_sv *) mg->mg_ptr);
 572     assert(shared);
 573     sharedsv_scalar_store(aTHX_ sv, shared);
 574     LEAVE_LOCK;
 575     return 0;
 576 }
 577
 578 int
 579 sharedsv_scalar_mg_free(pTHX_ SV *sv, MAGIC *mg)
 580 {
 581     shared_sv *shared = (shared_sv *) mg->mg_ptr;
 582 #if 0
 583     assert (SvREFCNT(SHAREDSvPTR(shared)) < 1000);
 584 #endif
 585     Perl_sharedsv_free(aTHX_ shared);
 586     return 0;
 587 }
 588
 589 int
 590 sharedsv_scalar_mg_clear(pTHX_ SV *sv, MAGIC *mg)
 591 {
 592     return 0;
 593 }
 594
 595 /*
 596  * Called during cloning of new threads
 597  */
 598 int
 599 sharedsv_scalar_mg_dup(pTHX_ MAGIC *mg, CLONE_PARAMS *param)
 600 {
 601     shared_sv *shared = (shared_sv *) mg->mg_ptr;
 602     if (shared) {
 603         SvREFCNT_inc(SHAREDSvPTR(shared));
 604     }
 605     return 0;
 606 }
 607
 608 MGVTBL sharedsv_scalar_vtbl = {
 609  sharedsv_scalar_mg_get,        /* get */
 610  sharedsv_scalar_mg_set,        /* set */
 611  0,                             /* len */
 612  sharedsv_scalar_mg_clear,      /* clear */
 613  sharedsv_scalar_mg_free,       /* free */
 614  0,                             /* copy */
 615  sharedsv_scalar_mg_dup         /* dup */
 616 };
 617
 618 /* Now the arrays/hashes stuff */
 619 int
 620 sharedsv_elem_mg_FETCH(pTHX_ SV *sv, MAGIC *mg)
 621 {
 622     dTHXc;
 623     shared_sv *shared = SV_to_sharedsv(aTHX_ mg->mg_obj);
 624     shared_sv *target = Perl_sharedsv_find(aTHX_ sv);
 625     SV** svp;
 626
 627     assert ( shared );
 628     assert ( SHAREDSvPTR(shared) );
 629
 630     ENTER_LOCK;
 631     if (SvTYPE(SHAREDSvPTR(shared)) == SVt_PVAV) {
 632         assert ( mg->mg_ptr == 0 );
 633         SHARED_CONTEXT;
 634         svp = av_fetch((AV*) SHAREDSvPTR(shared), mg->mg_len, 0);
 635     }
 636     else {
 637         char *key = mg->mg_ptr;
 638         STRLEN len = mg->mg_len;
 639         assert ( mg->mg_ptr != 0 );
 640         if (mg->mg_len == HEf_SVKEY) {
 641            key = SvPV((SV *) mg->mg_ptr, len);
 642         }
 643         SHARED_CONTEXT;
 644         svp = hv_fetch((HV*) SHAREDSvPTR(shared), key, len, 0);
 645     }
 646     CALLER_CONTEXT;
 647     if (svp) {
 648         /* Exists in the array */
 649         if (SvROK(*svp)) {
 650             SV *obj = Nullsv;
 651             Perl_sharedsv_associate(aTHX_ &obj, SvRV(*svp), NULL);
 652             sv_setsv_nomg(sv, &PL_sv_undef);
 653             SvRV_set(sv, obj);
 654             SvROK_on(sv);
 655             SvSETMAGIC(sv);
 656         }
 657         else {
 658             target = Perl_sharedsv_associate(aTHX_ &sv, *svp, target);
 659             sv_setsv(sv, *svp);
 660         }
 661     }
 662     else {
 663         /* Not in the array */
 664         sv_setsv(sv, &PL_sv_undef);
 665     }
 666     LEAVE_LOCK;
 667     return 0;
 668 }
 669
 670 int
 671 sharedsv_elem_mg_STORE(pTHX_ SV *sv, MAGIC *mg)
 672 {
 673     dTHXc;
 674     shared_sv *shared = SV_to_sharedsv(aTHX_ mg->mg_obj);
 675     shared_sv *target;
 676     SV **svp;
 677     /* Theory - SV itself is magically shared - and we have ordered the
 678        magic such that by the time we get here it has been stored
 679        to its shared counterpart
 680      */
 681     ENTER_LOCK;
 682     assert(shared);
 683     assert(SHAREDSvPTR(shared));
 684     if (SvTYPE(SHAREDSvPTR(shared)) == SVt_PVAV) {
 685         assert ( mg->mg_ptr == 0 );
 686         SHARED_CONTEXT;
 687         svp = av_fetch((AV*) SHAREDSvPTR(shared), mg->mg_len, 1);
 688     }
 689     else {
 690         char *key = mg->mg_ptr;
 691         STRLEN len = mg->mg_len;
 692         assert ( mg->mg_ptr != 0 );
 693         if (mg->mg_len == HEf_SVKEY)
 694            key = SvPV((SV *) mg->mg_ptr, len);
 695         SHARED_CONTEXT;
 696         svp = hv_fetch((HV*) SHAREDSvPTR(shared), key, len, 1);
 697     }
 698     CALLER_CONTEXT;
 699     target = Perl_sharedsv_associate(aTHX_ &sv, *svp, 0);
 700     sharedsv_scalar_store(aTHX_ sv, target);
 701     LEAVE_LOCK;
 702     return 0;
 703 }
 704
 705 int
 706 sharedsv_elem_mg_DELETE(pTHX_ SV *sv, MAGIC *mg)
 707 {
 708     dTHXc;
 709     MAGIC *shmg;
 710     shared_sv *shared = SV_to_sharedsv(aTHX_ mg->mg_obj);
 711     ENTER_LOCK;
 712     sharedsv_elem_mg_FETCH(aTHX_ sv, mg);
 713     if ((shmg = mg_find(sv, PERL_MAGIC_shared_scalar)))
 714         sharedsv_scalar_mg_get(aTHX_ sv, shmg);
 715     if (SvTYPE(SHAREDSvPTR(shared)) == SVt_PVAV) {
 716         SHARED_CONTEXT;
 717         av_delete((AV*) SHAREDSvPTR(shared), mg->mg_len, G_DISCARD);
 718     }
 719     else {
 720         char *key = mg->mg_ptr;
 721         STRLEN len = mg->mg_len;
 722         assert ( mg->mg_ptr != 0 );
 723         if (mg->mg_len == HEf_SVKEY)
 724            key = SvPV((SV *) mg->mg_ptr, len);
 725         SHARED_CONTEXT;
 726         hv_delete((HV*) SHAREDSvPTR(shared), key, len, G_DISCARD);
 727     }
 728     CALLER_CONTEXT;
 729     LEAVE_LOCK;
 730     return 0;
 731 }
 732
 733 int
 734 sharedsv_elem_mg_free(pTHX_ SV *sv, MAGIC *mg)
 735 {
 736     Perl_sharedsv_free(aTHX_ SV_to_sharedsv(aTHX_ mg->mg_obj));
 737     return 0;
 738 }
 739
 740 int
 741 sharedsv_elem_mg_dup(pTHX_ MAGIC *mg, CLONE_PARAMS *param)
 742 {
 743     shared_sv *shared = SV_to_sharedsv(aTHX_ mg->mg_obj);
 744     SvREFCNT_inc(SHAREDSvPTR(shared));
 745     mg->mg_flags |= MGf_DUP;
 746     return 0;
 747 }
 748
 749 MGVTBL sharedsv_elem_vtbl = {
 750  sharedsv_elem_mg_FETCH,        /* get */
 751  sharedsv_elem_mg_STORE,        /* set */
 752  0,                             /* len */
 753  sharedsv_elem_mg_DELETE,       /* clear */
 754  sharedsv_elem_mg_free,         /* free */
 755  0,                             /* copy */
 756  sharedsv_elem_mg_dup           /* dup */
 757 };
 758
 759 U32
 760 sharedsv_array_mg_FETCHSIZE(pTHX_ SV *sv, MAGIC *mg)
 761 {
 762     dTHXc;
 763     shared_sv *shared = (shared_sv *) mg->mg_ptr;
 764     U32 val;
 765     SHARED_EDIT;
 766     if (SvTYPE(SHAREDSvPTR(shared)) == SVt_PVAV) {
 767         val = av_len((AV*) SHAREDSvPTR(shared));
 768     }
 769     else {
 770         /* not actually defined by tie API but ... */
 771         val = HvKEYS((HV*) SHAREDSvPTR(shared));
 772     }
 773     SHARED_RELEASE;
 774     return val;
 775 }
 776
 777 int
 778 sharedsv_array_mg_CLEAR(pTHX_ SV *sv, MAGIC *mg)
 779 {
 780     dTHXc;
 781     shared_sv *shared = (shared_sv *) mg->mg_ptr;
 782     SHARED_EDIT;
 783     if (SvTYPE(SHAREDSvPTR(shared)) == SVt_PVAV) {
 784         av_clear((AV*) SHAREDSvPTR(shared));
 785     }
 786     else {
 787         hv_clear((HV*) SHAREDSvPTR(shared));
 788     }
 789     SHARED_RELEASE;
 790     return 0;
 791 }
 792
 793 int
 794 sharedsv_array_mg_free(pTHX_ SV *sv, MAGIC *mg)
 795 {
 796     Perl_sharedsv_free(aTHX_ (shared_sv *) mg->mg_ptr);
 797     return 0;
 798 }
 799
 800 /*
 801  * This is called when perl is about to access an element of
 802  * the array -
 803  */
 804 int
 805 sharedsv_array_mg_copy(pTHX_ SV *sv, MAGIC* mg,
 806                        SV *nsv, const char *name, int namlen)
 807 {
 808     shared_sv *shared = (shared_sv *) mg->mg_ptr;
 809     MAGIC *nmg = sv_magicext(nsv,mg->mg_obj,
 810                             toLOWER(mg->mg_type),&sharedsv_elem_vtbl,
 811                             name, namlen);
 812     ENTER_LOCK;
 813     SvREFCNT_inc(SHAREDSvPTR(shared));
 814     LEAVE_LOCK;
 815     nmg->mg_flags |= MGf_DUP;
 816     return 1;
 817 }
 818
 819 int
 820 sharedsv_array_mg_dup(pTHX_ MAGIC *mg, CLONE_PARAMS *param)
 821 {
 822     shared_sv *shared = (shared_sv *) mg->mg_ptr;
 823     SvREFCNT_inc(SHAREDSvPTR(shared));
 824     mg->mg_flags |= MGf_DUP;
 825     return 0;
 826 }
 827
 828 MGVTBL sharedsv_array_vtbl = {
 829  0,                             /* get */
 830  0,                             /* set */
 831  sharedsv_array_mg_FETCHSIZE,   /* len */
 832  sharedsv_array_mg_CLEAR,       /* clear */
 833  sharedsv_array_mg_free,        /* free */
 834  sharedsv_array_mg_copy,        /* copy */
 835  sharedsv_array_mg_dup          /* dup */
 836 };
 837
 838 =for apidoc sharedsv_unlock
 839
 840 Recursively unlocks a shared sv.
 841
 842 =cut
 843
 844 void
 845 Perl_sharedsv_unlock(pTHX_ shared_sv* ssv)
 846 {
 847     recursive_lock_release(aTHX_ &ssv->lock);
 848 }
 849
 850 =for apidoc sharedsv_lock
 851
 852 Recursive locks on a sharedsv.
 853 Locks are dynamically scoped at the level of the first lock.
 854
 855 =cut
 856
 857 void
 858 Perl_sharedsv_lock(pTHX_ shared_sv* ssv)
 859 {
 860     if (!ssv)
 861         return;
 862     recursive_lock_acquire(aTHX_ &ssv->lock, __FILE__, __LINE__);
 863 }
 864
 865 /* handles calls from lock() builtin via PL_lockhook */
 866
 867 void
 868 Perl_sharedsv_locksv(pTHX_ SV *sv)
 869 {
 870     shared_sv* shared;
 871
 872     if(SvROK(sv))
 873         sv = SvRV(sv);
 874     shared = Perl_sharedsv_find(aTHX_ sv);
 875     if(!shared)
 876        croak("lock can only be used on shared values");
 877     Perl_sharedsv_lock(aTHX_ shared);
 878 }
 879
 880 =head1 Shared SV Functions
 881
 882 =for apidoc sharedsv_init
 883
 884 Saves a space for keeping SVs wider than an interpreter,
 885
 886 =cut
 887
 888 void
 889 Perl_sharedsv_init(pTHX)
 890 {
 891   dTHXc;
 892   /* This pair leaves us in shared context ... */
 893   PL_sharedsv_space = perl_alloc();
 894   perl_construct(PL_sharedsv_space);
 895   CALLER_CONTEXT;
 896   recursive_lock_init(aTHX_ &PL_sharedsv_lock);
 897   PL_lockhook = &Perl_sharedsv_locksv;
 898   PL_sharehook = &Perl_sharedsv_share;
 899 }
 900
 901 #endif /* USE_ITHREADS */
 902
 903 MODULE = threads::shared        PACKAGE = threads::shared::tie
 904
 905 PROTOTYPES: DISABLE
 906
 907 #ifdef USE_ITHREADS
 908
 909 void
 910 PUSH(shared_sv *shared, ...)
 911 CODE:
 912         dTHXc;
 913         int i;
 914         for(i = 1; i < items; i++) {
 915             SV* tmp = newSVsv(ST(i));
 916             shared_sv *target;
 917             ENTER_LOCK;
 918             target = Perl_sharedsv_associate(aTHX_ &tmp, Nullsv, 0);
 919             sharedsv_scalar_store(aTHX_ tmp, target);
 920             SHARED_CONTEXT;
 921             av_push((AV*) SHAREDSvPTR(shared), SHAREDSvPTR(target));
 922             SvREFCNT_inc(SHAREDSvPTR(target));
 923             SHARED_RELEASE;
 924             SvREFCNT_dec(tmp);
 925         }
 926
 927 void
 928 UNSHIFT(shared_sv *shared, ...)
 929 CODE:
 930         dTHXc;
 931         int i;
 932         ENTER_LOCK;
 933         SHARED_CONTEXT;
 934         av_unshift((AV*)SHAREDSvPTR(shared), items - 1);
 935         CALLER_CONTEXT;
 936         for(i = 1; i < items; i++) {
 937             SV* tmp = newSVsv(ST(i));
 938             shared_sv *target = Perl_sharedsv_associate(aTHX_ &tmp, Nullsv, 0);
 939             sharedsv_scalar_store(aTHX_ tmp, target);
 940             SHARED_CONTEXT;
 941             av_store((AV*) SHAREDSvPTR(shared), i - 1, SHAREDSvPTR(target));
 942             SvREFCNT_inc(SHAREDSvPTR(target));
 943             CALLER_CONTEXT;
 944             SvREFCNT_dec(tmp);
 945         }
 946         LEAVE_LOCK;
 947
 948 void
 949 POP(shared_sv *shared)
 950 CODE:
 951         dTHXc;
 952         SV* sv;
 953         ENTER_LOCK;
 954         SHARED_CONTEXT;
 955         sv = av_pop((AV*)SHAREDSvPTR(shared));
 956         CALLER_CONTEXT;
 957         ST(0) = sv_newmortal();
 958         Perl_sharedsv_associate(aTHX_ &ST(0), sv, 0);
 959         SvREFCNT_dec(sv);
 960         LEAVE_LOCK;
 961         XSRETURN(1);
 962
 963 void
 964 SHIFT(shared_sv *shared)
 965 CODE:
 966         dTHXc;
 967         SV* sv;
 968         ENTER_LOCK;
 969         SHARED_CONTEXT;
 970         sv = av_shift((AV*)SHAREDSvPTR(shared));
 971         CALLER_CONTEXT;
 972         ST(0) = sv_newmortal();
 973         Perl_sharedsv_associate(aTHX_ &ST(0), sv, 0);
 974         SvREFCNT_dec(sv);
 975         LEAVE_LOCK;
 976         XSRETURN(1);
 977
 978 void
 979 EXTEND(shared_sv *shared, IV count)
 980 CODE:
 981         dTHXc;
 982         SHARED_EDIT;
 983         av_extend((AV*)SHAREDSvPTR(shared), count);
 984         SHARED_RELEASE;
 985
 986 void
 987 STORESIZE(shared_sv *shared,IV count)
 988 CODE:
 989         dTHXc;
 990         SHARED_EDIT;
 991         av_fill((AV*) SHAREDSvPTR(shared), count);
 992         SHARED_RELEASE;
 993
 994
 995
 996
 997 void
 998 EXISTS(shared_sv *shared, SV *index)
 999 CODE:
1000         dTHXc;
1001         bool exists;
1002         if (SvTYPE(SHAREDSvPTR(shared)) == SVt_PVAV) {
1003             SHARED_EDIT;
1004             exists = av_exists((AV*) SHAREDSvPTR(shared), SvIV(index));
1005         }
1006         else {
1007             STRLEN len;
1008             char *key = SvPV(index,len);
1009             SHARED_EDIT;
1010             exists = hv_exists((HV*) SHAREDSvPTR(shared), key, len);
1011         }
1012         SHARED_RELEASE;
1013         ST(0) = (exists) ? &PL_sv_yes : &PL_sv_no;
1014         XSRETURN(1);
1015
1016
1017 void
1018 FIRSTKEY(shared_sv *shared)
1019 CODE:
1020         dTHXc;
1021         char* key = NULL;
1022         I32 len = 0;
1023         HE* entry;
1024         ENTER_LOCK;
1025         SHARED_CONTEXT;
1026         hv_iterinit((HV*) SHAREDSvPTR(shared));
1027         entry = hv_iternext((HV*) SHAREDSvPTR(shared));
1028         if (entry) {
1029                 key = hv_iterkey(entry,&len);
1030                 CALLER_CONTEXT;
1031                 ST(0) = sv_2mortal(newSVpv(key, len));
1032         } else {
1033              CALLER_CONTEXT;
1034              ST(0) = &PL_sv_undef;
1035         }
1036         LEAVE_LOCK;
1037         XSRETURN(1);
1038
1039 void
1040 NEXTKEY(shared_sv *shared, SV *oldkey)
1041 CODE:
1042         dTHXc;
1043         char* key = NULL;
1044         I32 len = 0;
1045         HE* entry;
1046         ENTER_LOCK;
1047         SHARED_CONTEXT;
1048         entry = hv_iternext((HV*) SHAREDSvPTR(shared));
1049         if (entry) {
1050                 key = hv_iterkey(entry,&len);
1051                 CALLER_CONTEXT;
1052                 ST(0) = sv_2mortal(newSVpv(key, len));
1053         } else {
1054              CALLER_CONTEXT;
1055              ST(0) = &PL_sv_undef;
1056         }
1057         LEAVE_LOCK;
1058         XSRETURN(1);
1059
1060 MODULE = threads::shared                PACKAGE = threads::shared
1061
1062 PROTOTYPES: ENABLE
1063
1064 void
1065 _id(SV *ref)
1066         PROTOTYPE: \[$@%]
1067 CODE:
1068         shared_sv *shared;
1069         ref = SvRV(ref);
1070         if(SvROK(ref))
1071             ref = SvRV(ref);
1072         if( (shared = Perl_sharedsv_find(aTHX_ ref)) ){
1073             ST(0) = sv_2mortal(newSViv(PTR2IV(shared)));
1074             XSRETURN(1);
1075         }
1076         XSRETURN_UNDEF;
1077
1078
1079 void
1080 _refcnt(SV *ref)
1081         PROTOTYPE: \[$@%]
1082 CODE:
1083         shared_sv *shared;
1084         ref = SvRV(ref);
1085         if(SvROK(ref))
1086             ref = SvRV(ref);
1087         if( (shared = Perl_sharedsv_find(aTHX_ ref)) ){
1088           if (SHAREDSvPTR(shared)) {
1089             ST(0) = sv_2mortal(newSViv(SvREFCNT(SHAREDSvPTR(shared))));
1090             XSRETURN(1);
1091           }
1092           else {
1093              Perl_warn(aTHX_ "%" SVf " s=%p has no shared SV",ST(0),shared);
1094           }
1095         }
1096         else {
1097              Perl_warn(aTHX_ "%" SVf " is not shared",ST(0));
1098         }
1099         XSRETURN_UNDEF;
1100
1101 SV*
1102 share(SV *ref)
1103         PROTOTYPE: \[$@%]
1104         CODE:
1105         if(!SvROK(ref))
1106             Perl_croak(aTHX_ "Argument to share needs to be passed as ref");
1107         ref = SvRV(ref);
1108         if(SvROK(ref))
1109             ref = SvRV(ref);
1110         Perl_sharedsv_share(aTHX_ ref);
1111         RETVAL = newRV(ref);
1112         OUTPUT:
1113         RETVAL
1114
1115 void
1116 lock_enabled(SV *ref)
1117         PROTOTYPE: \[$@%]
1118         CODE:
1119         shared_sv* shared;
1120         if(!SvROK(ref))
1121             Perl_croak(aTHX_ "Argument to lock needs to be passed as ref");
1122         ref = SvRV(ref);
1123         if(SvROK(ref))
1124             ref = SvRV(ref);
1125         shared = Perl_sharedsv_find(aTHX_ ref);
1126         if(!shared)
1127            croak("lock can only be used on shared values");
1128         Perl_sharedsv_lock(aTHX_ shared);
1129
1130 void
1131 cond_wait_enabled(SV *ref_cond, SV *ref_lock = 0)
1132         PROTOTYPE: \[$@%];\[$@%]
1133         PREINIT:
1134         shared_sv* shared;
1135         perl_cond* user_condition;
1136         int locks;
1137         int same = 0;
1138
1139         CODE:
1140         if (!ref_lock || ref_lock == ref_cond) same = 1;
1141
1142         if(!SvROK(ref_cond))
1143             Perl_croak(aTHX_ "Argument to cond_wait needs to be passed as ref");
1144         ref_cond = SvRV(ref_cond);
1145         if(SvROK(ref_cond))
1146             ref_cond = SvRV(ref_cond);
1147         shared = Perl_sharedsv_find(aTHX_ ref_cond);
1148         if(!shared)
1149             croak("cond_wait can only be used on shared values");
1150
1151         user_condition = &shared->user_cond;
1152         if (! same) {
1153             if (!SvROK(ref_lock))
1154                 Perl_croak(aTHX_ "cond_wait lock needs to be passed as ref");
1155             ref_lock = SvRV(ref_lock);
1156             if (SvROK(ref_lock)) ref_lock = SvRV(ref_lock);
1157             shared = Perl_sharedsv_find(aTHX_ ref_lock);
1158             if (!shared)
1159                 croak("cond_wait lock must be a shared value");
1160         }
1161         if(shared->lock.owner != aTHX)
1162             croak("You need a lock before you can cond_wait");
1163         /* Stealing the members of the lock object worries me - NI-S */
1164         MUTEX_LOCK(&shared->lock.mutex);
1165         shared->lock.owner = NULL;
1166         locks = shared->lock.locks;
1167         shared->lock.locks = 0;
1168
1169         /* since we are releasing the lock here we need to tell other
1170         people that is ok to go ahead and use it */
1171         COND_SIGNAL(&shared->lock.cond);
1172         COND_WAIT(user_condition, &shared->lock.mutex);
1173         while(shared->lock.owner != NULL) {
1174             /* OK -- must reacquire the lock */
1175             COND_WAIT(&shared->lock.cond, &shared->lock.mutex);
1176         }
1177         shared->lock.owner = aTHX;
1178         shared->lock.locks = locks;
1179         MUTEX_UNLOCK(&shared->lock.mutex);
1180
1181 int
1182 cond_timedwait_enabled(SV *ref_cond, double abs, SV *ref_lock = 0)
1183         PROTOTYPE: \[$@%]$;\[$@%]
1184         PREINIT:
1185         shared_sv* shared;
1186         perl_cond* user_condition;
1187         int locks;
1188         int same = 0;
1189
1190         CODE:
1191         if (!ref_lock || ref_cond == ref_lock) same = 1;
1192
1193         if(!SvROK(ref_cond))
1194             Perl_croak(aTHX_ "Argument to cond_timedwait needs to be passed as ref");
1195         ref_cond = SvRV(ref_cond);
1196         if(SvROK(ref_cond))
1197             ref_cond = SvRV(ref_cond);
1198         shared = Perl_sharedsv_find(aTHX_ ref_cond);
1199         if(!shared)
1200             croak("cond_timedwait can only be used on shared values");
1201
1202         user_condition = &shared->user_cond;
1203         if (! same) {
1204             if (!SvROK(ref_lock))
1205                 Perl_croak(aTHX_ "cond_timedwait lock needs to be passed as ref");
1206             ref_lock = SvRV(ref_lock);
1207             if (SvROK(ref_lock)) ref_lock = SvRV(ref_lock);
1208             shared = Perl_sharedsv_find(aTHX_ ref_lock);
1209             if (!shared)
1210                 croak("cond_timedwait lock must be a shared value");
1211         }
1212         if(shared->lock.owner != aTHX)
1213             croak("You need a lock before you can cond_wait");
1214
1215         MUTEX_LOCK(&shared->lock.mutex);
1216         shared->lock.owner = NULL;
1217         locks = shared->lock.locks;
1218         shared->lock.locks = 0;
1219         /* since we are releasing the lock here we need to tell other
1220         people that is ok to go ahead and use it */
1221         COND_SIGNAL(&shared->lock.cond);
1222         RETVAL = Perl_sharedsv_cond_timedwait(user_condition, &shared->lock.mutex, abs);
1223         while (shared->lock.owner != NULL) {
1224             /* OK -- must reacquire the lock... */
1225             COND_WAIT(&shared->lock.cond, &shared->lock.mutex);
1226         }
1227         shared->lock.owner = aTHX;
1228         shared->lock.locks = locks;
1229         MUTEX_UNLOCK(&shared->lock.mutex);
1230
1231         if (RETVAL == 0)
1232             XSRETURN_UNDEF;
1233         OUTPUT:
1234         RETVAL
1235
1236 void
1237 cond_signal_enabled(SV *ref)
1238         PROTOTYPE: \[$@%]
1239         CODE:
1240         shared_sv* shared;
1241         if(!SvROK(ref))
1242             Perl_croak(aTHX_ "Argument to cond_signal needs to be passed as ref");
1243         ref = SvRV(ref);
1244         if(SvROK(ref))
1245             ref = SvRV(ref);
1246         shared = Perl_sharedsv_find(aTHX_ ref);
1247         if(!shared)
1248             croak("cond_signal can only be used on shared values");
1249         if (ckWARN(WARN_THREADS) && shared->lock.owner != aTHX)
1250             Perl_warner(aTHX_ packWARN(WARN_THREADS),
1251                             "cond_signal() called on unlocked variable");
1252         COND_SIGNAL(&shared->user_cond);
1253
1254 void
1255 cond_broadcast_enabled(SV *ref)
1256         PROTOTYPE: \[$@%]
1257         CODE:
1258         shared_sv* shared;
1259         if(!SvROK(ref))
1260             Perl_croak(aTHX_ "Argument to cond_broadcast needs to be passed as ref");
1261         ref = SvRV(ref);
1262         if(SvROK(ref))
1263             ref = SvRV(ref);
1264         shared = Perl_sharedsv_find(aTHX_ ref);
1265         if(!shared)
1266             croak("cond_broadcast can only be used on shared values");
1267         if (ckWARN(WARN_THREADS) && shared->lock.owner != aTHX)
1268             Perl_warner(aTHX_ packWARN(WARN_THREADS),
1269                             "cond_broadcast() called on unlocked variable");
1270         COND_BROADCAST(&shared->user_cond);
1271
1272
1273 SV*
1274 bless(SV* ref, ...);
1275         PROTOTYPE: $;$
1276         CODE:
1277         {
1278           HV* stash;
1279           shared_sv* shared;
1280           if (items == 1)
1281             stash = CopSTASH(PL_curcop);
1282           else {
1283             SV* ssv = ST(1);
1284             STRLEN len;
1285             char *ptr;
1286
1287             if (ssv && !SvGMAGICAL(ssv) && !SvAMAGIC(ssv) && SvROK(ssv))
1288               Perl_croak(aTHX_ "Attempt to bless into a reference");
1289             ptr = SvPV(ssv,len);
1290             if (ckWARN(WARN_MISC) && len == 0)
1291               Perl_warner(aTHX_ packWARN(WARN_MISC),
1292                           "Explicit blessing to '' (assuming package main)");
1293             stash = gv_stashpvn(ptr, len, TRUE);
1294           }
1295           SvREFCNT_inc(ref);
1296           (void)sv_bless(ref, stash);
1297           RETVAL = ref;
1298           shared = Perl_sharedsv_find(aTHX_ ref);
1299           if(shared) {
1300             dTHXc;
1301             ENTER_LOCK;
1302             SHARED_CONTEXT;
1303             {
1304               SV* fake_stash = newSVpv(HvNAME_get(stash),0);
1305               (void)sv_bless(SHAREDSvPTR(shared),(HV*)fake_stash);
1306             }
1307             CALLER_CONTEXT;
1308             LEAVE_LOCK;
1309           }
1310         }
1311         OUTPUT:
1312         RETVAL
1313
1314 #endif /* USE_ITHREADS */
1315
1316 BOOT:
1317 {
1318 #ifdef USE_ITHREADS
1319      Perl_sharedsv_init(aTHX);
1320 #endif /* USE_ITHREADS */
1321 }
1322
1323
1324