ext/threads/shared/shared.xs

   1
   2 #include "EXTERN.h"
   3 #include "perl.h"
   4 #include "XSUB.h"
   5
   6
   7 void shared_sv_attach_sv (SV* sv, shared_sv* shared) {
   8     HV* shared_hv = get_hv("threads::shared::shared", FALSE);
   9     SV* id = newSViv((IV)shared);
  10     STRLEN length = sv_len(id);
  11     SV* tiedobject;
  12     SV** tiedobject_ = hv_fetch(shared_hv, SvPV(id,length), length, 0);
  13     if(tiedobject_) {
  14         tiedobject = (*tiedobject_);
  15         SvROK_on(sv);
  16         SvRV(sv) = SvRV(tiedobject);
  17
  18     } else {
  19         croak("die\n");
  20     }
  21 }
  22
  23
  24 int shared_sv_fetch_mg (pTHX_ SV* sv, MAGIC *mg) {
  25     shared_sv* shared = (shared_sv*) SvIV(mg->mg_obj);
  26     SHAREDSvLOCK(shared);
  27     if(SvROK(SHAREDSvGET(shared))) {
  28         shared_sv* target = (shared_sv*) SvIV(SvRV(SHAREDSvGET(shared)));
  29         shared_sv_attach_sv(sv, target);
  30     } else {
  31         sv_setsv(sv, SHAREDSvGET(shared));
  32     }
  33     SHAREDSvUNLOCK(shared);
  34
  35     return 0;
  36 }
  37
  38 int shared_sv_store_mg (pTHX_ SV* sv, MAGIC *mg) {
  39     shared_sv* shared = (shared_sv*) SvIV(mg->mg_obj);
  40     SHAREDSvLOCK(shared);
  41     if(SvROK(SHAREDSvGET(shared)))
  42         Perl_sharedsv_thrcnt_dec(aTHX_ (shared_sv*) SvIV(SvRV(SHAREDSvGET(shared))));
  43     SHAREDSvEDIT(shared);
  44     if(SvROK(sv)) {
  45         shared_sv* target = Perl_sharedsv_find(aTHX_ SvRV(sv));
  46         if(!target) {
  47             SHAREDSvRELEASE(shared);
  48             sv_setsv(sv,SHAREDSvGET(shared));
  49             SHAREDSvUNLOCK(shared);
  50             Perl_croak(aTHX_ "You cannot assign a non shared reference to a shared scalar");
  51         }
  52         Perl_sv_free(PL_sharedsv_space,SHAREDSvGET(shared));
  53         SHAREDSvGET(shared) = newRV_noinc(newSViv((IV)target));
  54         SvROK_off(sv);
  55     } else {
  56         sv_setsv(SHAREDSvGET(shared), sv);
  57     }
  58     SHAREDSvRELEASE(shared);
  59     if(SvROK(SHAREDSvGET(shared)))
  60        Perl_sharedsv_thrcnt_inc(aTHX_ (shared_sv*) SvIV(SvRV(SHAREDSvGET(shared))));
  61     SHAREDSvUNLOCK(shared);
  62     return 0;
  63 }
  64
  65 int shared_sv_destroy_mg (pTHX_ SV* sv, MAGIC *mg) {
  66     shared_sv* shared = (shared_sv*) SvIV(mg->mg_obj);
  67     if(!shared)
  68         return 0;
  69     Perl_sharedsv_thrcnt_dec(aTHX_ shared);
  70 }
  71
  72 MGVTBL svtable = {MEMBER_TO_FPTR(shared_sv_fetch_mg),
  73                   MEMBER_TO_FPTR(shared_sv_store_mg),
  74                   0,
  75                   0,
  76                   MEMBER_TO_FPTR(shared_sv_destroy_mg)
  77 };
  78
  79 MODULE = threads::shared                PACKAGE = threads::shared
  80
  81
  82 PROTOTYPES: DISABLE
  83
  84
  85 SV*
  86 ptr(ref)
  87         SV* ref
  88         CODE:
  89         RETVAL = newSViv(SvIV(SvRV(ref)));
  90         OUTPUT:
  91         RETVAL
  92
  93
  94 SV*
  95 _thrcnt(ref)
  96         SV* ref
  97         CODE:
  98         shared_sv* shared = Perl_sharedsv_find(aTHX, ref);
  99         if(!shared)
 100            croak("thrcnt can only be used on shared values");
 101         SHAREDSvLOCK(shared);
 102         RETVAL = newSViv(SvREFCNT(SHAREDSvGET(shared)));
 103         SHAREDSvUNLOCK(shared);
 104         OUTPUT:
 105         RETVAL
 106
 107
 108 void
 109 thrcnt_inc(ref)
 110         SV* ref
 111         CODE:
 112         shared_sv* shared;
 113         if(SvROK(ref))
 114             ref = SvRV(ref);
 115         shared = Perl_sharedsv_find(aTHX, ref);
 116         if(!shared)
 117            croak("thrcnt can only be used on shared values");
 118         Perl_sharedsv_thrcnt_inc(aTHX_ shared);
 119
 120
 121 MODULE = threads::shared                PACKAGE = threads::shared::sv
 122
 123 SV*
 124 new(class, value)
 125         SV* class
 126         SV* value
 127         CODE:
 128         shared_sv* shared = Perl_sharedsv_new(aTHX);
 129         MAGIC* shared_magic;
 130         SV* obj = newSViv((IV)shared);
 131         SHAREDSvEDIT(shared);
 132         SHAREDSvGET(shared) = newSVsv(value);
 133         SHAREDSvRELEASE(shared);
 134         sv_magic(value, 0, PERL_MAGIC_ext, "threads::shared", 16);
 135         shared_magic = mg_find(value, PERL_MAGIC_ext);
 136         shared_magic->mg_virtual = &svtable;
 137         shared_magic->mg_obj = newSViv((IV)shared);
 138         shared_magic->mg_flags |= MGf_REFCOUNTED;
 139         SvMAGICAL_on(value);
 140         RETVAL = obj;
 141         OUTPUT:
 142         RETVAL
 143
 144