mysterx patch from Filipe Cabecinhas to add gao/coclass (merge to 4.1.4)

svn: r13223

collects/mysterx/mysterx.ss

@@ -54,6 +54,8 @@
     cci/coclass
     cocreate-instance-from-progid
     cci/progid
+    com-get-active-object-from-coclass
+    gao/coclass
     coclass
     progid
     set-coclass!
@@ -111,6 +113,8 @@
   (define cci/coclass cocreate-instance-from-coclass)
   (define cocreate-instance-from-progid mxprims:cocreate-instance-from-progid)
   (define cci/progid cocreate-instance-from-progid)
+  (define com-get-active-object-from-coclass mxprims:com-get-active-object-from-coclass)
+  (define gao/coclass com-get-active-object-from-coclass)
   (define coclass mxprims:coclass)
   (define progid mxprims:progid)
   (define set-coclass! mxprims:set-coclass!)

collects/mysterx/private/mxmain.ss

@@ -39,6 +39,7 @@
    progid->html
    cocreate-instance-from-coclass
    cocreate-instance-from-progid
+   com-get-active-object-from-coclass
    coclass
    progid
    set-coclass!
@@ -324,6 +325,7 @@
   (define progid->html #f)
   (define cocreate-instance-from-coclass #f)
   (define cocreate-instance-from-progid #f)
+  (define com-get-active-object-from-coclass #f)
   (define coclass #f)
   (define progid #f)
   (define set-coclass! #f)

collects/mysterx/scribblings/methprop.scrbl

@@ -49,6 +49,19 @@
 Like @scheme[cocreate-instance-from-coclass], but using a ProgID.}
 
 
+@deftogether[(
+@defproc[(com-get-active-object-from-coclass [coclass string?]
+                                             [where (or/c (one-of/c 'local 'remote) string?) 'local])
+         com-object?]
+@defproc[(gao/coclass [coclass string?]
+                      [where (or/c (one-of/c 'local 'remote) string?) 'local])
+         com-object?]
+)]{
+
+  Like @scheme[cocreate-instance-from-coclass], but gets an existing
+  active object instead of creating a new one.}
+
+
 @defproc[(coclass [obj com-object?]) string?]{
 
   Returns a string that is the name of the COM class instantiated by

src/mysterx/mysterx.cxx

@@ -151,6 +151,7 @@ static MX_PRIM mxPrims[] = {
   { mx_com_release_object,"com-release-object",1,1 },
   { mx_com_add_ref,"com-add-ref",1,1 },
   { mx_com_ref_count,"com-ref-count",1,1 },
+  { mx_com_get_active_object_from_coclass,"com-get-active-object-from-coclass",1,1 },
 
   // browsers
 
@@ -901,6 +902,64 @@ Scheme_Object *mx_cocreate_instance_from_progid(int argc, Scheme_Object **argv)
                                location, machine);
 }
 
+Scheme_Object *do_get_active_object(CLSID clsId, LPCTSTR name)
+{
+  HRESULT hr;
+  IUnknown *pUnk;
+  IDispatch *pIDispatch;
+  MX_COM_Object *com_object;
+
+  hr = GetActiveObject(clsId, NULL, &pUnk);
+
+  if (hr != ERROR_SUCCESS) {
+    char errBuff[2048];
+    sprintf(errBuff,
+            "com-get-active-object-from-coclass: "
+            "Unable to get instance of %s",
+            name);
+    codedComError(errBuff, hr);
+  }
+
+  hr = pUnk->QueryInterface(IID_IDispatch, (void **)&pIDispatch);
+
+  if (hr != ERROR_SUCCESS) {
+    char errBuff[2048];
+    sprintf(errBuff,
+            "com-get-active-object-from-coclass: "
+            "Unable to get instance of %s",
+            name);
+    codedComError(errBuff, hr);
+  }
+
+  com_object = (MX_COM_Object *)scheme_malloc_tagged(sizeof(MX_COM_Object));
+
+  com_object->so.type = mx_com_object_type;
+  com_object->pIDispatch = pIDispatch;
+  com_object->pITypeInfo = NULL;
+  com_object->clsId = clsId;
+  com_object->pEventTypeInfo = NULL;
+  com_object->pIConnectionPoint = NULL;
+  com_object->pISink = NULL;
+  com_object->connectionCookie = (DWORD)0;
+  com_object->released = FALSE;
+  com_object->types = NULL;
+
+  mx_register_com_object((Scheme_Object *)com_object, pIDispatch);
+
+  return (Scheme_Object *)com_object;
+}
+
+Scheme_Object *mx_com_get_active_object_from_coclass(int argc, Scheme_Object **argv)
+{
+  LPCTSTR coclass;
+
+  GUARANTEE_STRSYM("com-get-active-object-from-coclass", 0);
+
+  coclass = schemeToText(argv[0]);
+
+  return do_get_active_object(getCLSIDFromCoClass(coclass), coclass);
+}
+
 Scheme_Object *mx_set_coclass(int argc, Scheme_Object **argv)
 {
   CLSID clsId;
@@ -4211,7 +4270,8 @@ END_XFORM_SKIP;
   retval = retvalVariantToSchemeObject(&retvalVa);
 
   // all pointers are 32 bits, choose arbitrary one
-  if (retvalVa.vt != VT_VOID)
+  if (retvalVa.vt != VT_VOID &&
+      retvalVa.vt != VT_HRESULT)
     free(retvalVa.pullVal);
 
   return retval;

src/mysterx/mysterx.h

@@ -343,6 +343,7 @@ MX_PRIM_DECL(mx_com_set_property_type);
 MX_PRIM_DECL(mx_com_event_type);
 MX_PRIM_DECL(mx_cocreate_instance_from_coclass);
 MX_PRIM_DECL(mx_cocreate_instance_from_progid);
+MX_PRIM_DECL(mx_com_get_active_object_from_coclass);
 MX_PRIM_DECL(mx_coclass);
 MX_PRIM_DECL(mx_progid);
 MX_PRIM_DECL(mx_set_coclass);