view release on metacpan or  search on metacpan

Object.xs  view on Meta::CPAN

    }
    return 0;
  }

  referant = (spell_in_progress ? el : SvRV(el));
  hash = ISET_HASH(referant);
  index = hash & (s->buckets - 1);
  bucket = s->bucket + index;

  if (s->buckets == 0)
    return 0;

  if (!bucket->sv)
    return 0;

  el_iter = bucket->sv;
  el_last = el_iter + bucket->n;
  IF_DEBUG(_warn("remove: el_last = %p, el_iter = %p", el_last, el_iter));

  THR_LOCK;
  for (; el_iter != el_last; ++el_iter) {
    if (*el_iter == referant) {
      if (s->is_weak) {
	THR_UNLOCK;
	if (!spell_in_progress) {
	  IF_SPELL_DEBUG(_warn("Removing ST(%p) magic", referant));
	  _dispel_magic(s,referant);
	} else {
	  IF_SPELL_DEBUG(_warn("Not removing ST(%p) magic (spell in progress)", referant));
	}
	THR_LOCK;
      } else {
	THR_UNLOCK;
	IF_SPELL_DEBUG(_warn("Not removing ST(%p) magic from Muggle", referant));
	THR_LOCK;
	SvREFCNT_dec(referant);
      }
      *el_iter = 0;
      --s->elems;
      THR_UNLOCK;
      return 1;
    }
    else {
      THR_UNLOCK;
      IF_SPELL_DEBUG(_warn("ST(%p) != %p", referant, *el_iter));
      THR_LOCK;
    }
  }
  THR_UNLOCK;
  return 0;
}
  
MODULE = Set::Object		PACKAGE = Set::Object		

PROTOTYPES: DISABLE

void
new(pkg, ...)
   SV* pkg;

   PPCODE:

   {
     SV* self;
     ISET* s;
     I32 item;
     SV* isv;
	
     New(0, s, 1, ISET);
     s->elems = 0;
     s->buckets = 0;
     s->bucket = NULL;
     s->flat = Nullhv;
     s->is_weak = Nullsv;

     isv = newSViv( PTR2IV(s) );
     sv_2mortal(isv);

     self = newRV_inc(isv);
     sv_2mortal(self);

     sv_bless(self, gv_stashsv(pkg, FALSE));

     for (item = 1; item < items; ++item) {
       SV* el = ST(item);
       SvGETMAGIC(el);
       ISET_INSERT(s, el);
     }

     IF_DEBUG(_warn("set!"));

     PUSHs(self);
     XSRETURN(1);
   }

void
insert(self, ...)
   SV* self;

   PPCODE:
      ISET* s = INT2PTR(ISET*, SvIV(SvRV(self)));
      I32 item;
      int inserted = 0;

      for (item = 1; item < items; ++item)
      {
        SV* el = ST(item);
	if ((SV*)s == el) {
	  _warn("INSERTING SET UP OWN ARSE");
	}
        SvGETMAGIC(el);
	if ISET_INSERT(s, el)
          inserted++;
	IF_DEBUG(_warn("inserting %p %p size = %d", el, SvRV(el), s->elems));
      }

      XSRETURN_IV(inserted);
  
void
remove(self, ...)
   SV* self;

   PPCODE:

      ISET* s = INT2PTR(ISET*, SvIV(SvRV(self)));
      I32 item;
      int removed = 0;

      for (item = 1; item < items; ++item)
      {
         SV* el = ST(item);
         SvGETMAGIC(el);
	 removed += iset_remove_one(s, el, 0);
      }
      XSRETURN_IV(removed);

int
is_null(self)
   SV* self;

   CODE:
   ISET* s = INT2PTR(ISET*, SvIV(SvRV(self)));
   if (s->elems)
     XSRETURN_UNDEF;
   if (s->flat) {
     if (HvKEYS(s->flat)) {
       XSRETURN_UNDEF;
     }
   }
   RETVAL = 1;

   OUTPUT: RETVAL

int
size(self)
   SV* self;

   CODE:
   ISET* s = INT2PTR(ISET*, SvIV(SvRV(self)));
   RETVAL = s->elems + (s->flat ? HvKEYS(s->flat) : 0);

   OUTPUT: RETVAL

int
rc(self)
   SV* self;

   CODE:
   RETVAL = SvREFCNT(self);

   OUTPUT: RETVAL

int
rvrc(self)
   SV* self;

   CODE:
   
   if (SvROK(self)) {
     RETVAL = SvREFCNT(SvRV(self));
   } else {
     XSRETURN_UNDEF;
   }

   OUTPUT: RETVAL

void
includes(self, ...)
   SV* self;

   PPCODE:

      ISET* s = INT2PTR(ISET*, SvIV(SvRV(self)));
      I32 hash, index, item;
      SV **el_iter, **el_last;
      BUCKET* bucket;

      for (item = 1; item < items; ++item)
      {
         SV* el = ST(item);
         SV* rv;

	 if (!SvOK(el))
	   XSRETURN_NO;

         SvGETMAGIC(el);
	 if (!SvROK(el)) {
	   IF_DEBUG(_warn("includes! el = %s", SvPV_nolen(el)));
	   if (!iset_includes_scalar(s, el))
	     XSRETURN_NO;
	   goto next;
	 }

	 rv = SvRV(el);

         if (!s->buckets)
            XSRETURN_NO;

         hash = ISET_HASH(rv);
         index = hash & (s->buckets - 1);
         bucket = s->bucket + index;

	 IF_DEBUG(_warn("includes: looking for %p in bucket %d:%p",
			rv, index, bucket));

         if (!bucket->sv)
            XSRETURN_NO;

         el_iter = bucket->sv;
         el_last = el_iter + bucket->n;

         for (; el_iter != el_last; ++el_iter)
            if (*el_iter == rv)
               goto next;
            
         XSRETURN_NO;

         next: ;
      }

      XSRETURN_YES;


void
members(self)
   SV* self
   
   PPCODE:

      ISET* s = INT2PTR(ISET*, SvIV(SvRV(self)));
      BUCKET* bucket_iter = s->bucket;
      BUCKET* bucket_last = bucket_iter + s->buckets;

      EXTEND(sp, s->elems + (s->flat ? HvKEYS(s->flat) : 0) );

      for (; bucket_iter != bucket_last; ++bucket_iter)
      {
         SV **el_iter, **el_last;

         if (!bucket_iter->sv)
            continue;

         el_iter = bucket_iter->sv;
         el_last = el_iter + bucket_iter->n;

         for (; el_iter != el_last; ++el_iter)
         {
            if (*el_iter) {
               SV* el = newRV(*el_iter);
               if (SvOBJECT(*el_iter)) {
                  sv_bless(el, SvSTASH(*el_iter));
               }
               PUSHs(sv_2mortal(el));
            }
         }
      }

      if (s->flat) {
        int i = 0, num = hv_iterinit(s->flat);

        while (i++ < num) {
	  HE* he = hv_iternext(s->flat);

	  PUSHs(HeSVKEY_force(he));
        }
      }

void
clear(self)
   SV* self

   CODE:
      ISET* s = INT2PTR(ISET*, SvIV(SvRV(self)));

      iset_clear(s);
      if (s->flat) {
	hv_clear(s->flat);
	IF_REMOVE_DEBUG(_warn("iset_clear(%p): cleared", s));
      }
      
void
DESTROY(self)
   SV* self

   CODE:
      ISET* s = INT2PTR(ISET*, SvIV(SvRV(self)));
      if ( s ) {
	sv_setiv(SvRV(self), 0);

Object.xs  view on Meta::CPAN

        Perl_croak(aTHX_ "Not a NV nor IV");
      }
      sv_2pv(MH, &lp);
      SvPOK_only(MH);

      if (sv_cmp(MH, sv) != 0) {
	XSRETURN_UNDEF;
      }
    }

    if (SvNOKp(sv)) {
      /* How annoying - it's a double */
      dutch = SvNV(sv);
      if (SvIOKp(sv)) {
	innit = SvIV(sv);
      } else {
	innit = (int)dutch;
      }
      if (dutch - innit < (0.000000001)) {
	RETVAL = innit;
      } else {
	XSRETURN_UNDEF;
      }
    } else if (SvIOKp(sv)) {
      RETVAL = SvIV(sv);
    }
  } else {
    XSRETURN_UNDEF;
  }
OUTPUT:
  RETVAL

int
is_overloaded(sv)
	SV *sv
PROTOTYPE: $
CODE:
  SvGETMAGIC(sv);
  if ( !SvAMAGIC(sv) )
     XSRETURN_UNDEF;
  RETVAL = 1;
OUTPUT:
  RETVAL

int
is_object(sv)
	SV *sv
PROTOTYPE: $
CODE:
  SvGETMAGIC(sv);
  if ( !SvOBJECT(sv) )
     XSRETURN_UNDEF;
  RETVAL = 1;
OUTPUT:
  RETVAL

void
_STORABLE_thaw(obj, cloning, serialized, ...)
   SV* obj;

   PPCODE:

   {
	   ISET* s;
	   I32 item;
	   SV* isv;
	
	   New(0, s, 1, ISET);
	   s->elems = 0;
	   s->bucket = 0;
	   s->buckets = 0;
	   s->flat = NULL;
	   s->is_weak = 0;

	   if (!SvROK(obj)) {
	     Perl_croak(aTHX_ "Set::Object::STORABLE_thaw passed a non-reference");
	   }

	   /* FIXME - some random segfaults with 5.6.1, Storable 2.07,
		      freezing closures, and back-references to
		      overloaded objects.  One day I might even
		      understand why :-)

		      Bug in Storable... that's why.  old news.
	    */
	   isv = SvRV(obj);
	   SvIV_set(isv, PTR2IV(s) );
	   SvIOK_on(isv);

	   for (item = 3; item < items; ++item)
	   {
              SV* el = ST(item);
              SvGETMAGIC(el);
              ISET_INSERT(s, el);
	   }

      IF_DEBUG(_warn("set!"));

      PUSHs(obj);
      XSRETURN(1);
   }

BOOT:
{
#ifdef USE_ITHREADS
  MY_CXT_INIT;
  MY_CXT.s  = NULL;
  MUTEX_INIT(&iset_mutex);
#endif
}

#ifdef USE_ITHREADS

void
CLONE(...)
PROTOTYPE: DISABLE
PREINIT:
  ISET *old_s;
PPCODE:
 {
  dMY_CXT;
  old_s = MY_CXT.s;
 }
 {
  MY_CXT_CLONE;
  MY_CXT.s = old_s;
 }
 XSRETURN(0);

#endif