// mysterx.cxx : COM/ActiveX/DHTML extension for PLT Scheme // Author: Paul Steckler #include "stdafx.h" #include #include #include #include #include #include #define _WIN32_DCOM #include #include #include #include #include #include #include #include "resource.h" #include "escheme.h" #include "schvers.h" #include "bstr.h" // ATL support #include extern CComModule _Module; #include #include CComModule _Module; // end ATL support #include "myspage.h" #include "myspage_i.c" #include "myssink.h" #include "myssink_i.c" #include "mysterx.h" static WNDPROC AtlWndProc; HINSTANCE hInstance; HICON hIcon; HANDLE browserHwndMutex; HANDLE createHwndSem; HANDLE eventSinkMutex; const CLSID emptyClsId; static Scheme_Object *mx_omit_obj; /* omitted argument placeholder */ /* Normally false, but when true, mysterx will marshal any scheme */ /* object it would otherwise fail to marshal by simply sticking */ /* the 32-bit value in an UNSIGNED I4 variant and hoping for the */ /* best. Obviously this has GC implications, so don't use it. */ /* jrm uses it for dotnet. */ Scheme_Object * mx_marshal_raw_scheme_objects; Scheme_Object *scheme_date_type; static MX_TYPE_TBL_ENTRY *typeTable[TYPE_TBL_SIZE]; MYSSINK_TABLE myssink_table; static char *objectAttributes[] = { "InprocServer", "InprocServer32", "LocalServer", "LocalServer32", NULL }; static char *controlAttributes[] = { "Control", NULL }; static MX_PRIM mxPrims[] = { // version { mx_version,"mx-version",0,0}, // COM reflection { mx_com_invoke,"com-invoke",2,-1}, { mx_com_set_property,"com-set-property!",2,-1 }, { mx_com_get_property,"com-get-property",2, -1 }, { mx_com_methods,"com-methods",1,1 }, { mx_com_get_properties,"com-get-properties",1,1 }, { mx_com_set_properties,"com-set-properties", 1, 1 }, { mx_com_events,"com-events",1,1 }, { mx_com_method_type,"com-method-type",2,2 }, { mx_com_get_property_type,"com-get-property-type",2,2 }, { mx_com_set_property_type,"com-set-property-type",2,2 }, { mx_com_event_type,"com-event-type",2,2 }, { mx_com_help,"com-help",1,2 }, // COM types { mx_com_get_object_type,"com-object-type",1,1 }, { mx_com_is_a,"com-is-a?",2,2 }, { mx_cy_pred_ex,"com-currency?",1,1 }, { mx_date_pred_ex,"com-date?",1,1 }, { mx_date_to_scheme_date,"com-date->date",1,1 }, { scheme_date_to_mx_date,"date->com-date",1,1 }, { mx_scode_pred_ex,"com-scode?",1,1 }, { mx_scode_to_scheme_number,"com-scode->number",1,1 }, { scheme_number_to_mx_scode,"number->com-scode",1,1 }, { mx_currency_to_scheme_number,"com-currency->number",1,1 }, { scheme_number_to_mx_currency,"number->com-currency",1,1 }, { mx_comobj_pred_ex,"com-object?",1,1 }, { mx_iunknown_pred_ex,"com-iunknown?",1,1 }, // COM events { mx_com_register_event_handler,"com-register-event-handler",3,3 }, { mx_com_unregister_event_handler,"com-unregister-event-handler",2,2 }, // coclasses { mx_all_coclasses,"com-all-coclasses",0,0 }, { mx_all_controls,"com-all-controls",0,0 }, { mx_coclass_to_html,"coclass->html",3,4 }, { mx_progid_to_html,"progid->html",3,4 }, // COM objects { mx_cocreate_instance_from_coclass,"cocreate-instance-from-coclass",1,2 }, { mx_cocreate_instance_from_progid,"cocreate-instance-from-progid",1,2 }, { mx_coclass,"coclass",1,1 }, { mx_progid,"progid",1,1 }, { mx_set_coclass,"set-coclass!",2,2 }, { mx_set_coclass_from_progid,"set-coclass-from-progid!",2,2 }, { mx_com_object_eq,"com-object-eq?",2,2 }, { mx_com_register_object,"com-register-object",1,1 }, { 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 }, // browsers { mx_make_browser,"make-browser",6,6}, { mx_block_while_browsers,"block-while-browsers",0,0}, { mx_browser_show,"browser-show",2,2}, { mx_navigate,"navigate",2,2 }, { mx_go_back,"go-back",1,1 }, { mx_go_forward,"go-forward",1,1 }, { mx_refresh,"refresh",1,1 }, { mx_iconize,"iconize",1,1 }, { mx_restore,"restore",1,1 }, { mx_current_url,"current-url",1,1 }, { mx_register_navigate_handler,"register-navigate-handler",2,2 }, { mx_current_document,"current-document",1,1 }, { mx_print,"print-document",1,1 }, // documents { mx_document_pred,"document?",1,1 }, { mx_document_title,"document-title",1,1 }, { mx_insert_html,"document-insert-html",2,2 }, { mx_append_html,"document-append-html",2,2 }, { mx_replace_html,"document-replace-html",2,2 }, { mx_find_element,"document-find-element",3,4 }, { mx_find_element_by_id_or_name,"document-find-element-by-id-or-name",2,3 }, { mx_elements_with_tag,"document-elements-with-tag",2,2 }, { mx_document_objects,"document-objects",1,1 }, // elements { mx_element_insert_html,"element-insert-html",2,2 }, { mx_element_append_html,"element-append-html",2,2 }, { mx_element_insert_text,"element-insert-text",2,2 }, { mx_element_append_text,"element-append-text",2,2 }, { mx_element_replace_html,"element-replace-html",2,2 }, { mx_element_get_html,"element-get-html",1,1 }, { mx_element_get_text,"element-get-text",1,1 }, { mx_element_focus,"element-focus",1,1 }, { mx_element_selection,"element-selection",1,1 }, { mx_element_set_selection,"element-set-selection!",2,2 }, { mx_element_attribute,"element-attribute",2,2 }, { mx_element_set_attribute,"element-set-attribute!",3,3 }, { mx_element_click,"element-click",1,1 }, { mx_element_tag,"element-tag",1,1 }, { mx_element_font_family,"element-font-family",1,1 }, { mx_element_set_font_family,"element-set-font-family!",2,2 }, { mx_element_font_style,"element-font-style",1,1 }, { mx_element_set_font_style,"element-set-font-style!",2,2 }, { mx_element_font_variant,"element-font-variant",1,1 }, { mx_element_set_font_variant,"element-set-font-variant!",2,2 }, { mx_element_font_weight,"element-font-weight",1,1 }, { mx_element_set_font_weight,"element-set-font-weight!",2,2 }, { mx_element_font,"element-font",1,1 }, { mx_element_set_font,"element-set-font!",2,2 }, { mx_element_background,"element-background",1,1 }, { mx_element_set_background,"element-set-background!",2,2 }, { mx_element_background_attachment,"element-background-attachment",1,1 }, { mx_element_set_background_attachment,"element-set-background-attachment!",2,2 }, { mx_element_background_image,"element-background-image",1,1 }, { mx_element_set_background_image,"element-set-background-image!",2,2 }, { mx_element_background_repeat,"element-background-repeat",1,1 }, { mx_element_set_background_repeat,"element-set-background-repeat!",2,2 }, { mx_element_background_position,"element-background-position",1,1 }, { mx_element_set_background_position,"element-set-background-position!",2,2 }, { mx_element_text_decoration,"element-text-decoration",1,1 }, { mx_element_set_text_decoration,"element-set-text-decoration!",2,2 }, { mx_element_text_transform,"element-text-transform",1,1 }, { mx_element_set_text_transform,"element-set-text-transform!",2,2 }, { mx_element_text_align,"element-text-align",1,1 }, { mx_element_set_text_align,"element-set-text-align!",2,2 }, { mx_element_margin,"element-margin",1,1 }, { mx_element_set_margin,"element-set-margin!",2,2 }, { mx_element_padding,"element-padding",1,1 }, { mx_element_set_padding,"element-set-padding!",2,2 }, { mx_element_border,"element-border",1,1 }, { mx_element_set_border,"element-set-border!",2,2 }, { mx_element_border_top,"element-border-top",1,1 }, { mx_element_set_border_top,"element-set-border-top!",2,2 }, { mx_element_border_bottom,"element-border-bottom",1,1 }, { mx_element_set_border_bottom,"element-set-border-bottom!",2,2 }, { mx_element_border_left,"element-border-left",1,1 }, { mx_element_set_border_left,"element-set-border-left!",2,2 }, { mx_element_border_right,"element-border-right",1,1 }, { mx_element_set_border_right,"element-set-border-right!",2,2 }, { mx_element_border_color,"element-border-color",1,1 }, { mx_element_set_border_color,"element-set-border-color!",2,2 }, { mx_element_border_width,"element-border-width",1,1 }, { mx_element_set_border_width,"element-set-border-width!",2,2 }, { mx_element_border_style,"element-border-style",1,1 }, { mx_element_set_border_style,"element-set-border-style!",2,2 }, { mx_element_border_top_style,"element-border-top-style",1,1 }, { mx_element_set_border_top_style,"element-set-border-top-style!",2,2 }, { mx_element_border_bottom_style,"element-border-bottom-style",1,1 }, { mx_element_set_border_bottom_style,"element-set-border-bottom-style!",2,2 }, { mx_element_border_left_style,"element-border-left-style",1,1 }, { mx_element_set_border_left_style,"element-set-border-left-style!",2,2 }, { mx_element_border_right_style,"element-border-right-style",1,1 }, { mx_element_set_border_right_style,"element-set-border-right-style!",2,2 }, { mx_element_style_float,"element-style-float",1,1 }, { mx_element_set_style_float,"element-set-style-float!",2,2 }, { mx_element_clear,"element-clear",1,1 }, { mx_element_set_clear,"element-set-clear!",2,2 }, { mx_element_display,"element-display",1,1 }, { mx_element_set_display,"element-set-display!",2,2 }, { mx_element_visibility,"element-visibility",1,1 }, { mx_element_set_visibility,"element-set-visibility!",2,2 }, { mx_element_list_style_type,"element-list-style-type",1,1 }, { mx_element_set_list_style_type,"element-set-list-style-type!",2,2 }, { mx_element_list_style_position,"element-list-style-position",1,1 }, { mx_element_set_list_style_position,"element-set-list-style-position!",2,2 }, { mx_element_list_style_image,"element-list-style-image",1,1 }, { mx_element_set_list_style_image,"element-set-list-style-image!",2,2 }, { mx_element_list_style,"element-list-style",1,1 }, { mx_element_set_list_style,"element-set-list-style!",2,2 }, { mx_element_position,"element-position",1,1 }, { mx_element_overflow,"element-overflow",1,1 }, { mx_element_set_overflow,"element-set-overflow!",2,2 }, { mx_element_pagebreak_before,"element-pagebreak-before",1,1 }, { mx_element_set_pagebreak_before,"element-set-pagebreak-before!",2,2 }, { mx_element_pagebreak_after,"element-pagebreak-after",1,1 }, { mx_element_set_pagebreak_after,"element-set-pagebreak-after!",2,2 }, { mx_element_css_text,"element-css-text",1,1 }, { mx_element_set_css_text,"element-set-css-text!",2,2 }, { mx_element_cursor,"element-cursor",1,1 }, { mx_element_set_cursor,"element-set-cursor!",2,2 }, { mx_element_clip,"element-clip",1,1 }, { mx_element_set_clip,"element-set-clip!",2,2 }, { mx_element_filter,"element-filter",1,1 }, { mx_element_set_filter,"element-set-filter!",2,2 }, { mx_element_style_string,"element-style-string",1,1 }, { mx_element_text_decoration_none,"element-text-decoration-none",1,1 }, { mx_element_set_text_decoration_none,"element-set-text-decoration-none!",2,2 }, { mx_element_text_decoration_underline,"element-text-decoration-underline",1,1 }, { mx_element_set_text_decoration_underline,"element-set-text-decoration-underline!",2,2 }, { mx_element_text_decoration_overline,"element-text-decoration-overline",1,1 }, { mx_element_set_text_decoration_overline,"element-set-text-decoration-overline!",2,2 }, { mx_element_text_decoration_linethrough,"element-text-decoration-linethrough",1,1 }, { mx_element_set_text_decoration_linethrough,"element-set-text-decoration-linethrough!",2,2 }, { mx_element_text_decoration_blink,"element-text-decoration-blink",1,1 }, { mx_element_set_text_decoration_blink,"element-set-text-decoration-blink!",2,2 }, { mx_element_pixel_top,"element-pixel-top",1,1 }, { mx_element_set_pixel_top,"element-set-pixel-top!",2,2 }, { mx_element_pixel_left,"element-pixel-left",1,1 }, { mx_element_set_pixel_left,"element-set-pixel-left!",2,2 }, { mx_element_pixel_width,"element-pixel-width",1,1 }, { mx_element_set_pixel_width,"element-set-pixel-width!",2,2 }, { mx_element_pixel_height,"element-pixel-height",1,1 }, { mx_element_set_pixel_height,"element-set-pixel-height!",2,2 }, { mx_element_pos_top,"element-pos-top",1,1 }, { mx_element_set_pos_top,"element-set-pos-top!",2,2 }, { mx_element_pos_left,"element-pos-left",1,1 }, { mx_element_set_pos_left,"element-set-pos-left!",2,2 }, { mx_element_pos_width,"element-pos-width",1,1 }, { mx_element_set_pos_width,"element-set-pos-width!",2,2 }, { mx_element_pos_height,"element-pos-height",1,1 }, { mx_element_set_pos_height,"element-set-pos-height!",2,2 }, { mx_element_font_size,"element-font-size",1,1 }, { mx_element_set_font_size,"element-set-font-size!",2,2 }, { mx_element_color,"element-color",1,1 }, { mx_element_set_color,"element-set-color!",2,2 }, { mx_element_background_color,"element-background-color",1,1 }, { mx_element_set_background_color,"element-set-background-color!",2,2 }, { mx_element_background_position_x,"element-background-position-x",1,1 }, { mx_element_set_background_position_x,"element-set-background-position-x!",2,2 }, { mx_element_background_position_y,"element-background-position-y",1,1 }, { mx_element_set_background_position_y,"element-set-background-position-y!",2,2 }, { mx_element_letter_spacing,"element-letter-spacing",1,1 }, { mx_element_set_letter_spacing,"element-set-letter-spacing!",2,2 }, { mx_element_vertical_align,"element-vertical-align",1,1 }, { mx_element_set_vertical_align,"element-set-vertical-align!",2,2 }, { mx_element_text_indent,"element-text-indent",1,1 }, { mx_element_set_text_indent,"element-set-text-indent!",2,2 }, { mx_element_line_height,"element-line-height",1,1 }, { mx_element_set_line_height,"element-set-line-height!",2,2 }, { mx_element_margin_top,"element-margin-top",1,1 }, { mx_element_set_margin_top,"element-set-margin-top!",2,2 }, { mx_element_margin_bottom,"element-margin-bottom",1,1 }, { mx_element_set_margin_bottom,"element-set-margin-bottom!",2,2 }, { mx_element_margin_left,"element-margin-left",1,1 }, { mx_element_set_margin_left,"element-set-margin-left!",2,2 }, { mx_element_margin_right,"element-margin-right",1,1 }, { mx_element_set_margin_right,"element-set-margin-right!",2,2 }, { mx_element_padding_top,"element-padding-top",1,1 }, { mx_element_set_padding_top,"element-set-padding-top!",2,2 }, { mx_element_padding_bottom,"element-padding-bottom",1,1 }, { mx_element_set_padding_bottom,"element-set-padding-bottom!",2,2 }, { mx_element_padding_left,"element-padding-left",1,1 }, { mx_element_set_padding_left,"element-set-padding-left!",2,2 }, { mx_element_padding_right,"element-padding-right",1,1 }, { mx_element_set_padding_right,"element-set-padding-right!",2,2 }, { mx_element_border_top_color,"element-border-top-color",1,1 }, { mx_element_set_border_top_color,"element-set-border-top-color!",2,2 }, { mx_element_border_bottom_color,"element-border-bottom-color",1,1 }, { mx_element_set_border_bottom_color,"element-set-border-bottom-color!",2,2 }, { mx_element_border_left_color,"element-border-left-color",1,1 }, { mx_element_set_border_left_color,"element-set-border-left-color!",2,2 }, { mx_element_border_right_color,"element-border-right-color",1,1 }, { mx_element_set_border_right_color,"element-set-border-right-color!",2,2 }, { mx_element_border_top_width,"element-border-top-width",1,1 }, { mx_element_set_border_top_width,"element-set-border-top-width!",2,2 }, { mx_element_border_bottom_width,"element-border-bottom-width",1,1 }, { mx_element_set_border_bottom_width,"element-set-border-bottom-width!",2,2 }, { mx_element_border_left_width,"element-border-left-width",1,1 }, { mx_element_set_border_left_width,"element-set-border-left-width!",2,2 }, { mx_element_border_right_width,"element-border-right-width",1,1 }, { mx_element_set_border_right_width,"element-set-border-right-width!",2,2 }, { mx_element_width,"element-width",1,1 }, { mx_element_set_width,"element-set-width!",2,2 }, { mx_element_height,"element-height",1,1 }, { mx_element_set_height,"element-set-height!",2,2 }, { mx_element_top,"element-top",1,1 }, { mx_element_set_top,"element-set-top!",2,2 }, { mx_element_left,"element-left",1,1 }, { mx_element_set_left,"element-set-left!",2,2 }, { mx_element_z_index,"element-z-index",1,1 }, { mx_element_set_z_index,"element-set-z-index!",2,2 }, // events { mx_event_pred,"event?",1,1 }, { mx_get_event,"get-event",1,1 }, { mx_event_tag,"event-tag",1,1}, { mx_event_id,"event-id",1,1}, { mx_event_from_tag,"event-from-tag",1,1}, { mx_event_from_id,"event-from-id",1,1}, { mx_event_to_tag,"event-to-tag",1,1}, { mx_event_to_id,"event-to-id",1,1}, { mx_event_keycode,"event-keycode",1,1}, { mx_event_shiftkey,"event-shiftkey",1,1}, { mx_event_ctrlkey,"event-ctrlkey",1,1}, { mx_event_altkey,"event-altkey",1,1}, { mx_event_x,"event-x",1,1}, { mx_event_y,"event-y",1,1}, { mx_event_keypress_pred,"event-keypress?",1,1}, { mx_event_keydown_pred,"event-keydown?",1,1}, { mx_event_keyup_pred,"event-keyup?",1,1}, { mx_event_mousedown_pred,"event-mousedown?",1,1}, { mx_event_mousemove_pred,"event-mousemove?",1,1}, { mx_event_mouseover_pred,"event-mouseover?",1,1}, { mx_event_mouseout_pred,"event-mouseout?",1,1}, { mx_event_mouseup_pred,"event-mouseup?",1,1}, { mx_event_click_pred,"event-click?",1,1}, { mx_event_dblclick_pred,"event-dblclick?",1,1}, { mx_event_error_pred,"event-error?",1,1}, { mx_block_until_event,"block-until-event",1,1}, { mx_process_win_events,"process-win-events",0,0}, // dotnet hack { initialize_dotnet_runtime,"%%initialize-dotnet-runtime",0,0}, }; #if !defined(SCHEME_NONNEGATIVE) #define SCHEME_NONNEGATIVE(thing) (SCHEME_INTP (thing) && SCHEME_INT_VAL (thing) >= 0) #endif BOOL isEmptyClsId (CLSID clsId) { return memcmp (&clsId, &emptyClsId, sizeof (CLSID)) == 0; } void scheme_release_typedesc (void *p, void *) { MX_TYPEDESC *pTypeDesc; ITypeInfo *pITypeInfo, *pITypeInfoImpl; IDispatch *pInterface; /* NEED TO DO SOME NEW CLEANUP HERE */ pTypeDesc = (MX_TYPEDESC *)p; if (MX_MANAGED_OBJ_RELEASED (pTypeDesc)) { return; } pITypeInfo = pTypeDesc->pITypeInfo; pITypeInfoImpl = pTypeDesc->pITypeInfoImpl; pInterface = pTypeDesc->pInterface; if (pTypeDesc->descKind == funcDesc) { pITypeInfo->ReleaseFuncDesc (pTypeDesc->funcdescs.pFuncDesc); if (pITypeInfoImpl) { pITypeInfoImpl->ReleaseFuncDesc (pTypeDesc->funcdescs.pFuncDescImpl); } } else if (pTypeDesc->descKind == varDesc) { pITypeInfo->ReleaseVarDesc (pTypeDesc->pVarDesc); } pITypeInfo->Release(); if (pITypeInfoImpl) { pITypeInfoImpl->Release(); } if (pInterface) { pInterface->Release(); } MX_MANAGED_OBJ_RELEASED (pTypeDesc) = TRUE; } void scheme_release_com_object (void *comObject, void *pIDispatch) { ITypeInfo *pITypeInfo; ITypeInfo *pEventTypeInfo; IConnectionPoint *pIConnectionPoint; ISink *pISink; if (MX_MANAGED_OBJ_RELEASED (comObject)) { return; } // when COM object GC'd, release associated interfaces pITypeInfo = MX_COM_OBJ_TYPEINFO (comObject); pEventTypeInfo = MX_COM_OBJ_EVENTTYPEINFO (comObject); pIConnectionPoint = MX_COM_OBJ_CONNECTIONPOINT (comObject); pISink = MX_COM_OBJ_EVENTSINK (comObject); if (pITypeInfo) { pITypeInfo->Release(); } if (pEventTypeInfo) { pEventTypeInfo->Release(); } if (pIConnectionPoint) { pIConnectionPoint->Release(); } if (pISink) { pISink->Release(); } if (pIDispatch) { ((IDispatch *)pIDispatch)->Release(); } MX_MANAGED_OBJ_RELEASED (comObject) = TRUE; } void mx_register_object (Scheme_Object *obj, IUnknown *pIUnknown, void (*release_fun) (void *p, void *data)) { if (pIUnknown == NULL) { // nothing to do return; } scheme_register_finalizer (obj, release_fun, pIUnknown, NULL, NULL); scheme_add_managed ((Scheme_Custodian *)scheme_get_param (scheme_current_config(), MZCONFIG_CUSTODIAN), (Scheme_Object *)obj, (Scheme_Close_Custodian_Client *)release_fun, pIUnknown, 0); } Scheme_Object *mx_com_add_ref (int argc, Scheme_Object **argv) { IDispatch *pIDispatch; pIDispatch = MX_COM_OBJ_VAL (GUARANTEE_COM_OBJ ("com-add-ref", 0)); pIDispatch->AddRef(); return scheme_void; } Scheme_Object *mx_com_ref_count (int argc, Scheme_Object **argv) { IDispatch *pIDispatch; unsigned long n; pIDispatch = MX_COM_OBJ_VAL (GUARANTEE_COM_OBJ ("com-ref-count", 0)); n = pIDispatch->AddRef(); n--; pIDispatch->Release(); return scheme_make_integer_value_from_unsigned (n); } void mx_register_com_object (Scheme_Object *obj, IDispatch *pIDispatch) { mx_register_object (obj, pIDispatch, scheme_release_com_object); } Scheme_Object *mx_com_register_object (int argc, Scheme_Object **argv) { GUARANTEE_COM_OBJ ("com-register-com-object", 0); mx_register_com_object (argv[0], MX_COM_OBJ_VAL (argv[0])); return scheme_void; } void scheme_release_simple_com_object (void *comObject, void *pIUnknown) { if (MX_MANAGED_OBJ_RELEASED (comObject)) { return; } if (pIUnknown) { ((IUnknown *)pIUnknown)->Release(); } MX_MANAGED_OBJ_RELEASED (comObject) = TRUE; } void mx_register_simple_com_object (Scheme_Object *obj, IUnknown *pIUnknown) { mx_register_object (obj, pIUnknown, scheme_release_simple_com_object); } void scheme_release_browser (void *wb, void *hwndDestroy) { MX_Browser_Object *b; if (MX_MANAGED_OBJ_RELEASED (wb)) { return; } b = (MX_Browser_Object *)wb; if (b->pIWebBrowser2) { b->pIWebBrowser2->Release(); } if (((MX_Browser_Object *)wb)->pISink) { b->pISink->Release(); } if (b->pIEventQueue) { b->pIEventQueue->Release(); } if (hwndDestroy) { b->destroy = TRUE; // dummy msg to force GetMessage() to return PostMessage (b->hwnd, WM_NULL, 0, 0); } browserCount--; MX_MANAGED_OBJ_RELEASED (wb) = TRUE; } void scheme_release_document (void *doc, void *) { if (MX_MANAGED_OBJ_RELEASED (doc)) { return; } if (((MX_Document_Object *)doc)->pIHTMLDocument2) { ((MX_Document_Object *)doc)->pIHTMLDocument2->Release(); } MX_MANAGED_OBJ_RELEASED (doc) = TRUE; } Scheme_Object *mx_com_release_object (int argc, Scheme_Object **argv) { GUARANTEE_COM_OBJ ("com-release-object", 0); scheme_release_com_object ((void *)argv[0], MX_COM_OBJ_VAL (argv[0])); return scheme_void; } static const char * inv_kind_string (INVOKEKIND invKind) { return invKind == INVOKE_FUNC ? "method" : invKind == INVOKE_PROPERTYGET ? "property" : invKind == INVOKE_PROPERTYPUT ? "property" : invKind == INVOKE_EVENT ? "event" : NULL; } static const char * mx_fun_string (INVOKEKIND invKind) { return invKind == INVOKE_FUNC ? "com-invoke" : invKind == INVOKE_PROPERTYGET ? "com-get-property" : invKind == INVOKE_PROPERTYPUT ? "com-set-property!" : NULL; } static unsigned short getHashValue (IDispatch *pIDispatch, INVOKEKIND invKind, LPCTSTR name) { LPCTSTR p; unsigned short hashVal; hashVal = (unsigned short)pIDispatch + invKind; p = name; while (*p) { hashVal ^= (hashVal << 5) + (hashVal >> 2) + (unsigned short) (*p); p++; } return hashVal % TYPE_TBL_SIZE; } void addTypeToTable (IDispatch *pIDispatch, LPCTSTR name, INVOKEKIND invKind, MX_TYPEDESC *pTypeDesc) { unsigned short hashVal; MX_TYPE_TBL_ENTRY *pEntry, *p; // we don't call AddRef() for the IDispatch pointer // because it's not used as an interface, only its // pointer value is used, for hashing pTypeDesc->pITypeInfo->AddRef(); pEntry = (MX_TYPE_TBL_ENTRY *)scheme_malloc (sizeof (MX_TYPE_TBL_ENTRY)); scheme_dont_gc_ptr (pEntry); pEntry->pTypeDesc = pTypeDesc; pEntry->pIDispatch = pIDispatch; pEntry->invKind = invKind; pEntry->name = name; pEntry->next = NULL; hashVal = getHashValue (pIDispatch, invKind, name); p = typeTable[hashVal]; if (p == NULL) typeTable[hashVal] = pEntry; else { while (p->next != NULL) p = p->next; p->next = pEntry; } } MX_TYPEDESC * lookupTypeDesc (IDispatch *pIDispatch, LPCTSTR name, INVOKEKIND invKind) { unsigned short hashVal; MX_TYPE_TBL_ENTRY *p; hashVal = getHashValue (pIDispatch, invKind, name); p = typeTable[hashVal]; while (p) { if (p->pIDispatch == pIDispatch && p->invKind == invKind && lstrcmp (p->name, name) == 0) return p->pTypeDesc; p = p->next; } return NULL; } void codedComError (const char *s, HRESULT hr) { char buff[1024]; char finalBuff[2048]; if (FormatMessage (FORMAT_MESSAGE_FROM_SYSTEM, 0, hr, 0, buff, sizeof (buff), NULL) > 0) sprintf (finalBuff, "%s, code = %X: %s", s, hr, buff); else sprintf (finalBuff, "%s, code = %X", s, hr); scheme_signal_error (finalBuff); } Scheme_Object *mx_version (int argc, Scheme_Object **argv) { return scheme_make_utf8_string (MX_VERSION); } Scheme_Object *do_cocreate_instance (CLSID clsId, LPCTSTR name, LPCTSTR location, LPCTSTR machine) { HRESULT hr; IDispatch *pIDispatch; MX_COM_Object *com_object; if (lstrcmpi (location, TEXT ("local")) == 0) { hr = CoCreateInstance (clsId, NULL, CLSCTX_LOCAL_SERVER | CLSCTX_INPROC_SERVER, IID_IDispatch, (void **)&pIDispatch); } else if (lstrcmpi (location, TEXT ("remote")) == 0) { COSERVERINFO csi; MULTI_QI mqi; OLECHAR machineBuff[1024]; if (machine) { unsigned int len; unsigned int count; csi.dwReserved1 = 0; csi.dwReserved2 = 0; csi.pAuthInfo = NULL; len = (unsigned int)lstrlen (machine); count = MultiByteToWideChar (CP_ACP, (DWORD)0, machine, len, machineBuff, sizeray (machineBuff) - 1); machineBuff[len] = '\0'; if (count < len) { scheme_signal_error ("cocreate-instance-from-{coclass, progid}: " "Unable to translate machine name to Unicode"); } csi.pwszName = machineBuff; } mqi.pIID = &IID_IDispatch; mqi.pItf = NULL; mqi.hr = 0; hr = CoCreateInstanceEx (clsId, NULL, CLSCTX_REMOTE_SERVER, machine ? &csi : NULL, 1, &mqi); pIDispatch = (IDispatch *) (mqi.pItf); if (mqi.hr != S_OK || pIDispatch == NULL) { codedComError ("cocreate-instance-from-{coclass, progid}: " "Unable to obtain IDispatch interface for remote server", hr); } } else { scheme_signal_error ("cocreate-instance-from-{coclass, progid}: " "Expected 'local, 'remote, or machine name for 2nd argument, " "got '%s", location); } if (hr != ERROR_SUCCESS) { char errBuff[2048]; sprintf (errBuff, "cocreate-instance-from-{coclass, progid}: Unable to create instance of %s", name); codedComError (errBuff, hr); } com_object = (MX_COM_Object *)scheme_malloc (sizeof (MX_COM_Object)); com_object->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; mx_register_com_object ((Scheme_Object *)com_object, pIDispatch); return (Scheme_Object *)com_object; } static void bindCocreateLocation (int argc, Scheme_Object **argv, LPCTSTR * pLocation, LPCTSTR * pMachine, char *f) { if (argc == 2) { if (SCHEME_SYMBOLP (argv[1])) { *pLocation = schemeSymbolToText (argv[1]); *pMachine = NULL; } else if (SCHEME_CHAR_STRINGP (argv[1])) { *pLocation = TEXT ("remote"); *pMachine = schemeCharStringToText (argv[1]); } else scheme_wrong_type (f, "symbol or string", 0, argc, argv); } else { *pLocation = TEXT ("local"); *pMachine = NULL; } } Scheme_Object *mx_cocreate_instance_from_coclass (int argc, Scheme_Object **argv) { LPCTSTR coclass; LPCTSTR location; LPCTSTR machine; GUARANTEE_STRSYM ("cocreate-instance-from-coclass", 0); bindCocreateLocation (argc, argv, &location, &machine, "cocreate-instance-from-coclass"); coclass = schemeToText (argv[0]); return do_cocreate_instance (getCLSIDFromCoClass (coclass), coclass, location, machine); } CLSID schemeProgIdToCLSID (Scheme_Object *obj, const char * fname) { CLSID clsId; BSTR wideProgId = schemeToBSTR (obj); HRESULT hr = CLSIDFromProgID (wideProgId, &clsId); SysFreeString (wideProgId); if (FAILED (hr)) { char errBuff[2048]; sprintf (errBuff, "%s: Error retrieving CLSID from ProgID %s", fname, schemeToMultiByte (obj)); codedComError (errBuff, hr); } return clsId; } Scheme_Object *mx_cocreate_instance_from_progid (int argc, Scheme_Object **argv) { LPCTSTR location; LPCTSTR machine; GUARANTEE_STRSYM ("cocreate-instance-from-progid", 0); bindCocreateLocation (argc, argv, &location, &machine, "cocreate-instance-from-progid"); return do_cocreate_instance (schemeProgIdToCLSID (argv[0], "cocreate-instance-from-progid"), schemeToText (argv[0]), location, machine); } Scheme_Object *mx_set_coclass (int argc, Scheme_Object **argv) { GUARANTEE_COM_OBJ ("set-coclass!", 0); GUARANTEE_STRSYM ("set-coclass!", 1); MX_COM_OBJ_CLSID (argv[0]) = getCLSIDFromCoClass (schemeToText (argv[1])); return scheme_void; } Scheme_Object *mx_coclass (int argc, Scheme_Object **argv) { HRESULT hr; HKEY hkey, hsubkey; LONG result; FILETIME fileTime; unsigned long keyIndex; TCHAR clsIdBuffer[256]; OLECHAR oleClsIdBuffer[256]; DWORD clsIdBufferSize; DWORD dataType; BYTE dataBuffer[256]; DWORD dataBufferSize; CLSID clsId, registryClsId; int count; Scheme_Object *retval; clsId = MX_COM_OBJ_CLSID (GUARANTEE_COM_OBJ ("coclass", 0)); if (isEmptyClsId (clsId)) scheme_signal_error ("coclass: No coclass for object"); // use CLSID to rummage through Registry to find coclass result = RegOpenKeyEx (HKEY_CLASSES_ROOT, "CLSID", (DWORD)0, KEY_READ, &hkey); if (result != ERROR_SUCCESS) scheme_signal_error ("Error while searching Windows registry"); // enumerate subkeys until we find the one we want // really, should call RegQueryInfoKey to find size needed for buffers keyIndex = 0; retval = NULL; while (1) { // get next subkey clsIdBufferSize = sizeof (clsIdBuffer); result = RegEnumKeyEx (hkey, keyIndex++, clsIdBuffer, &clsIdBufferSize, 0, NULL, NULL, &fileTime); if (result == ERROR_NO_MORE_ITEMS) break; if (result != ERROR_SUCCESS) scheme_signal_error ("Error enumerating subkeys in Windows registry"); if (strlen (clsIdBuffer) != CLSIDLEN) // not a CLSID -- bogus entry continue; count = MultiByteToWideChar (CP_ACP, (DWORD)0, clsIdBuffer, (unsigned int)strlen (clsIdBuffer), oleClsIdBuffer, sizeray (oleClsIdBuffer)); if (count == 0) scheme_signal_error ("Error translating CLSID to Unicode"); oleClsIdBuffer[CLSIDLEN] = '\0'; hr = CLSIDFromString (oleClsIdBuffer, ®istryClsId); if (hr != NOERROR) scheme_signal_error ("coclass: Error obtaining coclass CLSID"); if (registryClsId != clsId) continue; // open subkey result = RegOpenKeyEx (hkey, clsIdBuffer, (DWORD)0, KEY_READ, &hsubkey); if (result != ERROR_SUCCESS) scheme_signal_error ("coclass: Error obtaining coclass value"); dataBufferSize = sizeof (dataBuffer); RegQueryValueEx (hsubkey, "", 0, &dataType, dataBuffer, &dataBufferSize); RegCloseKey (hsubkey); if (dataType == REG_SZ) { retval = multiByteToSchemeCharString ((char *)dataBuffer); break; } } RegCloseKey (hkey); if (retval == NULL) scheme_signal_error ("coclass: object's coclass not found in Registry"); return retval; } Scheme_Object * mx_progid (int argc, Scheme_Object **argv) { HRESULT hr; LPOLESTR wideProgId; CLSID clsId; clsId = MX_COM_OBJ_CLSID (GUARANTEE_COM_OBJ ("progid", 0)); if (isEmptyClsId (clsId)) scheme_signal_error ("progid: No coclass for object"); hr = ProgIDFromCLSID (clsId, &wideProgId); if (FAILED (hr)) scheme_signal_error ("progid: Error finding coclass"); return BSTRToSchemeString (wideProgId); } Scheme_Object *mx_set_coclass_from_progid (int argc, Scheme_Object **argv) { GUARANTEE_COM_OBJ ("set-coclass-from-progid!", 0); GUARANTEE_STRSYM ("set-coclass-from-progid!", 1); MX_COM_OBJ_CLSID (argv[0]) = schemeProgIdToCLSID (argv[1], "set-coclass-from-progid!"); return scheme_void; } ITypeInfo *typeInfoFromComObject (MX_COM_Object *obj) { HRESULT hr; ITypeInfo *pITypeInfo; IDispatch *pIDispatch; unsigned int count; pITypeInfo = obj->pITypeInfo; if (pITypeInfo) return pITypeInfo; pIDispatch = obj->pIDispatch; pIDispatch->GetTypeInfoCount (&count); if (count == 0) scheme_signal_error ("COM object does not expose type information"); hr = pIDispatch->GetTypeInfo (0, LOCALE_SYSTEM_DEFAULT, &pITypeInfo); if (FAILED (hr) || pITypeInfo == NULL) codedComError ("Error getting COM type information", hr); obj->pITypeInfo = pITypeInfo; return pITypeInfo; } Scheme_Object *mx_com_get_object_type (int argc, Scheme_Object **argv) { ITypeInfo *pITypeInfo; MX_COM_Type *retval; MX_COM_Object *obj; GUARANTEE_COM_OBJ ("com-object-type", 0); obj = (MX_COM_Object *)argv[0]; pITypeInfo = typeInfoFromComObject (obj); retval = (MX_COM_Type *)scheme_malloc (sizeof (MX_COM_Type)); retval->type = mx_com_type_type; retval->released = FALSE; retval->pITypeInfo = pITypeInfo; retval->clsId = obj->clsId; mx_register_simple_com_object ((Scheme_Object *)retval, pITypeInfo); return (Scheme_Object *)retval; } BOOL typeInfoEq (ITypeInfo *pITypeInfo1, ITypeInfo *pITypeInfo2) { HRESULT hr; TYPEATTR *pTypeAttr1, *pTypeAttr2; BOOL retval; // intensional equality if (pITypeInfo1 == pITypeInfo2) return TRUE; hr = pITypeInfo1->GetTypeAttr (&pTypeAttr1); if (FAILED (hr) || pTypeAttr1 == NULL) codedComError ("Error getting type attributes", hr); hr = pITypeInfo2->GetTypeAttr (&pTypeAttr2); if (FAILED (hr) || pTypeAttr2 == NULL) codedComError ("Error getting type attributes", hr); retval = (pTypeAttr1->guid == pTypeAttr2->guid); pITypeInfo1->ReleaseTypeAttr (pTypeAttr1); pITypeInfo2->ReleaseTypeAttr (pTypeAttr2); return retval; } Scheme_Object *mx_com_is_a (int argc, Scheme_Object **argv) { ITypeInfo *pITypeInfo1, *pITypeInfo2; GUARANTEE_COM_OBJ ("com-is-a?", 0); GUARANTEE_COM_TYPE ("com-is-a?", 1); pITypeInfo1 = typeInfoFromComObject ((MX_COM_Object *)argv[0]); pITypeInfo2 = MX_COM_TYPE_VAL ((MX_COM_Type *)argv[1]); return typeInfoEq (pITypeInfo1, pITypeInfo2) ? scheme_true : scheme_false; } Scheme_Object *mx_com_help (int argc, Scheme_Object **argv) { HRESULT hr; ITypeInfo *pITypeInfo; BSTR helpFileName; char buff[MAX_PATH]; unsigned int len; GUARANTEE_COM_OBJ_OR_TYPE ("com-help", 0); if (argc == 2) GUARANTEE_STRSYM ("com-help", 1); pITypeInfo = MX_COM_TYPEP (argv[0]) ? MX_COM_TYPE_VAL (argv[0]) : (MX_COM_OBJ_VAL (argv[0]) == NULL) ? (scheme_signal_error ("com-help: NULL COM object"), (ITypeInfo *) NULL) : typeInfoFromComObject ((MX_COM_Object *)argv[0]); hr = pITypeInfo->GetDocumentation (MEMBERID_NIL, NULL, NULL, NULL, &helpFileName); if (FAILED (hr)) codedComError ("Can't get help", hr); else if (helpFileName == NULL || wcscmp (helpFileName, L"") == 0) scheme_signal_error ("No help available"); WideCharToMultiByte (CP_ACP, (DWORD)0, helpFileName, SysStringLen (helpFileName), buff, sizeof (buff) - 1, NULL, NULL); SysFreeString (helpFileName); buff[sizeof (buff)-1] = '\0'; len = (unsigned int) strlen (buff); if (stricmp (buff + len - 4, ".CHM") == 0) { HWND hwnd = (argc >= 2) ? HtmlHelp (NULL, buff, HH_DISPLAY_INDEX, PtrToInt (schemeToText (argv[1]))) : HtmlHelp (NULL, buff, HH_DISPLAY_TOPIC, 0); if (hwnd) SetForegroundWindow (hwnd); } else if (stricmp (buff + len - 4, ".HLP") == 0) { if (argc >= 2) WinHelp (NULL, buff, HELP_KEY, PtrToInt (schemeToText (argv[1]))); else WinHelp (NULL, buff, HELP_FINDER, 0); } else scheme_signal_error ("Unknown help file type: %s", buff); return scheme_void; } void signalCodedEventSinkError (char *s, HRESULT hr) { ReleaseSemaphore (eventSinkMutex, 1, NULL); codedComError (s, hr); } void connectComObjectToEventSink (MX_COM_Object *obj) { HRESULT hr; IUnknown *pIUnknown; IDispatch *pIDispatch; ITypeInfo *pITypeInfo; IConnectionPointContainer *pIConnectionPointContainer; IConnectionPoint *pIConnectionPoint; ISink *pISink; DWORD cookie; TYPEATTR *pTypeAttr; if (obj->pIConnectionPoint) return; WaitForSingleObject (eventSinkMutex, INFINITE); pIDispatch = obj->pIDispatch; hr = pIDispatch->QueryInterface (IID_IConnectionPointContainer, (void **)&pIConnectionPointContainer); if (FAILED (hr) || pIConnectionPointContainer == NULL) signalCodedEventSinkError ("cocreate-instance-from-{coclass, progid}: " "Unable to get COM object connection point " "container", hr); pITypeInfo = eventTypeInfoFromComObject (obj); if (pITypeInfo == NULL) { ReleaseSemaphore (eventSinkMutex, 1, NULL); scheme_signal_error ("cocreate-instance-from-{coclass, progid}: " "Unable to get type information for events"); } hr = pITypeInfo->GetTypeAttr (&pTypeAttr); if (FAILED (hr) || pTypeAttr == NULL) signalCodedEventSinkError ("cocreate-instance-from-{coclass, progid}: " "Unable to get type attributes for events", hr); hr = pIConnectionPointContainer->FindConnectionPoint (pTypeAttr->guid, &pIConnectionPoint); pITypeInfo->ReleaseTypeAttr (pTypeAttr); pIConnectionPointContainer->Release(); if (FAILED (hr) || pIConnectionPoint == NULL) signalCodedEventSinkError ("cocreate-instance-from-{coclass, progid}: " "Unable to find COM object connection point", hr); hr = CoCreateInstance (CLSID_Sink, NULL, CLSCTX_LOCAL_SERVER | CLSCTX_INPROC_SERVER, IID_IUnknown, (void **)&pIUnknown); if (FAILED (hr) || pIUnknown == NULL) signalCodedEventSinkError ("cocreate-instance-from-{coclass, progid}: " "Unable to create sink object", hr); hr = pIUnknown->QueryInterface (IID_ISink, (void **)&pISink); if (FAILED (hr) || pISink == NULL) signalCodedEventSinkError ("cocreate-instance-from-{coclass, progid}: " "Unable to find sink interface", hr); pISink->set_myssink_table (&myssink_table); hr = pIConnectionPoint->Advise (pIUnknown, &cookie); pIUnknown->Release(); if (FAILED (hr)) signalCodedEventSinkError ("cocreate-instance-from-{coclass, progid}: " "Unable to connect sink to connection point", hr); obj->pEventTypeInfo = pITypeInfo; obj->pIConnectionPoint = pIConnectionPoint; obj->connectionCookie = cookie; obj->pISink = pISink; ReleaseSemaphore (eventSinkMutex, 1, NULL); } FUNCDESC *getFuncDescForEvent (LPOLESTR name, ITypeInfo *pITypeInfo) { HRESULT hr; TYPEATTR *pTypeAttr; FUNCDESC *pFuncDesc; BSTR bstr; UINT bstrCount; unsigned short numFuncDescs; int i; hr = pITypeInfo->GetTypeAttr (&pTypeAttr); if (FAILED (hr) || pTypeAttr == NULL) codedComError ("Unable to get type attributes for events", hr); numFuncDescs = pTypeAttr->cFuncs; pITypeInfo->ReleaseTypeAttr (pTypeAttr); for (i = 0; i < numFuncDescs; i++) { hr = pITypeInfo->GetFuncDesc (i, &pFuncDesc); if (FAILED (hr)) codedComError ("Error getting event method type description", hr); // rely on name of event hr = pITypeInfo->GetNames (pFuncDesc->memid, &bstr, 1, &bstrCount); if (FAILED (hr)) codedComError ("Error getting event method name", hr); if (wcscmp (name, bstr) == 0) { SysFreeString (bstr); return pFuncDesc; } SysFreeString (bstr); pITypeInfo->ReleaseFuncDesc (pFuncDesc); } return NULL; } Scheme_Object *mx_com_register_event_handler (int argc, Scheme_Object **argv) { ITypeInfo *pITypeInfo; ISink *pISink; FUNCDESC *pFuncDesc; BSTR unicodeName; GUARANTEE_COM_OBJ ("com-register-event-handler", 0); GUARANTEE_STRSYM ("com-register-event-handler", 1); GUARANTEE_PROCEDURE ("com-register-event-handler", 2); connectComObjectToEventSink ((MX_COM_Object *)argv[0]); pITypeInfo = MX_COM_OBJ_EVENTTYPEINFO (argv[0]); pISink = MX_COM_OBJ_EVENTSINK (argv[0]); unicodeName = schemeToBSTR (argv[1]); pFuncDesc = getFuncDescForEvent (unicodeName, pITypeInfo); SysFreeString (unicodeName); if (pFuncDesc == NULL) scheme_signal_error ("Can't find event %s in type description", schemeToText (argv[1])); pISink->register_handler (pFuncDesc->memid, argv[2]); pITypeInfo->ReleaseFuncDesc (pFuncDesc); return scheme_void; } Scheme_Object *mx_com_unregister_event_handler (int argc, Scheme_Object **argv) { ITypeInfo *pITypeInfo; ISink *pISink; FUNCDESC *pFuncDesc; BSTR unicodeName; GUARANTEE_STRSYM ("com-unregister-event-handler", 1); pITypeInfo = MX_COM_OBJ_EVENTTYPEINFO (GUARANTEE_COM_OBJ ("com-unregister-event-handler", 0)); if (pITypeInfo == NULL) scheme_signal_error ("No event type information for object"); pISink = MX_COM_OBJ_EVENTSINK (argv[0]); if (pISink == NULL) // no events registered return scheme_void; unicodeName = schemeToBSTR (argv[1]); pFuncDesc = getFuncDescForEvent (unicodeName, pITypeInfo); SysFreeString (unicodeName); if (pFuncDesc == NULL) scheme_signal_error ("Can't find event %s in type description", schemeToText (argv[1])); pISink->unregister_handler (pFuncDesc->memid); pITypeInfo->ReleaseFuncDesc (pFuncDesc); return scheme_void; } MX_TYPEDESC *doTypeDescFromTypeInfo (BSTR name, INVOKEKIND invKind, ITypeInfo *pITypeInfo) { HRESULT hr; TYPEATTR *pTypeAttr; FUNCDESC *pFuncDesc; VARDESC *pVarDesc; MEMBERID memID; MX_DESCKIND descKind; MX_TYPEDESC *pTypeDesc; BSTR bstr; UINT nameCount; UINT funcDescIndex; BOOL foundDesc; unsigned short dispFuncs, implFuncs; int i; hr = pITypeInfo->GetTypeAttr (&pTypeAttr); if (FAILED (hr)) codedComError ("Error getting attributes for type library", hr); foundDesc = FALSE; // can skip first 7, because those are IDispatch-specific dispFuncs = pTypeAttr->cFuncs; for (i = 7; i < dispFuncs; i++) { hr = pITypeInfo->GetFuncDesc (i, &pFuncDesc); if (FAILED (hr)) codedComError ("Error getting type description", hr); pITypeInfo->GetNames (pFuncDesc->memid, &bstr, 1, &nameCount); // see if this FUNCDESC is the one we want if (wcscmp (bstr, name) == 0 && (invKind == INVOKE_EVENT || pFuncDesc->invkind == invKind)) { foundDesc = TRUE; descKind = funcDesc; SysFreeString (bstr); memID = pFuncDesc->memid; funcDescIndex = i; break; } // if not, throw it back SysFreeString (bstr); pITypeInfo->ReleaseFuncDesc (pFuncDesc); } if (invKind == INVOKE_PROPERTYGET || invKind == INVOKE_PROPERTYPUT || invKind == INVOKE_PROPERTYPUTREF) { for (i = 0; i < pTypeAttr->cVars; i++) { hr = pITypeInfo->GetVarDesc (i, &pVarDesc); if (FAILED (hr)) { codedComError ("Error getting type description", hr); } // see if this VARDESC is the one we want pITypeInfo->GetNames (pVarDesc->memid, &bstr, 1, &nameCount); if (wcscmp (bstr, name)) { foundDesc = TRUE; descKind = varDesc; memID = pVarDesc->memid; break; } // if not, throw it back pITypeInfo->ReleaseVarDesc (pVarDesc); } } pITypeInfo->ReleaseTypeAttr (pTypeAttr); if (foundDesc == FALSE) { ITypeInfo *pITypeInfoImpl; TYPEATTR *pTypeAttrImpl; HREFTYPE refType; // search in inherited interfaces for (i = 0; i < pTypeAttr->cImplTypes; i++) { hr = pITypeInfo->GetRefTypeOfImplType (i, &refType); if (FAILED (hr)) scheme_signal_error ("Can't get implementation type library handle"); hr = pITypeInfo->GetRefTypeInfo (refType, &pITypeInfoImpl); if (FAILED (hr)) scheme_signal_error ("Can't get implementation type library"); hr = pITypeInfoImpl->GetTypeAttr (&pTypeAttrImpl); if (FAILED (hr)) scheme_signal_error ("Can't get implementation type library attributes"); // recursion, to ascend the inheritance graph pTypeDesc = doTypeDescFromTypeInfo (name, invKind, pITypeInfoImpl); // release interfaces pITypeInfoImpl->ReleaseTypeAttr (pTypeAttrImpl); pITypeInfoImpl->Release(); if (pTypeDesc) return pTypeDesc; } return NULL; } pTypeDesc = (MX_TYPEDESC *)scheme_malloc (sizeof (MX_TYPEDESC)); pTypeDesc->type = mx_com_typedesc_type; pTypeDesc->released = FALSE; pTypeDesc->memID = memID; pTypeDesc->pITypeInfo = pITypeInfo; pITypeInfo->AddRef(); pTypeDesc->descKind = descKind; pTypeDesc->funOffset = NO_FUNPTR; // assume for now if (descKind == funcDesc) { HREFTYPE refType; ITypeInfo *pITypeInfoImpl; pTypeDesc->funcdescs.pFuncDesc = pFuncDesc; hr = pITypeInfo->GetRefTypeOfImplType (-1, &refType); if (hr == S_OK) { hr = pITypeInfo->GetRefTypeInfo (refType, &pITypeInfoImpl); if (hr == S_OK) { TYPEATTR *pTypeAttrImpl; FUNCDESC *pFuncDescImpl; hr = pITypeInfoImpl->GetTypeAttr (&pTypeAttrImpl); if (hr == S_OK) { implFuncs = pTypeAttrImpl->cFuncs; // assumption: impl TypeInfo has FuncDescs in same order // as the Dispatch TypeInfo // but dispFuncs has IDispatch methods funcDescIndex -= dispFuncs - implFuncs; hr = pITypeInfoImpl->GetFuncDesc (funcDescIndex, &pFuncDescImpl); if (hr == S_OK) { if (pFuncDescImpl->funckind == FUNC_VIRTUAL || pFuncDescImpl->funckind == FUNC_PUREVIRTUAL) { pTypeDesc->implGuid = pTypeAttrImpl->guid; pTypeDesc->funOffset = pFuncDescImpl->oVft/4; pTypeDesc->pITypeInfoImpl = pITypeInfoImpl; pITypeInfoImpl->AddRef(); pTypeDesc->funcdescs.pFuncDescImpl = pFuncDescImpl; } else { pITypeInfoImpl->ReleaseFuncDesc (pFuncDescImpl); } } pITypeInfoImpl->ReleaseTypeAttr (pTypeAttrImpl); } else { pITypeInfoImpl->Release(); } } } } else { pTypeDesc->pVarDesc = pVarDesc; } scheme_add_managed ((Scheme_Custodian *)scheme_get_param (scheme_current_config(), MZCONFIG_CUSTODIAN), (Scheme_Object *)pTypeDesc, (Scheme_Close_Custodian_Client *)scheme_release_typedesc, NULL, 0); scheme_register_finalizer (pTypeDesc, scheme_release_typedesc, NULL, NULL, NULL); return pTypeDesc; } static MX_TYPEDESC *typeDescFromTypeInfo (LPCTSTR name, INVOKEKIND invKind, ITypeInfo *pITypeInfo) { BSTR unicodeName; MX_TYPEDESC *retval; unicodeName = textToBSTR (name, strlen (name)); retval = doTypeDescFromTypeInfo (unicodeName, invKind, pITypeInfo); SysFreeString (unicodeName); return retval; } MX_TYPEDESC *getMethodType (MX_COM_Object *obj, LPCTSTR name, INVOKEKIND invKind) { IDispatch *pIDispatch; MX_TYPEDESC *pTypeDesc; ITypeInfo *pITypeInfo; // need Unicode version of name to please ITypeInfo::GetIDsOfNames // note that we need string length + 1 pIDispatch = obj->pIDispatch; // check in hash table to see if we already have the type information pTypeDesc = lookupTypeDesc (pIDispatch, name, invKind); if (pTypeDesc) return pTypeDesc; if (invKind == INVOKE_EVENT) { pITypeInfo = eventTypeInfoFromComObject (obj); if (pITypeInfo == NULL) scheme_signal_error ("Can't find event type information"); } else pITypeInfo = typeInfoFromComObject (obj); pTypeDesc = typeDescFromTypeInfo (name, invKind, pITypeInfo); // pTypeDesc may be NULL if (pTypeDesc != NULL) addTypeToTable (pIDispatch, name, invKind, pTypeDesc); return pTypeDesc; } static int dispatchCmp (const char * s1, const char * * s2) { return lstrcmp (s1, *s2); } BOOL isDispatchName (const char *s) { static char *names[] = { // must be in alpha order "AddRef", "GetIDsOfNames", "GetTypeInfo", "GetTypeInfoCount", "Invoke", "QueryInterface", "Release", }; return bsearch (s, names, sizeray (names), sizeof (names[0]), (int (*) (const void *, const void *))dispatchCmp) ? TRUE : FALSE; } Scheme_Object *getTypeNames (ITypeInfo *pITypeInfo, TYPEATTR *pTypeAttr, Scheme_Object *retval, INVOKEKIND invKind) { ITypeInfo *pITypeInfoImpl; TYPEATTR *pTypeAttrImpl; BSTR bstr; FUNCDESC *pFuncDesc; VARDESC *pVarDesc; HREFTYPE refType; unsigned int count; int i; for (i = 0; i < pTypeAttr->cImplTypes; i++) { HRESULT hr = pITypeInfo->GetRefTypeOfImplType (i, &refType); if (FAILED (hr)) scheme_signal_error ("Can't get implementation type library handle"); hr = pITypeInfo->GetRefTypeInfo (refType, &pITypeInfoImpl); if (FAILED (hr)) scheme_signal_error ("Can't get implementation type library"); hr = pITypeInfoImpl->GetTypeAttr (&pTypeAttrImpl); if (FAILED (hr)) scheme_signal_error ("Can't get implementation type library attributes"); // recursion, to ascend the inheritance graph retval = getTypeNames (pITypeInfoImpl, pTypeAttrImpl, retval, invKind); // release interfaces pITypeInfoImpl->ReleaseTypeAttr (pTypeAttrImpl); pITypeInfoImpl->Release(); } // properties can appear in list of functions // or in list of variables for (i = 0; i < pTypeAttr->cFuncs; i++) { char buff[256]; unsigned int len; pITypeInfo->GetFuncDesc (i, &pFuncDesc); if (pFuncDesc->invkind == invKind) { pITypeInfo->GetNames (pFuncDesc->memid, &bstr, 1, &count); if (invKind == INVOKE_FUNC) { len = SysStringLen (bstr); WideCharToMultiByte (CP_ACP, (DWORD)0, bstr, len, buff, sizeof (buff) - 1, NULL, NULL); buff[len] = '\0'; } // don't consider names inherited from IDispatch if (invKind != INVOKE_FUNC || !isDispatchName (buff)) retval = scheme_make_pair (BSTRToSchemeString (bstr), retval); SysFreeString (bstr); } pITypeInfo->ReleaseFuncDesc (pFuncDesc); } if (invKind == INVOKE_FUNC) // done, if not a property return retval; for (i = 0; i < pTypeAttr->cVars; i++) { pITypeInfo->GetVarDesc (i, &pVarDesc); pITypeInfo->GetNames (pVarDesc->memid, &bstr, 1, &count); retval = scheme_make_pair (BSTRToSchemeString (bstr), retval); SysFreeString (bstr); pITypeInfo->ReleaseVarDesc (pVarDesc); } return retval; } Scheme_Object *mx_do_get_methods (int argc, Scheme_Object **argv, INVOKEKIND invKind) { ITypeInfo *pITypeInfo; HRESULT hr; TYPEATTR *pTypeAttr; Scheme_Object *retval; GUARANTEE_COM_OBJ_OR_TYPE ("com-{methods, {get, set}-properties}", 0); pITypeInfo = MX_COM_TYPEP (argv[0]) ? MX_COM_TYPE_VAL (argv[0]) : (MX_COM_OBJ_VAL (argv[0]) == NULL) ? (scheme_signal_error ("com-{methods, {get, set}-properties}: NULL COM object"), (ITypeInfo *) NULL) : typeInfoFromComObject ((MX_COM_Object *)argv[0]); hr = pITypeInfo->GetTypeAttr (&pTypeAttr); if (FAILED (hr) || pTypeAttr == NULL) codedComError ("Error getting type attributes", hr); retval = getTypeNames (pITypeInfo, pTypeAttr, scheme_null, invKind); pITypeInfo->ReleaseTypeAttr (pTypeAttr); return retval; } Scheme_Object *mx_com_methods (int argc, Scheme_Object **argv) { return mx_do_get_methods (argc, argv, INVOKE_FUNC); } Scheme_Object *mx_com_get_properties (int argc, Scheme_Object **argv) { return mx_do_get_methods (argc, argv, INVOKE_PROPERTYGET); } Scheme_Object *mx_com_set_properties (int argc, Scheme_Object **argv) { return mx_do_get_methods (argc, argv, INVOKE_PROPERTYPUT); } ITypeInfo *coclassTypeInfoFromTypeInfo (ITypeInfo *pITypeInfo, CLSID clsId) { HRESULT hr; ITypeLib *pITypeLib; ITypeInfo *pCoclassTypeInfo; ITypeInfo *pCandidateTypeInfo; TYPEATTR *pTypeAttr; TYPEKIND typeKind; HREFTYPE hRefType; UINT ndx; UINT typeInfoCount; UINT coclassCount; UINT typeCount; UINT coclassNdx; UINT i, j; hr = pITypeInfo->GetContainingTypeLib (&pITypeLib, &ndx); if (FAILED (hr)) scheme_signal_error ("Can't get dispatch type library"); // first try using explicit clsId if (!isEmptyClsId (clsId)) { hr = pITypeLib->GetTypeInfoOfGuid (clsId, &pCoclassTypeInfo); pITypeLib->Release(); if (FAILED (hr) || pCoclassTypeInfo == NULL) { codedComError ("Error getting type info for coclass", hr); return NULL; } return pCoclassTypeInfo; } // if no CLSID, search for coclass implementing supplied // interface typeInfoCount = pITypeLib->GetTypeInfoCount(); coclassCount = 0; // check for ambiguity for (i = 0; i < typeInfoCount; i++) { pITypeLib->GetTypeInfoType (i, &typeKind); if (typeKind == TKIND_COCLASS) { hr = pITypeLib->GetTypeInfo (i, &pCoclassTypeInfo); if (FAILED (hr) || pCoclassTypeInfo == NULL) { pITypeLib->Release(); codedComError ("Error getting type info for coclass", hr); } hr = pCoclassTypeInfo->GetTypeAttr (&pTypeAttr); if (FAILED (hr) || pTypeAttr == NULL) { pCoclassTypeInfo->Release(); pITypeLib->Release(); codedComError ("Error getting coclass type attributes", hr); } typeCount = pTypeAttr->cImplTypes; pCoclassTypeInfo->ReleaseTypeAttr (pTypeAttr); for (j = 0; j < typeCount; j++) { hr = pCoclassTypeInfo->GetRefTypeOfImplType (j, &hRefType); if (FAILED (hr)) { pCoclassTypeInfo->Release(); pITypeLib->Release(); codedComError ("Error retrieving type info handle", hr); } hr = pCoclassTypeInfo->GetRefTypeInfo (hRefType, &pCandidateTypeInfo); if (FAILED (hr) || pCandidateTypeInfo == NULL) { pCoclassTypeInfo->Release(); pITypeLib->Release(); codedComError ("Error retrieving candidate type info", hr); } if (typeInfoEq (pCandidateTypeInfo, pITypeInfo)) { coclassNdx = i; if (++coclassCount >= 2) { pCandidateTypeInfo->Release(); pCoclassTypeInfo->Release(); pITypeLib->Release(); scheme_signal_error ("Ambiguous coclass for object"); } } pCandidateTypeInfo->Release(); } pCoclassTypeInfo->Release(); } } if (coclassCount == 0) { pITypeLib->Release(); return NULL; } hr = pITypeLib->GetTypeInfo (coclassNdx, &pCoclassTypeInfo); pITypeLib->Release(); if (FAILED (hr) || pCoclassTypeInfo == NULL) codedComError ("Error getting type info for coclass", hr); return pCoclassTypeInfo; } ITypeInfo *eventTypeInfoFromCoclassTypeInfo (ITypeInfo *pCoclassTypeInfo) { HRESULT hr; ITypeInfo *pEventTypeInfo; TYPEATTR *pTypeAttr; HREFTYPE hRefType; UINT typeCount; UINT eventTypeInfoNdx; int typeFlags; UINT i; hr = pCoclassTypeInfo->GetTypeAttr (&pTypeAttr); if (FAILED (hr) || pTypeAttr == NULL) codedComError ("Error getting type attributes", hr); typeCount = pTypeAttr->cImplTypes; pCoclassTypeInfo->ReleaseTypeAttr (pTypeAttr); eventTypeInfoNdx = -1; for (i = 0; i < typeCount; i++) { hr = pCoclassTypeInfo->GetImplTypeFlags (i, &typeFlags); if (FAILED (hr)) codedComError ("Error retrieving type flags", hr); // look for [source, default] if ((typeFlags & IMPLTYPEFLAG_FSOURCE) && (typeFlags & IMPLTYPEFLAG_FDEFAULT)) { eventTypeInfoNdx = i; break; } } if (eventTypeInfoNdx == -1) return NULL; hr = pCoclassTypeInfo->GetRefTypeOfImplType (eventTypeInfoNdx, &hRefType); if (FAILED (hr)) codedComError ("Error retrieving type info handle", hr); hr = pCoclassTypeInfo->GetRefTypeInfo (hRefType, &pEventTypeInfo); if (FAILED (hr)) codedComError ("Error retrieving event type info", hr); return pEventTypeInfo; } ITypeInfo *eventTypeInfoFromComObject (MX_COM_Object *obj) { HRESULT hr; IDispatch *pIDispatch; ITypeInfo *pCoclassTypeInfo, *pEventTypeInfo; IProvideClassInfo *pIProvideClassInfo; pEventTypeInfo = obj->pEventTypeInfo; if (pEventTypeInfo) return pEventTypeInfo; pIDispatch = obj->pIDispatch; /* preferred mechanism for finding coclass ITypeInfo */ hr = pIDispatch->QueryInterface (IID_IProvideClassInfo, (void **)&pIProvideClassInfo); if (SUCCEEDED (hr) && pIProvideClassInfo != NULL) { hr = pIProvideClassInfo->GetClassInfo (&pCoclassTypeInfo); if (FAILED (hr) || pCoclassTypeInfo == NULL) scheme_signal_error ("Error getting coclass type information"); } else if (hr == E_NOINTERFACE) { ITypeInfo *pDispatchTypeInfo; /* alternate mechanism */ hr = pIDispatch->GetTypeInfo (0, LOCALE_SYSTEM_DEFAULT, &pDispatchTypeInfo); if (FAILED (hr)) codedComError ("Can't get dispatch type information", hr); pCoclassTypeInfo = coclassTypeInfoFromTypeInfo (pDispatchTypeInfo, obj->clsId); pDispatchTypeInfo->Release(); if (pCoclassTypeInfo == NULL) scheme_signal_error ("Error getting coclass type information"); } else codedComError ("Error getting COM event type information", hr); // have type info for coclass // event type info is one of the "implemented" interfaces pEventTypeInfo = eventTypeInfoFromCoclassTypeInfo (pCoclassTypeInfo); pCoclassTypeInfo->Release(); if (pEventTypeInfo == NULL) scheme_signal_error ("Error retrieving event type info"); obj->pEventTypeInfo = pEventTypeInfo; return pEventTypeInfo; } ITypeInfo *eventTypeInfoFromComType (MX_COM_Type *obj) { ITypeInfo *pCoclassTypeInfo, *pEventTypeInfo; pCoclassTypeInfo = coclassTypeInfoFromTypeInfo (obj->pITypeInfo, obj->clsId); if (pCoclassTypeInfo == NULL) scheme_signal_error ("Error getting coclass type information"); // have type info for coclass // event type info is one of the "implemented" interfaces pEventTypeInfo = eventTypeInfoFromCoclassTypeInfo (pCoclassTypeInfo); pCoclassTypeInfo->Release(); if (pEventTypeInfo == NULL) scheme_signal_error ("Error retrieving event type info"); return pEventTypeInfo; } Scheme_Object *mx_com_events (int argc, Scheme_Object **argv) { HRESULT hr; ITypeInfo *pEventTypeInfo; TYPEATTR *pEventTypeAttr; FUNCDESC *pFuncDesc; Scheme_Object *retval; UINT nameCount; BSTR bstr; UINT i; GUARANTEE_COM_OBJ_OR_TYPE ("com-events", 0); pEventTypeInfo = MX_COM_TYPEP (argv[0]) ? eventTypeInfoFromComType ((MX_COM_Type *)argv[0]) : (MX_COM_OBJ_VAL (argv[0]) == NULL) ? (scheme_signal_error ("com-events: NULL COM object"), (ITypeInfo *) NULL) : eventTypeInfoFromComObject ((MX_COM_Object *)argv[0]); // query for outbound interface info if (pEventTypeInfo == NULL) scheme_signal_error ("Can't find event type information"); hr = pEventTypeInfo->GetTypeAttr (&pEventTypeAttr); if (FAILED (hr) || pEventTypeAttr == NULL) codedComError ("Error retrieving event type attributes", hr); retval = scheme_null; for (i = 0; i < pEventTypeAttr->cFuncs; i++) { pEventTypeInfo->GetFuncDesc (i, &pFuncDesc); pEventTypeInfo->GetNames (pFuncDesc->memid, &bstr, 1, &nameCount); retval = scheme_make_pair (BSTRToSchemeString (bstr), retval); SysFreeString (bstr); } pEventTypeInfo->ReleaseFuncDesc (pFuncDesc); pEventTypeInfo->ReleaseTypeAttr (pEventTypeAttr); return retval; } VARTYPE getVarTypeFromElemDesc (ELEMDESC * pElemDesc) { unsigned short flags = pElemDesc->paramdesc.wParamFlags; return (flags & PARAMFLAG_FOPT) && (flags & PARAMFLAG_FHASDEFAULT) ? pElemDesc->paramdesc.pparamdescex->varDefaultValue.vt : pElemDesc->tdesc.vt == VT_PTR ? pElemDesc->tdesc.lptdesc->vt | VT_BYREF : pElemDesc->tdesc.vt; } Scheme_Object *elemDescToSchemeType (ELEMDESC *pElemDesc, BOOL ignoreByRef, BOOL isOpt) { static char buff[256]; char *s; BOOL isBox; VARTYPE vt; vt = getVarTypeFromElemDesc (pElemDesc); if (ignoreByRef) vt &= ~VT_BYREF; isBox = FALSE; switch (vt) { case VT_HRESULT : case VT_NULL : s = "void"; break; case VT_UI1 : s = "char"; break; case VT_UI1 | VT_BYREF : s = "char"; isBox = TRUE; break; case VT_UI2 : s = "unsigned-short"; break; case VT_UI2 | VT_BYREF : s = "unsigned-short"; isBox = TRUE; break; case VT_UI4 : case VT_UINT : s = "unsigned-int"; break; case VT_UI4 | VT_BYREF : case VT_UINT | VT_BYREF : s = "unsigned-int"; isBox = TRUE; break; case VT_UI8 : s = "unsigned-long-long"; break; case VT_UI8 | VT_BYREF : s = "unsigned-long-long"; isBox = TRUE; break; case VT_I1 : s = "signed-char"; break; case VT_I1 | VT_BYREF : s = "signed-char"; isBox = TRUE; break; case VT_I2 : s = "short-int"; break; case VT_I2 + VT_BYREF : s = "short-int"; isBox = TRUE; break; case VT_I4 : case VT_INT : s = "int"; break; case VT_I4 | VT_BYREF: case VT_INT | VT_BYREF: s = "int"; isBox = TRUE; break; case VT_I8 : s = "long-long"; break; case VT_I8 | VT_BYREF : s = "long-long"; isBox = TRUE; break; case VT_R4 : s = "float"; break; case VT_R4 | VT_BYREF : s = "float"; isBox = TRUE; break; case VT_R8 : s = "double"; break; case VT_R8 | VT_BYREF : s = "double"; isBox = TRUE; break; case VT_BSTR : s = "string"; break; case VT_BSTR | VT_BYREF : s = "string"; isBox = TRUE; break; case VT_CY : s = "mx-currency"; break; case VT_CY | VT_BYREF : s = "mx-currency"; isBox = TRUE; break; case VT_DATE : s = "mx-date"; break; case VT_DATE | VT_BYREF : s = "mx-date"; isBox = TRUE; break; case VT_BOOL : s = "boolean"; break; case VT_BOOL | VT_BYREF : s = "boolean"; isBox = FALSE; break; case VT_ERROR : s = "mx-scode"; break; case VT_ERROR | VT_BYREF: s = "mx-scode"; isBox = TRUE; break; case VT_UNKNOWN : s = "mx-unknown-com-object"; break; case VT_UNKNOWN | VT_BYREF : s = "mx-unknown-com-object"; isBox = TRUE; break; case VT_DISPATCH : s = "com-object"; break; case VT_DISPATCH | VT_BYREF : s = "com-object"; isBox = TRUE; break; case VT_VARIANT : s = "mx-any"; break; case VT_VARIANT | VT_BYREF : s = "mx-any"; isBox = FALSE; // Yes, FALSE. break; case VT_USERDEFINED : // Reporting this as `user-defined' is sure to confuse somebody. // The convention is that these are ENUMs that the caller and the // callee have agreed upon. For our purposes, they will be INTs, // but we'll report them as an enumeration. // s = "user-defined"; s = "com-enumeration"; break; case VT_USERDEFINED | VT_BYREF: // Reporting this as `user-defined-box' is sure to confuse somebody. // The convention is that these represent specific COM interfaces // that the caller and callee have agreed upon. For our purposes, // it is an IUnknown pointer. // s = "user-defined"; // isBox = TRUE; s = "mx-unknown-com-object"; break; case VT_VOID : s = "void"; break; default : { char defaultBuff[32]; sprintf (defaultBuff, "COM-0x%X", vt); return scheme_intern_symbol (defaultBuff); } } if (isBox) { if (isOpt) sprintf (buff, "%s-box-opt", s); else sprintf (buff, "%s-box", s); } else { if (isOpt) sprintf (buff, "%s-opt", s); else strcpy (buff, s); } return scheme_intern_exact_symbol (buff, (unsigned int)strlen (buff)); } Scheme_Object * mx_make_function_type (Scheme_Object *paramTypes, Scheme_Object *returnType) { return scheme_append (paramTypes, scheme_make_pair (scheme_intern_symbol ("->"), scheme_make_pair (returnType, scheme_null))); } BOOL isDefaultParam (FUNCDESC *pFuncDesc, short int i) { unsigned short flags; if (pFuncDesc->lprgelemdescParam == NULL) return FALSE; flags = pFuncDesc->lprgelemdescParam[i].paramdesc.wParamFlags; return ((flags & PARAMFLAG_FOPT) && (flags & PARAMFLAG_FHASDEFAULT)); } BOOL isOptionalParam (FUNCDESC *pFuncDesc, short int i) { unsigned short flags; if (pFuncDesc->lprgelemdescParam == NULL) return FALSE; flags = pFuncDesc->lprgelemdescParam[i].paramdesc.wParamFlags; return (flags & PARAMFLAG_FOPT); } short getOptParamCount (FUNCDESC *pFuncDesc, short hi) { short i; short numOptParams; numOptParams = 0; for (i = hi; i >= 0; i--) if (isOptionalParam (pFuncDesc, i)) numOptParams++; return numOptParams; } BOOL isLastParamRetval (short int numParams, INVOKEKIND invKind, FUNCDESC *pFuncDesc) { return (numParams > 0 && (invKind == INVOKE_PROPERTYGET || invKind == INVOKE_FUNC) && (pFuncDesc->lprgelemdescParam[numParams-1].paramdesc.wParamFlags & PARAMFLAG_FRETVAL)); } Scheme_Object *mx_do_get_method_type (int argc, Scheme_Object **argv, INVOKEKIND invKind) { MX_TYPEDESC *pTypeDesc; ITypeInfo* pITypeInfo; FUNCDESC *pFuncDesc; VARDESC *pVarDesc; Scheme_Object *s, *paramTypes, *returnType; const char *name; short int numActualParams; short int numOptParams; short int firstOptArg; short int hiBound; BOOL lastParamIsRetval; int i; GUARANTEE_COM_OBJ_OR_TYPE ("com-method-type", 0); if (MX_COM_OBJ_VAL (argv[0]) == NULL) scheme_signal_error ("NULL COM object"); name = schemeToMultiByte (GUARANTEE_STRSYM ("com-method-type", 1)); if (invKind == INVOKE_FUNC && isDispatchName (name)) scheme_signal_error ("com-method-type: IDispatch methods not available"); if (MX_COM_OBJP (argv[0])) pTypeDesc = getMethodType ((MX_COM_Object *)argv[0], name, invKind); else { pITypeInfo = invKind == INVOKE_EVENT ? eventTypeInfoFromComType ((MX_COM_Type *)argv[0]) : MX_COM_TYPE_VAL (argv[0]); pTypeDesc = typeDescFromTypeInfo (name, invKind, pITypeInfo); } // pTypeDesc may be NULL if there is no type info. if (pTypeDesc == NULL) return scheme_false; if (pTypeDesc->descKind == funcDesc) { pFuncDesc = pTypeDesc->funcdescs.pFuncDesc; paramTypes = scheme_null; numActualParams = pFuncDesc->cParams; if (pFuncDesc->cParamsOpt == -1) { // all args > pFuncDesc->cParams - 1 get packaged into SAFEARRAY // this branch is untested lastParamIsRetval = FALSE; paramTypes = scheme_make_pair (scheme_intern_symbol ("..."), paramTypes); for (i = numActualParams - 1; i >= 0; i--) { s = elemDescToSchemeType (&pFuncDesc->lprgelemdescParam[i], FALSE, FALSE); paramTypes = scheme_make_pair (s, paramTypes); } } else { lastParamIsRetval = isLastParamRetval (numActualParams, invKind, pFuncDesc); hiBound = numActualParams - (lastParamIsRetval ? 2 : 1); // parameters that are optional with a default value in IDL are not // counted in pFuncDesc->cParamsOpt, so look for default bit flag numOptParams = getOptParamCount (pFuncDesc, hiBound); firstOptArg = hiBound - numOptParams + 1; for (i = hiBound; i >= 0; i--) { s = elemDescToSchemeType (&pFuncDesc->lprgelemdescParam[i], FALSE, i >= firstOptArg); paramTypes = scheme_make_pair (s, paramTypes); } } } // if not a function type, distinguish varDesc's // by invKind else if (invKind == INVOKE_PROPERTYGET) { pVarDesc = pTypeDesc->pVarDesc; paramTypes = scheme_null; numActualParams = 0; } else if (invKind == INVOKE_PROPERTYPUT) { pVarDesc = pTypeDesc->pVarDesc; paramTypes = scheme_make_pair (elemDescToSchemeType (&pVarDesc->elemdescVar, FALSE, FALSE), scheme_null); numActualParams = 1; } switch (invKind) { case INVOKE_FUNC : // if final parameter is marked as retval, use its type returnType = lastParamIsRetval ? elemDescToSchemeType (&pFuncDesc->lprgelemdescParam[numActualParams-1], TRUE, FALSE) : elemDescToSchemeType (&pFuncDesc->elemdescFunc, TRUE, FALSE); break; case INVOKE_EVENT : case INVOKE_PROPERTYPUT : returnType = scheme_intern_symbol ("void"); break; case INVOKE_PROPERTYGET : // pTypeDesc->descKind may be either funcDesc or varDesc if (pTypeDesc->descKind == funcDesc) returnType = (lastParamIsRetval == FALSE || pFuncDesc->cParams == 0) ? elemDescToSchemeType (&pFuncDesc->elemdescFunc, TRUE, FALSE) : elemDescToSchemeType (&pFuncDesc->lprgelemdescParam[numActualParams-1], TRUE, FALSE); else // pTypeDesc->descKind == varDesc returnType = elemDescToSchemeType (&pVarDesc->elemdescVar, TRUE, FALSE); break; } return mx_make_function_type (paramTypes, returnType); } Scheme_Object *mx_com_method_type (int argc, Scheme_Object **argv) { return mx_do_get_method_type (argc, argv, INVOKE_FUNC); } Scheme_Object *mx_com_get_property_type (int argc, Scheme_Object **argv) { return mx_do_get_method_type (argc, argv, INVOKE_PROPERTYGET); } Scheme_Object *mx_com_set_property_type (int argc, Scheme_Object **argv) { return mx_do_get_method_type (argc, argv, INVOKE_PROPERTYPUT); } Scheme_Object *mx_com_event_type (int argc, Scheme_Object **argv) { return mx_do_get_method_type (argc, argv, (INVOKEKIND)INVOKE_EVENT); } BOOL schemeValueFitsVarType (Scheme_Object *val, VARTYPE vt) { long int longInt; unsigned long uLongInt; switch (vt) { case VT_NULL : return SCHEME_VOIDP (val); case VT_I1 : case VT_UI1 : return SCHEME_CHARP (val); case VT_I2 : return SCHEME_INTP (val) && scheme_get_int_val (val, &longInt) && longInt <= SHRT_MAX && longInt >= SHRT_MIN; case VT_UI2 : return SCHEME_INTP (val) && scheme_get_unsigned_int_val (val, &uLongInt) && uLongInt <= USHRT_MAX; case VT_I4 : case VT_INT : return SCHEME_EXACT_INTEGERP (val) && scheme_get_int_val (val, &longInt); case VT_UI4 : case VT_UINT : return SCHEME_EXACT_INTEGERP (val) && scheme_get_unsigned_int_val (val, &uLongInt); case VT_R4 : return SCHEME_FLTP (val) || (SCHEME_DBLP (val) && SCHEME_DBL_VAL (val) >= FLT_MIN && SCHEME_DBL_VAL (val) <= FLT_MAX); case VT_R8 : return SCHEME_DBLP (val); case VT_BSTR : return SCHEME_STRSYMP (val); case VT_CY : return MX_CYP (val); case VT_DATE : return MX_DATEP (val); case VT_BOOL : return TRUE; // ain't Scheme great case VT_ERROR : return MX_SCODEP (val); case VT_UNKNOWN : return MX_IUNKNOWNP (val); case VT_DISPATCH : return MX_COM_OBJP (val); case VT_VARIANT : // we can package anything into a VARIANTARG return TRUE; case VT_USERDEFINED : return TRUE; default : return FALSE; } } BOOL subArrayFitsVarType (Scheme_Object *val, unsigned short numDims, SAFEARRAYBOUND *bounds, VARTYPE vt) { Scheme_Object **els; unsigned long len; if (SCHEME_VECTORP (val) == FALSE) return FALSE; len = SCHEME_VEC_SIZE (val); if (len != bounds->cElements) return FALSE; els = SCHEME_VEC_ELS (val); if (numDims == 1) { // innermost vector for (unsigned long i = 0; i < len; i++) if (schemeValueFitsVarType (els[i], vt) == FALSE) return FALSE; } else { for (unsigned long i = 0; i < len; i++) // recursion, the programmer's best friend if (subArrayFitsVarType (els[i], numDims - 1, bounds + 1, vt) == FALSE) return FALSE; } return TRUE; } BOOL schemeValueFitsElemDesc (Scheme_Object *val, ELEMDESC *pElemDesc) { unsigned short flags; // if default available, check value has appropriate type flags = pElemDesc->paramdesc.wParamFlags; if (flags & PARAMFLAG_FOPT) { if (val == mx_omit_obj) return TRUE; if (flags & PARAMFLAG_FHASDEFAULT) return schemeValueFitsVarType (val, pElemDesc->paramdesc.pparamdescex->varDefaultValue.vt); } // if array, check we have a vector of proper dimension and contained types if (pElemDesc->tdesc.vt & VT_ARRAY) { return subArrayFitsVarType (val, pElemDesc->tdesc.lpadesc->cDims, pElemDesc->tdesc.lpadesc->rgbounds, pElemDesc->tdesc.lpadesc->tdescElem.vt); } // if box, check the contained value if (pElemDesc->tdesc.vt == VT_PTR) { // A VT_PTR to a VT_USERDEFINED isn't a box, it's // an IUnknown. return (pElemDesc->tdesc.lptdesc->vt == VT_VARIANT) ? TRUE : (pElemDesc->tdesc.lptdesc->vt == VT_USERDEFINED) ? (MX_COM_OBJP (val) || MX_IUNKNOWNP (val)) : (SCHEME_BOXP (val) && schemeValueFitsVarType (SCHEME_BOX_VAL (val), pElemDesc->tdesc.lptdesc->vt)); } // not array or box or default value return schemeValueFitsVarType (val, pElemDesc->tdesc.vt); } VARIANT_BOOL schemeValToBool (Scheme_Object *val) { return SCHEME_FALSEP (val) ? 0 : 0xFFFF; } VARTYPE schemeValueToVarType (Scheme_Object *obj) { // test for global constants if (SCHEME_FALSEP (obj)) return VT_BOOL; if (SCHEME_VOIDP (obj)) return VT_NULL; // handle fixnums if (SCHEME_INTP (obj)) return VT_I4; // otherwise, dispatch on value type switch (obj->type) { case scheme_char_type : return VT_UI1; case scheme_integer_type : return VT_I4; case scheme_float_type : return VT_R4; case scheme_double_type : return VT_R8; case scheme_symbol_type : case scheme_char_string_type : case scheme_byte_string_type : return VT_BSTR; case scheme_vector_type : // may need to specify elt type return VT_ARRAY; } scheme_signal_error ("Unable to coerce value to VARIANT"); return 0; // keep compiler happy } void *allocParamMemory (size_t n) { void *retval; // do we need a semaphore here? retval = scheme_malloc (n); scheme_dont_gc_ptr (retval); return retval; } void marshalSchemeValueToVariant (Scheme_Object *val, VARIANTARG *pVariantArg) { // called when COM type spec allows any VARIANT // or when COM type spec is unknown if (SCHEME_CHARP (val)) { pVariantArg->vt = VT_UI1; pVariantArg->bVal = SCHEME_CHAR_VAL (val); } else if (SCHEME_EXACT_INTEGERP (val)) { pVariantArg->vt = VT_I4; scheme_get_int_val (val, &pVariantArg->lVal); } #ifdef MZ_USE_SINGLE_FLOATS else if (SCHEME_FLTP (val)) { pVariantArg->vt = VT_R4; pVariantArg->fltVal = SCHEME_FLT_VAL (val); } #endif else if (SCHEME_DBLP (val)) { pVariantArg->vt = VT_R8; pVariantArg->dblVal = SCHEME_DBL_VAL (val); } else if (SCHEME_STRSYMP (val)) { pVariantArg->vt = VT_BSTR; pVariantArg->bstrVal = schemeToBSTR (val); } else if (MX_CYP (val)) { pVariantArg->vt = VT_CY; pVariantArg->cyVal = MX_CY_VAL (val); } else if (MX_DATEP (val)) { pVariantArg->vt = VT_DATE; pVariantArg->date = MX_DATE_VAL (val); } else if (val == scheme_false) { pVariantArg->vt = VT_BOOL; pVariantArg->boolVal = 0; } else if (val == scheme_true) { pVariantArg->vt = VT_BOOL; pVariantArg->boolVal = -1; } else if (MX_SCODEP (val)) { pVariantArg->vt = VT_ERROR; pVariantArg->scode = MX_SCODE_VAL (val); } else if (MX_COM_OBJP (val)) { pVariantArg->pdispVal = MX_COM_OBJ_VAL (val); pVariantArg->vt = VT_DISPATCH; } else if (MX_IUNKNOWNP (val)) { pVariantArg->vt = VT_UNKNOWN; pVariantArg->punkVal = MX_IUNKNOWN_VAL (val); } else if (SCHEME_VECTORP (val)) { pVariantArg->vt = VT_ARRAY | VT_VARIANT; pVariantArg->parray = schemeVectorToSafeArray (val); } else if (scheme_apply (mx_marshal_raw_scheme_objects, 0, NULL) == scheme_false) scheme_signal_error ("Unable to inject Scheme value %V into VARIANT", val); else { pVariantArg->vt = VT_INT; pVariantArg->intVal = PtrToInt (val); } return; } void marshalSchemeValue (Scheme_Object *val, VARIANTARG *pVariantArg) { char errBuff[128]; if (pVariantArg->vt & VT_ARRAY) pVariantArg->parray = schemeVectorToSafeArray (val); switch (pVariantArg->vt) { case VT_NULL : break; case VT_I1 : pVariantArg->cVal = SCHEME_CHAR_VAL (val); break; case VT_I1 | VT_BYREF : pVariantArg->pcVal = (char *)allocParamMemory (sizeof (char)); *pVariantArg->pcVal = SCHEME_CHAR_VAL (SCHEME_BOX_VAL (val)); break; case VT_UI1 : pVariantArg->bVal = SCHEME_CHAR_VAL (val); break; case VT_UI1 | VT_BYREF : pVariantArg->pbVal = (unsigned char *)allocParamMemory (sizeof (unsigned char)); *pVariantArg->pbVal = (unsigned char)SCHEME_CHAR_VAL (SCHEME_BOX_VAL (val)); break; case VT_I2 : pVariantArg->iVal = (short)SCHEME_INT_VAL (val); break; case VT_I2 | VT_BYREF : pVariantArg->piVal = (short *)allocParamMemory (sizeof (short)); *pVariantArg->piVal = (short)SCHEME_INT_VAL (SCHEME_BOX_VAL (val)); break; case VT_UI2 : pVariantArg->uiVal = (unsigned short)SCHEME_INT_VAL (val); break; case VT_UI2 | VT_BYREF : pVariantArg->puiVal = (unsigned short *)allocParamMemory (sizeof (unsigned short)); *pVariantArg->puiVal = (unsigned short)SCHEME_INT_VAL (SCHEME_BOX_VAL (val)); break; case VT_I4 : pVariantArg->lVal = SCHEME_INT_VAL (val); break; case VT_I4 | VT_BYREF : pVariantArg->plVal = (long *)allocParamMemory (sizeof (long)); *pVariantArg->plVal = (long)SCHEME_INT_VAL (SCHEME_BOX_VAL (val)); break; case VT_UI4 : pVariantArg->ulVal = SCHEME_INT_VAL (val); break; case VT_UI4 | VT_BYREF : pVariantArg->pulVal = (unsigned long *)allocParamMemory (sizeof (unsigned long)); *pVariantArg->pulVal = (unsigned long)SCHEME_INT_VAL (SCHEME_BOX_VAL (val)); break; case VT_INT : pVariantArg->intVal = SCHEME_INT_VAL (val); break; case VT_INT | VT_BYREF : pVariantArg->pintVal = (int *)allocParamMemory (sizeof (long)); *pVariantArg->pintVal = (int)SCHEME_INT_VAL (SCHEME_BOX_VAL (val)); break; case VT_UINT : pVariantArg->uintVal = SCHEME_INT_VAL (val); break; case VT_UINT | VT_BYREF : pVariantArg->puintVal = (unsigned int *)allocParamMemory (sizeof (long)); *pVariantArg->puintVal = (unsigned int)SCHEME_INT_VAL (SCHEME_BOX_VAL (val)); break; // VT_USERDEFINED in the typeDesc indicates an ENUM, // but VT_USERDEFINED is illegal to use in the DISPPARAMS. // The right thing to do is pass it as an INT. Note that // we have to bash out the variant tag. // ** NOTE THAT VT_USERDEFINED | VT_BYREF IS NOT // ** A REFERENCE TO AN INT case VT_USERDEFINED: pVariantArg->vt = VT_INT; pVariantArg->intVal = SCHEME_INT_VAL (val); break; case VT_R4 : pVariantArg->fltVal = (float)SCHEME_DBL_VAL (val); break; case VT_R4 | VT_BYREF : pVariantArg->pfltVal = (float *)allocParamMemory (sizeof (float)); *pVariantArg->pfltVal = (float)SCHEME_DBL_VAL (SCHEME_BOX_VAL (val)); break; case VT_R8 : pVariantArg->dblVal = SCHEME_DBL_VAL (val); break; case VT_R8 | VT_BYREF : pVariantArg->pdblVal = (double *)allocParamMemory (sizeof (double)); *pVariantArg->pdblVal = (double)SCHEME_DBL_VAL (SCHEME_BOX_VAL (val)); break; case VT_BSTR : pVariantArg->bstrVal = schemeToBSTR (val); break; case VT_BSTR | VT_BYREF : pVariantArg->pbstrVal = (BSTR *)allocParamMemory (sizeof (BSTR)); *pVariantArg->pbstrVal = schemeToBSTR (val); break; case VT_CY : pVariantArg->cyVal = MX_CY_VAL (val); break; case VT_CY | VT_BYREF : pVariantArg->pcyVal = (CY *)allocParamMemory (sizeof (CY)); *pVariantArg->pcyVal = (CY)MX_CY_VAL (val); break; case VT_DATE : pVariantArg->date = MX_DATE_VAL (val); break; case VT_DATE | VT_BYREF : pVariantArg->pdate = (DATE *)allocParamMemory (sizeof (DATE)); *pVariantArg->pdate = (DATE)MX_DATE_VAL (val); break; case VT_BOOL : pVariantArg->boolVal = schemeValToBool (val); break; case VT_BOOL | VT_BYREF : pVariantArg->pboolVal = (VARIANT_BOOL *)allocParamMemory (sizeof (VARIANT_BOOL)); *pVariantArg->pboolVal = schemeValToBool (val); break; case VT_ERROR : pVariantArg->scode = MX_SCODE_VAL (val); break; case VT_ERROR | VT_BYREF : pVariantArg->pscode = (SCODE *)allocParamMemory (sizeof (SCODE)); *pVariantArg->pscode = MX_SCODE_VAL (SCHEME_BOX_VAL (val)); break; case VT_DISPATCH : pVariantArg->pdispVal = MX_COM_OBJ_VAL (val); break; case VT_DISPATCH | VT_BYREF : pVariantArg->ppdispVal = (IDispatch **)allocParamMemory (sizeof (IDispatch *)); *pVariantArg->ppdispVal = MX_COM_OBJ_VAL (SCHEME_BOX_VAL (val)); break; // VT_USERDEFINED | VT_BYREF indicates that we should pass // the IUnknown pointer of a COM object. // VT_USERDEFINED | VT_BYREF is illegal in the DISPPARAMS, so // we bash it out to VT_UNKNOWN. case VT_USERDEFINED | VT_BYREF : pVariantArg->vt = VT_UNKNOWN; if (MX_COM_OBJP (val)) // shouldn't fail MX_COM_OBJ_VAL (val)->QueryInterface (IID_IUnknown, (void **)&pVariantArg->punkVal); else if (MX_IUNKNOWNP (val)) pVariantArg->punkVal = MX_COM_OBJ_VAL (val); // should never happen else scheme_signal_error ("Attempt to marshal non-com object into VT_USERDEFINED"); break; case VT_VARIANT | VT_BYREF : // pass boxed value of almost-arbitrary type pVariantArg->pvarVal = (VARIANTARG *) allocParamMemory (sizeof (VARIANTARG)); pVariantArg->pvarVal->vt = schemeValueToVarType (val); marshalSchemeValue (val, pVariantArg->pvarVal); break; case VT_UNKNOWN : pVariantArg->punkVal = MX_IUNKNOWN_VAL (val); break; case VT_UNKNOWN | VT_BYREF : pVariantArg->ppunkVal = (IUnknown **)allocParamMemory (sizeof (IUnknown *)); *pVariantArg->ppunkVal = MX_IUNKNOWN_VAL (SCHEME_BOX_VAL (val)); break; case VT_VARIANT : marshalSchemeValueToVariant (val, pVariantArg); break; case VT_PTR: scheme_signal_error ("unable to marshal VT_PTR"); break; default : sprintf (errBuff, "Unable to marshal Scheme value into VARIANT: 0x%X", pVariantArg->vt); scheme_signal_error (errBuff); } } Scheme_Object *variantToSchemeObject (VARIANTARG *pVariantArg) { char errBuff[128]; if (pVariantArg->vt & VT_ARRAY) return safeArrayToSchemeVector (pVariantArg->parray); switch (pVariantArg->vt) { case VT_EMPTY : case VT_NULL : return scheme_void; case VT_I1 : return scheme_make_char (pVariantArg->cVal); case VT_I2 : return scheme_make_integer_value (pVariantArg->iVal); case VT_I4 : return scheme_make_integer (pVariantArg->lVal); case VT_I8 : return scheme_make_integer_value_from_long_long (pVariantArg->llVal); case VT_UI1 : return scheme_make_char ((char) (pVariantArg->bVal)); case VT_UI2 : return scheme_make_integer (pVariantArg->uiVal); case VT_UI4 : return scheme_make_integer_value_from_unsigned (pVariantArg->ulVal); case VT_UI8 : return scheme_make_integer_value_from_unsigned_long_long (pVariantArg->ullVal); case VT_INT : return scheme_make_integer (pVariantArg->intVal); case VT_UINT : return scheme_make_integer_value_from_unsigned (pVariantArg->uintVal); case VT_R4 : #ifdef MZ_USE_SINGLE_FLOATS return scheme_make_float (pVariantArg->fltVal); #else return scheme_make_double ((double) (pVariantArg->fltVal)); #endif case VT_R8 : return scheme_make_double (pVariantArg->dblVal); case VT_BSTR : return unmarshalBSTR (pVariantArg->bstrVal); case VT_CY : return mx_make_cy (&pVariantArg->cyVal); case VT_DATE : return mx_make_date (&pVariantArg->date); case VT_BOOL : return mx_make_bool (pVariantArg->boolVal); case VT_ERROR : return mx_make_scode (pVariantArg->scode); case VT_DISPATCH : return mx_make_idispatch (pVariantArg->pdispVal); case VT_UNKNOWN : return mx_make_iunknown (pVariantArg->punkVal); default : sprintf (errBuff, "Can't make Scheme value from VARIANT 0x%X", pVariantArg->vt); scheme_signal_error (errBuff); } return NULL; } // we need this for direct calls, where the return value // is created by passing as a C pointer, which is stored in a VARIANTARG Scheme_Object *retvalVariantToSchemeObject (VARIANTARG *pVariantArg) { switch (pVariantArg->vt) { case VT_HRESULT : case VT_VOID : return scheme_void; case VT_BYREF|VT_UI1 : return scheme_make_char (*pVariantArg->pcVal); case VT_BYREF|VT_I2 : return scheme_make_integer (*pVariantArg->piVal); case VT_BYREF|VT_I4 : return scheme_make_integer_value (*pVariantArg->plVal); case VT_BYREF|VT_I8 : return scheme_make_integer_value_from_long_long (*pVariantArg->pllVal); case VT_BYREF|VT_R4 : #ifdef MZ_USE_SINGLE_FLOATS return scheme_make_float (*pVariantArg->pfltVal); #else return scheme_make_double ((double) (*pVariantArg->pfltVal)); #endif case VT_BYREF|VT_R8 : return scheme_make_double (*pVariantArg->pdblVal); case VT_BYREF|VT_BOOL : return mx_make_bool (*pVariantArg->pboolVal); case VT_BYREF|VT_ERROR : return mx_make_scode (*pVariantArg->pscode); case VT_BYREF|VT_CY : return mx_make_cy (pVariantArg->pcyVal); case VT_BYREF|VT_DATE : return mx_make_date (pVariantArg->pdate); case VT_BYREF|VT_BSTR : return unmarshalBSTR (*pVariantArg->pbstrVal); case VT_BYREF|VT_UNKNOWN : return mx_make_iunknown (*pVariantArg->ppunkVal); case VT_BYREF|VT_PTR : case VT_BYREF|VT_DISPATCH : return mx_make_idispatch (*pVariantArg->ppdispVal); case VT_BYREF|VT_SAFEARRAY : case VT_BYREF|VT_ARRAY : return safeArrayToSchemeVector (*pVariantArg->pparray); case VT_BYREF|VT_VARIANT : return variantToSchemeObject (pVariantArg->pvarVal); case VT_BYREF|VT_I1 : return scheme_make_char (*pVariantArg->pcVal); case VT_BYREF|VT_UI2 : return scheme_make_integer_value_from_unsigned (*pVariantArg->puiVal); case VT_BYREF|VT_UI4 : return scheme_make_integer_value_from_unsigned (*pVariantArg->pulVal); case VT_BYREF|VT_UI8 : return scheme_make_integer_value_from_unsigned_long_long (*pVariantArg->pullVal); case VT_BYREF|VT_INT : return scheme_make_integer_value (*pVariantArg->pintVal); case VT_BYREF|VT_UINT : return scheme_make_integer_value_from_unsigned (*pVariantArg->puintVal); default : {char buff[128]; sprintf (buff, "Can't create return value for VARIANT 0x%X", pVariantArg->vt); scheme_signal_error (buff); } } return NULL; } void unmarshalVariant (Scheme_Object *val, VARIANTARG *pVariantArg) { switch (pVariantArg->vt) { case VT_I1 | VT_BYREF : SCHEME_BOX_VAL (val) = scheme_make_char (*pVariantArg->pcVal); scheme_gc_ptr_ok (pVariantArg->pcVal); break; case VT_UI1 | VT_BYREF : SCHEME_BOX_VAL (val) = scheme_make_char ((char) (*pVariantArg->pbVal)); scheme_gc_ptr_ok (pVariantArg->pbVal); break; case VT_I2 | VT_BYREF : SCHEME_BOX_VAL (val) = scheme_make_integer (*pVariantArg->piVal); scheme_gc_ptr_ok (pVariantArg->piVal); break; case VT_UI2 | VT_BYREF : SCHEME_BOX_VAL (val) = scheme_make_integer_value_from_unsigned (*pVariantArg->puiVal); scheme_gc_ptr_ok (pVariantArg->puiVal); break; case VT_I4 | VT_BYREF : SCHEME_BOX_VAL (val) = scheme_make_integer_value (*pVariantArg->plVal); scheme_gc_ptr_ok (pVariantArg->plVal); break; case VT_UI4 | VT_BYREF : SCHEME_BOX_VAL (val) = scheme_make_integer_value_from_unsigned (*pVariantArg->pulVal); scheme_gc_ptr_ok (pVariantArg->pulVal); break; case VT_INT | VT_BYREF : SCHEME_BOX_VAL (val) = scheme_make_integer_value (*pVariantArg->pintVal); scheme_gc_ptr_ok (pVariantArg->pintVal); break; case VT_UINT | VT_BYREF : SCHEME_BOX_VAL (val) = scheme_make_integer_value_from_unsigned (*pVariantArg->puintVal); scheme_gc_ptr_ok (pVariantArg->puintVal); break; case VT_R4 | VT_BYREF : #ifdef MZ_USE_SINGLE_FLOATS SCHEME_BOX_VAL (val) = scheme_make_float (*pVariantArg->pfltVal); #else SCHEME_BOX_VAL (val) = scheme_make_double ((double) (*pVariantArg->pfltVal)); #endif scheme_gc_ptr_ok (pVariantArg->pfltVal); break; case VT_R8 | VT_BYREF : SCHEME_BOX_VAL (val) = scheme_make_double (*pVariantArg->pdblVal); scheme_gc_ptr_ok (pVariantArg->pdblVal); break; case VT_CY | VT_BYREF : SCHEME_BOX_VAL (val) = mx_make_cy (pVariantArg->pcyVal); scheme_gc_ptr_ok (pVariantArg->pcyVal); break; case VT_DATE | VT_BYREF : SCHEME_BOX_VAL (val) = mx_make_date (pVariantArg->pdate); scheme_gc_ptr_ok (pVariantArg->pdate); break; case VT_BOOL | VT_BYREF : SCHEME_BOX_VAL (val) = mx_make_bool (*pVariantArg->pboolVal); scheme_gc_ptr_ok (pVariantArg->pboolVal); break; case VT_ERROR | VT_BYREF : SCHEME_BOX_VAL (val) = mx_make_scode (*pVariantArg->pscode); scheme_gc_ptr_ok (pVariantArg->pscode); break; case VT_DISPATCH | VT_BYREF : SCHEME_BOX_VAL (val) = mx_make_idispatch (*pVariantArg->ppdispVal); scheme_gc_ptr_ok (pVariantArg->ppdispVal); break; case VT_UNKNOWN | VT_BYREF : SCHEME_BOX_VAL (val) = mx_make_iunknown (*pVariantArg->ppunkVal); scheme_gc_ptr_ok (pVariantArg->ppunkVal); break; case VT_VARIANT | VT_BYREF : scheme_gc_ptr_ok (pVariantArg->pvarVal); break; case VT_BSTR : // Don't try to update symbols! if (!SCHEME_SYMBOLP (val)) updateSchemeFromBSTR (val, pVariantArg->bstrVal); SysFreeString (pVariantArg->bstrVal); break; case VT_BSTR | VT_BYREF : SCHEME_BOX_VAL (val) = unmarshalBSTR (*pVariantArg->pbstrVal); SysFreeString (*pVariantArg->pbstrVal); scheme_gc_ptr_ok (pVariantArg->pbstrVal); break; default : ; // no unmarshaling or cleanup needed } } // Build the DISPPARAMS by filling out the fields // according to the Scheme type of object. // No optional or named args, no type checking. short int buildMethodArgumentsUsingDefaults (INVOKEKIND invKind, int argc, Scheme_Object **argv, DISPPARAMS *methodArguments) { short int numParamsPassed; BOOL lastParamIsRetval; int i, j, k; static DISPID dispidPropPut = DISPID_PROPERTYPUT; // First argument is object, second is name of method. numParamsPassed = argc - 2; // Need a return value if property get or invoking a function. lastParamIsRetval = (invKind == INVOKE_PROPERTYGET || invKind == INVOKE_FUNC); switch (invKind) { case INVOKE_PROPERTYPUT : // Named argument represents the assigned value methodArguments->rgdispidNamedArgs = &dispidPropPut; methodArguments->cNamedArgs = methodArguments->cArgs = 1; methodArguments->cArgs = numParamsPassed; break; case INVOKE_PROPERTYGET : methodArguments->rgdispidNamedArgs = NULL; methodArguments->cNamedArgs = 0; methodArguments->cArgs = numParamsPassed; break; default : methodArguments->rgdispidNamedArgs = NULL; methodArguments->cNamedArgs = 0; methodArguments->cArgs = numParamsPassed; break; } if (numParamsPassed > 0) { methodArguments->rgvarg = (VARIANTARG *)scheme_malloc (numParamsPassed * sizeof (VARIANTARG)); scheme_dont_gc_ptr (methodArguments->rgvarg); } // marshal Scheme argument list into COM argument list // arguments are in reverse order in rgvarg for (i = 0, j = numParamsPassed - 1, k = 2; i < argc - 2; i++, j--, k++) { // i = index of ELEMDESC's // j = index of VARIANTARG's VariantInit (&methodArguments->rgvarg[j]); if (argv[k] == mx_omit_obj) { // omitted argument methodArguments->rgvarg[j].vt = VT_ERROR; methodArguments->rgvarg[j].lVal = DISP_E_PARAMNOTFOUND; } else marshalSchemeValueToVariant (argv[k], &methodArguments->rgvarg[j]); } return numParamsPassed; } short int getLcidParamIndex (FUNCDESC *pFuncDesc, short int numParams) { ELEMDESC *pElemDescs; int i; pElemDescs = pFuncDesc->lprgelemdescParam; for (i = 0; i < numParams; i++) { if (pElemDescs[i].paramdesc.wParamFlags & PARAMFLAG_FLCID) return i; } return NO_LCID; } void checkArgTypesAndCounts (FUNCDESC *pFuncDesc, BOOL direct, INVOKEKIND invKind, int argc, Scheme_Object **argv, MX_ARGS_COUNT *argsCount) { char errBuff[256]; short int numParamsPassed; short int numOptParams; short int lcidIndex; int i, j, k; numParamsPassed = pFuncDesc->cParams; argsCount->retvalInParams = isLastParamRetval (numParamsPassed, invKind, pFuncDesc); if (argsCount->retvalInParams) numParamsPassed--; numOptParams = getOptParamCount (pFuncDesc, numParamsPassed - 1); lcidIndex = NO_LCID; if (direct) { lcidIndex = getLcidParamIndex (pFuncDesc, numParamsPassed); if (lcidIndex != NO_LCID) numParamsPassed--; } argsCount->lcidIndex = lcidIndex; argsCount->numParamsPassed = numParamsPassed; argsCount->numOptParams = numOptParams; if (pFuncDesc->cParamsOpt == -1) { // last args get packaged into SAFEARRAY // this branch is untested // optional parameters with default values not counted in pFuncDesc->cParamsOpt if (argc < numParamsPassed + 2 - 1) { sprintf (errBuff, "%s (%s \"%s\")", mx_fun_string (invKind), inv_kind_string (invKind), schemeToText (argv[1])); scheme_wrong_count (errBuff, numParamsPassed-1, -1, argc-2, argv+2); } } else { // optional parameters with default values // not counted in pFuncDesc->cParamsOpt if (argc < numParamsPassed - numOptParams + 2 || // too few argc > numParamsPassed + 2) { // too many sprintf (errBuff, "%s (%s \"%s\")", mx_fun_string (invKind), inv_kind_string (invKind), schemeToText (argv[1])); scheme_wrong_count (errBuff, numParamsPassed-numOptParams, numParamsPassed, argc-2, argv+2); } } // compare types of actual arguments to prescribed types for (i = 0, j = 2, k = 0; i < argc - 2; i++, j++, k++) { // i = index of ELEMDESC's // j = index of actual args in argv if (direct && k == lcidIndex) // skip an entry k++; if (schemeValueFitsElemDesc (argv[j], &pFuncDesc->lprgelemdescParam[k]) == FALSE) { sprintf (errBuff, "%s (%s \"%s\")", mx_fun_string (invKind), inv_kind_string (invKind), schemeToText (argv[1])); scheme_wrong_type (errBuff, SCHEME_SYM_VAL (elemDescToSchemeType (&(pFuncDesc->lprgelemdescParam[k]), FALSE, FALSE)), j, argc, argv); } } } short int buildMethodArgumentsUsingFuncDesc (FUNCDESC *pFuncDesc, INVOKEKIND invKind, int argc, Scheme_Object **argv, DISPPARAMS *methodArguments) { MX_ARGS_COUNT argsCount; short int numParamsPassed; short int numOptParams; static DISPID dispidPropPut = DISPID_PROPERTYPUT; int i, j, k; checkArgTypesAndCounts (pFuncDesc, FALSE, // indirect invKind, argc, argv, &argsCount); numParamsPassed = argsCount.numParamsPassed; numOptParams = argsCount.numOptParams; switch (invKind) { case INVOKE_PROPERTYPUT : // Named argument represents the assigned value methodArguments->rgdispidNamedArgs = &dispidPropPut; methodArguments->cNamedArgs = methodArguments->cArgs = 1; methodArguments->cArgs = numParamsPassed; break; case INVOKE_PROPERTYGET : methodArguments->rgdispidNamedArgs = NULL; methodArguments->cNamedArgs = 0; methodArguments->cArgs = numParamsPassed; break; default : methodArguments->rgdispidNamedArgs = NULL; methodArguments->cNamedArgs = 0; methodArguments->cArgs = numParamsPassed; break; } if (numParamsPassed > 0) { methodArguments->rgvarg = (VARIANTARG *)scheme_malloc (numParamsPassed * sizeof (VARIANTARG)); scheme_dont_gc_ptr (methodArguments->rgvarg); } // marshal Scheme argument list into COM argument list // arguments are in reverse order in rgvarg for (i = 0, j = numParamsPassed - 1, k = 2; i < argc - 2; i++, j--, k++) { // i = index of ELEMDESC's // j = index of VARIANTARG's VariantInit (&methodArguments->rgvarg[j]); if (argv[k] == mx_omit_obj) { // omitted argument methodArguments->rgvarg[j].vt = VT_ERROR; methodArguments->rgvarg[j].lVal = DISP_E_PARAMNOTFOUND; } else { methodArguments->rgvarg[j].vt = getVarTypeFromElemDesc (&pFuncDesc->lprgelemdescParam[i]); marshalSchemeValue (argv[k], &methodArguments->rgvarg[j]); } } // omitted optional arguments // supply default if available if (numOptParams > 0) { for (i = argc - 2, j = numParamsPassed - 1 - (argc - 2); j >= 0; i++, j--) { if (isDefaultParam (pFuncDesc, i)) methodArguments->rgvarg[j] = pFuncDesc->lprgelemdescParam[i].paramdesc.pparamdescex->varDefaultValue; else { VariantInit (&methodArguments->rgvarg[j]); methodArguments->rgvarg[j].vt = VT_ERROR; methodArguments->rgvarg[j].lVal = DISP_E_PARAMNOTFOUND; } } } return numParamsPassed; } short int buildMethodArgumentsUsingVarDesc (VARDESC *pVarDesc, INVOKEKIND invKind, int argc, Scheme_Object **argv, DISPPARAMS *methodArguments) { char errBuff[256]; short int numParamsPassed; int i, j, k; static DISPID dispidPropPut = DISPID_PROPERTYPUT; numParamsPassed = (invKind == INVOKE_PROPERTYGET) ? 0 : (invKind == INVOKE_PROPERTYPUT) ? 1 : 0; if (argc != numParamsPassed + 2) { sprintf (errBuff, "%s (%s \"%s\")", mx_fun_string (invKind), inv_kind_string (invKind), schemeToText (argv[1])); scheme_wrong_count (errBuff, numParamsPassed + 2, numParamsPassed + 2, argc, argv); } switch (invKind) { case INVOKE_PROPERTYPUT : // check that value is of expected type if (schemeValueFitsElemDesc (argv[2], &pVarDesc->elemdescVar) == FALSE) { sprintf (errBuff, "%s (%s \"%s\")", mx_fun_string (invKind), inv_kind_string (invKind), schemeToText (argv[1])); scheme_wrong_type (errBuff, SCHEME_SYM_VAL (elemDescToSchemeType (&(pVarDesc->elemdescVar), FALSE, FALSE)), 2, argc, argv); } methodArguments->rgdispidNamedArgs = &dispidPropPut; methodArguments->cNamedArgs = methodArguments->cArgs = 1; break; case INVOKE_PROPERTYGET : methodArguments->rgdispidNamedArgs = NULL; methodArguments->cNamedArgs = 0; methodArguments->cArgs = numParamsPassed; break; } if (numParamsPassed > 0) { methodArguments->rgvarg = (VARIANTARG *)scheme_malloc (numParamsPassed * sizeof (VARIANTARG)); scheme_dont_gc_ptr (methodArguments->rgvarg); } // marshal Scheme argument list into COM argument list for (i = 0, j = numParamsPassed - 1, k = 2; i < numParamsPassed; i++, j--, k++) { // i = index of ELEMDESC's // j = index of VARIANTARG's VariantInit (&methodArguments->rgvarg[j]); methodArguments->rgvarg[j].vt = getVarTypeFromElemDesc (&pVarDesc->elemdescVar); marshalSchemeValue (argv[k], &methodArguments->rgvarg[j]); } return numParamsPassed; } short int buildMethodArguments (MX_TYPEDESC *pTypeDesc, INVOKEKIND invKind, int argc, Scheme_Object **argv, DISPPARAMS *methodArguments) { return (pTypeDesc == NULL) ? buildMethodArgumentsUsingDefaults (invKind, argc, argv, methodArguments) : (pTypeDesc->descKind == funcDesc) ? buildMethodArgumentsUsingFuncDesc (pTypeDesc->funcdescs.pFuncDesc, invKind, argc, argv, methodArguments) : buildMethodArgumentsUsingVarDesc (pTypeDesc->pVarDesc, invKind, argc, argv, methodArguments); } void allocateDirectRetval (VARIANT *va) { switch (va->vt) { case VT_BYREF|VT_UI1 : va->pbVal = (BYTE *)allocParamMemory (sizeof (BYTE)); break; case VT_BYREF|VT_I2 : va->piVal = (SHORT *)allocParamMemory (sizeof (SHORT)); break; case VT_BYREF|VT_I4 : va->plVal = (LONG *)allocParamMemory (sizeof (LONG)); break; case VT_BYREF|VT_I8 : va->pllVal = (LONGLONG *)allocParamMemory (sizeof (LONGLONG)); break; case VT_BYREF|VT_R4 : va->pfltVal = (FLOAT *)allocParamMemory (sizeof (FLOAT)); break; case VT_BYREF|VT_R8 : va->pdblVal = (DOUBLE *)allocParamMemory (sizeof (DOUBLE)); break; case VT_BYREF|VT_BOOL : va->pboolVal = (VARIANT_BOOL *)allocParamMemory (sizeof (VARIANT_BOOL)); break; case VT_BYREF|VT_ERROR : va->pscode = (SCODE *)allocParamMemory (sizeof (SCODE)); break; case VT_BYREF|VT_CY : va->pcyVal = (CY *)allocParamMemory (sizeof (CY)); break; case VT_BYREF|VT_DATE : va->pdate = (DATE *)allocParamMemory (sizeof (DATE)); break; case VT_BYREF|VT_BSTR : va->pbstrVal = (BSTR *)allocParamMemory (sizeof (BSTR)); break; case VT_BYREF|VT_UNKNOWN : va->ppunkVal = (IUnknown **)allocParamMemory (sizeof (IUnknown *)); break; case VT_BYREF|VT_PTR : case VT_BYREF|VT_DISPATCH : va->ppdispVal = (IDispatch **)allocParamMemory (sizeof (IDispatch *)); break; case VT_BYREF|VT_ARRAY : case VT_BYREF|VT_SAFEARRAY : va->pparray = (SAFEARRAY **)allocParamMemory (sizeof (SAFEARRAY *)); break; case VT_BYREF|VT_VARIANT : va->pvarVal = (VARIANT *)allocParamMemory (sizeof (VARIANT)); break; case VT_BYREF|VT_I1 : va->pcVal = (CHAR *)allocParamMemory (sizeof (CHAR)); break; case VT_BYREF|VT_UI2 : va->puiVal = (USHORT *)allocParamMemory (sizeof (USHORT)); break; case VT_BYREF|VT_UI4 : va->pulVal = (ULONG *)allocParamMemory (sizeof (ULONG)); break; case VT_BYREF|VT_UI8 : va->pullVal = (ULONGLONG *)allocParamMemory (sizeof (ULONGLONG)); break; case VT_BYREF|VT_INT : va->pintVal = (INT *)allocParamMemory (sizeof (INT)); break; case VT_BYREF|VT_UINT : va->puintVal = (UINT *)allocParamMemory (sizeof (UINT)); break; default : {char buff[128]; sprintf (buff, "Can't allocate return value for VARIANT 0x%X", va->vt); scheme_signal_error (buff); } } } static Scheme_Object *mx_make_direct_call (int argc, Scheme_Object **argv, INVOKEKIND invKind, IDispatch *pIDispatch, const char * name, MX_TYPEDESC *pTypeDesc) { HRESULT hr; Scheme_Object *retval; MX_ARGS_COUNT argsCount; IDispatch *pInterface; COMPTR funPtr; VARIANT retvalVa, va, *vaPtr; static VARIANT argVas[MAXDIRECTARGS]; static VARIANT optArgVas[MAXDIRECTARGS]; FUNCDESC *pFuncDesc; short numParamsPassed; short numOptParams; short lcidIndex; char buff[128]; int i, j; pFuncDesc = pTypeDesc->funcdescs.pFuncDescImpl; checkArgTypesAndCounts (pFuncDesc, TRUE, // direct invKind, argc, argv, &argsCount); numParamsPassed = argsCount.numParamsPassed; numOptParams = argsCount.numOptParams; lcidIndex = argsCount.lcidIndex; if (pTypeDesc->pInterface == NULL) { COMPTR *vtbl; hr = pIDispatch->QueryInterface (pTypeDesc->implGuid, (void **)&pInterface); if (FAILED (hr) || pInterface == NULL) { sprintf (buff, "Failed to get direct interface for call to `%s'", name); codedComError (buff, hr); } vtbl = ((COMPTR * *)pInterface)[0]; pTypeDesc->pInterface = pInterface; pTypeDesc->funPtr = funPtr = vtbl[pTypeDesc->funOffset]; } else { pInterface = pTypeDesc->pInterface; funPtr = pTypeDesc->funPtr; } // push return value ptr VariantInit (&retvalVa); retvalVa.vt = getVarTypeFromElemDesc (argsCount.retvalInParams ? &pFuncDesc->lprgelemdescParam[pFuncDesc->cParams-1] : &pFuncDesc->elemdescFunc); if (invKind != INVOKE_PROPERTYPUT && retvalVa.vt != VT_VOID && retvalVa.vt != VT_HRESULT) { retvalVa.vt |= VT_BYREF; allocateDirectRetval (&retvalVa); pushOneArg (retvalVa, buff); } // these must be macros, not functions, so that stack is maintained pushOptArgs (pFuncDesc, numParamsPassed, numOptParams, optArgVas, vaPtr, va, argc, i, j, lcidIndex, buff); pushSuppliedArgs (pFuncDesc, numParamsPassed, argc, argv, argVas, vaPtr, va, i, j, lcidIndex, buff); // push the "this" pointer before calling __asm { push pInterface; call funPtr; mov hr, eax; } if (FAILED (hr)) { char buff[128]; sprintf (buff, "COM method `%s' failed", name); codedComError (buff, hr); } // unmarshal boxed values, cleanup i = argc - 1; j = argc - 3; if (lcidIndex != NO_LCID && lcidIndex <= j + 1) j++; vaPtr = argVas + j; for ( ; j >= 0; i--, j--, vaPtr--) { if (j == lcidIndex) i++; else unmarshalVariant (argv[i], vaPtr); } if (invKind == INVOKE_PROPERTYPUT) return scheme_void; retval = retvalVariantToSchemeObject (&retvalVa); // all pointers are 32 bits, choose arbitrary one if (retvalVa.vt != VT_VOID) scheme_gc_ptr_ok (retvalVa.pullVal); return retval; } static Scheme_Object *mx_make_call (int argc, Scheme_Object **argv, INVOKEKIND invKind) { Scheme_Object *retval; MX_TYPEDESC *pTypeDesc; DISPID dispid = 0; DISPPARAMS methodArguments; VARIANT methodResult; EXCEPINFO exnInfo; unsigned int errorIndex; IDispatch *pIDispatch; const char *name; short numParamsPassed; int i, j; HRESULT hr; char buff[256]; pIDispatch = MX_COM_OBJ_VAL (GUARANTEE_COM_OBJ (mx_fun_string (invKind), 0)); if (pIDispatch == NULL) scheme_signal_error ("NULL COM object"); name = schemeToText (GUARANTEE_STRSYM (mx_fun_string (invKind), 1)); if (invKind == INVOKE_FUNC && isDispatchName (name)) { sprintf (buff, "%s: IDispatch methods may not be called", mx_fun_string (invKind)); scheme_signal_error (buff); } // check arity, types of method arguments pTypeDesc = getMethodType ((MX_COM_Object *)argv[0], name, invKind); // try direct call via function pointer // otherwise, use COM Automation if (pTypeDesc && (pTypeDesc->funOffset != NO_FUNPTR) && /* assignment */ (retval = mx_make_direct_call (argc, argv, invKind, pIDispatch, name, pTypeDesc))) return retval; if (pTypeDesc) dispid = pTypeDesc->memID; else { // If there is no pTypeDesc, then we have to wing it. // Look for a dispid for the method name. If we find it, just push // the arguments and let the COM object figure things out. // Translate the name to Unicode. OLECHAR namebuf[1024]; unsigned int len = (unsigned int)strlen (name); unsigned int count = MultiByteToWideChar (CP_ACP, (DWORD)0, name, len, namebuf, sizeray (namebuf)-1); namebuf[len] = '\0'; if (count < len) { sprintf (buff, "%s: Unable to translate name \"%s\" to Unicode", mx_fun_string (invKind), name); scheme_signal_error (buff); } LPOLESTR namearray = (LPOLESTR)&namebuf; hr = pIDispatch->GetIDsOfNames (IID_NULL, &namearray, 1, LOCALE_SYSTEM_DEFAULT, &dispid); if (FAILED (hr)) { const char *funString = mx_fun_string (invKind); switch (hr) { case E_OUTOFMEMORY : sprintf (buff, "%s: out of memory", funString); scheme_signal_error (buff); case DISP_E_UNKNOWNNAME : sprintf (buff, "%s: unknown name \"%s\"", funString, name); scheme_signal_error (buff); case DISP_E_UNKNOWNLCID : sprintf (buff, "%s: unknown LCID", funString); scheme_signal_error (buff); default : codedComError (funString, hr); } } } // Build the method arguments even if pTypeDesc is NULL. numParamsPassed = buildMethodArguments (pTypeDesc, invKind, argc, argv, &methodArguments); if (invKind != INVOKE_PROPERTYPUT) VariantInit (&methodResult); // invoke requested method hr = pIDispatch->Invoke (dispid, IID_NULL, LOCALE_SYSTEM_DEFAULT, invKind, &methodArguments, (invKind == INVOKE_PROPERTYPUT) ? NULL : &methodResult, &exnInfo, &errorIndex); if (hr == DISP_E_EXCEPTION) { char errBuff[2048]; char description[1024]; BOOL hasErrorCode; BOOL hasDescription; hasErrorCode = (exnInfo.wCode > 0); hasDescription = (exnInfo.bstrDescription != NULL); if (hasDescription) { unsigned int len; len = SysStringLen (exnInfo.bstrDescription); WideCharToMultiByte (CP_ACP, (DWORD)0, exnInfo.bstrDescription, len, description, sizeof (description)-1, NULL, NULL); description[len] = '\0'; } if (hasErrorCode) { sprintf (errBuff, "COM object exception, error code 0x%X%s%s", exnInfo.wCode, hasDescription ? "\nDescription: " : "" , hasDescription ? description : ""); scheme_signal_error (errBuff); } else { sprintf (errBuff, "COM object exception%s%s", hasDescription ? "\nDescription: " : "" , hasDescription ? description : ""); codedComError (errBuff, exnInfo.scode); } } if (FAILED (hr)) { char buff[2048]; sprintf (buff, "\"%s\" (%s) failed", schemeToText (argv[1]), inv_kind_string (invKind)); codedComError (buff, hr); } // unmarshal data passed by reference, cleanup for (i = 2, j = numParamsPassed - 1; i < argc; i++, j--) unmarshalVariant (argv[i], &methodArguments.rgvarg[j]); if (numParamsPassed > 0) scheme_gc_ptr_ok (methodArguments.rgvarg); if (invKind == INVOKE_PROPERTYPUT) return scheme_void; // unmarshal return value return variantToSchemeObject (&methodResult); } Scheme_Object *mx_com_invoke (int argc, Scheme_Object **argv) { return mx_make_call (argc, argv, INVOKE_FUNC); } Scheme_Object *mx_com_get_property (int argc, Scheme_Object **argv) { return mx_make_call (argc, argv, INVOKE_PROPERTYGET); } Scheme_Object *mx_com_set_property (int argc, Scheme_Object **argv) { return mx_make_call (argc, argv, INVOKE_PROPERTYPUT); } Scheme_Object *mx_all_clsid (int argc, Scheme_Object **argv, char **attributes) { LONG result; Scheme_Object *retval; HKEY hkey, hsubkey; FILETIME fileTime; unsigned long keyIndex; TCHAR clsidBuffer[256]; DWORD clsidBufferSize; DWORD dataType; BYTE dataBuffer[256]; DWORD dataBufferSize; BOOL loopFlag; char **p; retval = scheme_null; result = RegOpenKeyEx (HKEY_CLASSES_ROOT, "CLSID", (DWORD)0, KEY_READ, &hkey); if (result != ERROR_SUCCESS) return retval; // enumerate subkeys until we find the one we want keyIndex = 0; while (1) { // get next subkey clsidBufferSize = sizeray (clsidBuffer); result = RegEnumKeyEx (hkey, keyIndex++, clsidBuffer, &clsidBufferSize, 0, NULL, NULL, &fileTime); if (result == ERROR_NO_MORE_ITEMS) break; if (strlen (clsidBuffer) != CLSIDLEN) // not a CLSID -- bogus entry continue; // open subkey result = RegOpenKeyEx (hkey, clsidBuffer, (DWORD)0, KEY_READ, &hsubkey); if (result != ERROR_SUCCESS) scheme_signal_error ("Error while searching Windows registry"); dataBufferSize = sizeof (dataBuffer); RegQueryValueEx (hsubkey, "", 0, &dataType, dataBuffer, &dataBufferSize); if (dataType == REG_SZ) { int subkeyIndex; TCHAR subkeyBuffer[256]; DWORD subkeyBufferSize; subkeyIndex = 0; loopFlag = TRUE; while (loopFlag) { subkeyBufferSize = sizeray (subkeyBuffer); result = RegEnumKeyEx (hsubkey, subkeyIndex++, subkeyBuffer, &subkeyBufferSize, 0, NULL, NULL, &fileTime); if (result == ERROR_NO_MORE_ITEMS) break; p = attributes; while (*p) { if (stricmp (subkeyBuffer, *p) == 0) { retval = scheme_make_pair (multiByteToSchemeCharString ((char *)dataBuffer), retval); loopFlag = FALSE; break; // *p loop } p++; } } } RegCloseKey (hsubkey); } RegCloseKey (hkey); return retval; } Scheme_Object *mx_all_controls (int argc, Scheme_Object **argv) { return mx_all_clsid (argc, argv, controlAttributes); } Scheme_Object *mx_all_coclasses (int argc, Scheme_Object **argv) { return mx_all_clsid (argc, argv, objectAttributes); } Scheme_Object *mx_com_object_eq (int argc, Scheme_Object **argv) { IUnknown *pIUnknown1, *pIUnknown2; IDispatch *pIDispatch1, *pIDispatch2; Scheme_Object *retval; pIDispatch1 = MX_COM_OBJ_VAL (GUARANTEE_COM_OBJ ("com-object-eq?", 0)); pIDispatch2 = MX_COM_OBJ_VAL (GUARANTEE_COM_OBJ ("com-object-eq?", 1)); // these should never fail pIDispatch1->QueryInterface (IID_IUnknown, (void **)&pIUnknown1); pIDispatch2->QueryInterface (IID_IUnknown, (void **)&pIUnknown2); retval = (pIUnknown1 == pIUnknown2) ? scheme_true : scheme_false; pIUnknown1->Release(); pIUnknown2->Release(); return retval; } Scheme_Object *mx_document_title (int argc, Scheme_Object **argv) { HRESULT hr; IHTMLDocument2 *pDocument; BSTR bstr; Scheme_Object *retval; pDocument = MX_DOCUMENT_VAL (GUARANTEE_DOCUMENT ("document-title", 0)); hr = pDocument->get_title (&bstr); if (FAILED (hr)) scheme_signal_error ("document-title: Can't get title"); retval = BSTRToSchemeString (bstr); SysFreeString (bstr); return retval; } Scheme_Object *mx_document_objects (int argc, Scheme_Object **argv) { HRESULT hr; IHTMLDocument2 *pDocument; IHTMLElement *pBody; IHTMLElementCollection *pObjectsCollection; long numObjects; Scheme_Object *retval; int i; IDispatch *pObjectDispatch; MX_COM_Object *com_object; pDocument = MX_DOCUMENT_VAL (GUARANTEE_DOCUMENT ("document-objects", 0)); hr = pDocument->get_body (&pBody); if (FAILED (hr) || pBody == NULL) codedComError ("document-objects: Can't find document BODY", hr); pObjectsCollection = getBodyElementsWithTag (pBody, TEXT ("OBJECT")); pBody->Release(); pObjectsCollection->get_length (&numObjects); retval = scheme_null; for (i = numObjects - 1; i >= 0; i--) { pObjectDispatch = getObjectInCollection (pObjectsCollection, i); com_object = (MX_COM_Object *)scheme_malloc (sizeof (MX_COM_Object)); com_object->type = mx_com_object_type; com_object->pIDispatch = pObjectDispatch; com_object->clsId = emptyClsId; com_object->pITypeInfo = NULL; com_object->pEventTypeInfo = NULL; com_object->pIConnectionPoint = NULL; com_object->pISink = NULL; com_object->connectionCookie = (DWORD)0; com_object->released = FALSE; mx_register_com_object ((Scheme_Object *)com_object, pObjectDispatch); retval = scheme_make_pair ((Scheme_Object *)com_object, retval); } pObjectsCollection->Release(); return retval; } MX_Element *make_mx_element (IHTMLElement *pIHTMLElement) { MX_Element *elt; elt = (MX_Element *)scheme_malloc (sizeof (MX_Element)); elt->type = mx_element_type; elt->released = FALSE; elt->valid = TRUE; elt->pIHTMLElement = pIHTMLElement; // this should not be necessary // apparently, IE does not always call AddRef() // for HTML elements if (pIHTMLElement->AddRef() > 2) pIHTMLElement->Release(); mx_register_simple_com_object ((Scheme_Object *)elt, pIHTMLElement); return elt; } Scheme_Object *mx_elements_with_tag (int argc, Scheme_Object **argv) { HRESULT hr; IHTMLDocument2 *pDocument; IHTMLElement *pBody, *pIHTMLElement; IHTMLElementCollection *pCollection; long numObjects; Scheme_Object *retval; MX_Element *elt; IDispatch *pDispatch; int i; GUARANTEE_STRSYM ("elements-with-tag", 1); pDocument = MX_DOCUMENT_VAL (GUARANTEE_DOCUMENT ("elements-with-tag", 0)); pDocument->get_body (&pBody); if (pBody == NULL) scheme_signal_error ("elements-with-tag: Can't find document BODY"); if (stricmp (schemeToText (argv[1]), "BODY") == 0) return scheme_make_pair ((Scheme_Object *) (make_mx_element (pBody)), scheme_null); pCollection = getBodyElementsWithTag (pBody, schemeToText (argv[1])); pBody->Release(); pCollection->get_length (&numObjects); retval = scheme_null; for (i = numObjects - 1; i >= 0; i--) { pDispatch = getElementInCollection (pCollection, i); hr = pDispatch->QueryInterface (IID_IHTMLElement, (void **)&pIHTMLElement); if (FAILED (hr) || pIHTMLElement == NULL) codedComError ("elements-with-tag: Can't get IHTMLElement interface", hr); elt = make_mx_element (pIHTMLElement); mx_register_simple_com_object ((Scheme_Object *)elt, pIHTMLElement); retval = scheme_make_pair ((Scheme_Object *)elt, retval); } pCollection->Release(); return retval; } CLSID getCLSIDFromCoClass (LPCTSTR name) { HKEY hkey, hsubkey; LONG result; FILETIME fileTime; unsigned long keyIndex; TCHAR clsIdBuffer[256]; OLECHAR oleClsIdBuffer[256]; DWORD clsIdBufferSize; DWORD dataType; BYTE dataBuffer[256]; DWORD dataBufferSize; CLSID clsId; BOOL loopFlag; int count; unsigned int len; char **p; // dummy entry clsId = emptyClsId; // get HKEY to Interfaces listing in Registry result = RegOpenKeyEx (HKEY_CLASSES_ROOT, "CLSID", (DWORD)0, KEY_READ, &hkey); if (result != ERROR_SUCCESS) scheme_signal_error ("Error while searching Windows registry"); // enumerate subkeys until we find the one we want // really, should call RegQueryInfoKey to find size needed for buffers keyIndex = 0; while (1) { // get next subkey clsIdBufferSize = sizeof (clsIdBuffer); result = RegEnumKeyEx (hkey, keyIndex++, clsIdBuffer, &clsIdBufferSize, 0, NULL, NULL, &fileTime); if (result == ERROR_NO_MORE_ITEMS) break; if (result != ERROR_SUCCESS) scheme_signal_error ("Error enumerating subkeys in Windows registry"); if (strlen (clsIdBuffer) != CLSIDLEN) // not a CLSID -- bogus entry continue; // open subkey result = RegOpenKeyEx (hkey, clsIdBuffer, (DWORD)0, KEY_READ, &hsubkey); if (result != ERROR_SUCCESS) return clsId; dataBufferSize = sizeof (dataBuffer); RegQueryValueEx (hsubkey, "", 0, &dataType, dataBuffer, &dataBufferSize); if (dataType == REG_SZ && lstrcmp (name, (char *)dataBuffer) == 0) { int subkeyIndex; TCHAR subkeyBuffer[256]; DWORD subkeyBufferSize; // confirm this is a COM object subkeyIndex = 0; loopFlag = TRUE; while (loopFlag) { subkeyBufferSize = sizeray (subkeyBuffer); result = RegEnumKeyEx (hsubkey, subkeyIndex++, subkeyBuffer, &subkeyBufferSize, 0, NULL, NULL, &fileTime); if (result == ERROR_NO_MORE_ITEMS) break; if (result != ERROR_SUCCESS) scheme_signal_error ("Error enumerating subkeys in Windows registry"); p = objectAttributes; while (*p) { if (stricmp (subkeyBuffer, *p) == 0) { len = (unsigned int) strlen (clsIdBuffer); count = MultiByteToWideChar (CP_ACP, (DWORD)0, clsIdBuffer, len, oleClsIdBuffer, sizeray (oleClsIdBuffer) - 1); oleClsIdBuffer[len] = '\0'; if (count == 0) scheme_signal_error ("Error translating CLSID to Unicode", name); CLSIDFromString (oleClsIdBuffer, &clsId); loopFlag = FALSE; break; // *p loop } p++; } } } RegCloseKey (hsubkey); } RegCloseKey (hkey); if (isEmptyClsId (clsId)) scheme_signal_error ("Coclass %s not found", name); return clsId; } Scheme_Object *mx_find_element (int argc, Scheme_Object **argv) { IHTMLElement *pIHTMLElement; int index; GUARANTEE_DOCUMENT ("find-element", 0); GUARANTEE_STRSYM ("find-element", 1); GUARANTEE_STRSYM ("find-element", 2); if (argc > 3) GUARANTEE_NONNEGATIVE ("find-element", 3); index = (argc > 3) ? SCHEME_INT_VAL (argv[3]) : 0; pIHTMLElement = findBodyElement (MX_DOCUMENT_VAL (argv[0]), schemeToText (argv[1]), schemeToText (argv[2]), index); if (pIHTMLElement == NULL) scheme_signal_error ("find-element: HTML element with tag = %s, id = %s not found", schemeToText (argv[1]), schemeToText (argv[2])); return (Scheme_Object *) make_mx_element (pIHTMLElement); } Scheme_Object *mx_find_element_by_id_or_name (int argc, Scheme_Object **argv) { HRESULT hr; IHTMLElement *pIHTMLElement; IHTMLElementCollection *pIHTMLElementCollection; IHTMLDocument2 *pIHTMLDocument2; VARIANT name, index; BSTR bstr; IDispatch *pEltDispatch; if (argc > 2) GUARANTEE_NONNEGATIVE ("find-element-by-id-or-name", 2); pIHTMLDocument2 = MX_DOCUMENT_VAL (GUARANTEE_DOCUMENT ("find-element-by-id-or-name", 0)); hr = pIHTMLDocument2->get_all (&pIHTMLElementCollection); if (FAILED (hr) || pIHTMLElementCollection == NULL) { scheme_signal_error ("find-element-by-id-or-name: " "Couldn't retrieve element collection " "from HTML document"); } bstr = schemeToBSTR (GUARANTEE_STRSYM ("find-element-by-id-or-name", 1)); name.vt = VT_BSTR; name.bstrVal = bstr; index.vt = VT_I4; index.lVal = (argc > 2) ? SCHEME_INT_VAL (argv[2]) : 0; pIHTMLElementCollection->item (name, index, &pEltDispatch); SysFreeString (bstr); pIHTMLElementCollection->Release(); if (pEltDispatch == NULL) scheme_signal_error ("find-element-by-id-or-name: " "Couldn't find element with id = %s", schemeToText (argv[1])); hr = pEltDispatch->QueryInterface (IID_IHTMLElement, (void **)&pIHTMLElement); if (FAILED (hr) || pIHTMLElement == NULL) scheme_signal_error ("find-element-by-id-or-name: " "Couldn't retrieve element interface " "for element with id = %s", schemeToText (argv[1])); return (Scheme_Object *) make_mx_element (pIHTMLElement); } // for coclass->html, progid->html Scheme_Object *mx_clsid_to_html (CLSID clsId, const char *controlName, const char *fname, int argc, Scheme_Object **argv ) { LPOLESTR clsIdString; char widthBuff[25]; char heightBuff[25]; char buff[512]; char *format; GUARANTEE_INTEGER (fname, 1); GUARANTEE_INTEGER (fname, 2); format = "%u"; if (argc > 3) { const char * symString = schemeToMultiByte (GUARANTEE_STRSYM (fname, 3)); if (stricmp (symString, "percent") == 0) format = "%u%%"; else if (stricmp (symString, "pixels")) scheme_signal_error ("%s: Invalid size specifier '%s: " "must be either 'pixels or 'percent", fname, symString); } sprintf (widthBuff, format, SCHEME_INT_VAL (argv[1])); sprintf (heightBuff, format, SCHEME_INT_VAL (argv[2])); StringFromCLSID (clsId, &clsIdString); * (clsIdString + wcslen (clsIdString) - 1) = L'\0'; if (clsIdString == NULL) scheme_signal_error ("%s: Can't convert control CLSID to string", fname); sprintf (buff, "\n" "", controlName, widthBuff, heightBuff, clsIdString + 1); return multiByteToSchemeCharString (buff); } Scheme_Object * mx_coclass_to_html (int argc, Scheme_Object **argv) { LPCTSTR controlName = schemeToText (GUARANTEE_STRSYM ("coclass->html", 0)); CLSID clsId = getCLSIDFromCoClass (controlName); if (isEmptyClsId (clsId)) scheme_signal_error ("coclass->html: Coclass \"%s\" not found", schemeToMultiByte (argv[0])); return mx_clsid_to_html (clsId, controlName, "coclass->html", argc, argv); } Scheme_Object *mx_progid_to_html (int argc, Scheme_Object **argv) { HRESULT hr; BSTR wideProgId; CLSID clsId; wideProgId = schemeToBSTR (GUARANTEE_STRSYM ("progid->html", 0)); hr = CLSIDFromProgID (wideProgId, &clsId); SysFreeString (wideProgId); if (FAILED (hr)) scheme_signal_error ("progid->html: ProgID \"%s\" not found", schemeToText (argv[0])); return mx_clsid_to_html (clsId, schemeToText (argv[0]), "progid->html", argc, argv); } Scheme_Object *mx_stuff_html (int argc, Scheme_Object **argv, WCHAR *oleWhere, char *scheme_name) { IHTMLDocument2 *pDocument; IHTMLElement *pBody; BSTR where, html; pDocument = MX_DOCUMENT_VAL (GUARANTEE_DOCUMENT (scheme_name, 0)); html = schemeToBSTR (GUARANTEE_STRSYM (scheme_name, 1)); pDocument->get_body (&pBody); if (pBody == NULL) scheme_signal_error ("Can't find document BODY"); where = SysAllocString (oleWhere); pBody->insertAdjacentHTML (where, html); SysFreeString (where); SysFreeString (html); return scheme_void; } Scheme_Object *mx_insert_html (int argc, Scheme_Object **argv) { return mx_stuff_html (argc, argv, L"AfterBegin", "doc-insert-html"); } Scheme_Object *mx_append_html (int argc, Scheme_Object **argv) { return mx_stuff_html (argc, argv, L"BeforeEnd", "doc-append-html"); } Scheme_Object *mx_replace_html (int argc, Scheme_Object **argv) { IHTMLDocument2 *pDocument; IHTMLElement *pBody; BSTR html; pDocument = MX_DOCUMENT_VAL (GUARANTEE_DOCUMENT ("replace-html", 0)); html = schemeToBSTR (GUARANTEE_STRSYM ("replace-html", 1)); pDocument->get_body (&pBody); if (pBody == NULL) scheme_signal_error ("Can't find document body"); pBody->put_innerHTML (html); SysFreeString (html); return scheme_void; } /* blocking on Win events doesn't seem to work any longer static BOOL win_event_available (void *) { MSG msg; return (PeekMessage (&msg, NULL, 0x400, 0x400, PM_NOREMOVE) || PeekMessage (&msg, NULL, 0x113, 0x113, PM_NOREMOVE)); } static void win_event_sem_fun (MX_Document_Object *doc, void *fds) { static HANDLE dummySem; if (!dummySem) { dummySem = CreateSemaphore (NULL, 0, 1, NULL); if (!dummySem) { scheme_signal_error ("Error creating Windows event semaphore"); } } scheme_add_fd_eventmask (fds, QS_ALLINPUT); scheme_add_fd_handle (dummySem, fds, TRUE); } */ Scheme_Object *mx_process_win_events (int argc, Scheme_Object **argv) { MSG msg; /* this used to work, sort of scheme_block_until ((int (*) (Scheme_Object *))win_event_available, (void (*) (Scheme_Object *, void *))win_event_sem_fun, NULL, 0.0F); */ while (PeekMessage (&msg, NULL, 0x400, 0x400, PM_REMOVE) || PeekMessage (&msg, NULL, 0x113, 0x113, PM_REMOVE)) { TranslateMessage (&msg); DispatchMessage (&msg); } return scheme_void; } void initMysSinkTable (void) { myssink_table.pmake_cy = mx_make_cy; myssink_table.pmake_date = mx_make_date; myssink_table.pmake_bool = mx_make_bool; myssink_table.pmake_scode = mx_make_scode; myssink_table.pmake_idispatch = mx_make_idispatch; myssink_table.pmake_iunknown = mx_make_iunknown; myssink_table.pcy_pred = mx_cy_pred; myssink_table.pdate_pred = mx_date_pred; myssink_table.pscode_pred = mx_scode_pred; myssink_table.pcomobj_pred = mx_comobj_pred; myssink_table.piunknown_pred = mx_iunknown_pred; myssink_table.pcy_val = mx_cy_val; myssink_table.pdate_val = mx_date_val; myssink_table.pscode_val = mx_scode_val; myssink_table.pcomobj_val = mx_comobj_val; myssink_table.piunknown_val = mx_iunknown_val; } Scheme_Object *mx_release_type_table (void) { int i; MX_TYPE_TBL_ENTRY *p, *psave; for (i = 0; i < sizeray (typeTable); i++) { p = typeTable[i]; while (p) { scheme_release_typedesc ((void *)p->pTypeDesc, NULL); psave = p; p = p->next; scheme_gc_ptr_ok (psave); } } return scheme_void; } void mx_exit_closer (Scheme_Object *obj, Scheme_Close_Custodian_Client *fun, void *data) { if ((fun == (Scheme_Close_Custodian_Client *) scheme_release_com_object) || (fun == (Scheme_Close_Custodian_Client *) scheme_release_simple_com_object)) { (*fun) (obj, data); } } void mx_cleanup (void) { mx_release_type_table(); /* looks like CoUninitialize() gets called automatically */ } Scheme_Object *scheme_module_name (void) { return scheme_intern_symbol (MXMAIN); } Scheme_Object *scheme_initialize (Scheme_Env *env) { HRESULT hr; Scheme_Object *mx_fun; int i; Scheme_Object *mx_name; scheme_register_extension_global (&mx_omit_obj, sizeof (mx_omit_obj)); scheme_register_extension_global (&scheme_date_type, sizeof (scheme_date_type)); // should not be necessary, but sometimes // this variable is not 0'd out - bug in VC++ or MzScheme? memset (typeTable, 0, sizeof (typeTable)); // globals in mysterx.cxx mx_name = scheme_intern_symbol (MXMAIN); scheme_date_type = scheme_builtin_value ("struct:date"); mx_com_object_type = scheme_make_type (""); mx_com_type_type = scheme_make_type (""); mx_browser_type = scheme_make_type (""); mx_document_type = scheme_make_type (""); mx_element_type = scheme_make_type (""); mx_event_type = scheme_make_type (""); mx_com_cy_type = scheme_make_type (""); mx_com_date_type = scheme_make_type (""); mx_com_scode_type = scheme_make_type (""); mx_com_iunknown_type = scheme_make_type (""); mx_com_omit_type = scheme_make_type (""); mx_com_typedesc_type = scheme_make_type (""); hr = CoInitialize (NULL); // S_OK means success, S_FALSE means COM already loaded if (FAILED (hr) && hr != S_FALSE) { return scheme_false; } Scheme_Object * arglist[1] = {scheme_false}; scheme_register_extension_global (&mx_unmarshal_strings_as_symbols, sizeof mx_unmarshal_strings_as_symbols); scheme_register_extension_global (&mx_marshal_raw_scheme_objects, sizeof mx_marshal_raw_scheme_objects); mx_unmarshal_strings_as_symbols = scheme_apply (scheme_builtin_value ("make-parameter"), 1, arglist); mx_marshal_raw_scheme_objects = scheme_apply (scheme_builtin_value ("make-parameter"), 1, arglist); // export prims + omit value env = scheme_primitive_module (mx_name, env); for (i = 0; i < sizeray (mxPrims); i++) { mx_fun = scheme_make_prim_w_arity (mxPrims[i].c_fun, mxPrims[i].name, mxPrims[i].minargs, mxPrims[i].maxargs); scheme_add_global (mxPrims[i].name, mx_fun, env); } mx_omit_obj = (Scheme_Object *)scheme_malloc (sizeof (MX_OMIT)); mx_omit_obj->type = mx_com_omit_type; scheme_add_global ("com-omit", mx_omit_obj, env); scheme_finish_primitive_module (env); initEventNames(); initMysSinkTable(); if (isatty (fileno (stdin))) { fprintf (stderr, "MysterX extension for PLT Scheme, " "Copyright (c) 1999-2003 PLT (Paul Steckler)\n"); } scheme_add_atexit_closer (mx_exit_closer); atexit (mx_cleanup); return scheme_void; } Scheme_Object * scheme_reload (Scheme_Env *env) { return scheme_initialize (env); } // for some reason, couldn't put ATL stuff in browser.cxx // so we leave the Win message loop here void browserHwndMsgLoop (LPVOID p) { HRESULT hr; MSG msg; HWND hwnd; IUnknown *pIUnknown; BROWSER_WINDOW_INIT *pBrowserWindowInit; LONG hasScrollBars; BOOL *destroy; pBrowserWindowInit = (BROWSER_WINDOW_INIT *)p; // set apparently-unused low bit in style to inform // DHTMLPage object that we want scrollbars hasScrollBars = (pBrowserWindowInit->browserWindow.style & (WS_HSCROLL|WS_VSCROLL)) ? 1L : 0L; hwnd = CreateWindow ("AtlAxWin7", "myspage.DHTMLPage.1", WS_VISIBLE | hasScrollBars | (pBrowserWindowInit->browserWindow.style & ~ (WS_HSCROLL|WS_VSCROLL)), pBrowserWindowInit->browserWindow.x, pBrowserWindowInit->browserWindow.y, pBrowserWindowInit->browserWindow.width, pBrowserWindowInit->browserWindow.height, NULL, NULL, hInstance, NULL); if (hwnd == NULL) scheme_signal_error ("make-browser: Can't create browser window"); ShowWindow (hwnd, SW_SHOW); SetForegroundWindow (hwnd); browserHwnd = hwnd; if (hasScrollBars) // clear spurious low bit to avoid trouble SetWindowLong (hwnd, GWL_STYLE, GetWindowLong (hwnd, GWL_STYLE) & ~1L); SetClassLong (hwnd, GCL_HICON, HandleToLong (hIcon)); SetWindowText (hwnd, pBrowserWindowInit->browserWindow.label); pIUnknown = NULL; destroy = & (pBrowserWindowInit->browserObject->destroy); while (IsWindow (hwnd)) { if (pIUnknown == NULL) { AtlAxGetControl (hwnd, &pIUnknown); if (pIUnknown) { hr = CoMarshalInterThreadInterfaceInStream (IID_IUnknown, pIUnknown, pBrowserWindowInit->ppIStream); if (FAILED (hr)) { DestroyWindow (hwnd); ReleaseSemaphore (createHwndSem, 1, NULL); codedComError ("Can't marshal document interface", hr); } ReleaseSemaphore (createHwndSem, 1, NULL); } } while (IsWindow (hwnd) && GetMessage (&msg, NULL, 0, 0)) { TranslateMessage (&msg); DispatchMessage (&msg); if (*destroy) { *destroy = FALSE; DestroyWindow (hwnd); } } browserCount--; } } #define DLL_RELATIVE_PATH L"../../../../../../../lib" #include "../mzscheme/delayed.inc" BOOL APIENTRY DllMain (HANDLE hModule, DWORD reason, LPVOID lpReserved) { if (reason == DLL_PROCESS_ATTACH) { load_delayed_dll((HINSTANCE)hModule, "libmzgcxxxxxxx.dll"); load_delayed_dll((HINSTANCE)hModule, "libmzschxxxxxxx.dll"); hInstance = (HINSTANCE)hModule; browserHwndMutex = CreateSemaphore (NULL, 1, 1, NULL); createHwndSem = CreateSemaphore (NULL, 0, 1, NULL); eventSinkMutex = CreateSemaphore (NULL, 1, 1, NULL); hIcon = (HICON)LoadImage (hInstance, MAKEINTRESOURCE (MYSTERX_ICON), IMAGE_ICON, 0, 0, 0); _Module.Init (NULL, hInstance, &LIBID_ATLLib); AtlAxWinInit(); } else if (reason == DLL_PROCESS_DETACH) _Module.Term(); return TRUE; } #if defined (MYSTERX_DOTNET) /// JRM HACKS for CLR // Note that these must come last because the #include and #import // both screw up some names used above. #include // The import has a useless warning in it. #pragma warning (disable: 4278) #import #pragma warning (default: 4278) // This doesn't appear to be necessary. // // raw_interfaces_only high_property_prefixes ("_get", "_put", "_putref") // using namespace mscorlib; ICorRuntimeHost * pCLR = NULL; Scheme_Object * initialize_dotnet_runtime (int argc, Scheme_Object **argv) { HRESULT hr; _AppDomain *pDefaultDomain = NULL; IUnknown *pAppDomainPunk = NULL; IDispatch *pAppDomainDispatch = NULL; hr = CorBindToRuntimeEx (NULL, // latest version // workspace mode L"wks", // We'll only be running one domain. STARTUP_LOADER_OPTIMIZATION_SINGLE_DOMAIN, CLSID_CorRuntimeHost, IID_ICorRuntimeHost, (void **) &pCLR); if (FAILED (hr)) scheme_signal_error ("%%%%initialize-dotnet-runtime: CorBindToRuntimeEx() failed."); hr = pCLR->Start(); if (FAILED (hr)) scheme_signal_error ("%%%%initialize-dotnet-runtime: CLR failed to start."); hr = pCLR->GetDefaultDomain (&pAppDomainPunk); if (FAILED (hr) || pAppDomainPunk == NULL) scheme_signal_error ("%%%%initialize-dotnet-runtime: GetDefaultDomain() failed."); hr = pAppDomainPunk->QueryInterface (__uuidof (_AppDomain), (void **) &pDefaultDomain); if (FAILED (hr) || pDefaultDomain == NULL) scheme_signal_error ("%%%%initialize-dotnet-runtime: QueryInterface for _AppDomain failed."); pDefaultDomain->Release(); hr = pAppDomainPunk->QueryInterface (IID_IDispatch, (void **) &pAppDomainDispatch); if (FAILED (hr) || pAppDomainDispatch == NULL) scheme_signal_error ("%%%%initialize-dotnet-runtime: QueryInterface for IDispatch failed."); Scheme_Object * arglist[1] = {scheme_true}; scheme_apply (mx_unmarshal_strings_as_symbols, 1, arglist); scheme_apply (mx_marshal_raw_scheme_objects, 1, arglist); return mx_make_idispatch (pAppDomainDispatch); } /// END OF JRM HACK #else Scheme_Object * initialize_dotnet_runtime (int argc, Scheme_Object **argv) { scheme_signal_error ("%%%%initialize-dotnet-runtime: Support for .NET is not available in this image."); return scheme_false; } #endif