File : gnatcom-dispinterface.adb


------------------------------------------------------------------------------
--                                                                          --
--      GNATCOM - Ada 95 COM/DCOM/COM+ Development Framework and Tools      --
--                                                                          --
--                G N A T C O M . D I S P I N T E R F A C E                 --
--                                                                          --
--                                 B o d y                                  --
--                                                                          --
--                            $Revision: 1.3 $
--                                                                          --
--             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.Exceptions;

with GNATCOM.BSTR;
with GNATCOM.VARIANT;
with GNATCOM.Errors;

package body GNATCOM.Dispinterface is

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

   DISPATCH_METHOD          : constant := 1;
   DISPATCH_PROPERTYGET     : constant := 2;
   DISPATCH_PROPERTYPUT     : constant := 4;
   DISPATCH_PROPERTYPUTREF  : constant := 8;
   --  DISPID_UNKNOWN           : constant := -1;
   --  DISPID_VALUE             : constant := 0;
   DISPID_PROPERTYPUT       : constant := -3;
   --  DISPID_NEWENUM           : constant := -4;
   --  DISPID_EVALUATE          : constant := -5;
   --  DISPID_CONSTRUCTOR       : constant := -6;
   --  DISPID_DESTRUCTOR        : constant := -7;
   DISP_E_PARAMNOTFOUND     : constant := 16#80020004#;
   DISP_E_TYPEMISMATCH      : constant := 16#80020005#;
   DISP_E_EXCEPTION         : constant := 16#80020009#;

   ------------
   -- Attach --
   ------------

   procedure Attach
     (This : in out Dispinterface_Type;
      From : in     GNATCOM.Types.Pointer_To_IDispatch)
   is
   begin
      Attach (This,
              GNATCOM.Interface.To_Pointer_To_IUnknown (From.all'Address));
   end Attach;

   ------------
   -- Attach --
   ------------

   procedure Attach
     (This : in out Dispinterface_Type;
      From : in     GNATCOM.Types.VARIANT)
   is
   begin
      Attach (This, GNATCOM.VARIANT.To_Pointer_To_IDispatch (From));
   end Attach;

   -----------------------------------
   -- To_VARIANT_From_Dispinterface --
   -----------------------------------

   function To_VARIANT_From_Dispinterface (From : Dispinterface_Type)
     return GNATCOM.Types.VARIANT
   is
   begin
      AddRef (From);
      return GNATCOM.VARIANT.To_VARIANT
        (To_Pointer_To_IDispatch (Address (From)));
   end To_VARIANT_From_Dispinterface;

   ---------
   -- Get --
   ---------

   function Get
     (This   : Dispinterface_Type;
      Name   : String;
      LCID   : Interfaces.C.long  := 0)
      return GNATCOM.Types.VARIANT
   is
   begin
      return Get (This, Get_DISPID (This, Name), LCID);
   end Get;

   function Get
     (This   : Dispinterface_Type;
      DISPID : Interfaces.C.long;
      LCID   : Interfaces.C.long  := 0)
      return GNATCOM.Types.VARIANT
   is
      Parameters : Parameter_Array (1 .. 0);
   begin
      return Invoke (This,
                     DISPID,
                     DISPATCH_PROPERTYGET,
                     Parameters,
                     False,
                     LCID);
   end Get;

   ---------
   -- Get --
   ---------

   function Get
     (This        : Dispinterface_Type;
      Name        : String;
      Index_Value : GNATCOM.Types.VARIANT;
      Free        : Boolean               := True;
      LCID        : Interfaces.C.long     := 0)
     return GNATCOM.Types.VARIANT
   is
   begin
      return Get (This, Get_DISPID (This, Name), Index_Value, Free, LCID);
   end Get;

   function Get
     (This        : Dispinterface_Type;
      DISPID      : Interfaces.C.long;
      Index_Value : GNATCOM.Types.VARIANT;
      Free        : Boolean               := True;
      LCID        : Interfaces.C.long     := 0)
     return GNATCOM.Types.VARIANT
   is
   begin
      return Invoke (This,
                     DISPID,
                     DISPATCH_PROPERTYGET,
                     (1 => Index_Value),
                     Free,
                     LCID);
   end Get;

   ---------
   -- Get --
   ---------

   function Get
     (This         : Dispinterface_Type;
      Name         : String;
      Index_Values : Parameter_Array;
      Free         : Boolean            := True;
      LCID         : Interfaces.C.long  := 0)
     return GNATCOM.Types.VARIANT
   is
   begin
      return Get (This, Get_DISPID (This, Name), Index_Values, Free, LCID);
   end Get;

   function Get
     (This         : Dispinterface_Type;
      DISPID       : Interfaces.C.long;
      Index_Values : Parameter_Array;
      Free         : Boolean            := True;
      LCID         : Interfaces.C.long  := 0)
      return GNATCOM.Types.VARIANT
   is
   begin
      return Invoke (This,
                     DISPID,
                     DISPATCH_PROPERTYGET,
                     Index_Values,
                     Free,
                     LCID);
   end Get;

   ----------------
   -- Get_DISPID --
   ----------------

   function Get_DISPID
     (This    : Dispinterface_Type;
      Of_Name : String)
      return Interfaces.C.long
   is
      PName     : aliased GNATCOM.Types.BSTR := GNATCOM.BSTR.To_BSTR (Of_Name);
      ID        : aliased Interfaces.C.long := 0;
   begin
      Error_Check
        (Pointer (This).Vtbl.GetIDsOfNames (Pointer (This),
                                            GNATCOM.Types.GUID_NULL'Access,
                                            PName'Unchecked_Access,
                                            1,
                                            0,
                                            ID'Unchecked_Access));
      GNATCOM.BSTR.Free (PName);
      return ID;
   end Get_DISPID;

   -------------------
   -- Get_Type_Info --
   -------------------

   function Get_Type_Info
     (This : Dispinterface_Type;
      LCID : Interfaces.C.long  := 0)
      return GNATCOM.Types.Pointer_To_ITypeInfo
   is
      Info : aliased GNATCOM.Types.Pointer_To_ITypeInfo;
   begin
      Error_Check
        (Pointer (This).Vtbl.GetTypeInfo (Pointer (This),
                                          1,
                                          LCID,
                                          Info'Unchecked_Access));
      return Info;
   end Get_Type_Info;

   -------------------
   -- Has_Type_Info --
   -------------------

   function Has_Type_Info (This : Dispinterface_Type) return Boolean is
      use type Interfaces.C.int;

      Count : aliased Interfaces.C.int;
   begin
      Error_Check
        (Pointer (This).Vtbl.GetTypeInfoCount (Pointer (This),
                                               Count'Unchecked_Access));
      if Count > 0 then
         return True;
      else
         return False;
      end if;
   end Has_Type_Info;

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

   procedure Initialize (This : in out Dispinterface_Type) is
   begin
      Set_IID (This, GNATCOM.Types.IID_IDispatch);
   end Initialize;

   ------------
   -- Invoke --
   ------------

   function Invoke
     (This       : Dispinterface_Type;
      Name       : String;
      Parameters : Parameter_Array;
      Free       : Boolean            := True;
      LCID       : Interfaces.C.long  := 0)
     return GNATCOM.Types.VARIANT
   is
   begin
      return Invoke (This, Get_DISPID (This, Name), Parameters, Free, LCID);
   end Invoke;

   function Invoke
     (This       : Dispinterface_Type;
      DISPID     : Interfaces.C.long;
      Parameters : Parameter_Array;
      Free       : Boolean            := True;
      LCID       : Interfaces.C.long  := 0)
      return GNATCOM.Types.VARIANT
   is
   begin
      return Invoke (This,
                     DISPID,
                     DISPATCH_METHOD,
                     Parameters,
                     Free,
                     LCID);
   end Invoke;

   ------------
   -- Invoke --
   ------------

   procedure Invoke
     (This       : in Dispinterface_Type;
      Name       : in String;
      Parameters : in Parameter_Array;
      Free       : in Boolean            := True;
      LCID       : in Interfaces.C.long  := 0)
   is
   begin
      Invoke (This, Get_DISPID (This, Name), Parameters, Free, LCID);
   end Invoke;

   procedure Invoke
     (This       : in Dispinterface_Type;
      DISPID     : in Interfaces.C.long;
      Parameters : in Parameter_Array;
      Free       : in Boolean            := True;
      LCID       : in Interfaces.C.long  := 0)
   is
      Result : GNATCOM.Types.VARIANT;
   begin
      Result := Invoke (This,
                        DISPID,
                        DISPATCH_METHOD,
                        Parameters,
                        Free,
                        LCID);
   end Invoke;

   ------------
   -- Invoke --
   ------------

   function Invoke
     (This   : Dispinterface_Type;
      Name   : String;
      LCID   : Interfaces.C.long  := 0)
     return GNATCOM.Types.VARIANT
   is
   begin
      return Invoke (This, Get_DISPID (This, Name), LCID);
   end Invoke;

   function Invoke
     (This   : Dispinterface_Type;
      DISPID : Interfaces.C.long;
      LCID   : Interfaces.C.long  := 0)
     return GNATCOM.Types.VARIANT
   is
      Parameters : Parameter_Array (1 .. 0);
   begin
      return Invoke (This,
                     DISPID,
                     DISPATCH_METHOD,
                     Parameters,
                     False,
                     LCID);
   end Invoke;

   ------------
   -- Invoke --
   ------------

   procedure Invoke
     (This   : in Dispinterface_Type;
      Name   : in String;
      LCID   : in Interfaces.C.long  := 0)
   is
   begin
      Invoke (This, Get_DISPID (This, Name), LCID);
   end Invoke;

   procedure Invoke
     (This   : in Dispinterface_Type;
      DISPID : in Interfaces.C.long;
      LCID   : in Interfaces.C.long  := 0)
   is
      Result : GNATCOM.Types.VARIANT;
   begin
      Result := Invoke (This, DISPID, LCID);
   end Invoke;

   ------------
   -- Invoke --
   ------------

   function Invoke
     (This       : Dispinterface_Type;
      Name       : String;
      wFlags     : Interfaces.C.short;
      Parameters : Parameter_Array;
      Free       : Boolean            := True;
      LCID       : Interfaces.C.long  := 0)
      return GNATCOM.Types.VARIANT
   is
   begin
      return Invoke
        (This, Get_DISPID (This, Name), wFlags, Parameters, Free, LCID);
   end Invoke;

   function Invoke
     (This       : Dispinterface_Type;
      DISPID     : Interfaces.C.long;
      wFlags     : Interfaces.C.short;
      Parameters : Parameter_Array;
      Free       : Boolean            := True;
      LCID       : Interfaces.C.long  := 0)
      return GNATCOM.Types.VARIANT
   is
      use type Interfaces.C.short;
      use type System.Address;

      function To_Pointer_To_VARIANT_PARAM_ARRAY is
         new Ada.Unchecked_Conversion
        (System.Address,
         GNATCOM.Types.Pointer_To_VARIANT_PARAM_ARRAY);

      function To_Pointer_To_DISPID_PARAM_ARRAY is
         new Ada.Unchecked_Conversion
        (System.Address,
         GNATCOM.Types.Pointer_To_DISPID_PARAM_ARRAY);

      HR             : GNATCOM.Types.HRESULT;
      No_Arguments   : aliased GNATCOM.Types.DISPPARAMS :=
        (null, null, 0, 0);
      Params         : aliased GNATCOM.Types.DISPPARAMS;
      Pdispparams    : GNATCOM.Types.Pointer_To_DISPPARAMS;
      Exception_Info : aliased GNATCOM.Types.EXCEPINFO;
      Argument_Error : aliased Interfaces.C.int;
      Result         : aliased GNATCOM.Types.VARIANT :=
        GNATCOM.Types.VARIANT_MISSING;
      Put_DISPID     : aliased Interfaces.C.long := DISPID_PROPERTYPUT;
      PDispatch      : GNATCOM.Types.Pointer_To_IDispatch := Pointer (This);
   begin
      if Parameters'Length = 0 then
         Pdispparams := No_Arguments'Unchecked_Access;
      else
         Params.rgvarg := To_Pointer_To_VARIANT_PARAM_ARRAY
           (Parameters'Address);
         Params.cArgs := Parameters'Length;
         if wFlags = DISPATCH_PROPERTYPUT then
            Params.rgdispidNamedArgs := To_Pointer_To_DISPID_PARAM_ARRAY
              (Put_DISPID'Address);
            Params.cNamedArgs := 1;
         else
            Params.rgdispidNamedArgs := null;
            Params.cNamedArgs := 0;
         end if;

         Pdispparams := Params'Unchecked_Access;
      end if;

      HR := PDispatch.Vtbl.Invoke (PDispatch,
                                   DISPID,
                                   GNATCOM.Types.GUID_NULL'Access,
                                   LCID,
                                   wFlags,
                                   Pdispparams,
                                   Result'Unchecked_Access,
                                   Exception_Info'Unchecked_Access,
                                   Argument_Error'Unchecked_Access);

      if Free then
         for N in Parameters'Range loop
            declare
               Temp : GNATCOM.Types.VARIANT := Parameters (N);
            begin
               GNATCOM.VARIANT.Clear (Temp);
            end;
         end loop;
      end if;

      if GNATCOM.Errors.FAILED (HR) then
         if (Exception_Info.pfnDeferredFillIn /= System.Null_Address) then
            declare
               type DefferedFillIn_Type is
                 access procedure (pei : GNATCOM.Types.Pointer_To_EXCEPINFO);

               function To_Procedure is
                  new Ada.Unchecked_Conversion (System.Address,
                                                DefferedFillIn_Type);

               DefferedFillin : DefferedFillIn_Type :=
                 To_Procedure (Exception_Info.pfnDeferredFillIn'Address);
            begin
               DefferedFillin (Exception_Info'Unchecked_Access);
            end;
         end if;
      end if;

      case HR is
         when DISP_E_PARAMNOTFOUND =>
            Ada.Exceptions.Raise_Exception
              (PARAMETER_ERROR'Identity,
               "Parameter number" &
               Interfaces.C.int'Image (Argument_Error) &
               " not found");
         when DISP_E_TYPEMISMATCH =>
            Ada.Exceptions.Raise_Exception
              (TYPE_MISMATCH_ERROR'Identity,
               "Type mismatch in" &
               "parameter number" &
               Interfaces.C.int'Image (Argument_Error));
         when DISP_E_EXCEPTION =>
            Ada.Exceptions.Raise_Exception
              (INVOKE_ERROR'Identity,
               "Exception " &
               GNATCOM.BSTR.To_Ada (Exception_Info.bstrSource) &
               " - " &
               GNATCOM.BSTR.To_Ada (Exception_Info.bstrDescription));
         when others =>
            Error_Check (HR);
      end case;

      return Result;
   end Invoke;

   -------------
   -- Pointer --
   -------------

   function Pointer
     (This : Dispinterface_Type)
      return GNATCOM.Types.Pointer_To_IDispatch
   is
   begin
      return To_Pointer_To_IDispatch (Address (This));
   end Pointer;

   ---------
   -- Put --
   ---------

   procedure Put
     (This   : in Dispinterface_Type;
      Name   : in String;
      Value  : in GNATCOM.Types.VARIANT;
      Free   : in Boolean               := True;
      LCID   : in Interfaces.C.long     := 0)
   is
   begin
      Put (This, Get_DISPID (This, Name), Value, Free, LCID);
   end Put;

   procedure Put
     (This   : in Dispinterface_Type;
      DISPID : in Interfaces.C.long;
      Value  : in GNATCOM.Types.VARIANT;
      Free   : in Boolean               := True;
      LCID   : in Interfaces.C.long     := 0)
   is
      Result : GNATCOM.Types.VARIANT;
   begin
      Result := Invoke (This,
                        DISPID,
                        DISPATCH_PROPERTYPUT,
                        (1 => Value),
                        Free,
                        LCID);
   end Put;

   ---------
   -- Put --
   ---------

   procedure Put
     (This        : in Dispinterface_Type;
      Name        : in String;
      Value       : in GNATCOM.Types.VARIANT;
      Index_Value : in GNATCOM.Types.VARIANT;
      Free        : in Boolean               := True;
      LCID        : in Interfaces.C.long     := 0)
   is
   begin
      Put (This, Get_DISPID (This, Name), Value, Index_Value, Free, LCID);
   end Put;

   procedure Put
     (This        : in Dispinterface_Type;
      DISPID      : in Interfaces.C.long;
      Value       : in GNATCOM.Types.VARIANT;
      Index_Value : in GNATCOM.Types.VARIANT;
      Free        : in Boolean               := True;
      LCID        : in Interfaces.C.long     := 0)
   is
      Result : GNATCOM.Types.VARIANT;
   begin
      Result := Invoke (This,
                        DISPID,
                        DISPATCH_PROPERTYPUT,
                        (Value, Index_Value),
                        Free,
                        LCID);
   end Put;

   ---------
   -- Put --
   ---------

   procedure Put
     (This         : in Dispinterface_Type;
      Name         : in String;
      Value        : in GNATCOM.Types.VARIANT;
      Index_Values : in Parameter_Array;
      Free         : in Boolean               := True;
      LCID         : in Interfaces.C.long     := 0)
   is
   begin
      Put (This, Get_DISPID (This, Name), Value, Index_Values, Free, LCID);
   end Put;

   procedure Put
     (This         : in Dispinterface_Type;
      DISPID       : in Interfaces.C.long;
      Value        : in GNATCOM.Types.VARIANT;
      Index_Values : in Parameter_Array;
      Free         : in Boolean               := True;
      LCID         : in Interfaces.C.long     := 0)
   is
      Result     : GNATCOM.Types.VARIANT;
      Parameters : Parameter_Array (1 .. Index_Values'Size + 1);
   begin
      Parameters (1) := Value;
      Parameters (2 .. Parameters'Last) := Index_Values;

      Result := Invoke (This,
                        DISPID,
                        DISPATCH_PROPERTYPUT,
                        Parameters,
                        Free,
                        LCID);
   end Put;

   ---------
   -- Put --
   ---------

   procedure Put
     (This       : in Dispinterface_Type;
      Name       : in String;
      Parameters : in Parameter_Array;
      Free       : in Boolean            := True;
      LCID       : in Interfaces.C.long  := 0)
   is
   begin
      Put (This, Get_DISPID (This, Name), Parameters, Free, LCID);
   end Put;

   procedure Put
     (This       : in Dispinterface_Type;
      DISPID     : in Interfaces.C.long;
      Parameters : in Parameter_Array;
      Free       : in Boolean            := True;
      LCID       : in Interfaces.C.long  := 0)
   is
      Result : GNATCOM.Types.VARIANT;
   begin
      Result := Invoke (This,
                        DISPID,
                        DISPATCH_PROPERTYPUT,
                        Parameters,
                        Free,
                        LCID);
   end Put;

   ------------
   -- PutRef --
   ------------

   procedure PutRef
     (This   : in Dispinterface_Type;
      Name   : in String;
      Value  : in GNATCOM.Types.VARIANT;
      LCID   : in Interfaces.C.long     := 0)
   is
   begin
      PutRef (This, Get_DISPID (This, Name), Value, LCID);
   end PutRef;

   procedure PutRef
     (This   : in Dispinterface_Type;
      DISPID : in Interfaces.C.long;
      Value  : in GNATCOM.Types.VARIANT;
      LCID   : in Interfaces.C.long     := 0)
   is
      Result : GNATCOM.Types.VARIANT;
   begin
      Result := Invoke (This,
                        DISPID,
                        DISPATCH_PROPERTYPUTREF,
                        (1 => Value),
                        False,
                        LCID);
   end PutRef;

   ------------
   -- PutRef --
   ------------

   procedure PutRef
     (This       : in Dispinterface_Type;
      Name       : in String;
      Parameters : in Parameter_Array;
      LCID       : in Interfaces.C.long  := 0)
   is
   begin
      PutRef (This, Get_DISPID (This, Name), Parameters, LCID);
   end PutRef;

   procedure PutRef
     (This       : in Dispinterface_Type;
      DISPID     : in Interfaces.C.long;
      Parameters : in Parameter_Array;
      LCID       : in Interfaces.C.long  := 0)
   is
      Result : GNATCOM.Types.VARIANT;
   begin
      Result := Invoke (This,
                        DISPID,
                        DISPATCH_PROPERTYPUTREF,
                        Parameters,
                        False,
                        LCID);
   end PutRef;

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

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

      if GNATCOM.Errors.FAILED (Result) then
         declare
            Message : String := GNATCOM.Errors.To_String (Result);
         begin
            case Result is
               when DISP_E_UNKNOWNNAME =>
                  Ada.Exceptions.Raise_Exception
                    (UNKNOWN_NAME_ERROR'Identity,
                     Message);
               when DISP_E_UNKNOWNLCID =>
                  Ada.Exceptions.Raise_Exception
                    (UNKNOWN_LCID_ERROR'Identity,
                     Message);
               when DISP_E_BADINDEX =>
                  Ada.Exceptions.Raise_Exception
                    (ELEMENT_NOT_FOUND_ERROR'Identity,
                     Message);
               when TYPE_E_ELEMENTNOTFOUND =>
                  Ada.Exceptions.Raise_Exception
                    (ELEMENT_NOT_FOUND_ERROR'Identity,
                     Message);
               when DISP_E_PARAMNOTOPTIONAL =>
                  Ada.Exceptions.Raise_Exception
                    (PARAMETER_ERROR'Identity,
                     Message);
               when DISP_E_BADPARAMCOUNT =>
                  Ada.Exceptions.Raise_Exception
                    (PARAMETER_ERROR'Identity,
                     Message);
               when DISP_E_BADVARTYPE =>
                  Ada.Exceptions.Raise_Exception
                    (TYPE_MISMATCH_ERROR'Identity,
                     Message);
               when DISP_E_MEMBERNOTFOUND =>
                  Ada.Exceptions.Raise_Exception
                    (UNKNOWN_NAME_ERROR'Identity,
                     Message);
               when DISP_E_NONAMEDARGS =>
                  Ada.Exceptions.Raise_Exception
                    (TYPE_MISMATCH_ERROR'Identity,
                     Message);
               when DISP_E_OVERFLOW =>
                  Ada.Exceptions.Raise_Exception
                    (TYPE_MISMATCH_ERROR'Identity,
                     Message);
               when others =>
                  GNATCOM.Errors.Error_Check (Result);
            end case;
         end;
      end if;
   end Error_Check;

end GNATCOM.Dispinterface;