remove CLONE_SKIP frmo Event and Surface, but associates the object w…

…ith the interpreter which owns it so it only gets destroyed once... seems to work, but needs more testing...
asb-capfan · Jan 12, 2010 · 2be22ba · 2be22ba
1 parent a4394c0
commit 2be22ba
Show file tree

Hide file tree

Showing 5 changed files with 50 additions and 26 deletions.
diff --git a/lib/SDL/Event.pm b/lib/SDL/Event.pm
@@ -5,5 +5,5 @@ require Exporter;
 require DynaLoader;
 our @ISA = qw(Exporter DynaLoader);
 bootstrap SDL::Event;
-sub CLONE_SKIP { 1 };
+#sub CLONE_SKIP { 1 };
 1;
diff --git a/lib/SDL/Surface.pm b/lib/SDL/Surface.pm
@@ -5,5 +5,5 @@ require Exporter;
 require DynaLoader;
 our @ISA = qw(Exporter DynaLoader);
 bootstrap SDL::Surface;
-sub CLONE_SKIP { 1 };
+#sub CLONE_SKIP { 1 };
 1;
diff --git a/src/Core/objects/Event.xs b/src/Core/objects/Event.xs
@@ -963,17 +963,26 @@ event_syswm_msg ( event, ... )
 		RETVAL
 
 void
-event_DESTROY(self)
-	SDL_Event *self
+event_DESTROY(bag)
+	SV* bag
 	CODE:
-		if(self->type == SDL_USEREVENT)
-		{
-		if( (self->user).data1 != NULL )
-		  SvREFCNT_dec( (self->user).data1);
-		if( (self->user).data2 != NULL )
-		  SvREFCNT_dec( (self->user).data2);
-		}
-		safefree(self);
-
-
+               if( sv_isobject(bag) && (SvTYPE(SvRV(bag)) == SVt_PVMG) ) {
+                   void** pointers = (void**)(SvIV((SV*)SvRV( bag ))); 
+                   SDL_Event* self = (SDL_Event*)(pointers[0]);
+                   if (my_perl == pointers[1]) {
+                       //warn("Freed surface %p and pixels %p \n", surface, surface->pixels);
+                       if(self->type == SDL_USEREVENT) {
+                           if( (self->user).data1 != NULL )
+                              SvREFCNT_dec( (self->user).data1);
+                           if( (self->user).data2 != NULL )
+                              SvREFCNT_dec( (self->user).data2);
+                       }
+                       safefree(self);
+                       free(pointers);
+                   }
+               } else if (bag == 0) {
+                   XSRETURN(0);
+               } else {
+                   XSRETURN_UNDEF;
+               }
 
diff --git a/src/Core/objects/Surface.xs b/src/Core/objects/Surface.xs
@@ -144,9 +144,20 @@ surface_set_pixels(surface, index, value)
 	((unsigned int*)surface->pixels)[index] = value;
 
 void
-surface_DESTROY(surface)
-	SDL_Surface *surface
+surface_DESTROY(bag)
+	SV* bag
 	CODE:
-		//warn("Freed surface %p and pixels %p \n", surface, surface->pixels);
-		SDL_FreeSurface(surface);
+               if( sv_isobject(bag) && (SvTYPE(SvRV(bag)) == SVt_PVMG) ) {
+                   void** pointers = (void**)(SvIV((SV*)SvRV( bag ))); 
+                   SDL_Surface* surface = (SDL_Surface*)(pointers[0]);
+                   if (my_perl == pointers[1]) {
+                       //warn("Freed surface %p and pixels %p \n", surface, surface->pixels);
+                       SDL_FreeSurface(surface);
+                       free(pointers);
+                   }
+               } else if (bag == 0) {
+                   XSRETURN(0);
+               } else {
+                   XSRETURN_UNDEF;
+               }
 
diff --git a/typemap b/typemap
@@ -102,18 +102,22 @@ OUTPUT
 # The Perl object is blessed into 'CLASS', which should be a
 # char* having the name of the package for the blessing.
 O_OBJECT
-	sv_setref_pv( $arg, CLASS, (void*)$var );
+        void** pointers = malloc(2 * sizeof(void*));
+        pointers[0] = (void*)$var;
+        pointers[1] = (void*)my_perl;
+	sv_setref_pv( $arg, CLASS, (void*)pointers );
 
 
 INPUT
 
 O_OBJECT
-	if( sv_isobject($arg) && (SvTYPE(SvRV($arg)) == SVt_PVMG) )
-		{ $var = ($type)SvIV((SV*)SvRV( $arg )); }
-	else if ($arg == 0)
-	{ XSRETURN(0); }
-	else{
-		XSRETURN_UNDEF;
-	}
+	if( sv_isobject($arg) && (SvTYPE(SvRV($arg)) == SVt_PVMG) ) {
+           void** pointers = (void**)(SvIV((SV*)SvRV( $arg ))); 
+           $var = ($type)(pointers[0]);
+        } else if ($arg == 0) {
+           XSRETURN(0);
+        } else {
+           XSRETURN_UNDEF;
+        }