shared.xs

source of perl for linux application,

        dTHXc;
        SHARED_CONTEXT;
        SvREFCNT_dec(ssv);
        CALLER_CONTEXT;
    }
    LEAVE_LOCK;
}


/* Implements Perl-level share() and :shared */

void
Perl_sharedsv_share(pTHX_ SV *sv)
{
    switch(SvTYPE(sv)) {
    case SVt_PVGV:
        Perl_croak(aTHX_ "Cannot share globs yet");
        break;

    case SVt_PVCV:
        Perl_croak(aTHX_ "Cannot share subs yet");
        break;

    default:
        ENTER_LOCK;
        (void) S_sharedsv_new_shared(aTHX_ sv);
        LEAVE_LOCK;
        SvSETMAGIC(sv);
        break;
    }
}


#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 /* OS2 */
#endif /* WIN32 */

/* Do OS-specific condition timed wait */

bool
Perl_sharedsv_cond_timedwait(perl_cond *cond, perl_mutex *mut, double abs)
{
#if defined(NETWARE) || defined(FAKE_THREADS) || defined(I_MACH_CTHREADS)
    Perl_croak_nocontext("cond_timedwait not supported on this platform");
#else
#  ifdef WIN32
    int got_it = 0;

    cond->waiters++;
    MUTEX_UNLOCK(mut);
    /* See comments in win32/win32thread.h COND_WAIT vis-a-vis race */
    switch (WaitForSingleObject(cond->sem, S_abs_2_rel_milli(abs))) {
        case WAIT_OBJECT_0:   got_it = 1; break;
        case WAIT_TIMEOUT:                break;
        default:
            /* WAIT_FAILED? WAIT_ABANDONED? others? */
            Perl_croak_nocontext("panic: cond_timedwait (%ld)",GetLastError());
            break;
    }
    MUTEX_LOCK(mut);
    cond->waiters--;
    return (got_it);
#  else
#    ifdef OS2
    int rc, got_it = 0;
    STRLEN n_a;

    ABS2RELMILLI(abs);

    if ((rc = DosResetEventSem(*cond,&n_a)) && (rc != ERROR_ALREADY_RESET))
        Perl_rc = rc, croak_with_os2error("panic: cond_timedwait-reset");
    MUTEX_UNLOCK(mut);
    if (CheckOSError(DosWaitEventSem(*cond,abs))
        && (rc != ERROR_INTERRUPT))
        croak_with_os2error("panic: cond_timedwait");
    if (rc == ERROR_INTERRUPT) errno = EINTR;
    MUTEX_LOCK(mut);
    return (got_it);
#    else         /* Hope you're I_PTHREAD! */
    struct timespec ts;
    int got_it = 0;

    ts.tv_sec = (long)abs;
    abs -= (NV)ts.tv_sec;
    ts.tv_nsec = (long)(abs * 1000000000.0);

    switch (pthread_cond_timedwait(cond, mut, &ts)) {
        case 0:         got_it = 1; break;
        case ETIMEDOUT:             break;
#ifdef OEMVS
        case -1:
            if (errno == ETIMEDOUT || errno == EAGAIN)
                break;
#endif
        default:
            Perl_croak_nocontext("panic: cond_timedwait");
            break;
    }
    return (got_it);
#    endif /* OS2 */
#  endif /* WIN32 */
#endif /* NETWARE || FAKE_THREADS || I_MACH_CTHREADS */
}


/* Given a shared RV, copy it's value to a private RV, also copying the
 * object status of the referent.
 * If the private side is already an appropriate RV->SV combination, keep
 * it if possible.
 */
STATIC void
S_get_RV(pTHX_ SV *sv, SV *ssv) {
    SV *sobj = SvRV(ssv);
    SV *obj;
    if (! (SvROK(sv) &&
           ((obj = SvRV(sv))) &&
           (Perl_sharedsv_find(aTHX_ obj) == sobj) &&
           (SvTYPE(obj) == SvTYPE(sobj))))
    {
        /* Can't reuse obj */
        if (SvROK(sv)) {
            SvREFCNT_dec(SvRV(sv));
        } else {
            assert(SvTYPE(sv) >= SVt_RV);
            sv_setsv_nomg(sv, &PL_sv_undef);
            SvROK_on(sv);
        }
        obj = S_sharedsv_new_private(aTHX_ SvRV(ssv));
        SvRV_set(sv, obj);
    }

    if (SvOBJECT(obj)) {
        /* Remove any old blessing */
        SvREFCNT_dec(SvSTASH(obj));
        SvOBJECT_off(obj);
    }
    if (SvOBJECT(sobj)) {
        /* Add any new old blessing */
        STRLEN len;
        char* stash_ptr = SvPV((SV*) SvSTASH(sobj), len);
        HV* stash = gv_stashpvn(stash_ptr, len, TRUE);
        SvOBJECT_on(obj);
        SvSTASH_set(obj, (HV*)SvREFCNT_inc(stash));
    }
}


/* ------------ PERL_MAGIC_shared_scalar(n) functions -------------- */

/* Get magic for PERL_MAGIC_shared_scalar(n) */

int
sharedsv_scalar_mg_get(pTHX_ SV *sv, MAGIC *mg)
{
    SV *ssv = (SV *) mg->mg_ptr;
    assert(ssv);

    ENTER_LOCK;
    if (SvROK(ssv)) {
        S_get_RV(aTHX_ sv, ssv);
    } else {
        sv_setsv_nomg(sv, ssv);
    }
    LEAVE_LOCK;
    return (0);
}

/* Copy the contents of a private SV to a shared SV.
 * Used by various mg_set()-type functions.
 * Assumes lock is held.
 */
void
sharedsv_scalar_store(pTHX_ SV *sv, SV *ssv)
{
    dTHXc;
    bool allowed = TRUE;

    assert(PL_sharedsv_lock.owner == aTHX);
    if (SvROK(sv)) {
        SV *obj = SvRV(sv);
        SV *sobj = Perl_sharedsv_find(aTHX_ obj);
        if (sobj) {
            SHARED_CONTEXT;
            (void)SvUPGRADE(ssv, SVt_RV);
            sv_setsv_nomg(ssv, &PL_sv_undef);

            SvRV_set(ssv, SvREFCNT_inc(sobj));
            SvROK_on(ssv);
            if (SvOBJECT(sobj)) {
                /* Remove any old blessing */
                SvREFCNT_dec(SvSTASH(sobj));
                SvOBJECT_off(sobj);
            }
            if (SvOBJECT(obj)) {
              SV* fake_stash = newSVpv(HvNAME_get(SvSTASH(obj)),0);
              SvOBJECT_on(sobj);
              SvSTASH_set(sobj, (HV*)fake_stash);
            }
            CALLER_CONTEXT;
        } else {
            allowed = FALSE;
        }
    } else {
        SvTEMP_off(sv);
        SHARED_CONTEXT;
        sv_setsv_nomg(ssv, sv);
        if (SvOBJECT(ssv)) {
            /* Remove any old blessing */
            SvREFCNT_dec(SvSTASH(ssv));
            SvOBJECT_off(ssv);
        }
        if (SvOBJECT(sv)) {
          SV* fake_stash = newSVpv(HvNAME_get(SvSTASH(sv)),0);
          SvOBJECT_on(ssv);
          SvSTASH_set(ssv, (HV*)fake_stash);
        }
        CALLER_CONTEXT;
    }
    if (!allowed) {
        Perl_croak(aTHX_ "Invalid value for shared scalar");
    }
}

/* Set magic for PERL_MAGIC_shared_scalar(n) */

int
sharedsv_scalar_mg_set(pTHX_ SV *sv, MAGIC *mg)
{
    SV *ssv = (SV*)(mg->mg_ptr);
    assert(ssv);
    ENTER_LOCK;
    if (SvTYPE(ssv) < SvTYPE(sv)) {
        dTHXc;
        SHARED_CONTEXT;
        sv_upgrade(ssv, SvTYPE(sv));
        CALLER_CONTEXT;
    }
    sharedsv_scalar_store(aTHX_ sv, ssv);
    LEAVE_LOCK;
    return (0);
}

/* Free magic for PERL_MAGIC_shared_scalar(n) */

int
sharedsv_scalar_mg_free(pTHX_ SV *sv, MAGIC *mg)
{
    S_sharedsv_dec(aTHX_ (SV*)mg->mg_ptr);
    return (0);
}

/*
 * Called during cloning of PERL_MAGIC_shared_scalar(n) magic in new thread
 */
int
sharedsv_scalar_mg_dup(pTHX_ MAGIC *mg, CLONE_PARAMS *param)
{
    SvREFCNT_inc_void(mg->mg_ptr);
    return (0);
}

#ifdef MGf_LOCAL
/*
 * Called during local $shared
 */
int
sharedsv_scalar_mg_local(pTHX_ SV* nsv, MAGIC *mg)
{
    MAGIC *nmg;
    SV *ssv = (SV *) mg->mg_ptr;
    if (ssv) {
        ENTER_LOCK;
        SvREFCNT_inc_void(ssv);
        LEAVE_LOCK;
    }
    nmg = sv_magicext(nsv, mg->mg_obj, mg->mg_type, mg->mg_virtual,
                           mg->mg_ptr, mg->mg_len);
    nmg->mg_flags   = mg->mg_flags;
    nmg->mg_private = mg->mg_private;

    return (0);
}
#endif

MGVTBL sharedsv_scalar_vtbl = {
    sharedsv_scalar_mg_get,     /* get */
    sharedsv_scalar_mg_set,     /* set */
    0,                          /* len */
    0,                          /* clear */
    sharedsv_scalar_mg_free,    /* free */
    0,                          /* copy */
    sharedsv_scalar_mg_dup,     /* dup */
#ifdef MGf_LOCAL
    sharedsv_scalar_mg_local,   /* local */
#endif
};

/* ------------ PERL_MAGIC_tiedelem(p) functions -------------- */

/* Get magic for PERL_MAGIC_tiedelem(p) */

int
sharedsv_elem_mg_FETCH(pTHX_ SV *sv, MAGIC *mg)
{
    dTHXc;
    SV *saggregate = S_sharedsv_from_obj(aTHX_ mg->mg_obj);
    SV** svp;

    ENTER_LOCK;
    if (SvTYPE(saggregate) == SVt_PVAV) {
        assert ( mg->mg_ptr == 0 );
        SHARED_CONTEXT;
        svp = av_fetch((AV*) saggregate, mg->mg_len, 0);
    } else {
        char *key = mg->mg_ptr;
        STRLEN len = mg->mg_len;
        assert ( mg->mg_ptr != 0 );
        if (mg->mg_len == HEf_SVKEY) {
           key = SvPV((SV *) mg->mg_ptr, len);
        }
        SHARED_CONTEXT;
        svp = hv_fetch((HV*) saggregate, key, len, 0);
    }
    CALLER_CONTEXT;
    if (svp) {
        /* Exists in the array */
        if (SvROK(*svp)) {
            S_get_RV(aTHX_ sv, *svp);
        } else {
            /* XXX Can this branch ever happen? DAPM */
            /* XXX assert("no such branch"); */
            Perl_sharedsv_associate(aTHX_ sv, *svp);
            sv_setsv(sv, *svp);
        }
    } else {
        /* Not in the array */
        sv_setsv(sv, &PL_sv_undef);
    }
    LEAVE_LOCK;
    return (0);
}

/* Set magic for PERL_MAGIC_tiedelem(p) */

int
sharedsv_elem_mg_STORE(pTHX_ SV *sv, MAGIC *mg)
{
    dTHXc;
    SV *saggregate = S_sharedsv_from_obj(aTHX_ mg->mg_obj);
    SV **svp;
    /* Theory - SV itself is magically shared - and we have ordered the
       magic such that by the time we get here it has been stored
       to its shared counterpart
     */
    ENTER_LOCK;
    assert(saggregate);
    if (SvTYPE(saggregate) == SVt_PVAV) {
        assert ( mg->mg_ptr == 0 );
        SHARED_CONTEXT;
        svp = av_fetch((AV*) saggregate, mg->mg_len, 1);
    } else {
        char *key = mg->mg_ptr;
        STRLEN len = mg->mg_len;
        assert ( mg->mg_ptr != 0 );
        if (mg->mg_len == HEf_SVKEY)
           key = SvPV((SV *) mg->mg_ptr, len);
        SHARED_CONTEXT;
        svp = hv_fetch((HV*) saggregate, key, len, 1);
    }
    CALLER_CONTEXT;
    Perl_sharedsv_associate(aTHX_ sv, *svp);
    sharedsv_scalar_store(aTHX_ sv, *svp);
    LEAVE_LOCK;
    return (0);
}

/* Clear magic for PERL_MAGIC_tiedelem(p) */

int
sharedsv_elem_mg_DELETE(pTHX_ SV *sv, MAGIC *mg)
{
    dTHXc;
    MAGIC *shmg;
    SV *saggregate = S_sharedsv_from_obj(aTHX_ mg->mg_obj);
    ENTER_LOCK;
    sharedsv_elem_mg_FETCH(aTHX_ sv, mg);
    if ((shmg = mg_find(sv, PERL_MAGIC_shared_scalar)))
        sharedsv_scalar_mg_get(aTHX_ sv, shmg);
    if (SvTYPE(saggregate) == SVt_PVAV) {
        SHARED_CONTEXT;
        av_delete((AV*) saggregate, mg->mg_len, G_DISCARD);
    } else {
        char *key = mg->mg_ptr;
        STRLEN len = mg->mg_len;
        assert ( mg->mg_ptr != 0 );
        if (mg->mg_len == HEf_SVKEY)
           key = SvPV((SV *) mg->mg_ptr, len);
        SHARED_CONTEXT;
        hv_delete((HV*) saggregate, key, len, G_DISCARD);
    }
    CALLER_CONTEXT;
    LEAVE_LOCK;
    return (0);
}

/* Called during cloning of PERL_MAGIC_tiedelem(p) magic in new
 * thread */

int
sharedsv_elem_mg_dup(pTHX_ MAGIC *mg, CLONE_PARAMS *param)
{
    SvREFCNT_inc_void(S_sharedsv_from_obj(aTHX_ mg->mg_obj));
    assert(mg->mg_flags & MGf_DUP);
    return (0);
}

MGVTBL sharedsv_elem_vtbl = {
    sharedsv_elem_mg_FETCH,     /* get */
    sharedsv_elem_mg_STORE,     /* set */
    0,                          /* len */
    sharedsv_elem_mg_DELETE,    /* clear */
    0,                          /* free */
    0,                          /* copy */
    sharedsv_elem_mg_dup,       /* dup */
#ifdef MGf_LOCAL
    0,                          /* local */
#endif
};

/* ------------ PERL_MAGIC_tied(P) functions -------------- */

/* Len magic for PERL_MAGIC_tied(P) */

U32
sharedsv_array_mg_FETCHSIZE(pTHX_ SV *sv, MAGIC *mg)
{
    dTHXc;
    SV *ssv = (SV *) mg->mg_ptr;
    U32 val;
    SHARED_EDIT;
    if (SvTYPE(ssv) == SVt_PVAV) {
        val = av_len((AV*) ssv);
    } else {
        /* Not actually defined by tie API but ... */
        val = HvKEYS((HV*) ssv);
    }
    SHARED_RELEASE;
    return (val);
}

/* Clear magic for PERL_MAGIC_tied(P) */

int
sharedsv_array_mg_CLEAR(pTHX_ SV *sv, MAGIC *mg)
{
    dTHXc;
    SV *ssv = (SV *) mg->mg_ptr;
    SHARED_EDIT;
    if (SvTYPE(ssv) == SVt_PVAV) {
        av_clear((AV*) ssv);
    } else {
        hv_clear((HV*) ssv);
    }
    SHARED_RELEASE;
    return (0);
}

/* Free magic for PERL_MAGIC_tied(P) */

int
sharedsv_array_mg_free(pTHX_ SV *sv, MAGIC *mg)
{
    S_sharedsv_dec(aTHX_ (SV*)mg->mg_ptr);
    return (0);
}

/*
 * Copy magic for PERL_MAGIC_tied(P)
 * This is called when perl is about to access an element of
 * the array -
 */
int
sharedsv_array_mg_copy(pTHX_ SV *sv, MAGIC* mg,
                       SV *nsv, const char *name, int namlen)
{
    MAGIC *nmg = sv_magicext(nsv,mg->mg_obj,
                            toLOWER(mg->mg_type),&sharedsv_elem_vtbl,
                            name, namlen);