GNOME.org
 

orbit-perl patch

I enclose an accumulated patch to
orbit-perl, against the latest CVS version
as of 9th January 2002.

This works well with ORBit 0.5.13.

Here's the fix list:

* implemented support for null and void Anys (myself)

* fixed serious refcount problem with inout args in server.c
  which resulted in freeing of previously freed memory and
  thus memory corruption

* fixed handling of inout args in client.c (related to above) (myself)

* fixed typecode memory leak in demarshal.c (myself)

* added _narrow() in ORBit.xs, as originally
  suggested by Alex Hornby in
  http://mail.gnome.org/archives/orbit-list/2001-April/msg00067.html
  (his original patch isn't quite right for the current version)

* corrected spelling of error messages
  in ORBit.xs ("privided" -> "provided") (myself)

* corrected spelling of create_reference_object_with_id()
  to create_reference_with_id(), as originally
  suggested by Mark McLoughlin in
 
http://mail.gnome.org/archives/orbit-perl-list/2001-April/msg00000.html

* fixed invalid pointer arithmetic on void * types
  and other non-gcc compilation issues (myself)

* added parameter checking to XS(_porbit_repoid) as
  originally suggested by someone on some mailing list
  but I can't find the post

There are various other places where arguments to XS
stubs are not checked and core dumps can be created
by passing in incorrect arguments from perl; I might
come up with some additional patches for those issues
later on. For now, this fixes some major problems
with inout parameters, Any support, and compilation
in non-gcc environments.

	-Huw Rogers
Index: ORBit.pm
===================================================================
RCS file: /cvs/gnome/orbit-perl/ORBit.pm,v
retrieving revision 1.7
diff -c -r1.7 ORBit.pm
*** ORBit.pm	2000/12/14 17:27:23	1.7
--- ORBit.pm	2002/01/08 19:19:08
***************
*** 89,101 ****
  
  package CORBA::Any;
  
  sub new {
      my ($pkg, $tc, $val) = @_;
  
-     if (ref($tc) ne 'CORBA::TypeCode') {
- 	Carp::croak ('First argument to CORBA::Any::new must be a CORBA::TypeCode');
-     }
-     
      return bless [ $tc, $val ];
  }
  
--- 89,104 ----
  
  package CORBA::Any;
  
+ $CORBA::Any::TC_null = CORBA::TypeCode->new('IDL:CORBA/Null:1.0');
+ 
  sub new {
      my ($pkg, $tc, $val) = @_;
+ 
+     $tc = $CORBA::Any::TC_null unless (defined($tc));
+     Carp::croak (
+ 	'First argument to CORBA::Any::new must be a CORBA::TypeCode')
+ 	    if (ref($tc) ne 'CORBA::TypeCode');
  
      return bless [ $tc, $val ];
  }
  
Index: ORBit.xs
===================================================================
RCS file: /cvs/gnome/orbit-perl/ORBit.xs,v
retrieving revision 1.11
diff -c -r1.11 ORBit.xs
*** ORBit.xs	2001/02/08 05:43:33	1.11
--- ORBit.xs	2002/01/08 19:19:09
***************
*** 361,366 ****
--- 361,376 ----
      RETVAL
  
  void
+ _narrow (self, repoid)
+     CORBA::Object self;
+     char * repoid;
+     CODE:
+     {
+         g_free(self->object_id);
+         self->object_id = g_strdup(repoid);
+     }
+ 
+ void
  DESTROY (self)
      CORBA::Object self
      CODE:
***************
*** 645,656 ****
  	
  	if (fd < 0) {
  	    av_undef (args);
! 	    croak ("CORBA::ORBit::io_watch: a non-negative fd must be privided");
  	}
  
  	if (condition == 0) {
  	    av_undef (args);
! 	    croak ("CORBA::ORBit::io_watch: a non-negative fd must be privided");
  	}
  
  	RETVAL = porbit_source_new ();
--- 655,666 ----
  	
  	if (fd < 0) {
  	    av_undef (args);
! 	    croak ("CORBA::ORBit::io_watch: a non-negative fd must be provided");
  	}
  
  	if (condition == 0) {
  	    av_undef (args);
! 	    croak ("CORBA::ORBit::io_watch: a non-negative fd must be provided");
  	}
  
  	RETVAL = porbit_source_new ();
***************
*** 972,978 ****
      RETVAL = porbit_find_typecode (id);
      if (!RETVAL)
          croak ("Cannot find typecode for '%s'", id);
-     RETVAL = (CORBA_TypeCode)CORBA_Object_duplicate ((CORBA_Object)RETVAL, NULL);
      OUTPUT:
      RETVAL
      
--- 982,987 ----
***************
*** 1216,1222 ****
      RETVAL
  
  CORBA::Object
! create_reference_object_with_id (self, perl_id, intf)
      PortableServer::POA self
      SV *perl_id
      char *intf
--- 1225,1231 ----
      RETVAL
  
  CORBA::Object
! create_reference_with_id (self, perl_id, intf)
      PortableServer::POA self
      SV *perl_id
      char *intf
Index: client.c
===================================================================
RCS file: /cvs/gnome/orbit-perl/client.c,v
retrieving revision 1.3
diff -c -r1.3 client.c
*** client.c	2001/02/05 05:32:30	1.3
--- client.c	2002/01/08 19:19:09
***************
*** 356,360 ****
  	}
      }
  
!     XSRETURN(return_count);
  }
--- 356,367 ----
  	}
      }
  
!     switch (GIMME_V) {
!     case G_ARRAY:
!       XSRETURN(return_count);
!     case G_SCALAR:
!       XSRETURN(1);
!     case G_VOID:
!       XSRETURN_EMPTY;
!     }
  }
Index: demarshal.c
===================================================================
RCS file: /cvs/gnome/orbit-perl/demarshal.c,v
retrieving revision 1.8
diff -c -r1.8 demarshal.c
*** demarshal.c	2001/02/09 03:11:37	1.8
--- demarshal.c	2002/01/08 19:19:09
***************
*** 305,311 ****
      }
  
      repoid = (char *)buf->cur;
!     buf->cur += str_len;
  
      if (type == CORBA_USER_EXCEPTION) {
  	CORBA_unsigned_long i;
--- 305,311 ----
      }
  
      repoid = (char *)buf->cur;
!     buf->cur = (guchar *)buf->cur + str_len;
  
      if (type == CORBA_USER_EXCEPTION) {
  	CORBA_unsigned_long i;
***************
*** 416,422 ****
      HV *stash;
      
      ORBit_decode_CORBA_TypeCode(&res_tc, buf);
-     CORBA_Object_duplicate((CORBA_Object)res_tc, NULL);
  
      av = newAV();
  
--- 416,421 ----
***************
*** 474,480 ****
      strbuf = SvPVX(res);
  
      memcpy (strbuf, buf->cur, len);
!     buf->cur += len;
  
      /* This should already be a NULL according to the spec
       * but we'll play it safe here.
--- 473,479 ----
      strbuf = SvPVX(res);
  
      memcpy (strbuf, buf->cur, len);
!     buf->cur = (guchar *)buf->cur + len;
  
      /* This should already be a NULL according to the spec
       * but we'll play it safe here.
***************
*** 507,513 ****
  
      index = 1;
      for (i = 0; i < wire_length; i++) {
!         CORBA_octet c = *(char *)(buf->cur++);
  
  	if (!(i == 0 && offset))
  	    SvPVX(digits_sv)[index++] = '0' + ((c & 0xf0) >> 4);
--- 506,512 ----
  
      index = 1;
      for (i = 0; i < wire_length; i++) {
!         CORBA_octet c = *(char *)(buf->cur = (guchar *)buf->cur + 1);
  
  	if (!(i == 0 && offset))
  	    SvPVX(digits_sv)[index++] = '0' + ((c & 0xf0) >> 4);
Index: interfaces.c
===================================================================
RCS file: /cvs/gnome/orbit-perl/interfaces.c,v
retrieving revision 1.6
diff -c -r1.6 interfaces.c
*** interfaces.c	2001/02/08 05:43:33	1.6
--- interfaces.c	2002/01/08 19:19:09
***************
*** 120,125 ****
--- 120,126 ----
  
  XS(_porbit_repoid) {
      dXSARGS;
+     if (items != 1) croak("Usage: _repoid(self)");
  
      ST(0) = (SV *)CvXSUBANY(cv).any_ptr;
  
***************
*** 404,409 ****
--- 405,411 ----
  	load_container (contained, retval, ev);
  	break;
      default:
+       break;
      }
  
   error:
***************
*** 517,522 ****
--- 519,528 ----
  void
  porbit_init_typecodes  (void)
  {
+     porbit_store_typecode ("IDL:CORBA/Null:1.0",
+ 			   duplicate_typecode(TC_null));
+     porbit_store_typecode ("IDL:CORBA/Void:1.0",
+ 			   duplicate_typecode(TC_void));
      porbit_store_typecode ("IDL:CORBA/Short:1.0", 
  			   duplicate_typecode(TC_CORBA_short));
      porbit_store_typecode ("IDL:CORBA/Long:1.0", 
Index: marshal.c
===================================================================
RCS file: /cvs/gnome/orbit-perl/marshal.c,v
retrieving revision 1.4
diff -c -r1.4 marshal.c
*** marshal.c	2001/02/05 01:58:39	1.4
--- marshal.c	2002/01/08 19:19:09
***************
*** 303,309 ****
  static const char *status_subnames[] = { "COMPLETED_YES", "COMPLETED_NO", "COMPLETED_MAYBE" };
  
  static struct CORBA_TypeCode_struct status_typecode = {
!    {}, CORBA_tk_enum, NULL, NULL, 0, 3, status_subnames
  };
  
  static const char *sysex_subnames[] = { "-minor", "-status" };
--- 303,309 ----
  static const char *status_subnames[] = { "COMPLETED_YES", "COMPLETED_NO", "COMPLETED_MAYBE" };
  
  static struct CORBA_TypeCode_struct status_typecode = {
!    { 0 }, CORBA_tk_enum, NULL, NULL, 0, 3, status_subnames
  };
  
  static const char *sysex_subnames[] = { "-minor", "-status" };
***************
*** 311,317 ****
  static CORBA_TypeCode sysex_subtypes[] = { (CORBA_TypeCode)TC_CORBA_ulong, &status_typecode };
  
  static struct CORBA_TypeCode_struct sysex_typecode = {
!     {}, CORBA_tk_except, NULL, NULL, 0, 2, sysex_subnames, sysex_subtypes
  };
  
  SV *
--- 311,317 ----
  static CORBA_TypeCode sysex_subtypes[] = { (CORBA_TypeCode)TC_CORBA_ulong, &status_typecode };
  
  static struct CORBA_TypeCode_struct sysex_typecode = {
!     { 0 }, CORBA_tk_except, NULL, NULL, 0, 2, sysex_subnames, sysex_subtypes
  };
  
  SV *
Index: server.c
===================================================================
RCS file: /cvs/gnome/orbit-perl/server.c,v
retrieving revision 1.6
diff -c -r1.6 server.c
*** server.c	2001/02/05 05:32:31	1.6
--- server.c	2002/01/08 19:19:10
***************
*** 380,388 ****
  		    inout_args = newAV();
  	    
  		av_push(inout_args,arg);
! 		XPUSHs(sv_2mortal(newRV_noinc(arg)));
! 
! 		return_items++;
  	    } else {
  		XPUSHs(sv_2mortal(arg));
  	    }
--- 380,386 ----
  		    inout_args = newAV();
  	    
  		av_push(inout_args,arg);
! 		XPUSHs(sv_2mortal(newRV_inc(arg)));
  	    } else {
  		XPUSHs(sv_2mortal(arg));
  	    }
[Date Prev][Date Next]   [Thread Prev][Thread Next]   [Thread Index] [Date Index] [Author Index]