library com;

uses Windows, ComObj, ActiveX, AxCtrls, Classes, Rubies, uDefUtils, Pythia;

{$E so}

type
  PCom = ^TCom;
  TCom = record
    Disp: IDispatch;
  end;

var
  cCom: Tvalue;

procedure ComFree(p: PCom); cdecl;
begin
  Dispose(p);
end;

function Com_new(This, class_name: Tvalue): Tvalue; cdecl;
var
  Disp: IDispatch;
  p: PCom;
begin
  Disp := CreateOleObject(dl_String(class_name));
  p := New(PCom);
  p^.Disp := Disp;
  result := rb_data_object_alloc(This, p, nil, @ComFree);
end;

function Com_ole_methods(This, list: Tvalue): Tvalue; cdecl;
var
  p: PCom;
  Props: TStrings;
begin
  p := ap_data_get_struct(This);
  ap_data_get_object(list, TStrings, Props);
  EnumDispatchProperties(p^.Disp, GUID_NULL, VT_EMPTY, Props);
  result := list;
end;

procedure OleConstLoad(TypeLib: ITypeLib; klass: Tvalue);
var
  constant: Tvalue;
  count, i, j: Integer;
  TypeInfo: ITypeInfo;
  TypeAttr: PTypeAttr;
  VarDesc: PVarDesc;
  name: WideString;
  A: Variant;
  S: string;
begin
  constant := rb_hash_new;
  count := TypeLib.GetTypeInfoCount;
  for i := 0 to count-1 do
  begin
    OleCheck(TypeLib.GetTypeInfo(i, TypeInfo));
    OleCheck(TypeInfo.GetTypeAttr(TypeAttr));
    for j := 0 to TypeAttr^.cVars-1 do
    begin
      OleCheck(TypeInfo.GetVarDesc(j, VarDesc));
      if (VarDesc^.varkind = VAR_CONST) and
        not
        (
          VarDesc^.wVarFlags and
            (
              VARFLAG_FHIDDEN or
              VARFLAG_FRESTRICTED or
              VARFLAG_FNONBROWSABLE
            ) <> 0
        ) then
      begin
        OleCheck(TypeInfo.GetDocumentation(VarDesc^.memid, @name,
          nil, nil, nil));
        A := VarDesc^.lpvarValue^; // value
        S := name; // const name
        rb_hash_aset(constant, rb_str_new2(PChar(S)), ap_Variant(A));
      end;
      TypeInfo.ReleaseVarDesc(VarDesc);
    end;
    TypeInfo.ReleaseTypeAttr(TypeAttr);
  end;
  rb_define_const(klass, 'CONSTANTS', constant);
end;

function Com_const_load(This: Tvalue): Tvalue; cdecl;
const
  lcid = LOCALE_SYSTEM_DEFAULT;
var
  p: PCom;
  TypeInfo: ITypeInfo;
  TypeLib: ITypeLib;
  Index: Integer;
begin
  p := ap_data_get_struct(This);
  p^.Disp.GetTypeInfo(0, lcid, TypeInfo);
  OleCheck(TypeInfo.GetContainingTypeLib(TypeLib, Index));
  OleConstLoad(TypeLib, cCom);
  result := This;
end;

var
  NeedToUninitialize: Boolean = False;

procedure Init_com; cdecl;
begin
  PhiStart;

  if CoInitFlags = -1 then
    NeedToUninitialize := Succeeded(CoInitialize(nil));
  cCom := rb_define_class_under(ap_mPhi, 'Com', ap_cObject);
  rb_define_singleton_method(cCom, 'new', @Com_new, 1);
  rb_define_method(cCom, 'ole_methods', @Com_ole_methods, 1);
  rb_define_method(cCom, 'const_load', @Com_const_load, 0);
end;

exports
  Init_com;

var
  SaveExit: Pointer;

procedure LibExit;
begin
  if NeedToUninitialize then CoUnInitialize;
  ExitProc := SaveExit;
end;

begin
  SaveExit := ExitProc;
  ExitProc := @LibExit;
end.

