void
GetOLE (container)
   CContainer*  container
CODE:
{
#ifdef PERL_5005
  typedef SV* (*MYPROC)(CPERLarg_ HV *, IDispatch *, SV *);
#else
  typedef SV* (*MYPROC)(pTHX_ HV *, IDispatch *, SV *);
#endif

  HMODULE hmodule;
  MYPROC pCreatePerlObject;
  IDispatch * pDispatch;

  ST(0) = &PL_sv_undef;
  // Try to find OLE.dll
  hmodule = GetModuleHandle("OLE");
  if (hmodule == 0) {
    // Try to find using Dynaloader
    AV* av_modules = get_av("DynaLoader::dl_modules", FALSE);
    AV* av_librefs = get_av("DynaLoader::dl_librefs", FALSE);
    if (av_modules && av_librefs) {
      // Look at Win32::OLE package
      for (I32 i = 0; i < av_len(av_modules); i++) {
        SV** sv = av_fetch(av_modules, i, 0);
        if (sv && SvPOK (*sv) &&
            strEQ(SvPV_nolen(*sv), "Win32::OLE")) {
          // Tahe
          sv = av_fetch(av_librefs, i, 0);
          hmodule = (HMODULE) (sv && SvIOK (*sv) ? SvIV(*sv) : 0);
          break;
        }
      }
    }
  }

  if (hmodule != 0) {
    pCreatePerlObject = (MYPROC) GetProcAddress(hmodule, "CreatePerlOb
+ject");
    if (pCreatePerlObject != 0)  {
      HV *stash = gv_stashpv("Win32::OLE", TRUE);
      pDispatch = container->GetIDispatch();
      pDispatch->AddRef();
#ifdef PERL_5005
      ST(0) = (pCreatePerlObject)(PERL_OBJECT_THIS_ stash, pDispatch, 
+NULL);
#else
      ST(0) = (pCreatePerlObject)(aTHX_ stash, pDispatch, NULL);
#endif
    }
  }
}
[download]

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), F
+ALSE);
        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", pO
+bj,
     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 */
[download]