File : gnatcom-variant.adb


------------------------------------------------------------------------------
--                                                                          --
--      GNATCOM - Ada 95 COM/DCOM/COM+ Development Framework and Tools      --
--                                                                          --
--                     G N A T C O M . V A R I A N T                        --
--                                                                          --
--                                B o d y                                   --
--                                                                          --
--                            $Revision: 1.4 $
--                                                                          --
--             Copyright (C) 1999, 2000, 2001 David Botton                  --
--                                                                          --
-- This is free software;  you can  redistribute it  and/or modify it under --
-- terms of the  GNU General Public License as published  by the Free Soft- --
-- ware  Foundation;  either version 2,  or (at your option) any later ver- --
-- sion. It is distributed in the hope that it will be useful,  but WITHOUT --
-- ANY WARRANTY;  without  even the  implied warranty of MERCHANTABILITY or --
-- FITNESS FOR A PARTICULAR PURPOSE.    See the GNU General  Public License --
-- for  more details.  You should have  received  a copy of the GNU General --
-- Public License  distributed with this;  see file COPYING.  If not, write --
-- to  the Free Software Foundation,  59 Temple Place - Suite 330,  Boston, --
-- MA 02111-1307, USA.                                                      --
--                                                                          --
-- As a special exception,  if other files  instantiate  generics from this --
-- unit, or you link  this unit with other files  to produce an executable, --
-- this  unit  does not  by itself cause  the resulting  executable  to  be --
-- covered  by the  GNU  General  Public  License.  This exception does not --
-- however invalidate  any other reasons why  the executable file  might be --
-- covered by the  GNU Public License.                                      --
--                                                                          --
-- More information about GNATCOM and the most current public version can   --
-- be located on the web at http://www.adapower.com/gnatcom                 --
--                                                                          --
-- Support for GNATCOM is available from Ada Core Technologies, Inc.        --
--                                                                          --
-- In the U.S., contact Ada Core Technologies at:                           --
-- Tel: +1 (212) 620 7300 ext 117                                           --
-- Fax: +1 (212) 807 0162                                                   --
-- Email: sales@gnat.com                                                    --
--                                                                          --
-- In Europe and elsewhere, contact ACT Europe at:                          --
-- Tel: +33 1 49 70 67 16                                                   --
-- Fax: +33 1 49 70 05 52                                                   --
-- Email: sales@act-europe.fr                                               --
------------------------------------------------------------------------------

with Ada.Unchecked_Conversion;
with System;
with GNATCOM.Errors;
with GNATCOM.BSTR;

with GNATCOM.ITypeLib_Interface;
with GNATCOM.ITypeInfo_Interface;

package body GNATCOM.VARIANT is

   procedure Error_Check (Result : in GNATCOM.Types.HRESULT);
   --  Check for VARIANT specific errors

   procedure VariantInit (pvarg : in System.Address);
   pragma Import (StdCall, VariantInit, "VariantInit");

   function VariantClear (pvarg : in System.Address)
                         return GNATCOM.Types.HRESULT;
   pragma Import (StdCall, VariantClear, "VariantClear");

   function VariantCopy (pvargDest : System.Address;
                         pvargSrc  : System.Address)
                        return GNATCOM.Types.HRESULT;
   pragma Import (StdCall, VariantCopy, "VariantCopy");

   function VariantChangeType (pvargDest : System.Address;
                               pvarSrc   : System.Address;
                               wFlags    : Interfaces.C.unsigned_short;
                               vt        : GNATCOM.Types.VARTYPE)
                              return GNATCOM.Types.HRESULT;
   pragma Import (StdCall, VariantChangeType, "VariantChangeType");

   function SysAllocString (C_String : GNATCOM.Types.BSTR)
                           return GNATCOM.Types.BSTR;
   pragma Import (StdCall, SysAllocString, "SysAllocString");

   type SYSTEMTIME is
      record
         wYear         : Interfaces.C.short;
         wMonth        : Interfaces.C.short;
         wDayOfWeek    : Interfaces.C.short := 0;
         wDay          : Interfaces.C.short;
         wHour         : Interfaces.C.short;
         wMinute       : Interfaces.C.short;
         wSecond       : Interfaces.C.short;
         wMilliseconds : Interfaces.C.short := 0;
      end record;

   function VariantTimeToSystemTime
     (vtime        : in     GNATCOM.Types.DATE;
      lpSystemTime : access SYSTEMTIME)
     return Interfaces.C.int;
   pragma Import (StdCall, VariantTimeToSystemTime, "VariantTimeToSystemTime");

   function SystemTimeToVariantTime
     (systemtime : in     GNATCOM.VARIANT.SYSTEMTIME;
      pvtime     : access GNATCOM.Types.DATE)
     return Interfaces.C.int;
   pragma Import (StdCall, SystemTimeToVariantTime, "SystemTimeToVariantTime");

   -----------------
   -- Change_Type --
   -----------------

   procedure Change_Type (This : in out GNATCOM.Types.VARIANT;
                          VT   : in     GNATCOM.Types.VARTYPE)
   is
      use type Interfaces.C.unsigned_short;
   begin
      if This.vt /= VT then
         Error_Check (VariantChangeType (pvargDest => This'Address,
                                         pvarSrc  => This'Address,
                                         wFlags    => 0,
                                         vt        => VT));
      end if;
   end Change_Type;

   -----------
   -- Clear --
   -----------

   procedure Clear (This : in out GNATCOM.Types.VARIANT) is
   begin
      Error_Check (VariantClear (This'Address));
   end Clear;

   ----------
   -- Free --
   ----------

   procedure Free (This : in GNATCOM.Types.VARIANT) is
      Temp : GNATCOM.Types.VARIANT := This;
   begin
      Error_Check (VariantClear (Temp'Address));
   end Free;

   ----------
   -- Copy --
   ----------

   function Copy (From : GNATCOM.Types.VARIANT)
     return GNATCOM.Types.VARIANT
   is
      Temp_Var    : GNATCOM.Types.VARIANT := From;
      New_Variant : GNATCOM.Types.VARIANT;
   begin
      Initialize (New_Variant);
      Error_Check (VariantCopy (pvargDest => New_Variant'Address,
                                pvargSrc  => Temp_Var'Address));
      return New_Variant;
   end Copy;

   -----------------
   -- Error_Check --
   -----------------

   procedure Error_Check (Result : in GNATCOM.Types.HRESULT) is
   begin
      GNATCOM.Errors.Set_Last_HRESULT (Result);

      if GNATCOM.Errors.FAILED (Result) then
         case Result is
            when DISP_E_ARRAYISLOCKED =>
               raise ARRAY_LOCKED_ERROR;
            when DISP_E_BADVARTYPE =>
               raise INVALID_TYPE_ERROR;
            when DISP_E_OVERFLOW =>
               raise OVERFLOW_ERROR;
            when DISP_E_TYPEMISMATCH =>
               raise TYPE_MISMATCH_ERROR;
            when others =>
               GNATCOM.Errors.Error_Check (Result);
         end case;
      end if;
   end Error_Check;

   ----------------
   -- Initialize --
   ----------------

   procedure Initialize (This : in out GNATCOM.Types.VARIANT) is
   begin
      VariantInit (This'Address);
   end Initialize;

   ------------
   -- To_Ada --
   ------------

   function To_Ada
     (From  : GNATCOM.Types.VARIANT;
      Clear : Boolean := True)
      return String
   is
      use type GNATCOM.Types.VARTYPE;

      Temp_Var : GNATCOM.Types.VARIANT := From;
      Do_Clear : Boolean := Clear;
   begin
      if Temp_Var.vt = GNATCOM.Types.VT_NULL then
         return "";
      end if;

      if Temp_Var.vt /= GNATCOM.Types.VT_BSTR then
         Do_Clear := True;
      end if;

      Change_Type (Temp_Var, GNATCOM.Types.VT_BSTR);

      return GNATCOM.BSTR.To_Ada (Temp_Var.u.bstrVal, Do_Clear);
   end To_Ada;

   -----------------
   -- To_Ada_Wide --
   -----------------

   function To_Ada_Wide
     (From  : GNATCOM.Types.VARIANT;
      Clear : Boolean := True)
      return Wide_String
   is
      use type GNATCOM.Types.VARTYPE;

      Temp_Var : GNATCOM.Types.VARIANT := From;
      Do_Clear : Boolean := Clear;
   begin
      if Temp_Var.vt = GNATCOM.Types.VT_NULL then
         return "";
      end if;

      if Temp_Var.vt /= GNATCOM.Types.VT_BSTR then
         Do_Clear := True;
      end if;

      Change_Type (Temp_Var, GNATCOM.Types.VT_BSTR);

      return GNATCOM.BSTR.To_Ada_Wide (Temp_Var.u.bstrVal, Do_Clear);
   end To_Ada_Wide;

   ------------
   -- To_Ada --
   ------------

   function To_Ada
     (From  : GNATCOM.Types.VARIANT)
      return Integer
   is
      Temp_Var : GNATCOM.Types.VARIANT := Copy (From);
      Result   : Integer;
   begin
      Change_Type (Temp_Var, GNATCOM.Types.VT_I4);
      Result := Integer (Temp_Var.u.lVal);
      VARIANT.Clear (Temp_Var);
      return Result;
   end To_Ada;

   ------------
   -- To_Ada --
   ------------

   function To_Ada
     (From  : GNATCOM.Types.VARIANT)
      return Float
   is
      Temp_Var : GNATCOM.Types.VARIANT := Copy (From);
      Result   : Float;
   begin
      Change_Type (Temp_Var, GNATCOM.Types.VT_R4);
      Result := Float (Temp_Var.u.fltVal);
      VARIANT.Clear (Temp_Var);
      return Result;
   end To_Ada;

   ------------
   -- To_Ada --
   ------------

   function To_Ada
     (From  : GNATCOM.Types.VARIANT)
     return Ada.Calendar.Time
   is
      use Ada.Calendar;
      use type Interfaces.C.int;
      use type Interfaces.C.short;

      Temp_Var : GNATCOM.Types.VARIANT := Copy (From);
      C_Time   : aliased SYSTEMTIME;
      Ada_Time : Ada.Calendar.Time;
   begin
      Change_Type (Temp_Var, GNATCOM.Types.VT_DATE);

      if VariantTimeToSystemTime (Temp_Var.u.date, C_Time'Access) /= 0 then
         Ada_Time := Time_Of (Year_Number (C_Time.wYear),
                              Month_Number (C_Time.wMonth),
                              Day_Number (C_Time.wDay),
                              Day_Duration
                              ((Day_Duration (C_Time.wHour) * 60 * 60) +
                               (Day_Duration (C_Time.wMinute) * 60) +
                               (Day_Duration (C_Time.wSecond))));

         VARIANT.Clear (Temp_Var);
         return Ada_Time;
      else
         raise INVALID_TYPE_ERROR;
      end if;

   end To_Ada;

   ------------
   -- To_Ada --
   ------------

   function To_Ada
     (From  : GNATCOM.Types.VARIANT)
      return Boolean
   is
      use type GNATCOM.Types.VARIANT_BOOL;

      Temp_Var : GNATCOM.Types.VARIANT := Copy (From);
      Result   : Boolean;
   begin
      Change_Type (Temp_Var, GNATCOM.Types.VT_BOOL);

      if Temp_Var.u.boolVal = GNATCOM.Types.VARIANT_BOOL_FALSE then
         Result := False;
      else
         Result := True;
      end if;
      VARIANT.Clear (Temp_Var);
      return Result;
   end To_Ada;

   -------------
   -- To_BSTR --
   -------------

   function To_BSTR
     (From : GNATCOM.Types.VARIANT;
      Copy : Boolean := False)
      return GNATCOM.Types.BSTR
   is
      use type GNATCOM.Types.VARTYPE;

      Temp_Var : GNATCOM.Types.VARIANT := From;
      Do_Copy : Boolean := Copy;
   begin
      if From.vt /= GNATCOM.Types.VT_BSTR then
         Do_Copy := False;
      end if;

      Change_Type (Temp_Var, GNATCOM.Types.VT_BSTR);

      if Copy then
         return SysAllocString (Temp_Var.u.bstrVal);
      else
         return Temp_Var.u.bstrVal;
      end if;

   end To_BSTR;

   ----------
   -- To_C --
   ----------

   function To_C
     (From  : GNATCOM.Types.VARIANT;
      Clear : Boolean               := True)
      return Interfaces.C.char_array
   is
      use type GNATCOM.Types.VARTYPE;

      Temp_Var : GNATCOM.Types.VARIANT := From;
      Do_Clear : Boolean := Clear;
   begin
      if Temp_Var.vt /= GNATCOM.Types.VT_BSTR then
         Do_Clear := True;
      end if;

      Change_Type (Temp_Var, GNATCOM.Types.VT_BSTR);

      return GNATCOM.BSTR.To_C (Temp_Var.u.bstrVal, Do_Clear);
   end To_C;

   ---------------
   -- To_C_Wide --
   ---------------

   function To_C_Wide
     (From  : GNATCOM.Types.VARIANT;
      Clear : Boolean               := True)
      return Interfaces.C.wchar_array
   is
      use type GNATCOM.Types.VARTYPE;

      Temp_Var : GNATCOM.Types.VARIANT := From;
      Do_Clear : Boolean := Clear;
   begin
      if Temp_Var.vt /= GNATCOM.Types.VT_BSTR then
         Do_Clear := True;
      end if;

      Change_Type (Temp_Var, GNATCOM.Types.VT_BSTR);

      return GNATCOM.BSTR.To_C_Wide (Temp_Var.u.bstrVal, Do_Clear);
   end To_C_Wide;

   -----------------------------
   -- To_Pointer_To_IDispatch --
   -----------------------------

   function To_Pointer_To_IDispatch
     (From  : GNATCOM.Types.VARIANT;
      Clear : Boolean                   := True)
      return GNATCOM.Types.Pointer_To_IDispatch
   is
      Temp_Var  : GNATCOM.Types.VARIANT := From;
      Interface : GNATCOM.Types.Pointer_To_IDispatch;
      Ref       : Interfaces.C.unsigned_long;
   begin
      Change_Type (Temp_Var, GNATCOM.Types.VT_DISPATCH);
      Interface := Temp_Var.u.pdispVal;
      Ref := Interface.Vtbl.AddRef (Interface);

      if Clear then
         VARIANT.Clear (Temp_Var);
      end if;

      return Interface;
   end To_Pointer_To_IDispatch;

   ----------------------------
   -- To_Pointer_To_IUnknown --
   ----------------------------

   function To_Pointer_To_IUnknown
     (From  : GNATCOM.Types.VARIANT;
      Clear : Boolean                   := True)
      return GNATCOM.Types.Pointer_To_IUnknown
   is
      Temp_Var  : GNATCOM.Types.VARIANT := From;
      Interface : GNATCOM.Types.Pointer_To_IUnknown;
      Ref       : Interfaces.C.unsigned_long;
   begin
      Change_Type (Temp_Var, GNATCOM.Types.VT_DISPATCH);
      Interface := Temp_Var.u.punkVal;
      Ref := Interface.Vtbl.AddRef (Interface);

      if Clear then
         VARIANT.Clear (Temp_Var);
      end if;

      return Interface;
   end To_Pointer_To_IUnknown;

   -----------------------------
   -- To_Pointer_To_SAFEARRAY --
   -----------------------------

   function To_Pointer_To_SAFEARRAY (From  : GNATCOM.Types.VARIANT)
     return GNATCOM.Types.Pointer_To_SAFEARRAY
   is
      use type GNATCOM.Types.VARTYPE;
   begin
      if (From.vt and GNATCOM.Types.VT_ARRAY) = 0 then
         raise INVALID_TYPE_ERROR;
      end if;

      return From.u.parray;
   end To_Pointer_To_SAFEARRAY;

   ----------------
   -- To_VARIANT --
   ----------------

   function To_VARIANT
     (From : String)
      return GNATCOM.Types.VARIANT
   is
      New_Variant : GNATCOM.Types.VARIANT;
   begin
      Initialize (New_Variant);
      New_Variant.vt := GNATCOM.Types.VT_BSTR;
      New_Variant.u.bstrVal := GNATCOM.BSTR.To_BSTR (From);
      return New_Variant;
   end To_VARIANT;

   ----------------
   -- To_VARIANT --
   ----------------

   function To_VARIANT
     (From : Integer;
      VT   : GNATCOM.Types.VARTYPE := GNATCOM.Types.VT_I4)
      return GNATCOM.Types.VARIANT
   is
      New_Variant : GNATCOM.Types.VARIANT;
   begin
      Initialize (New_Variant);
      New_Variant.vt := VT;
      New_Variant.u.lVal := Interfaces.C.long (From);
      return New_Variant;
   end To_VARIANT;

   ----------------
   -- To_VARIANT --
   ----------------

   function To_VARIANT
     (From : Float)
      return GNATCOM.Types.VARIANT
   is
      New_Variant : GNATCOM.Types.VARIANT;
   begin
      Initialize (New_Variant);
      New_Variant.vt := GNATCOM.Types.VT_R4;
      New_Variant.u.fltVal := Interfaces.C.C_float (From);
      return New_Variant;
   end To_VARIANT;

   ----------------
   -- To_VARIANT --
   ----------------

   function To_VARIANT
     (From : Boolean)
      return GNATCOM.Types.VARIANT
   is
      New_Variant : GNATCOM.Types.VARIANT;
   begin
      Initialize (New_Variant);
      New_Variant.vt := GNATCOM.Types.VT_BOOL;
      if From then
         New_Variant.u.boolVal := GNATCOM.Types.VARIANT_BOOL_TRUE;
      else
         New_Variant.u.boolVal := GNATCOM.Types.VARIANT_BOOL_FALSE;
      end if;
      return New_Variant;
   end To_VARIANT;

   ----------------
   -- To_VARIANT --
   ----------------

   function To_VARIANT
     (From : Ada.Calendar.Time)
      return GNATCOM.Types.VARIANT
   is
      use Ada.Calendar;
      use type Ada.Calendar.Day_Duration;
      use type Interfaces.C.int;
      use type Interfaces.C.short;

      New_Variant : GNATCOM.Types.VARIANT;
      C_Time      : SYSTEMTIME;
      Seconds     : Ada.Calendar.Day_Duration;
      Temp        : Ada.Calendar.Day_Duration;
      V_Time      : aliased GNATCOM.Types.DATE;
   begin
      C_Time.wYear   := Interfaces.C.short (Year (From));
      C_Time.wMonth  := Interfaces.C.short (Month (From));
      C_Time.wDay    := Interfaces.C.short (Day (From));

      Seconds := Ada.Calendar.Seconds (From);

      Temp := Seconds / (60*60);
      C_Time.wHour   :=
        Interfaces.C.short (Float'Floor (Float (Temp)));

      Temp := (Seconds - (Ada.Calendar.Day_Duration
                          (C_Time.wHour) * (60*60))) / 60;
      C_Time.wMinute :=
        Interfaces.C.short (Float'Floor (Float (Temp)));

      Temp := Seconds -
        ((Ada.Calendar.Day_Duration (C_Time.wHour) * (60 * 60)) +
         (Ada.Calendar.Day_Duration (C_Time.wMinute) * 60));
      C_Time.wSecond :=
        Interfaces.C.short (Float'Floor (Float (Temp)));

      if SystemTimeToVariantTime (C_Time, V_Time'Access) /= 0 then
         Initialize (New_Variant);
         New_Variant.vt := GNATCOM.Types.VT_DATE;
         New_Variant.u.date := V_Time;
         return New_Variant;
      else
         raise INVALID_TYPE_ERROR;
      end if;

   end To_VARIANT;

   ----------------
   -- To_VARIANT --
   ----------------

   function To_VARIANT
     (From : GNATCOM.Types.BSTR;
      Copy : Boolean := False)
      return GNATCOM.Types.VARIANT
   is
      New_Variant : GNATCOM.Types.VARIANT;
   begin
      Initialize (New_Variant);
      New_Variant.vt := GNATCOM.Types.VT_BSTR;
      if Copy then
         New_Variant.u.bstrVal := SysAllocString (From);
      else
         New_Variant.u.bstrVal := From;
      end if;
      return New_Variant;
   end To_VARIANT;

   ----------------
   -- To_VARIANT --
   ----------------

   function To_VARIANT
     (From   : GNATCOM.Types.Pointer_To_IUnknown;
      AddRef : Boolean := True)
      return GNATCOM.Types.VARIANT
   is
      Ref       : Interfaces.C.unsigned_long;
      New_Variant : GNATCOM.Types.VARIANT;
   begin
      Initialize (New_Variant);
      New_Variant.vt := GNATCOM.Types.VT_UNKNOWN;
      if AddRef then
         Ref := From.Vtbl.AddRef (From);
      end if;
      New_Variant.u.punkVal := From;
      return New_Variant;
   end To_VARIANT;

   ----------------
   -- To_VARIANT --
   ----------------

   function To_VARIANT
     (From   : GNATCOM.Types.Pointer_To_IDispatch;
      AddRef : Boolean := True)
      return GNATCOM.Types.VARIANT
   is
      Ref       : Interfaces.C.unsigned_long;
      New_Variant : GNATCOM.Types.VARIANT;
   begin
      Initialize (New_Variant);
      New_Variant.vt := GNATCOM.Types.VT_DISPATCH;
      if AddRef then
         Ref := From.Vtbl.AddRef (From);
      end if;
      New_Variant.u.pdispVal := From;
      return New_Variant;
   end To_VARIANT;

   ----------------
   -- To_VARIANT --
   ----------------

   function To_VARIANT (From : GNATCOM.Types.Pointer_To_SAFEARRAY;
                        VT   : GNATCOM.Types.VARTYPE)
     return GNATCOM.Types.VARIANT
   is
      use type GNATCOM.Types.VARTYPE;

      New_Variant : GNATCOM.Types.VARIANT;
   begin
      Initialize (New_Variant);
      New_Variant.vt := GNATCOM.Types.VT_ARRAY or VT;
      New_Variant.u.parray := From;
      return New_Variant;
   end To_VARIANT;

   ----------------------
   -- To_VARIANT_BYREF --
   ----------------------

   function To_VARIANT_BYREF (From : System.Address;
                              VT   : GNATCOM.Types.VARTYPE)
     return GNATCOM.Types.VARIANT
   is
      use type GNATCOM.Types.VARTYPE;

      RefVar : GNATCOM.Types.VARIANT;
   begin
      Initialize (RefVar);
      RefVar.vt := GNATCOM.Types.VT_BYREF + VT;
      RefVar.u.byref := From;

      return RefVar;
   end To_VARIANT_BYREF;

   ----------------------
   -- To_VARIANT_BYREF --
   ----------------------

   function To_VARIANT_BYREF (From : access GNATCOM.Types.BSTR)
     return GNATCOM.Types.VARIANT
   is
   begin
      return To_VARIANT_BYREF (From.all'Address, GNATCOM.Types.VT_BSTR);
   end To_VARIANT_BYREF;

   ----------------------
   -- To_VARIANT_BYREF --
   ----------------------

   function To_VARIANT_BYREF (From : access GNATCOM.Types.VARIANT)
     return GNATCOM.Types.VARIANT
   is
   begin
      return To_VARIANT_BYREF (From.all'Address, GNATCOM.Types.VT_VARIANT);
   end To_VARIANT_BYREF;

   -----------------------
   -- To_VARIANT_From_C --
   -----------------------

   function To_VARIANT_From_C
     (From : Interfaces.C.char_array)
      return GNATCOM.Types.VARIANT
   is
      New_Variant : GNATCOM.Types.VARIANT;
   begin
      Initialize (New_Variant);
      New_Variant.vt := GNATCOM.Types.VT_BSTR;
      New_Variant.u.bstrVal := GNATCOM.BSTR.To_BSTR_From_C (From);
      return New_Variant;
   end To_VARIANT_From_C;

   --------------------------
   -- To_VARIANT_From_Wide --
   --------------------------

   function To_VARIANT_From_Wide
     (From : Wide_String)
     return GNATCOM.Types.VARIANT
   is
      New_Variant : GNATCOM.Types.VARIANT;
   begin
      Initialize (New_Variant);
      New_Variant.vt := GNATCOM.Types.VT_BSTR;
      New_Variant.u.bstrVal := GNATCOM.BSTR.To_BSTR_From_Wide (From);
      return New_Variant;
   end To_VARIANT_From_Wide;

   ----------------------------
   -- To_VARIANT_From_Wide_C --
   ----------------------------

   function To_VARIANT_From_Wide_C
     (From : Interfaces.C.wchar_array)
      return GNATCOM.Types.VARIANT
   is
      New_Variant : GNATCOM.Types.VARIANT;
   begin
      Initialize (New_Variant);
      New_Variant.vt := GNATCOM.Types.VT_BSTR;
      New_Variant.u.bstrVal := GNATCOM.BSTR.To_BSTR_From_Wide_C (From);
      return New_Variant;
   end To_VARIANT_From_Wide_C;

   -------------
   -- Get_UDT --
   -------------

   function Get_UDT (From  : GNATCOM.Types.VARIANT) return Pointer_To_Element
   is
      use type Interfaces.C.unsigned_short;

      type BRECORD is
         record
            pvRecord  : Pointer_To_Element;
            pIRecInfo : GNATCOM.Types.Pointer_To_Void;
         end record;

      function To_BRECORD is
         new Ada.Unchecked_Conversion (Interfaces.C.double,
                                       BRECORD);

      Result : BRECORD := To_BRECORD (From.u.dblVal);
   begin
      if From.vt /= GNATCOM.Types.VT_RECORD then
         raise INVALID_TYPE_ERROR;
      end if;

      return Result.pvRecord;
   end Get_UDT;

   -------------
   -- Put_UDT --
   -------------

   function Put_UDT
     (UDT       : access Element;
      Lib_ID    : in     GNATCOM.Types.GUID;
      Ver_Maj   : in     Natural;
      Ver_Min   : in     Natural;
      Type_GUID : in     GNATCOM.Types.GUID)
     return GNATCOM.Types.VARIANT
   is
      use GNATCOM.ITypeLib_Interface;
      use GNATCOM.ITypeInfo_Interface;

      Lib       : GNATCOM.ITypeLib_Interface.ITypeLib_Type;
      Type_Lib  : aliased GNATCOM.Types.Pointer_To_ITypeLib;
      Type_Info : GNATCOM.ITypeInfo_Interface.ITypeInfo_Type;
      GUID      : aliased GNATCOM.Types.GUID := Lib_ID;
      TGUID     : aliased GNATCOM.Types.GUID := Type_GUID;

      function LoadRegTypeLib
        (guid           : access GNATCOM.Types.GUID;
         wMaj           : Natural;
         wMin           : Natural;
         lcid           : Interfaces.C.long;
         pLib           : access GNATCOM.Types.Pointer_To_ITypeLib)
        return GNATCOM.Types.HRESULT;
      pragma Import (StdCall, LoadRegTypeLib, "LoadRegTypeLib");

      function Put_UDT_BI is new Put_UDT_By_Type_Info (Element);
   begin
      GNATCOM.Errors.Error_Check
        (LoadRegTypeLib
         (GUID'Access, Ver_Maj, Ver_Min, 0, Type_Lib'Access));

      Attach (Lib, Type_Lib);

      Attach (Type_Info, GetTypeInfoOfGuid (Lib, TGUID'Unchecked_Access));

      return Put_UDT_BI (UDT, Pointer (Type_Info));
   end Put_UDT;

   ----------------------
   -- Put_UDT_By_Index --
   ----------------------

   function Put_UDT_By_Index
     (UDT     : access Element;
      Lib_ID  : in     GNATCOM.Types.GUID;
      Ver_Maj : in     Natural;
      Ver_Min : in     Natural;
      Index   : in     Natural)
     return GNATCOM.Types.VARIANT
   is
      use GNATCOM.ITypeLib_Interface;
      use GNATCOM.ITypeInfo_Interface;

      Lib       : GNATCOM.ITypeLib_Interface.ITypeLib_Type;
      Type_Lib  : aliased GNATCOM.Types.Pointer_To_ITypeLib;
      Type_Info : GNATCOM.ITypeInfo_Interface.ITypeInfo_Type;
      GUID      : aliased GNATCOM.Types.GUID := Lib_ID;

      function LoadRegTypeLib
        (guid           : access GNATCOM.Types.GUID;
         wMaj           : Natural;
         wMin           : Natural;
         lcid           : Interfaces.C.long;
         pLib           : access GNATCOM.Types.Pointer_To_ITypeLib)
        return GNATCOM.Types.HRESULT;
      pragma Import (StdCall, LoadRegTypeLib, "LoadRegTypeLib");

      function Put_UDT_BI is new Put_UDT_By_Type_Info (Element);
   begin
      GNATCOM.Errors.Error_Check
        (LoadRegTypeLib
         (GUID'Access, Ver_Maj, Ver_Min, 0, Type_Lib'Access));

      Attach (Lib, Type_Lib);

      Attach (Type_Info, GetTypeInfo (Lib, Interfaces.C.int (Index)));

      return Put_UDT_BI (UDT, Pointer (Type_Info));
   end Put_UDT_By_Index;

   --------------------------
   -- Put_UDT_By_Type_Info --
   --------------------------

   function Put_UDT_By_Type_Info
     (UDT       : access Element;
      Type_Info : in     GNATCOM.Types.Pointer_To_ITypeInfo)
     return GNATCOM.Types.VARIANT
   is
      function GetRecordInfoFromTypeInfo
        (Info          : in     GNATCOM.Types.Pointer_To_ITypeInfo;
         ppRecord_Info : access GNATCOM.Types.Pointer_To_Void)
        return GNATCOM.Types.HRESULT;
      pragma Import (StdCall, GetRecordInfoFromTypeInfo,
                       "GetRecordInfoFromTypeInfo");

      Record_Info : aliased GNATCOM.Types.Pointer_To_Void;

      type Pointer_To_Element is access all Element;

      type BRECORD is
         record
            pvRecord  : Pointer_To_Element;
            pIRecInfo : GNATCOM.Types.Pointer_To_Void;
         end record;

      function To_double is
         new Ada.Unchecked_Conversion (BRECORD,
                                       Interfaces.C.double);
      New_Variant : GNATCOM.Types.VARIANT;
   begin
      GNATCOM.Errors.Error_Check
        (GetRecordInfoFromTypeInfo (Type_Info, Record_Info'Access));

      Initialize (New_Variant);
      New_Variant.vt := GNATCOM.Types.VT_RECORD;
      New_Variant.u.dblVal := To_double (BRECORD'(Pointer_To_Element (UDT),
                                                  Record_Info));

      return New_Variant;
   end Put_UDT_By_Type_Info;

end GNATCOM.VARIANT;