SV *
CreatePerlObject(pTHX_ HV *stash, IDispatch *pDispatch, SV *destroy)
{
    dPERINTERP;

    /* returns a mortal reference to a new Perl OLE object */

    IV unique = QueryPkgVar(aTHX_ stash, _UNIQUE_NAME, _UNIQUE_LEN);
    if (unique) {
        IUnknown *punk; // XXX check error?
        pDispatch->QueryInterface(IID_IUnknown, (void**)&punk);
        SV **svp = hv_fetch(g_hv_unique, (char*)&punk, sizeof(punk), FALSE);
        DBG(("hv_fetch(%08x) returned %08x", punk, svp));
        punk->Release();
        if (svp)
            return sv_2mortal(sv_bless(newRV(INT2PTR(SV*, SvIV(*svp))), stash));
    }

    if (!pDispatch) {
	warn(MY_VERSION ": CreatePerlObject() No IDispatch interface");
	DEBUGBREAK;
	return &PL_sv_undef;
    }

    WINOLEOBJECT *pObj;
    HV *hvinner = newHV();
    SV *inner;
    SV *sv;
    GV **gv = (GV**)hv_fetch(stash, TIE_NAME, TIE_LEN, FALSE);
    char *szTie = szWINOLETIE;

    if (gv && (sv = GvSV(*gv)) != NULL && SvPOK(sv))
	szTie = SvPV_nolen(sv);

    New(0, pObj, 1, WINOLEOBJECT);
    pObj->flags = 0;
    pObj->pDispatch = pDispatch;
    pObj->pTypeInfo = NULL;
    pObj->pEnum = NULL;
    pObj->pEventSink = NULL;
    pObj->hashTable = newHV();
    pObj->self = newHV();

    pObj->destroy = NULL;
    if (destroy) {
	if (SvPOK(destroy))
	    pObj->destroy = newSVsv(destroy);
	else if (SvROK(destroy) && SvTYPE(SvRV(destroy)) == SVt_PVCV)
	    pObj->destroy = newRV_inc(SvRV(destroy));
    }

    if (unique) {
        IUnknown *punk; // XXX check error?
        pDispatch->QueryInterface(IID_IUnknown, (void**)&punk);
        /* use XIV as a weak reference */
        SV **svp = hv_store(g_hv_unique, (char*)&punk, sizeof(punk),
                            newSViv(PTR2IV(pObj->self)), 0);
        DBG(("hv_store(%08x) returned %08x", punk, svp));
        punk->Release();
        pObj->flags |= OBJFLAG_UNIQUE;
    }

    AddToObjectChain(aTHX_ &pObj->header, WINOLE_MAGIC);

    DBG(("CreatePerlObject=|%lx| Class=%s Tie=%s pDispatch=0x%x\n", pObj,
	 HvNAME(stash), szTie, pDispatch));

    hv_store(hvinner, PERL_OLE_ID, PERL_OLE_IDLEN, newSViv(PTR2IV(pObj)), 0);
    inner = sv_bless(newRV_noinc((SV*)hvinner), gv_stashpv(szTie, TRUE));
    sv_magic((SV*)pObj->self, inner, 'P', Nullch, 0);
    SvREFCNT_dec(inner);

    return sv_2mortal(sv_bless(newRV_noinc((SV*)pObj->self), stash));

}   /* CreatePerlObject */